git.iko.soy/servant
on master help sign in
swap
aaeee8895 ahead, 0 behind
87 files changed+1190−350
since splitsnapshots
unifiedsplit
.github/workflows/master.yml+49−60 cabal.project+1−26 changelog.d/1529+10 changelog.d/1556+81 changelog.d/1569+13 changelog.d/1571+10 changelog.d/1573+2 changelog.d/1580+12 changelog.d/1589+2 changelog.d/1595+2 changelog.d/1606+10 changelog.d/1638+2 changelog.d/1649+8 doc/Makefile+1−1 doc/conf.py+1−2 doc/cookbook/curl-mock/curl-mock.cabal+3 doc/cookbook/index.rst+1 doc/cookbook/managed-resource/ManagedResource.lhs+114 doc/cookbook/managed-resource/managed-resource.cabal+30 doc/cookbook/open-id-connect/OpenIdConnect.lhs+1−1 doc/cookbook/using-free-client/UsingFreeClient.lhs+1−1 doc/cookbook/uverb/UVerb.lhs+1−1 doc/requirements.txt+1 doc/tutorial/install.rst+26 doc/tutorial/tutorial.cabal+1−1 servant-auth/servant-auth-client/servant-auth-client.cabal+8−8 servant-auth/servant-auth-docs/servant-auth-docs.cabal+7−7 servant-auth/servant-auth-server/servant-auth-server.cabal+13−12 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal.hs+6−9 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs+14−1 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs+2−2 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs+1 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs+6−9 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hs+1 servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs+33−6 servant-auth/servant-auth-swagger/servant-auth-swagger.cabal+7−11 servant-auth/servant-auth/servant-auth.cabal+5−5 servant-auth/servant-auth/src/Servant/Auth.hs+1−1 servant-client-core/servant-client-core.cabal+6−6 servant-client-core/src/Servant/Client/Core.hs+1 servant-client-core/src/Servant/Client/Core/HasClient.hs+33−20 servant-client-core/src/Servant/Client/Core/Request.hs+20−5 servant-client-ghcjs/servant-client-ghcjs.cabal+2−2 servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs+8−5 servant-client/servant-client.cabal+7−7 servant-client/src/Servant/Client/Internal/HttpClient.hs+9−8 servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs+18−6 servant-client/test/Servant/ClientTestUtils.hs+13−1 servant-client/test/Servant/SuccessSpec.hs+11−1 servant-conduit/servant-conduit.cabal+3−3 servant-docs/golden/comprehensive.md+18 servant-docs/servant-docs.cabal+3−3 servant-docs/src/Servant/Docs/Internal.hs+8−1 servant-foreign/servant-foreign.cabal+5−5 servant-foreign/src/Servant/Foreign/Internal.hs+7 servant-http-streams/servant-http-streams.cabal+9−9 servant-machines/servant-machines.cabal+2−2 servant-pipes/servant-pipes.cabal+2−2 servant-server/CHANGELOG.md+12 servant-server/example/greet.hs−1 servant-server/servant-server.cabal+12−12 servant-server/src/Servant/Server.hs+3−2 servant-server/src/Servant/Server/Experimental/Auth.hs+2−1 servant-server/src/Servant/Server/Internal.hs+95−11 servant-server/src/Servant/Server/Internal/Handler.hs+7−2 servant-server/src/Servant/Server/Internal/Router.hs+50−15 servant-server/test/Servant/Server/RouterSpec.hs+127−6 servant-server/test/Servant/ServerSpec.hs+54−6 servant-swagger/servant-swagger.cabal+13−13 servant-swagger/src/Servant/Swagger.hs+5−3 servant-swagger/src/Servant/Swagger/Internal.hs+15 servant-swagger/src/Servant/Swagger/Internal/Test.hs+8−6 servant/CHANGELOG.md+5 servant/servant.cabal+10−9 servant/src/Servant/API.hs+11−3 servant/src/Servant/API/ContentTypes.hs+1−1 servant/src/Servant/API/Raw.hs+3 servant/src/Servant/API/ResponseHeaders.hs+23 servant/src/Servant/API/TypeLevel.hs+3−3 servant/src/Servant/API/UVerb.hs+3 servant/src/Servant/API/UVerb/Union.hs+2−2 servant/src/Servant/API/WithResource.hs+3 servant/src/Servant/Links.hs+25−4 servant/src/Servant/Test/ComprehensiveAPI.hs+1 servant/src/Servant/Types/SourceT.hs+3 servant/test/Servant/API/ContentTypesSpec.hs+11 servant/test/Servant/API/ResponseHeadersSpec.hs+11
.github/workflows/master.yml+49−60
@@ -19,6 +19,8 @@ jobs:
1919 - "8.8.4"
2020 - "8.10.7"
2121 - "9.0.2"
22+ - "9.2.2"
23+ - "9.4.2"
2224
2325 steps:
2426 - uses: actions/checkout@v2
@@ -47,10 +49,7 @@ jobs:
4749
4850 - name: Configure
4951 run: |
50− # Using separate store-dir because default one already has 'ghc-paths' package installed
51− # with hardcoded path to ghcup's GHC path (which it was built with). This leads to failure in
52− # doctest, as it tries to invoke that GHC, and it doesn't exist here.
53− cabal --store-dir /tmp/cabal-store install --ignore-project -j2 doctest --constraint='doctest ^>=0.18'
52+ cabal install --ignore-project -j2 doctest --constraint='doctest ^>=0.20'
5453
5554 - name: Build
5655 run: |
@@ -61,66 +60,56 @@ jobs:
6160 cabal test all
6261
6362 - name: Run doctests
64− # doctests are broken on GHC 9 due to compiler bug:
65− # https://gitlab.haskell.org/ghc/ghc/-/issues/19460
66− continue-on-error: ${{ matrix.ghc == '9.0.1' }}
6763 run: |
6864 # Necessary for doctest to be found in $PATH
6965 export PATH="$HOME/.cabal/bin:$PATH"
7066
71− # Filter out base-compat-batteries from .ghc.environment.*, as its modules
72− # conflict with those of base-compat.
73− #
74− # FIXME: This is an ugly hack. Ultimately, we'll want to use cabal-doctest
75− # (or cabal v2-doctest, if it ever lands) to provide a clean GHC environment.
76− # This might allow running doctests in GHCJS build as well.
77− perl -i -e 'while (<ARGV>) { print unless /package-id\s+(base-compat-batteries)-\d+(\.\d+)*/; }' .ghc.environment.*
78−
79− (cd servant && doctest src)
80− (cd servant-client && doctest src)
81− (cd servant-client-core && doctest src)
82− (cd servant-http-streams && doctest src)
83− (cd servant-docs && doctest src)
84− (cd servant-foreign && doctest src)
85− (cd servant-server && doctest src)
86− (cd servant-machines && doctest src)
87− (cd servant-conduit && doctest src)
88− (cd servant-pipes && doctest src)
89−
90− stack:
91− name: stack / ghc ${{ matrix.ghc }}
92− runs-on: ubuntu-latest
93− strategy:
94− matrix:
95− stack: ["2.7.3"]
96− ghc: ["8.10.7"]
97−
98− steps:
99− - uses: actions/checkout@v2
100−
101− - uses: haskell/actions/setup@v1
102− name: Setup Haskell Stack
103− with:
104− ghc-version: ${{ matrix.ghc }}
105− stack-version: ${{ matrix.stack }}
106−
107− - uses: actions/cache@v2.1.3
108− name: Cache ~/.stack
109− with:
110− path: ~/.stack
111− key: ${{ runner.os }}-${{ matrix.ghc }}-stack
112−
113− - name: Install dependencies
114− run: |
115− stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies
116−
117− - name: Build
118− run: |
119− stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks
120−
121− - name: Test
122− run: |
123− stack test --system-ghc
67+ DOCTEST="cabal repl --with-ghc=doctest --ghc-options=-w"
68+ (cd servant && eval $DOCTEST)
69+ (cd servant-client && eval $DOCTEST)
70+ (cd servant-client-core && eval $DOCTEST)
71+ (cd servant-http-streams && eval $DOCTEST)
72+ (cd servant-docs && eval $DOCTEST)
73+ (cd servant-foreign && eval $DOCTEST)
74+ (cd servant-server && eval $DOCTEST)
75+ (cd servant-machines && eval $DOCTEST)
76+ (cd servant-conduit && eval $DOCTEST)
77+ (cd servant-pipes && eval $DOCTEST)
78+
79+ # stack:
80+ # name: stack / ghc ${{ matrix.ghc }}
81+ # runs-on: ubuntu-latest
82+ # strategy:
83+ # matrix:
84+ # stack: ["2.7.5"]
85+ # ghc: ["8.10.7"]
86+
87+ # steps:
88+ # - uses: actions/checkout@v2
89+
90+ # - uses: haskell/actions/setup@v1
91+ # name: Setup Haskell Stack
92+ # with:
93+ # ghc-version: ${{ matrix.ghc }}
94+ # stack-version: ${{ matrix.stack }}
95+
96+ # - uses: actions/cache@v2.1.3
97+ # name: Cache ~/.stack
98+ # with:
99+ # path: ~/.stack
100+ # key: ${{ runner.os }}-${{ matrix.ghc }}-stack
101+
102+ # - name: Install dependencies
103+ # run: |
104+ # stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies
105+
106+ # - name: Build
107+ # run: |
108+ # stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks
109+
110+ # - name: Test
111+ # run: |
112+ # stack test --system-ghc
124113
125114 ghcjs:
126115 name: ubuntu-latest / ghcjs 8.6
cabal.project+1−26
@@ -47,33 +47,8 @@ packages:
4747 doc/cookbook/using-custom-monad
4848 doc/cookbook/using-free-client
4949 -- doc/cookbook/open-id-connect
50+ doc/cookbook/managed-resource
5051
5152tests: True
5253optimization: False
5354-- reorder-goals: True
54−
55−constraints:
56− -- see https://github.com/haskell-infra/hackage-trustees/issues/119
57− foundation >=0.0.14,
58− memory <0.14.12 || >0.14.12
59−
60−constraints: base-compat ^>=0.11
61−constraints: semigroups ^>=0.19
62−
63−-- allow-newer: sqlite-simple-0.4.16.0:semigroups
64−-- allow-newer: direct-sqlite-2.3.24:semigroups
65−
66−-- needed for doctests
67−write-ghc-environment-files: always
68−
69−-- https://github.com/chordify/haskell-servant-pagination/pull/12
70−allow-newer: servant-pagination-2.2.2:servant
71−allow-newer: servant-pagination-2.2.2:servant-server
72−
73−allow-newer: servant-js:servant
74−allow-newer: servant-multipart:servant
75−allow-newer: servant-multipart:servant-server
76−allow-newer: servant-multipart-api:servant
77−
78−-- ghc 9
79−allow-newer: tdigest:base
changelog.d/1529new file+10
@@ -0,0 +1,10 @@
1+synopsis: Fix performRequest in servant-client-ghcjs
2+prs: #1529
3+
4+description: {
5+
6+performRequest function in servant-client-ghcjs was not compatible with the
7+latest RunClient typeclass. Added the acceptStatus parameter and fixed the
8+functionality to match what servant-client provides.
9+
10+}
changelog.d/1556new file+81
@@ -0,0 +1,81 @@
1+synopsis: Display capture hints in router layout
2+prs: #1556
3+
4+description: {
5+
6+This PR enhances the `Servant.Server.layout` function, which produces a textual description of the routing layout of an API. More precisely, it changes `<capture>` blocks, so that they display the name and type of the variable being captured instead.
7+
8+Example:
9+
10+For the following API
11+```haskell
12+type API =
13+ "a" :> "d" :> Get '[JSON] NoContent
14+ :<|> "b" :> Capture "x" Int :> Get '[JSON] Bool
15+ :<|> "a" :> "e" :> Get '[JSON] Int
16+```
17+
18+we previously got the following output:
19+
20+```
21+/
22+├─ a/
23+│ ├─ d/
24+│ │ └─•
25+│ └─ e/
26+│ └─•
27+└─ b/
28+ └─ <capture>/
29+ ├─•
30+ ┆
31+ └─•
32+```
33+
34+now we get:
35+
36+```
37+/
38+├─ a/
39+│ ├─ d/
40+│ │ └─•
41+│ └─ e/
42+│ └─•
43+└─ b/
44+ └─ <x::Int>/
45+ ├─•
46+ ┆
47+ └─•
48+```
49+
50+This change is achieved by the introduction of a CaptureHint type, which is passed as an extra argument to the CaptureRouter and CaptureAllRouter constructors for the Router' type.
51+CaptureHint values are then used in routerLayout, to display the name and type of captured values, instead of just `<capture>` previously.
52+
53+N.B.:
54+Because the choice smart constructor for routers can aggregate Capture combinators with different capture hints, the Capture*Router constructors actually take a list of CaptureHint, instead of a single one.
55+
56+This PR also introduces Spec tests for the routerLayout function.
57+
58+Warning:
59+This change is potentially breaking, because it adds the constraint `Typeable a` to all types that are to be captured. Because all types are typeable since GHC 7.10, this is not as bad as it sounds ; it only break expressions where `a` is quantified in an expression with `Capture a`.
60+In those cases, the fix is easy: it suffices to add `Typeable a` to the left-hand side of the quantification constraint.
61+
62+For instance, the following code will no longer compile:
63+```haskell
64+type MyAPI a = Capture "foo" a :> Get '[JSON] ()
65+
66+myServer :: forall a. Server (MyAPI a)
67+myServer = const $ return ()
68+
69+myApi :: forall a. Proxy (MyAPI a)
70+myApi = Proxy
71+
72+app :: forall a. (FromHttpApiData a) => Application
73+app = serve (myApi @a) (myServer @a)
74+```
75+
76+Indeed, `app` should be replaced with:
77+```haskell
78+app :: forall a. (FromHttpApiData a, Typeable a) => Application
79+app = serve (myApi @a) (myServer @a)
80+```
81+}
changelog.d/1569new file+13
@@ -0,0 +1,13 @@
1+synopsis: Encode captures using toEncodedUrlPiece
2+prs: #1569
3+issues: #1511
4+
5+description: {
6+The `servant-client` library now makes direct use of `toEncodedUrlPiece` from `ToHttpApiData`
7+to encode captured values when building the request path. It gives user freedom to implement
8+URL-encoding however they need.
9+
10+Previous behavior was to use `toUrlPiece` and URL-encode its output using `toEncodedUrlPiece`
11+from the `Text` instance of `ToHttpApiData`. The issue with this approach is that
12+`ToHttpApiData Text` is overly zealous and also encodes characters, such as `*`, which are perfectly valid in a URL.
13+}
changelog.d/1571new file+10
@@ -0,0 +1,10 @@
1+synopsis: Support UVerb in servant-auth-server
2+prs: #1571
3+issues: #1570
4+description: {
5+UVerb endpoints are now supported by servant-auth-server and can be used under the
6+Auth combinator when writing servers. It is still unsupported by
7+servant-auth-client.
8+
9+This PR also brings Headers support in UVerb responses
10+}
changelog.d/1573new file+2
@@ -0,0 +1,2 @@
1+synopsis: Add API docs for ServerT
2+prs: #1573
changelog.d/1580new file+12
@@ -0,0 +1,12 @@
1+synopsis: Allow IO in validationKeys
2+prs: #1580
3+issues: #1579
4+
5+description: {
6+
7+Currently validationKeys are a fixed JWKSet. This does not work with OIDC
8+providers such as AWS Cognito or Okta, which regularly fetching jwks_uri to
9+discover new and expired keys.
10+
11+This change alters the type of validationKeys from JWKSet to IO JWKSet.
12+}
changelog.d/1589new file+2
@@ -0,0 +1,2 @@
1+synopsis: Only include question mark for nonempty query strings
2+prs: 1589
changelog.d/1595new file+2
@@ -0,0 +1,2 @@
1+synopsis: Run ClientEnv's makeClientRequest in IO.
2+prs: #1595
changelog.d/1606new file+10
@@ -0,0 +1,10 @@
1+synopsis: Handle Cookies correctly for RunStreamingClient
2+prs: #1606
3+issues: #1605
4+
5+description: {
6+
7+Makes performWithStreamingRequest take into consideration the
8+CookieJar, which it previously didn't.
9+
10+}
changelog.d/1638new file+2
@@ -0,0 +1,2 @@
1+synopsis: Add Functor instance to AuthHandler.
2+prs: #1638
changelog.d/1649new file+8
@@ -0,0 +1,8 @@
1+synopsis: Add HasStatus instance for Headers (that defers StatusOf to underlying value)
2+prs: #1649
3+
4+description: {
5+
6+Adds a new HasStatus (Headers hs a) instance (StatusOf (Headers hs a) = StatusOf a)
7+
8+}
doc/Makefile+1−1
@@ -10,7 +10,7 @@ BUILDDIR = _build
1010
1111# Put it first so that "make" without argument is like "make help".
1212help:
13− @if [ ! -d venv ]; then echo "WARNING: There is no venv directory, did you forget to 'virtualenv venv'. Check building-the-docs file."; fi
13+ @if [ ! -d venv ]; then echo "WARNING: There is no venv directory, did you forget to 'virtualenv venv'. Check README.md."; fi
1414 @if [ ! "z$$(which $(SPHINXBUILD))" = "z$$(pwd)/venv/bin/sphinx-build" ]; then echo "WARNING: Did you forgot to 'source venv/bin/activate'"; fi
1515 @$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O)
1616
doc/conf.py+1−2
@@ -46,7 +46,7 @@ master_doc = 'index'
4646
4747# General information about the project.
4848project = u'Servant'
49−copyright = u'2018, Servant Contributors'
49+copyright = u'2022, Servant Contributors'
5050author = u'Servant Contributors'
5151
5252# The version info for the project you're documenting, acts as replacement for
@@ -169,4 +169,3 @@ texinfo_documents = [
169169source_parsers = {
170170 '.lhs': CommonMarkParser,
171171}
172−
doc/cookbook/curl-mock/curl-mock.cabal+3
@@ -11,6 +11,9 @@ build-type: Simple
1111tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
1212
1313executable cookbock-curl-mock
14+ if impl(ghc >= 9.2)
15+ -- generic-arbitrary is incompatible
16+ buildable: False
1417 main-is: CurlMock.lhs
1518 build-depends: base == 4.*
1619 , aeson
doc/cookbook/index.rst+1
@@ -37,3 +37,4 @@ you name it!
3737 sentry/Sentry.lhs
3838 testing/Testing.lhs
3939 open-id-connect/OpenIdConnect.lhs
40+ managed-resource/ManagedResource.lhs
doc/cookbook/managed-resource/ManagedResource.lhsnew file+114
@@ -0,0 +1,114 @@
1+# Request-lifetime Managed Resources
2+
3+Let's see how we can write a handle that uses a resource managed by Servant. The resource is created automatically by Servant when the server recieves a request, and the resource is automatically destroyed when the server is finished handling a request.
4+
5+As usual, we start with a little bit of throat clearing.
6+
7+
8+``` haskell
9+{-# LANGUAGE DataKinds #-}
10+{-# LANGUAGE TypeOperators #-}
11+import Control.Concurrent
12+import Control.Exception (bracket, throwIO)
13+import Control.Monad.IO.Class
14+import Control.Monad.Trans.Resource
15+import Data.Acquire
16+import Network.HTTP.Client (newManager, defaultManagerSettings)
17+import Network.Wai.Handler.Warp
18+import Servant
19+import Servant.Client
20+import System.IO
21+```
22+
23+Here we define an API type that uses the `WithResource` combinator. The server handler for an endpoint with a `WithResource res` component will receive a value of that type as an argument.
24+
25+``` haskell
26+type API = WithResource Handle :> ReqBody '[PlainText] String :> Post '[JSON] NoContent
27+
28+api :: Proxy API
29+api = Proxy
30+```
31+
32+But this resource value has to come from somewhere. Servant obtains the value using an Acquire provided in the context. The Acquire knows how to both create and destroy resources of a particular type.
33+
34+``` haskell
35+appContext :: Context '[Acquire Handle]
36+appContext = acquireHandle :. EmptyContext
37+
38+acquireHandle :: Acquire Handle
39+acquireHandle = mkAcquire newHandle closeHandle
40+
41+newHandle :: IO Handle
42+newHandle = do
43+ putStrLn "opening file"
44+ h <- openFile "test.txt" AppendMode
45+ putStrLn "opened file"
46+ return h
47+
48+closeHandle :: Handle -> IO ()
49+closeHandle h = do
50+ putStrLn "closing file"
51+ hClose h
52+ putStrLn "closed file"
53+```
54+
55+Now we create the handler which will use this resource. This handler will write the request message to the System.IO.Handle which was provided to us. In some situations the handler will succeed, but in some in will fail. In either case, Servant will clean up the resource for us.
56+
57+``` haskell
58+server :: Server API
59+server = writeToFile
60+
61+ where writeToFile :: (ReleaseKey, Handle) -> String -> Handler NoContent
62+ writeToFile (_, h) msg = case msg of
63+ "illegal" -> error "wait, that's illegal!"
64+ legalMsg -> liftIO $ do
65+ putStrLn "writing file"
66+ hPutStrLn h legalMsg
67+ putStrLn "wrote file"
68+ return NoContent
69+```
70+
71+Finally we run the server in the background while we post messages to it.
72+
73+``` haskell
74+runApp :: IO ()
75+runApp = run 8080 (serveWithContext api appContext $ server)
76+
77+postMsg :: String -> ClientM NoContent
78+postMsg = client api
79+
80+main :: IO ()
81+main = do
82+ mgr <- newManager defaultManagerSettings
83+ bracket (forkIO $ runApp) killThread $ \_ -> do
84+ ms <- flip runClientM (mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ do
85+ liftIO $ putStrLn "sending hello message"
86+ _ <- postMsg "hello"
87+ liftIO $ putStrLn "sending illegal message"
88+ _ <- postMsg "illegal"
89+ liftIO $ putStrLn "done"
90+ print ms
91+```
92+
93+This program prints
94+
95+```
96+sending hello message
97+opening file
98+opened file
99+writing file
100+wrote file
101+closing file
102+closed file
103+sending illegal message
104+opening file
105+opened file
106+closing file
107+closed file
108+wait, that's illegal!
109+CallStack (from HasCallStack):
110+ error, called at ManagedResource.lhs:63:24 in main:Main
111+Left (FailureResponse (Request {requestPath = (BaseUrl {baseUrlScheme = Http, baseUrlHost = "localhost", baseUrlPort = 8080, baseUrlPath = ""},""), requestQueryString = fromList [], requestBody = Just ((),text/plain;charset=utf-8), requestAccept = fromList [], requestHeaders = fromList [], requestHttpVersion = HTTP/1.1, requestMethod = "POST"}) (Response {responseStatusCode = Status {statusCode = 500, statusMessage = "Internal Server Error"}, responseHeaders = fromList [("Transfer-Encoding","chunked"),("Date","Thu, 24 Nov 2022 21:04:47 GMT"),("Server","Warp/3.3.23"),("Content-Type","text/plain; charset=utf-8")], responseHttpVersion = HTTP/1.1, responseBody = "Something went wrong"}))
112+```
113+
114+and appends to a file called `test.txt`. We can see from the output that when a legal message is sent, the file is opened, written to, and closed. We can also see that when an illegal message is sent, the file is opened but not written to. Crucially, it is still closed even though the handler threw an exception.
doc/cookbook/managed-resource/managed-resource.cabalnew file+30
@@ -0,0 +1,30 @@
1+cabal-version: 2.2
2+name: cookbook-managed-resource
3+version: 0.1
4+synopsis: Simple managed resource cookbook example
5+homepage: http://docs.servant.dev/
6+license: BSD-3-Clause
7+license-file: ../../../servant/LICENSE
8+author: Servant Contributors
9+maintainer: haskell-servant-maintainers@googlegroups.com
10+build-type: Simple
11+tested-with: GHC==9.4.2
12+
13+executable cookbook-managed-resource
14+ main-is: ManagedResource.lhs
15+ build-depends: base == 4.*
16+ , text >= 1.2
17+ , aeson >= 1.2
18+ , servant
19+ , servant-client
20+ , servant-server
21+ , warp >= 3.2
22+ , wai >= 3.2
23+ , http-types >= 0.12
24+ , markdown-unlit >= 0.4
25+ , http-client >= 0.5
26+ , transformers
27+ , resourcet
28+ default-language: Haskell2010
29+ ghc-options: -Wall -pgmL markdown-unlit
30+ build-tool-depends: markdown-unlit:markdown-unlit
doc/cookbook/open-id-connect/OpenIdConnect.lhs+1−1
@@ -330,7 +330,7 @@ data Customer = Customer {
330330```
331331
332332Here is the code that displays the homepage.
333−It should contain a link to the the `/login` URL.
333+It should contain a link to the `/login` URL.
334334When the user clicks on this link it will be redirected to Google login page
335335with some generated information.
336336
doc/cookbook/using-free-client/UsingFreeClient.lhs+1−1
@@ -119,7 +119,7 @@ Now we can use `servant-client`'s internals to convert servant's `Request`
119119to http-client's `Request`, and we can inspect it:
120120
121121```haskell
122− let req' = I.defaultMakeClientRequest burl req
122+ req' <- I.defaultMakeClientRequest burl req
123123 putStrLn $ "Making request: " ++ show req'
124124```
125125
doc/cookbook/uverb/UVerb.lhs+1−1
@@ -199,7 +199,7 @@ parsers in the hope that the ones that should will always error out so
199199you can try until the right one returns a value.)
200200
201201[servant-exceptions](https://github.com/ch1bo/servant-exceptions) is
202−another shot at at the problem. It is inspired by
202+another shot at the problem. It is inspired by
203203servant-checked-exceptions, so it may be worth taking a closer look.
204204The README claims that
205205[cardano-sl](https://github.com/input-output-hk/cardano-sl) also has
doc/requirements.txt+1
@@ -1,3 +1,4 @@
11recommonmark==0.5.0
22Sphinx==1.8.4
33sphinx_rtd_theme>=0.4.2
4+jinja2<3.1.0
doc/tutorial/install.rst+26
@@ -40,3 +40,29 @@ nix
4040`Nix <https://nixos.org/nix/>`_ users should feel free to take a look at
4141the `nix/shell.nix` file in the repository and use it to provision a suitable
4242environment to build and run the examples.
43+
44+Note for Ubuntu users
45+--------
46+
47+Ubuntu's packages for `ghc`, `cabal`, and `stack` are years out of date.
48+If the instructions above fail for you,
49+try replacing the Ubuntu packages with up-to-date versions.
50+First remove the installed versions:
51+
52+.. code-block:: bash
53+
54+ # remove the obsolete versions
55+ $ sudo apt remove ghc haskell-stack cabal-install
56+
57+Then install fresh versions of the Haskell toolchain
58+using the `ghcup <https://www.haskell.org/ghcup/install/>`_ installer.
59+
60+As of February 2022, one easy way to do this is by running a bootstrap script:
61+
62+.. code-block:: bash
63+
64+ $ curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh
65+
66+The script is interactive and will prompt you for details about what
67+you want installed and where. To install manually,
68+see `the detailed instructions <https://www.haskell.org/ghcup/install/#manual-install>`_.
doc/tutorial/tutorial.cabal+1−1
@@ -64,7 +64,7 @@ library
6464 , blaze-markup >= 0.8.0.0 && < 0.9
6565 , cookie >= 0.4.3 && < 0.5
6666 , js-jquery >= 3.3.1 && < 3.4
67− , lucid >= 2.9.11 && < 2.10
67+ , lucid >= 2.9.11 && < 2.12
6868 , random >= 1.1 && < 1.3
6969 , servant-js >= 0.9 && < 0.10
7070 , time >= 1.6.0.1 && < 1.13
servant-auth/servant-auth-client/servant-auth-client.cabal+8−8
@@ -7,9 +7,9 @@ description: This package provides instances that allow generating clients fr
77 APIs that use
88 <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.
99 .
10− For a quick overview of the usage, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>.
10+ For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
1111category: Web, Servant, Authentication
12−homepage: http://github.com/haskell-servant/servant/servant-auth#readme
12+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
1313bug-reports: https://github.com/haskell-servant/servant/issues
1414author: Julian K. Arni
1515maintainer: jkarni@gmail.com
@@ -31,8 +31,8 @@ library
3131 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
3232 ghc-options: -Wall
3333 build-depends:
34− base >= 4.10 && < 4.16
35− , bytestring >= 0.10.6.0 && < 0.11
34+ base >= 4.10 && < 4.18
35+ , bytestring >= 0.10.6.0 && < 0.12
3636 , containers >= 0.5.6.2 && < 0.7
3737 , servant-auth == 0.4.*
3838 , servant >= 0.13 && < 0.20
@@ -50,7 +50,7 @@ test-suite spec
5050 test
5151 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
5252 ghc-options: -Wall
53− build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.9
53+ build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.10
5454
5555 -- dependencies with bounds inherited from the library stanza
5656 build-depends:
@@ -62,10 +62,10 @@ test-suite spec
6262
6363 -- test dependencies
6464 build-depends:
65− hspec >= 2.5.5 && < 2.9
65+ hspec >= 2.5.5 && < 2.10
6666 , QuickCheck >= 2.11.3 && < 2.15
6767 , aeson >= 1.3.1.1 && < 3
68− , bytestring >= 0.10.6.0 && < 0.11
68+ , bytestring >= 0.10.6.0 && < 0.12
6969 , http-client >= 0.5.13.1 && < 0.8
7070 , http-types >= 0.12.2 && < 0.13
7171 , servant-auth-server >= 0.4.2.0 && < 0.5
@@ -74,7 +74,7 @@ test-suite spec
7474 , transformers >= 0.4.2.0 && < 0.6
7575 , wai >= 3.2.1.2 && < 3.3
7676 , warp >= 3.2.25 && < 3.4
77− , jose >= 0.7.0.0 && < 0.10
77+ , jose >= 0.10 && < 0.11
7878 other-modules:
7979 Servant.Auth.ClientSpec
8080 default-language: Haskell2010
servant-auth/servant-auth-docs/servant-auth-docs.cabal+7−7
@@ -7,9 +7,9 @@ description: This package provides instances that allow generating docs from
77 APIs that use
88 <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.
99 .
10− For a quick overview of the usage, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>.
10+ For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
1111category: Web, Servant, Authentication
12−homepage: http://github.com/haskell-servant/servant/servant-auth#readme
12+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
1313bug-reports: https://github.com/haskell-servant/servant/issues
1414author: Julian K. Arni
1515maintainer: jkarni@gmail.com
@@ -35,11 +35,11 @@ library
3535 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
3636 ghc-options: -Wall
3737 build-depends:
38− base >= 4.10 && < 4.16
38+ base >= 4.10 && < 4.18
3939 , servant-docs >= 0.11.2 && < 0.13
4040 , servant >= 0.13 && < 0.20
4141 , servant-auth == 0.4.*
42− , lens >= 4.16.1 && <5.2
42+ , lens >= 4.16.1 && <5.3
4343 exposed-modules:
4444 Servant.Auth.Docs
4545 default-language: Haskell2010
@@ -50,7 +50,7 @@ test-suite doctests
5050 build-depends:
5151 base,
5252 servant-auth-docs,
53− doctest >= 0.16 && < 0.19,
53+ doctest >= 0.16 && < 0.21,
5454 QuickCheck >= 2.11.3 && < 2.15,
5555 template-haskell
5656 ghc-options: -Wall -threaded
@@ -64,7 +64,7 @@ test-suite spec
6464 test
6565 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
6666 ghc-options: -Wall
67− build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.9
67+ build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.10
6868
6969 -- dependencies with bounds inherited from the library stanza
7070 build-depends:
@@ -78,7 +78,7 @@ test-suite spec
7878 -- test dependencies
7979 build-depends:
8080 servant-auth-docs
81− , hspec >= 2.5.5 && < 2.9
81+ , hspec >= 2.5.5 && < 2.10
8282 , QuickCheck >= 2.11.3 && < 2.15
8383
8484 default-language: Haskell2010
servant-auth/servant-auth-server/servant-auth-server.cabal+13−12
@@ -7,9 +7,9 @@ description: This package provides the required instances for using the @Auth
77 .
88 Both cookie- and token- (REST API) based authentication is provided.
99 .
10− For a quick overview of the usage, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>.
10+ For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
1111category: Web, Servant, Authentication
12−homepage: http://github.com/haskell-servant/servant/servant-auth#readme
12+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
1313bug-reports: https://github.com/haskell-servant/servant/issues
1414author: Julian K. Arni
1515maintainer: jkarni@gmail.com
@@ -31,27 +31,27 @@ library
3131 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
3232 ghc-options: -Wall
3333 build-depends:
34− base >= 4.10 && < 4.16
34+ base >= 4.10 && < 4.18
3535 , aeson >= 1.0.0.1 && < 3
3636 , base64-bytestring >= 1.0.0.1 && < 2
3737 , blaze-builder >= 0.4.1.0 && < 0.5
38− , bytestring >= 0.10.6.0 && < 0.11
38+ , bytestring >= 0.10.6.0 && < 0.12
3939 , case-insensitive >= 1.2.0.11 && < 1.3
4040 , cookie >= 0.4.4 && < 0.5
4141 , data-default-class >= 0.1.2.0 && < 0.2
4242 , entropy >= 0.4.1.3 && < 0.5
4343 , http-types >= 0.12.2 && < 0.13
44− , jose >= 0.7.0.0 && < 0.10
45− , lens >= 4.16.1 && < 5.2
46− , memory >= 0.14.16 && < 0.17
44+ , jose >= 0.10 && < 0.11
45+ , lens >= 4.16.1 && < 5.3
46+ , memory >= 0.14.16 && < 0.19
4747 , monad-time >= 0.3.1.0 && < 0.4
48− , mtl >= 2.2.2 && < 2.3
48+ , mtl ^>= 2.2.2 || ^>= 2.3.1
4949 , servant >= 0.13 && < 0.20
5050 , servant-auth == 0.4.*
5151 , servant-server >= 0.13 && < 0.20
5252 , tagged >= 0.8.4 && < 0.9
5353 , text >= 1.2.3.0 && < 2.1
54− , time >= 1.5.0.1 && < 1.10
54+ , time >= 1.5.0.1 && < 1.13
5555 , unordered-containers >= 0.2.9.0 && < 0.3
5656 , wai >= 3.2.1.2 && < 3.3
5757
@@ -102,7 +102,7 @@ test-suite spec
102102 test
103103 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
104104 ghc-options: -Wall
105− build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.8
105+ build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.10
106106
107107 -- dependencies with bounds inherited from the library stanza
108108 build-depends:
@@ -123,12 +123,13 @@ test-suite spec
123123 -- test dependencies
124124 build-depends:
125125 servant-auth-server
126− , hspec >= 2.5.5 && < 2.8
126+ , hspec >= 2.5.5 && < 2.10
127127 , QuickCheck >= 2.11.3 && < 2.15
128128 , http-client >= 0.5.13.1 && < 0.8
129− , lens-aeson >= 1.0.2 && < 1.2
129+ , lens-aeson >= 1.0.2 && < 1.3
130130 , warp >= 3.2.25 && < 3.4
131131 , wreq >= 0.5.2.1 && < 0.6
132+ , text >= 1.2.3.0 && < 2.1
132133 other-modules:
133134 Servant.Auth.ServerSpec
134135 default-language: Haskell2010
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal.hs+6−9
@@ -54,15 +54,12 @@ instance ( n ~ 'S ('S 'Z)
5454
5555 makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z)))
5656 makeCookies authResult = do
57− xsrf <- makeXsrfCookie cookieSettings
58− fmap (Just xsrf `SetCookieCons`) $
59− case authResult of
60− (Authenticated v) -> do
61− ejwt <- makeSessionCookie cookieSettings jwtSettings v
62− case ejwt of
63− Nothing -> return $ Nothing `SetCookieCons` SetCookieNil
64− Just jwt -> return $ Just jwt `SetCookieCons` SetCookieNil
65− _ -> return $ Nothing `SetCookieCons` SetCookieNil
57+ case authResult of
58+ (Authenticated v) -> do
59+ ejwt <- makeSessionCookie cookieSettings jwtSettings v
60+ xsrf <- makeXsrfCookie cookieSettings
61+ return $ Just xsrf `SetCookieCons` (ejwt `SetCookieCons` SetCookieNil)
62+ _ -> return $ Nothing `SetCookieCons` (Nothing `SetCookieCons` SetCookieNil)
6663
6764 go :: (AuthResult v -> ServerT api Handler)
6865 -> (AuthResult v, SetCookieList n)
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs+14−1
@@ -11,6 +11,7 @@ import Data.Tagged (Tagged (..))
1111import qualified Network.HTTP.Types as HTTP
1212import Network.Wai (mapResponseHeaders)
1313import Servant
14+import Servant.API.UVerb.Union
1415import Servant.API.Generic
1516import Servant.Server.Generic
1617import Web.Cookie
@@ -33,12 +34,24 @@ type family AddSetCookieApiVerb a where
3334 AddSetCookieApiVerb (Headers ls a) = Headers (Header "Set-Cookie" SetCookie ': ls) a
3435 AddSetCookieApiVerb a = Headers '[Header "Set-Cookie" SetCookie] a
3536
37+#if MIN_VERSION_servant_server(0,18,1)
38+type family MapAddSetCookieApiVerb (as :: [*]) where
39+ MapAddSetCookieApiVerb '[] = '[]
40+ MapAddSetCookieApiVerb (a ': as) = (AddSetCookieApiVerb a ': MapAddSetCookieApiVerb as)
41+#endif
42+
3643type family AddSetCookieApi a :: *
3744type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b
3845type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b
46+#if MIN_VERSION_servant_server(0,19,0)
3947type instance AddSetCookieApi (NamedRoutes api) = AddSetCookieApi (ToServantApi api)
48+#endif
4049type instance AddSetCookieApi (Verb method stat ctyps a)
4150 = Verb method stat ctyps (AddSetCookieApiVerb a)
51+#if MIN_VERSION_servant_server(0,18,1)
52+type instance AddSetCookieApi (UVerb method ctyps as)
53+ = UVerb method ctyps (MapAddSetCookieApiVerb as)
54+#endif
4255type instance AddSetCookieApi Raw = Raw
4356#if MIN_VERSION_servant_server(0,15,0)
4457type instance AddSetCookieApi (Stream method stat framing ctyps a)
@@ -57,7 +70,7 @@ instance {-# OVERLAPS #-} AddSetCookies ('S n) oldb newb
5770 => AddSetCookies ('S n) (a -> oldb) (a -> newb) where
5871 addSetCookies cookies oldfn = addSetCookies cookies . oldfn
5972
60−instance AddSetCookies 'Z orig orig where
73+instance (orig1 ~ orig2) => AddSetCookies 'Z orig1 orig2 where
6174 addSetCookies _ = id
6275
6376instance {-# OVERLAPPABLE #-}
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs+2−2
@@ -33,7 +33,7 @@ data JWTSettings = JWTSettings
3333 -- | Algorithm used to sign JWT.
3434 , jwtAlg :: Maybe Jose.Alg
3535 -- | Keys used to validate JWT.
36− , validationKeys :: Jose.JWKSet
36+ , validationKeys :: IO Jose.JWKSet
3737 -- | An @aud@ predicate. The @aud@ is a string or URI that identifies the
3838 -- intended recipient of the JWT.
3939 , audienceMatches :: Jose.StringOrURI -> IsMatch
@@ -44,7 +44,7 @@ defaultJWTSettings :: Jose.JWK -> JWTSettings
4444defaultJWTSettings k = JWTSettings
4545 { signingKey = k
4646 , jwtAlg = Nothing
47− , validationKeys = Jose.JWKSet [k]
47+ , validationKeys = pure $ Jose.JWKSet [k]
4848 , audienceMatches = const Matches }
4949
5050-- | The policies to use when generating cookies.
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs+1
@@ -2,6 +2,7 @@
22module Servant.Auth.Server.Internal.Cookie where
33
44import Blaze.ByteString.Builder (toByteString)
5+import Control.Monad (MonadPlus(..), guard)
56import Control.Monad.Except
67import Control.Monad.Reader
78import qualified Crypto.JOSE as Jose
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs+6−9
@@ -1,18 +1,14 @@
11module Servant.Auth.Server.Internal.JWT where
22
33import Control.Lens
4−import Control.Monad.Except
4+import Control.Monad (MonadPlus(..), guard)
55import Control.Monad.Reader
66import qualified Crypto.JOSE as Jose
77import qualified Crypto.JWT as Jose
8−import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON,
9− toJSON)
108import Data.ByteArray (constEq)
119import qualified Data.ByteString as BS
1210import qualified Data.ByteString.Lazy as BSL
13−import qualified Data.HashMap.Strict as HM
1411import Data.Maybe (fromMaybe)
15−import qualified Data.Text as T
1612import Data.Time (UTCTime)
1713import Network.Wai (requestHeaders)
1814
@@ -42,7 +38,7 @@ jwtAuthCheck jwtSettings = do
4238-- token expires.
4339makeJWT :: ToJWT a
4440 => a -> JWTSettings -> Maybe UTCTime -> IO (Either Jose.Error BSL.ByteString)
45−makeJWT v cfg expiry = runExceptT $ do
41+makeJWT v cfg expiry = Jose.runJOSE $ do
4642 bestAlg <- Jose.bestJWSAlg $ signingKey cfg
4743 let alg = fromMaybe bestAlg $ jwtAlg cfg
4844 ejwt <- Jose.signClaims (signingKey cfg)
@@ -58,14 +54,15 @@ makeJWT v cfg expiry = runExceptT $ do
5854
5955verifyJWT :: FromJWT a => JWTSettings -> BS.ByteString -> IO (Maybe a)
6056verifyJWT jwtCfg input = do
61− verifiedJWT <- liftIO $ runExceptT $ do
57+ keys <- validationKeys jwtCfg
58+ verifiedJWT <- Jose.runJOSE $ do
6259 unverifiedJWT <- Jose.decodeCompact (BSL.fromStrict input)
6360 Jose.verifyClaims
6461 (jwtSettingsToJwtValidationSettings jwtCfg)
65− (validationKeys jwtCfg)
62+ keys
6663 unverifiedJWT
6764 return $ case verifiedJWT of
6865 Left (_ :: Jose.JWTError) -> Nothing
6966 Right v -> case decodeJWT v of
7067 Left _ -> Nothing
71− Right v' -> Just v'
68+ Right v' -> Just v'
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hs+1
@@ -2,6 +2,7 @@
22module Servant.Auth.Server.Internal.Types where
33
44import Control.Applicative
5+import Control.Monad (MonadPlus(..), ap)
56import Control.Monad.Reader
67import Control.Monad.Time
78import Data.Monoid (Monoid (..))
servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs+33−6
@@ -1,4 +1,5 @@
11{-# LANGUAGE CPP #-}
2+{-# LANGUAGE TypeApplications #-}
23module Servant.Auth.ServerSpec (spec) where
34
45#if !MIN_VERSION_servant_server(0,16,0)
@@ -6,13 +7,12 @@ module Servant.Auth.ServerSpec (spec) where
67#endif
78
89import Control.Lens
9−import Control.Monad.Except (runExceptT)
1010import Control.Monad.IO.Class (liftIO)
1111import Crypto.JOSE (Alg (HS256, None), Error,
1212 JWK, JWSHeader,
1313 KeyMaterialGenParam (OctGenParam),
1414 ToCompact, encodeCompact,
15− genJWK, newJWSHeader)
15+ genJWK, newJWSHeader, runJOSE)
1616import Crypto.JWT (Audience (..), ClaimsSet,
1717 NumericDate (NumericDate),
1818 SignedJWT,
@@ -25,6 +25,7 @@ import Data.Aeson (FromJSON, ToJSON, Value,
2525import Data.Aeson.Lens (_JSON)
2626import qualified Data.ByteString as BS
2727import qualified Data.ByteString.Lazy as BSL
28+import Data.Text (Text, pack)
2829import Data.CaseInsensitive (mk)
2930import Data.Foldable (find)
3031import Data.Monoid
@@ -40,6 +41,7 @@ import Network.HTTP.Types (Status, status200,
4041import Network.Wai (responseLBS)
4142import Network.Wai.Handler.Warp (testWithApplication)
4243import Network.Wreq (Options, auth, basicAuth,
44+ checkResponse,
4345 cookieExpiryTime, cookies,
4446 defaults, get, getWith, postWith,
4547 header, oauth2Bearer,
@@ -183,8 +185,21 @@ cookieAuthSpec
183185 it "fails with no XSRF header or cookie" $ \port -> property
184186 $ \(user :: User) -> do
185187 jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
186− opts <- addJwtToCookie cookieCfg jwt
187− getWith opts (url port) `shouldHTTPErrorWith` status401
188+ opts' <- addJwtToCookie cookieCfg jwt
189+ let opts = opts' & checkResponse .~ Just mempty
190+ resp <- getWith opts (url port)
191+ resp ^. responseStatus `shouldBe` status401
192+ (resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"]
193+
194+ -- Validating that the XSRF cookie isn't added for UVerb routes either.
195+ -- These routes can return a 401 response directly without using throwError / throwAll,
196+ -- which revealed a bug:
197+ --
198+ -- https://github.com/haskell-servant/servant/issues/1570#issuecomment-1076374449
199+ resp <- getWith opts (url port ++ "/uverb")
200+ resp ^. responseStatus `shouldBe` status401
201+ (resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"]
202+
188203
189204 it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property
190205 $ \(user :: User) -> do
@@ -406,13 +421,14 @@ type API auths
406421 = Auth auths User :>
407422 ( Get '[JSON] Int
408423 :<|> ReqBody '[JSON] Int :> Post '[JSON] Int
409− :<|> NamedRoutes DummyRoutes
424+ :<|> "named" :> NamedRoutes DummyRoutes
410425 :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)
411426#if MIN_VERSION_servant_server(0,15,0)
412427 :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
413428#endif
414429 :<|> "raw" :> Raw
415430 )
431+ :<|> "uverb" :> Auth auths User :> UVerb 'GET '[JSON] '[WithStatus 200 Int, WithStatus 401 Text, WithStatus 403 Text]
416432 :<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
417433 , Header "Set-Cookie" SetCookie ] NoContent)
418434 :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
@@ -490,6 +506,11 @@ server ccfg =
490506 :<|> raw
491507 Indefinite -> throwAll err401
492508 _ -> throwAll err403
509+ ) :<|>
510+ (\authResult -> case authResult of
511+ Authenticated usr -> respond (WithStatus @200 (42 :: Int))
512+ Indefinite -> respond (WithStatus @401 $ pack "Authentication required")
513+ _ -> respond (WithStatus @403 $ pack "Forbidden")
493514 )
494515 :<|> getLogin
495516 :<|> getLogout
@@ -540,7 +561,7 @@ addJwtToHeader jwt = case jwt of
540561 $ defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v]
541562
542563createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT)
543−createJWT k a b = runExceptT $ signClaims k a b
564+createJWT k a b = runJOSE $ signClaims k a b
544565
545566addJwtToCookie :: ToCompact a => CookieSettings -> Either Error a -> IO Options
546567addJwtToCookie ccfg jwt = case jwt >>= (return . encodeCompact) of
@@ -570,6 +591,12 @@ shouldMatchCookieNames cj patterns
570591 = fmap cookie_name (destroyCookieJar cj)
571592 `shouldMatchList` patterns
572593
594+shouldNotHaveCookies :: HCli.CookieJar -> [BS.ByteString] -> Expectation
595+shouldNotHaveCookies cj patterns =
596+ sequence_ $ (\cookieName -> cookieNames `shouldNotContain` [cookieName]) <$> patterns
597+ where cookieNames :: [BS.ByteString]
598+ cookieNames = cookie_name <$> destroyCookieJar cj
599+
573600shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation
574601shouldMatchCookieNameValues cj patterns
575602 = fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj)
servant-auth/servant-auth-swagger/servant-auth-swagger.cabal+7−11
@@ -7,9 +7,9 @@ description: This package provides instances that allow generating swagger2 s
77 APIs that use
88 <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.
99 .
10− For a quick overview of the usage, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>.
10+ For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
1111category: Web, Servant, Authentication
12−homepage: http://github.com/haskell-servant/servant/servant-auth#readme
12+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
1313bug-reports: https://github.com/haskell-servant/servant/issues
1414author: Julian K. Arni
1515maintainer: jkarni@gmail.com
@@ -31,15 +31,13 @@ library
3131 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
3232 ghc-options: -Wall
3333 build-depends:
34− base >= 4.10 && < 4.16
34+ base >= 4.10 && < 4.18
3535 , text >= 1.2.3.0 && < 2.1
3636 , servant-swagger >= 1.1.5 && < 2
3737 , swagger2 >= 2.2.2 && < 3
3838 , servant >= 0.13 && < 0.20
3939 , servant-auth == 0.4.*
40− , lens >= 4.16.1 && < 5.2
41− if impl(ghc >= 9)
42− buildable: False
40+ , lens >= 4.16.1 && < 5.3
4341 exposed-modules:
4442 Servant.Auth.Swagger
4543 default-language: Haskell2010
@@ -51,7 +49,7 @@ test-suite spec
5149 test
5250 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
5351 ghc-options: -Wall
54− build-tool-depends: hspec-discover:hspec-discover >= 2.5.5 && <2.9
52+ build-tool-depends: hspec-discover:hspec-discover >= 2.5.5 && <2.10
5553 -- dependencies with bounds inherited from the library stanza
5654 build-depends:
5755 base
@@ -61,13 +59,11 @@ test-suite spec
6159 , servant
6260 , servant-auth
6361 , lens
64− if impl(ghc >= 9)
65− buildable: False
66−
62+
6763 -- test dependencies
6864 build-depends:
6965 servant-auth-swagger
70− , hspec >= 2.5.5 && < 2.9
66+ , hspec >= 2.5.5 && < 2.10
7167 , QuickCheck >= 2.11.3 && < 2.15
7268 other-modules:
7369 Servant.Auth.SwaggerSpec
servant-auth/servant-auth/servant-auth.cabal+5−5
@@ -9,9 +9,9 @@ description: This package provides an @Auth@ combinator for 'servant'. This c
99 'servant-auth' additionally provides concrete authentication schemes, such
1010 as Basic Access Authentication, JSON Web Tokens, and Cookies.
1111 .
12− For more details on how to use this, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>.
12+ For more details on how to use this, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
1313category: Web, Servant, Authentication
14−homepage: http://github.com/haskell-servant/servant/servant-auth#readme
14+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
1515bug-reports: https://github.com/haskell-servant/servant/issues
1616author: Julian K. Arni
1717maintainer: jkarni@gmail.com
@@ -33,11 +33,11 @@ library
3333 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
3434 ghc-options: -Wall
3535 build-depends:
36− base >= 4.10 && < 4.16
36+ base >= 4.10 && < 4.18
3737 , containers >= 0.6 && < 0.7
3838 , aeson >= 1.3.1.1 && < 3
39− , jose >= 0.7.0.0 && < 0.10
40− , lens >= 4.16.1 && < 5.2
39+ , jose >= 0.10 && < 0.11
40+ , lens >= 4.16.1 && < 5.3
4141 , servant >= 0.15 && < 0.20
4242 , text >= 1.2.3.0 && < 2.1
4343 , unordered-containers >= 0.2.9.0 && < 0.3
servant-auth/servant-auth/src/Servant/Auth.hs+1−1
@@ -27,7 +27,7 @@ instance HasLink sub => HasLink (Auth (tag :: [*]) value :> sub) where
2727
2828-- ** Combinators
2929
30−-- | A JSON Web Token (JWT) in the the Authorization header:
30+-- | A JSON Web Token (JWT) in the Authorization header:
3131--
3232-- @Authorization: Bearer \<token\>@
3333--
servant-client-core/servant-client-core.cabal+6−6
@@ -50,14 +50,14 @@ library
5050 --
5151 -- note: mtl lower bound is so low because of GHC-7.8
5252 build-depends:
53− base >= 4.9 && < 4.16
53+ base >= 4.9 && < 4.18
5454 , bytestring >= 0.10.8.1 && < 0.12
5555 , constraints >= 0.2 && < 0.14
5656 , containers >= 0.5.7.1 && < 0.7
5757 , deepseq >= 1.4.2.0 && < 1.5
5858 , text >= 1.2.3.0 && < 2.1
59− , transformers >= 0.5.2.0 && < 0.6
60− , template-haskell >= 2.11.1.0 && < 2.18
59+ , transformers >= 0.5.2.0 && < 0.7
60+ , template-haskell >= 2.11.1.0 && < 2.20
6161
6262 if !impl(ghc >= 8.2)
6363 build-depends:
@@ -71,7 +71,7 @@ library
7171 -- Here can be exceptions if we really need features from the newer versions.
7272 build-depends:
7373 aeson >= 1.4.1.0 && < 3
74− , base-compat >= 0.10.5 && < 0.12
74+ , base-compat >= 0.10.5 && < 0.13
7575 , base64-bytestring >= 1.0.0.1 && < 1.3
7676 , exceptions >= 0.10.0 && < 0.11
7777 , free >= 5.1 && < 5.2
@@ -104,8 +104,8 @@ test-suite spec
104104 -- Additional dependencies
105105 build-depends:
106106 deepseq >= 1.4.2.0 && < 1.5
107− , hspec >= 2.6.0 && < 2.9
107+ , hspec >= 2.6.0 && < 2.10
108108 , QuickCheck >= 2.12.6.1 && < 2.15
109109
110110 build-tool-depends:
111− hspec-discover:hspec-discover >= 2.6.0 && <2.9
111+ hspec-discover:hspec-discover >= 2.6.0 && <2.10
servant-client-core/src/Servant/Client/Core.hs+1
@@ -59,6 +59,7 @@ module Servant.Client.Core
5959 , appendToPath
6060 , setRequestBodyLBS
6161 , setRequestBody
62+ , encodeQueryParamValue
6263 ) where
6364import Servant.Client.Core.Auth
6465import Servant.Client.Core.BaseUrl
servant-client-core/src/Servant/Client/Core/HasClient.hs+33−20
@@ -33,9 +33,7 @@ import Control.Arrow
3333import Control.Monad
3434 (unless)
3535import qualified Data.ByteString as BS
36−import Data.ByteString.Builder
37− (toLazyByteString)
38−import qualified Data.ByteString.Lazy as BL
36+import qualified Data.ByteString.Lazy as BL
3937import Data.Either
4038 (partitionEithers)
4139import Data.Constraint (Dict(..))
@@ -76,10 +74,10 @@ import Servant.API
7674 FromSourceIO (..), Header', Headers (..), HttpVersion,
7775 IsSecure, MimeRender (mimeRender),
7876 MimeUnrender (mimeUnrender), NoContent (NoContent),
79− NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,
77+ NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw, RawM,
8078 ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
8179 StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
82− Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,
80+ Verb, WithNamedContext, WithResource, WithStatus (..), contentType, getHeadersHList,
8381 getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)
8482import Servant.API.Generic
8583 (GenericMode(..), ToServant, ToServantApi
@@ -210,7 +208,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)
210208 clientWithRoute pm (Proxy :: Proxy api)
211209 (appendToPath p req)
212210
213− where p = (toUrlPiece val)
211+ where p = toEncodedUrlPiece val
214212
215213 hoistClientMonad pm _ f cl = \a ->
216214 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
@@ -245,7 +243,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
245243 clientWithRoute pm (Proxy :: Proxy sublayout)
246244 (foldl' (flip appendToPath) req ps)
247245
248− where ps = map (toUrlPiece) vals
246+ where ps = map toEncodedUrlPiece vals
249247
250248 hoistClientMonad pm _ f cl = \as ->
251249 hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)
@@ -571,7 +569,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire
571569 (Proxy :: Proxy mods) add (maybe req add) mparam
572570 where
573571 add :: a -> Request
574− add param = appendToQueryString pname (Just $ encodeQueryParam param) req
572+ add param = appendToQueryString pname (Just $ encodeQueryParamValue param) req
575573
576574 pname :: Text
577575 pname = pack $ symbolVal (Proxy :: Proxy sym)
@@ -579,9 +577,6 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire
579577 hoistClientMonad pm _ f cl = \arg ->
580578 hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)
581579
582−encodeQueryParam :: ToHttpApiData a => a -> BS.ByteString
583−encodeQueryParam = BL.toStrict . toLazyByteString . toEncodedUrlPiece
584−
585580-- | If you use a 'QueryParams' in one of your endpoints in your API,
586581-- the corresponding querying function will automatically take
587582-- an additional argument, a list of values of the type specified
@@ -623,7 +618,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
623618 )
624619
625620 where pname = pack $ symbolVal (Proxy :: Proxy sym)
626− paramlist' = map (Just . encodeQueryParam) paramlist
621+ paramlist' = map (Just . encodeQueryParamValue) paramlist
627622
628623 hoistClientMonad pm _ f cl = \as ->
629624 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
@@ -679,6 +674,16 @@ instance RunClient m => HasClient m Raw where
679674
680675 hoistClientMonad _ _ f cl = \meth -> f (cl meth)
681676
677+instance RunClient m => HasClient m RawM where
678+ type Client m RawM
679+ = H.Method -> m Response
680+
681+ clientWithRoute :: Proxy m -> Proxy RawM -> Request -> Client m RawM
682+ clientWithRoute _pm Proxy req httpMethod = do
683+ runRequest req { requestMethod = httpMethod }
684+
685+ hoistClientMonad _ _ f cl = \meth -> f (cl meth)
686+
682687-- | If you use a 'ReqBody' in one of your endpoints in your API,
683688-- the corresponding querying function will automatically take
684689-- an additional argument of the type specified by your 'ReqBody'.
@@ -745,7 +750,7 @@ instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
745750 clientWithRoute pm (Proxy :: Proxy api)
746751 (appendToPath p req)
747752
748− where p = pack $ symbolVal (Proxy :: Proxy path)
753+ where p = toEncodedUrlPiece $ pack $ symbolVal (Proxy :: Proxy path)
749754
750755 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
751756
@@ -781,6 +786,14 @@ instance HasClient m subapi =>
781786
782787 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl
783788
789+instance HasClient m subapi =>
790+ HasClient m (WithResource res :> subapi) where
791+
792+ type Client m (WithResource res :> subapi) = Client m subapi
793+ clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi)
794+
795+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl
796+
784797instance ( HasClient m api
785798 ) => HasClient m (AuthProtect tag :> api) where
786799 type Client m (AuthProtect tag :> api)
@@ -879,7 +892,7 @@ infixl 2 /:
879892--
880893-- Example:
881894--
882−-- @@
895+-- @
883896-- type Api = NamedRoutes RootApi
884897--
885898-- data RootApi mode = RootApi
@@ -899,8 +912,8 @@ infixl 2 /:
899912-- rootClient = client api
900913--
901914-- endpointClient :: ClientM Person
902−-- endpointClient = client // subApi // endpoint
903−-- @@
915+-- endpointClient = client \/\/ subApi \/\/ endpoint
916+-- @
904917(//) :: a -> (a -> b) -> b
905918x // f = f x
906919
@@ -911,7 +924,7 @@ x // f = f x
911924--
912925-- Example:
913926--
914−-- @@
927+-- @
915928-- type Api = NamedRoutes RootApi
916929--
917930-- data RootApi mode = RootApi
@@ -932,11 +945,11 @@ x // f = f x
932945-- rootClient = client api
933946--
934947-- hello :: String -> ClientM String
935−-- hello name = rootClient // hello /: name
948+-- hello name = rootClient \/\/ hello \/: name
936949--
937950-- endpointClient :: ClientM Person
938−-- endpointClient = client // subApi /: "foobar123" // endpoint
939−-- @@
951+-- endpointClient = client \/\/ subApi \/: "foobar123" \/\/ endpoint
952+-- @
940953(/:) :: (a -> b -> c) -> b -> a -> c
941954(/:) = flip
942955
servant-client-core/src/Servant/Client/Core/Request.hs+20−5
@@ -17,6 +17,7 @@ module Servant.Client.Core.Request (
1717 addHeader,
1818 appendToPath,
1919 appendToQueryString,
20+ encodeQueryParamValue,
2021 setRequestBody,
2122 setRequestBodyLBS,
2223 ) where
@@ -33,6 +34,8 @@ import Data.Bifunctor
3334import Data.Bitraversable
3435 (Bitraversable (..), bifoldMapDefault, bimapDefault)
3536import qualified Data.ByteString as BS
37+import Data.ByteString.Builder
38+ (Builder)
3639import qualified Data.ByteString.Builder as Builder
3740import qualified Data.ByteString.Lazy as LBS
3841import qualified Data.Sequence as Seq
@@ -111,7 +114,7 @@ instance (NFData path, NFData body) => NFData (RequestF body path) where
111114 rnfB Nothing = ()
112115 rnfB (Just (b, mt)) = rnf b `seq` mediaTypeRnf mt
113116
114−type Request = RequestF RequestBody Builder.Builder
117+type Request = RequestF RequestBody Builder
115118
116119-- | The request body. R replica of the @http-client@ @RequestBody@.
117120data RequestBody
@@ -142,18 +145,30 @@ defaultRequest = Request
142145 , requestMethod = methodGet
143146 }
144147
145−appendToPath :: Text -> Request -> Request
148+-- | Append extra path to the request being constructed.
149+--
150+-- Warning: This function assumes that the path fragment is already URL-encoded.
151+appendToPath :: Builder -> Request -> Request
146152appendToPath p req
147− = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p }
153+ = req { requestPath = requestPath req <> "/" <> p }
148154
149−appendToQueryString :: Text -- ^ param name
150− -> Maybe BS.ByteString -- ^ param value
155+-- | Append a query parameter to the request being constructed.
156+--
157+appendToQueryString :: Text -- ^ query param name
158+ -> Maybe BS.ByteString -- ^ query param value
151159 -> Request
152160 -> Request
153161appendToQueryString pname pvalue req
154162 = req { requestQueryString = requestQueryString req
155163 Seq.|> (encodeUtf8 pname, pvalue)}
156164
165+-- | Encode a query parameter value.
166+--
167+encodeQueryParamValue :: ToHttpApiData a => a -> BS.ByteString
168+encodeQueryParamValue = LBS.toStrict . Builder.toLazyByteString . toEncodedUrlPiece
169+
170+-- | Add header to the request being constructed.
171+--
157172addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request
158173addHeader name val req
159174 = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}
servant-client-ghcjs/servant-client-ghcjs.cabal+2−2
@@ -38,7 +38,7 @@ library
3838 Servant.Client.Internal.XhrClient
3939
4040 build-depends:
41− base >=4.11 && <4.12
41+ base >=4.11 && <5
4242 , bytestring >=0.10 && <0.12
4343 , case-insensitive >=1.2.0.0 && <1.3.0.0
4444 , containers >=0.5 && <0.7
@@ -48,7 +48,7 @@ library
4848 , http-media >=0.6.2 && <0.9
4949 , http-types >=0.12 && <0.13
5050 , monad-control >=1.0.0.4 && <1.1
51− , mtl >=2.2.2 && <2.3
51+ , mtl ^>=2.2.2 || ^>=2.3.1
5252 , semigroupoids >=5.3 && <5.4
5353 , string-conversions >=0.3 && <0.5
5454 , transformers >=0.3 && <0.6
servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs+8−5
@@ -120,7 +120,7 @@ instance Exception StreamingNotSupportedException where
120120 displayException _ = "streamingRequest: streaming is not supported!"
121121
122122instance RunClient ClientM where
123− runRequest = performRequest
123+ runRequestAcceptStatus = performRequest
124124 throwClientError = throwError
125125
126126runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ClientError a)
@@ -152,15 +152,18 @@ runClientM m = do
152152
153153 runClientMOrigin m (ClientEnv (BaseUrl protocol hostname port ""))
154154
155−performRequest :: Request -> ClientM Response
156−performRequest req = do
155+performRequest :: Maybe [Status] -> Request -> ClientM Response
156+performRequest acceptStatus req = do
157157 xhr <- liftIO initXhr
158158 burl <- asks baseUrl
159159 liftIO $ performXhr xhr burl req
160160 resp <- toResponse xhr
161161
162− let status = statusCode (responseStatusCode resp)
163− unless (status >= 200 && status < 300) $ do
162+ let status = responseStatusCode resp
163+ goodStatus = case acceptStatus of
164+ Nothing -> statusIsSuccessful status
165+ Just good -> status `elem` good
166+ unless goodStatus $ do
164167 let f b = (burl, BL.toStrict $ toLazyByteString b)
165168 throwError $ FailureResponse (bimap (const ()) f req) resp
166169
servant-client/servant-client.cabal+7−7
@@ -41,15 +41,15 @@ library
4141 -- Bundled with GHC: Lower bound to not force re-installs
4242 -- text and mtl are bundled starting with GHC-8.4
4343 build-depends:
44− base >= 4.9 && < 4.16
44+ base >= 4.9 && < 4.18
4545 , bytestring >= 0.10.8.1 && < 0.12
4646 , containers >= 0.5.7.1 && < 0.7
4747 , deepseq >= 1.4.2.0 && < 1.5
48− , mtl >= 2.2.2 && < 2.3
48+ , mtl ^>= 2.2.2 || ^>= 2.3.1
4949 , stm >= 2.4.5.1 && < 2.6
5050 , text >= 1.2.3.0 && < 2.1
51− , time >= 1.6.0.1 && < 1.10
52− , transformers >= 0.5.2.0 && < 0.6
51+ , time >= 1.6.0.1 && < 1.13
52+ , transformers >= 0.5.2.0 && < 0.7
5353
5454 if !impl(ghc >= 8.2)
5555 build-depends:
@@ -64,7 +64,7 @@ library
6464 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
6565 -- Here can be exceptions if we really need features from the newer versions.
6666 build-depends:
67− base-compat >= 0.10.5 && < 0.12
67+ base-compat >= 0.10.5 && < 0.13
6868 , http-client >= 0.5.13.1 && < 0.8
6969 , http-media >= 0.7.1.3 && < 0.9
7070 , http-types >= 0.12.2 && < 0.13
@@ -124,7 +124,7 @@ test-suite spec
124124 -- Additional dependencies
125125 build-depends:
126126 entropy >= 0.4.1.3 && < 0.5
127− , hspec >= 2.6.0 && < 2.9
127+ , hspec >= 2.6.0 && < 2.10
128128 , HUnit >= 1.6.0.0 && < 1.7
129129 , network >= 2.8.0.0 && < 3.2
130130 , QuickCheck >= 2.12.6.1 && < 2.15
@@ -133,7 +133,7 @@ test-suite spec
133133 , tdigest >= 0.2 && < 0.3
134134
135135 build-tool-depends:
136− hspec-discover:hspec-discover >= 2.6.0 && < 2.9
136+ hspec-discover:hspec-discover >= 2.6.0 && < 2.10
137137
138138test-suite readme
139139 type: exitcode-stdio-1.0
servant-client/src/Servant/Client/Internal/HttpClient.hs+9−8
@@ -24,7 +24,7 @@ import Control.Monad
2424import Control.Monad.Base
2525 (MonadBase (..))
2626import Control.Monad.Catch
27− (MonadCatch, MonadThrow)
27+ (MonadCatch, MonadThrow, MonadMask)
2828import Control.Monad.Error.Class
2929 (MonadError (..))
3030import Control.Monad.IO.Class
@@ -80,7 +80,7 @@ data ClientEnv
8080 { manager :: Client.Manager
8181 , baseUrl :: BaseUrl
8282 , cookieJar :: Maybe (TVar Client.CookieJar)
83− , makeClientRequest :: BaseUrl -> Request -> Client.Request
83+ , makeClientRequest :: BaseUrl -> Request -> IO Client.Request
8484 -- ^ this function can be used to customize the creation of @http-client@ requests from @servant@ requests. Default value: 'defaultMakeClientRequest'
8585 -- Note that:
8686 -- 1. 'makeClientRequest' exists to allow overriding operational semantics e.g. 'responseTimeout' per request,
@@ -136,7 +136,7 @@ newtype ClientM a = ClientM
136136 { unClientM :: ReaderT ClientEnv (ExceptT ClientError IO) a }
137137 deriving ( Functor, Applicative, Monad, MonadIO, Generic
138138 , MonadReader ClientEnv, MonadError ClientError, MonadThrow
139− , MonadCatch)
139+ , MonadCatch, MonadMask)
140140
141141instance MonadBase IO ClientM where
142142 liftBase = ClientM . liftBase
@@ -162,7 +162,7 @@ runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm
162162performRequest :: Maybe [Status] -> Request -> ClientM Response
163163performRequest acceptStatus req = do
164164 ClientEnv m burl cookieJar' createClientRequest <- ask
165− let clientRequest = createClientRequest burl req
165+ clientRequest <- liftIO $ createClientRequest burl req
166166 request <- case cookieJar' of
167167 Nothing -> pure clientRequest
168168 Just cj -> liftIO $ do
@@ -229,8 +229,8 @@ clientResponseToResponse f r = Response
229229-- | Create a @http-client@ 'Client.Request' from a @servant@ 'Request'
230230-- The 'Client.host', 'Client.path' and 'Client.port' fields are extracted from the 'BaseUrl'
231231-- otherwise the body, headers and query string are derived from the @servant@ 'Request'
232−defaultMakeClientRequest :: BaseUrl -> Request -> Client.Request
233−defaultMakeClientRequest burl r = Client.defaultRequest
232+defaultMakeClientRequest :: BaseUrl -> Request -> IO Client.Request
233+defaultMakeClientRequest burl r = return Client.defaultRequest
234234 { Client.method = requestMethod r
235235 , Client.host = fromString $ baseUrlHost burl
236236 , Client.port = baseUrlPort burl
@@ -246,7 +246,7 @@ defaultMakeClientRequest burl r = Client.defaultRequest
246246 where
247247 -- Content-Type and Accept are specified by requestBody and requestAccept
248248 headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $
249− toList $requestHeaders r
249+ toList $ requestHeaders r
250250
251251 acceptHdr
252252 | null hs = Nothing
@@ -289,7 +289,8 @@ defaultMakeClientRequest burl r = Client.defaultRequest
289289 Https -> True
290290
291291 -- Query string builder which does not do any encoding
292− buildQueryString = ("?" <>) . foldl' addQueryParam mempty
292+ buildQueryString [] = mempty
293+ buildQueryString qps = "?" <> foldl' addQueryParam mempty qps
293294
294295 addQueryParam qs (k, v) =
295296 qs <> (if BS.null qs then mempty else "&") <> urlEncode True k <> foldMap ("=" <>) v
servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs+18−6
@@ -24,7 +24,8 @@ import Control.DeepSeq
2424 (NFData, force)
2525import Control.Exception
2626 (evaluate, throwIO)
27−import Control.Monad ()
27+import Control.Monad
28+ (unless)
2829import Control.Monad.Base
2930 (MonadBase (..))
3031import Control.Monad.Codensity
@@ -140,7 +141,7 @@ performRequest :: Maybe [Status] -> Request -> ClientM Response
140141performRequest acceptStatus req = do
141142 -- TODO: should use Client.withResponse here too
142143 ClientEnv m burl cookieJar' createClientRequest <- ask
143− let clientRequest = createClientRequest burl req
144+ clientRequest <- liftIO $ createClientRequest burl req
144145 request <- case cookieJar' of
145146 Nothing -> pure clientRequest
146147 Just cj -> liftIO $ do
@@ -174,10 +175,21 @@ performRequest acceptStatus req = do
174175-- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above).
175176performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a
176177performWithStreamingRequest req k = do
177− m <- asks manager
178− burl <- asks baseUrl
179− createClientRequest <- asks makeClientRequest
180− let request = createClientRequest burl req
178+ ClientEnv m burl cookieJar' createClientRequest <- ask
179+ clientRequest <- liftIO $ createClientRequest burl req
180+ request <- case cookieJar' of
181+ Nothing -> pure clientRequest
182+ Just cj -> liftIO $ do
183+ now <- getCurrentTime
184+ atomically $ do
185+ oldCookieJar <- readTVar cj
186+ let (newRequest, newCookieJar) =
187+ Client.insertCookiesIntoRequest
188+ clientRequest
189+ oldCookieJar
190+ now
191+ writeTVar cj newCookieJar
192+ pure newRequest
181193 ClientM $ lift $ lift $ Codensity $ \k1 ->
182194 Client.withResponse request m $ \res -> do
183195 let status = Client.responseStatus res
servant-client/test/Servant/ClientTestUtils.hs+13−1
@@ -160,6 +160,7 @@ type Api =
160160 WithStatus 301 Text]
161161 :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]
162162 :<|> NamedRoutes RecordRoutes
163+ :<|> "captureVerbatim" :> Capture "someString" Verbatim :> Get '[PlainText] Text
163164
164165api :: Proxy Api
165166api = Proxy
@@ -214,7 +215,8 @@ getRoot
214215 :<|> EmptyClient
215216 :<|> uverbGetSuccessOrRedirect
216217 :<|> uverbGetCreated
217− :<|> recordRoutes = client api
218+ :<|> recordRoutes
219+ :<|> captureVerbatim = client api
218220
219221server :: Application
220222server = serve api (
@@ -259,6 +261,7 @@ server = serve api (
259261 { something = pure ["foo", "bar", "pweet"]
260262 }
261263 }
264+ :<|> pure . decodeUtf8 . unVerbatim
262265 )
263266
264267-- * api for testing failures
@@ -370,3 +373,12 @@ instance ToHttpApiData UrlEncodedByteString where
370373
371374instance FromHttpApiData UrlEncodedByteString where
372375 parseUrlPiece = pure . UrlEncodedByteString . HTTP.urlDecode True . encodeUtf8
376+
377+newtype Verbatim = Verbatim { unVerbatim :: ByteString }
378+
379+instance ToHttpApiData Verbatim where
380+ toEncodedUrlPiece = byteString . unVerbatim
381+ toUrlPiece = decodeUtf8 . unVerbatim
382+
383+instance FromHttpApiData Verbatim where
384+ parseUrlPiece = pure . Verbatim . encodeUtf8
servant-client/test/Servant/SuccessSpec.hs+11−1
@@ -36,6 +36,8 @@ import Data.Maybe
3636import Data.Monoid ()
3737import Data.Text
3838 (Text)
39+import Data.Text.Encoding
40+ (encodeUtf8)
3941import qualified Network.HTTP.Client as C
4042import qualified Network.HTTP.Types as HTTP
4143import Test.Hspec
@@ -160,7 +162,8 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
160162 mgr <- C.newManager C.defaultManagerSettings
161163 -- In proper situation, extra headers should probably be visible in API type.
162164 -- However, testing for response timeout is difficult, so we test with something which is easy to observe
163− let createClientRequest url r = (defaultMakeClientRequest url r) { C.requestHeaders = [("X-Added-Header", "XXX")] }
165+ let createClientRequest url r = fmap (\req -> req { C.requestHeaders = [("X-Added-Header", "XXX")] })
166+ (defaultMakeClientRequest url r)
164167 clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }
165168 res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv
166169 case res of
@@ -196,3 +199,10 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
196199 case eitherResponse of
197200 Left clientError -> fail $ show clientError
198201 Right response -> matchUnion response `shouldBe` Just (WithStatus @201 carol)
202+
203+ it "encodes URL pieces following ToHttpApiData instance" $ \(_, baseUrl) -> do
204+ let textOrig = "*"
205+ eitherResponse <- runClient (captureVerbatim $ Verbatim $ encodeUtf8 textOrig) baseUrl
206+ case eitherResponse of
207+ Left clientError -> fail $ show clientError
208+ Right textBack -> textBack `shouldBe` textOrig
servant-conduit/servant-conduit.cabal+3−3
@@ -23,7 +23,7 @@ extra-source-files:
2323
2424source-repository head
2525 type: git
26− location: http://github.com/haskell-servant/servant-conduit.git
26+ location: http://github.com/haskell-servant/servant.git
2727
2828library
2929 exposed-modules: Servant.Conduit
@@ -31,8 +31,8 @@ library
3131 base >=4.9 && <5
3232 , bytestring >=0.10.8.1 && <0.12
3333 , conduit >=1.3.1 && <1.4
34− , mtl >=2.2.2 && <2.3
35− , resourcet >=1.2.2 && <1.3
34+ , mtl ^>=2.2.2 || ^>=2.3.1
35+ , resourcet >=1.2.2 && <1.4
3636 , servant >=0.15 && <0.20
3737 , unliftio-core >=0.1.2.0 && <0.3
3838 hs-source-dirs: src
servant-docs/golden/comprehensive.md+18
@@ -530,6 +530,24 @@
530530
531531```
532532
533+## GET /resource
534+
535+### Response:
536+
537+- Status code 200
538+- Headers: []
539+
540+- Supported content types are:
541+
542+ - `application/json;charset=utf-8`
543+ - `application/json`
544+
545+- Example (`application/json;charset=utf-8`, `application/json`):
546+
547+```javascript
548+
549+```
550+
533551## GET /streaming
534552
535553### Request:
servant-docs/servant-docs.cabal+3−3
@@ -41,7 +41,7 @@ library
4141 --
4242 -- note: mtl lower bound is so low because of GHC-7.8
4343 build-depends:
44− base >= 4.9 && < 4.16
44+ base >= 4.9 && < 4.18
4545 , bytestring >= 0.10.8.1 && < 0.12
4646 , text >= 1.2.3.0 && < 2.1
4747
@@ -54,12 +54,12 @@ library
5454 build-depends:
5555 aeson >= 1.4.1.0 && < 3
5656 , aeson-pretty >= 0.8.5 && < 0.9
57− , base-compat >= 0.10.5 && < 0.12
57+ , base-compat >= 0.10.5 && < 0.13
5858 , case-insensitive >= 1.2.0.11 && < 1.3
5959 , hashable >= 1.2.7.0 && < 1.5
6060 , http-media >= 0.7.1.3 && < 0.9
6161 , http-types >= 0.12.2 && < 0.13
62− , lens >= 4.17 && < 5.2
62+ , lens >= 4.17 && < 5.3
6363 , string-conversions >= 0.4.0.1 && < 0.5
6464 , universe-base >= 1.1.1 && < 1.2
6565 , unordered-containers >= 0.2.9.0 && < 0.3
servant-docs/src/Servant/Docs/Internal.hs+8−1
@@ -62,6 +62,7 @@ import GHC.TypeLits
6262import Servant.API
6363import Servant.API.ContentTypes
6464import Servant.API.TypeLevel
65+import Servant.API.Generic
6566
6667import qualified Data.Universe.Helpers as U
6768
@@ -446,7 +447,7 @@ docsWith opts intros (ExtraInfo endpoints) p =
446447 & apiEndpoints %~ HM.unionWith (flip combineAction) endpoints
447448
448449
449−-- | Generate the docs for a given API that implements 'HasDocs' with with any
450+-- | Generate the docs for a given API that implements 'HasDocs' with any
450451-- number of introduction(s)
451452docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API
452453docsWithIntros intros = docsWith defaultDocOptions intros mempty
@@ -1143,6 +1144,9 @@ instance HasDocs api => HasDocs (Vault :> api) where
11431144instance HasDocs api => HasDocs (WithNamedContext name context api) where
11441145 docsFor Proxy = docsFor (Proxy :: Proxy api)
11451146
1147+instance HasDocs api => HasDocs (WithResource res :> api) where
1148+ docsFor Proxy = docsFor (Proxy :: Proxy api)
1149+
11461150instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth realm usr :> api) where
11471151 docsFor Proxy (endpoint, action) =
11481152 docsFor (Proxy :: Proxy api) (endpoint, action')
@@ -1150,6 +1154,9 @@ instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth r
11501154 authProxy = Proxy :: Proxy (BasicAuth realm usr)
11511155 action' = over authInfo (|> toAuthInfo authProxy) action
11521156
1157+instance HasDocs (ToServantApi api) => HasDocs (NamedRoutes api) where
1158+ docsFor Proxy = docsFor (Proxy :: Proxy (ToServantApi api))
1159+
11531160-- ToSample instances for simple types
11541161instance ToSample NoContent
11551162instance ToSample Bool
servant-foreign/servant-foreign.cabal+5−5
@@ -41,7 +41,7 @@ library
4141 --
4242 -- note: mtl lower bound is so low because of GHC-7.8
4343 build-depends:
44− base >= 4.9 && < 4.16
44+ base >= 4.9 && < 4.18
4545 , text >= 1.2.3.0 && < 2.1
4646
4747 -- Servant dependencies
@@ -51,8 +51,8 @@ library
5151 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
5252 -- Here can be exceptions if we really need features from the newer versions.
5353 build-depends:
54− base-compat >= 0.10.5 && < 0.12
55− , lens >= 4.17 && < 5.2
54+ base-compat >= 0.10.5 && < 0.13
55+ , lens >= 4.17 && < 5.3
5656 , http-types >= 0.12.2 && < 0.13
5757
5858 hs-source-dirs: src
@@ -74,7 +74,7 @@ test-suite spec
7474
7575 -- Additional dependencies
7676 build-depends:
77− hspec >= 2.6.0 && <2.9
77+ hspec >= 2.6.0 && <2.10
7878 build-tool-depends:
79− hspec-discover:hspec-discover >=2.6.0 && <2.9
79+ hspec-discover:hspec-discover >=2.6.0 && <2.10
8080 default-language: Haskell2010
servant-foreign/src/Servant/Foreign/Internal.hs+7
@@ -487,6 +487,13 @@ instance HasForeign lang ftype api =>
487487
488488 foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)
489489
490+instance HasForeign lang ftype api =>
491+ HasForeign lang ftype (WithResource res :> api) where
492+
493+ type Foreign ftype (WithResource res :> api) = Foreign ftype api
494+
495+ foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)
496+
490497instance HasForeign lang ftype api
491498 => HasForeign lang ftype (HttpVersion :> api) where
492499 type Foreign ftype (HttpVersion :> api) = Foreign ftype api
servant-http-streams/servant-http-streams.cabal+9−9
@@ -38,14 +38,14 @@ library
3838 -- Bundled with GHC: Lower bound to not force re-installs
3939 -- text and mtl are bundled starting with GHC-8.4
4040 build-depends:
41− base >= 4.9 && < 4.16
41+ base >= 4.9 && < 4.18
4242 , bytestring >= 0.10.8.1 && < 0.12
4343 , containers >= 0.5.7.1 && < 0.7
4444 , deepseq >= 1.4.2.0 && < 1.5
45− , mtl >= 2.2.2 && < 2.3
45+ , mtl ^>= 2.2.2 || ^>= 2.3.1
4646 , text >= 1.2.3.0 && < 2.1
47− , time >= 1.6.0.1 && < 1.10
48− , transformers >= 0.5.2.0 && < 0.6
47+ , time >= 1.6.0.1 && < 1.13
48+ , transformers >= 0.5.2.0 && < 0.7
4949
5050 if !impl(ghc >= 8.2)
5151 build-depends:
@@ -60,19 +60,19 @@ library
6060 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
6161 -- Here can be exceptions if we really need features from the newer versions.
6262 build-depends:
63− base-compat >= 0.10.5 && < 0.12
63+ base-compat >= 0.10.5 && < 0.13
6464 , case-insensitive
6565 , http-streams >= 0.8.6.1 && < 0.9
6666 , http-media >= 0.7.1.3 && < 0.9
6767 , io-streams >= 1.5.0.1 && < 1.6
6868 , http-types >= 0.12.2 && < 0.13
69− , http-common >= 0.8.2.0 && < 0.8.3
69+ , http-common >= 0.8.2.0 && < 0.9
7070 , exceptions >= 0.10.0 && < 0.11
7171 , kan-extensions >= 5.2 && < 5.3
7272 , monad-control >= 1.0.2.3 && < 1.1
7373 , semigroupoids >= 5.3.1 && < 5.4
7474 , transformers-base >= 0.4.5.2 && < 0.5
75− , transformers-compat >= 0.6.2 && < 0.7
75+ , transformers-compat >= 0.6.2 && < 0.8
7676
7777 hs-source-dirs: src
7878 default-language: Haskell2010
@@ -112,7 +112,7 @@ test-suite spec
112112 -- Additional dependencies
113113 build-depends:
114114 entropy >= 0.4.1.3 && < 0.5
115− , hspec >= 2.6.0 && < 2.9
115+ , hspec >= 2.6.0 && < 2.10
116116 , HUnit >= 1.6.0.0 && < 1.7
117117 , network >= 2.8.0.0 && < 3.2
118118 , QuickCheck >= 2.12.6.1 && < 2.15
@@ -121,7 +121,7 @@ test-suite spec
121121 , tdigest >= 0.2 && < 0.3
122122
123123 build-tool-depends:
124− hspec-discover:hspec-discover >= 2.6.0 && < 2.9
124+ hspec-discover:hspec-discover >= 2.6.0 && < 2.10
125125
126126test-suite readme
127127 type: exitcode-stdio-1.0
servant-machines/servant-machines.cabal+2−2
@@ -23,7 +23,7 @@ extra-source-files:
2323
2424source-repository head
2525 type: git
26− location: http://github.com/haskell-servant/servant-machines.git
26+ location: http://github.com/haskell-servant/servant.git
2727
2828library
2929 exposed-modules: Servant.Machines
@@ -31,7 +31,7 @@ library
3131 base >=4.9 && <5
3232 , bytestring >=0.10.8.1 && <0.12
3333 , machines >=0.6.4 && <0.8
34− , mtl >=2.2.2 && <2.3
34+ , mtl ^>=2.2.2 || ^>=2.3.1
3535 , servant >=0.15 && <0.20
3636 hs-source-dirs: src
3737 default-language: Haskell2010
servant-pipes/servant-pipes.cabal+2−2
@@ -23,7 +23,7 @@ extra-source-files:
2323
2424source-repository head
2525 type: git
26− location: http://github.com/haskell-servant/servant-pipes.git
26+ location: http://github.com/haskell-servant/servant.git
2727
2828library
2929 exposed-modules: Servant.Pipes
@@ -32,7 +32,7 @@ library
3232 , bytestring >=0.10.8.1 && <0.12
3333 , pipes >=4.3.9 && <4.4
3434 , pipes-safe >=2.3.1 && <2.4
35− , mtl >=2.2.2 && <2.3
35+ , mtl ^>=2.2.2 || ^>=2.3.1
3636 , monad-control >=1.0.2.3 && <1.1
3737 , servant >=0.15 && <0.20
3838 hs-source-dirs: src
servant-server/CHANGELOG.md+12
@@ -3,6 +3,18 @@
33
44Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions.
55
6+0.19.2
7+------
8+
9+Compatibility with GHC 9.4, see [PR #1592](https://github.com/haskell-servant/servant/pull/1592).
10+
11+0.19.1
12+------
13+
14+- Add `MonadFail` instance for `Handler` wrt [#1545](https://github.com/haskell-servant/servant/issues/1545)
15+- Support GHC 9.2 [#1525](https://github.com/haskell-servant/servant/issues/1525)
16+- Add capture hints in `Router` type for debug and display purposes [PR #1556] (https://github.com/haskell-servant/servant/pull/1556)
17+
6180.19
719----
820
servant-server/example/greet.hs−1
@@ -18,7 +18,6 @@ import Network.Wai.Handler.Warp
1818
1919import Servant
2020import Servant.Server.Generic ()
21−import Servant.API.Generic
2221
2322-- * Example
2423
servant-server/servant-server.cabal+12−12
@@ -1,6 +1,6 @@
11cabal-version: 2.2
22name: servant-server
3−version: 0.19
3+version: 0.19.2
44
55synopsis: A family of combinators for defining webservices APIs and serving them
66category: Servant, Web
@@ -23,7 +23,7 @@ author: Servant Contributors
2323maintainer: haskell-servant-maintainers@googlegroups.com
2424copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
2525build-type: Simple
26−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
26+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.3
2727
2828extra-source-files:
2929 CHANGELOG.md
@@ -60,25 +60,25 @@ library
6060 -- Bundled with GHC: Lower bound to not force re-installs
6161 -- text and mtl are bundled starting with GHC-8.4
6262 build-depends:
63− base >= 4.9 && < 4.16
63+ base >= 4.9 && < 4.18
6464 , bytestring >= 0.10.8.1 && < 0.12
6565 , constraints >= 0.2 && < 0.14
6666 , containers >= 0.5.7.1 && < 0.7
67− , mtl >= 2.2.2 && < 2.3
67+ , mtl ^>= 2.2.2 || ^>= 2.3.1
6868 , text >= 1.2.3.0 && < 2.1
69− , transformers >= 0.5.2.0 && < 0.6
69+ , transformers >= 0.5.2.0 && < 0.7
7070 , filepath >= 1.4.1.1 && < 1.5
7171
7272 -- Servant dependencies
7373 -- strict dependency as we re-export 'servant' things.
7474 build-depends:
75− servant >= 0.19
76− , http-api-data >= 0.4.1 && < 0.4.4
75+ servant >= 0.19 && < 0.20
76+ , http-api-data >= 0.4.1 && < 0.5.1
7777
7878 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
7979 -- Here can be exceptions if we really need features from the newer versions.
8080 build-depends:
81− base-compat >= 0.10.5 && < 0.12
81+ base-compat >= 0.10.5 && < 0.13
8282 , base64-bytestring >= 1.0.0.1 && < 1.3
8383 , exceptions >= 0.10.0 && < 0.11
8484 , http-media >= 0.7.1.3 && < 0.9
@@ -88,10 +88,10 @@ library
8888 , network >= 2.8 && < 3.2
8989 , sop-core >= 0.4.0.0 && < 0.6
9090 , string-conversions >= 0.4.0.1 && < 0.5
91− , resourcet >= 1.2.2 && < 1.3
91+ , resourcet >= 1.2.2 && < 1.4
9292 , tagged >= 0.8.6 && < 0.9
9393 , transformers-base >= 0.4.5.2 && < 0.5
94− , wai >= 3.2.1.2 && < 3.3
94+ , wai >= 3.2.2.1 && < 3.3
9595 , wai-app-static >= 3.1.6.2 && < 3.2
9696 , word8 >= 0.1.3 && < 0.2
9797
@@ -159,7 +159,7 @@ test-suite spec
159159 build-depends:
160160 aeson >= 1.4.1.0 && < 3
161161 , directory >= 1.3.0.0 && < 1.4
162− , hspec >= 2.6.0 && < 2.9
162+ , hspec >= 2.6.0 && < 2.10
163163 , hspec-wai >= 0.10.1 && < 0.12
164164 , QuickCheck >= 2.12.6.1 && < 2.15
165165 , should-not-typecheck >= 2.1.0 && < 2.2
@@ -167,4 +167,4 @@ test-suite spec
167167 , wai-extra >= 3.0.24.3 && < 3.2
168168
169169 build-tool-depends:
170− hspec-discover:hspec-discover >= 2.6.0 && <2.9
170+ hspec-discover:hspec-discover >= 2.6.0 && <2.10
servant-server/src/Servant/Server.hs+3−2
@@ -235,7 +235,7 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])
235235-- > │ └─ e/
236236-- > │ └─•
237237-- > ├─ b/
238−-- > │ └─ <capture>/
238+-- > │ └─ <x::Int>/
239239-- > │ ├─•
240240-- > │ ┆
241241-- > │ └─•
@@ -252,7 +252,8 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])
252252--
253253-- [@─•@] Leaves reflect endpoints.
254254--
255−-- [@\<capture\>/@] This is a delayed capture of a path component.
255+-- [@\<x::Int\>/@] This is a delayed capture of a single
256+-- path component named @x@, of expected type @Int@.
256257--
257258-- [@\<raw\>@] This is a part of the API we do not know anything about.
258259--
servant-server/src/Servant/Server/Experimental/Auth.hs+2−1
@@ -1,5 +1,6 @@
11{-# OPTIONS_GHC -fno-warn-orphans #-}
22{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE DeriveFunctor #-}
34{-# LANGUAGE DeriveGeneric #-}
45{-# LANGUAGE FlexibleContexts #-}
56{-# LANGUAGE FlexibleInstances #-}
@@ -44,7 +45,7 @@ type family AuthServerData a :: *
4445-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
4546newtype AuthHandler r usr = AuthHandler
4647 { unAuthHandler :: r -> Handler usr }
47− deriving (Generic, Typeable)
48+ deriving (Functor, Generic, Typeable)
4849
4950-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
5051mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr
servant-server/src/Servant/Server/Internal.hs+95−11
@@ -1,10 +1,12 @@
11{-# LANGUAGE AllowAmbiguousTypes #-}
22{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE CPP #-}
34{-# LANGUAGE DataKinds #-}
45{-# LANGUAGE DeriveDataTypeable #-}
56{-# LANGUAGE FlexibleContexts #-}
67{-# LANGUAGE FlexibleInstances #-}
78{-# LANGUAGE InstanceSigs #-}
9+{-# LANGUAGE LambdaCase #-}
810{-# LANGUAGE MultiParamTypeClasses #-}
911{-# LANGUAGE OverloadedStrings #-}
1012{-# LANGUAGE PolyKinds #-}
@@ -34,9 +36,10 @@ module Servant.Server.Internal
3436import Control.Monad
3537 (join, when)
3638import Control.Monad.Trans
37− (liftIO)
39+ (liftIO, lift)
3840import Control.Monad.Trans.Resource
39− (runResourceT)
41+ (runResourceT, ReleaseKey)
42+import Data.Acquire
4043import qualified Data.ByteString as B
4144import qualified Data.ByteString.Builder as BB
4245import qualified Data.ByteString.Char8 as BC8
@@ -63,7 +66,7 @@ import Network.HTTP.Types hiding
6366import Network.Socket
6467 (SockAddr)
6568import Network.Wai
66− (Application, Request, httpVersion, isSecure, lazyRequestBody,
69+ (Application, Request, Response, ResponseReceived, httpVersion, isSecure, lazyRequestBody,
6770 queryString, remoteHost, getRequestBodyChunk, requestHeaders,
6871 requestMethod, responseLBS, responseStream, vault)
6972import Prelude ()
@@ -73,10 +76,10 @@ import Servant.API
7376 CaptureAll, Description, EmptyAPI, Fragment,
7477 FramingRender (..), FramingUnrender (..), FromSourceIO (..),
7578 Header', If, IsSecure (..), NoContentVerb, QueryFlag,
76− QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),
79+ QueryParam', QueryParams, Raw, RawM, ReflectMethod (reflectMethod),
7780 RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
7881 Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
79− WithNamedContext, NamedRoutes)
82+ WithNamedContext, WithResource, NamedRoutes)
8083import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
8184import Servant.API.ContentTypes
8285 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
@@ -94,6 +97,8 @@ import Servant.API.TypeErrors
9497import Web.HttpApiData
9598 (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
9699 parseUrlPieces)
100+import Data.Kind
101+ (Type)
97102
98103import Servant.Server.Internal.BasicAuth
99104import Servant.Server.Internal.Context
@@ -112,6 +117,10 @@ import Servant.API.TypeLevel
112117 (AtLeastOneFragment, FragmentUnique)
113118
114119class HasServer api context where
120+ -- | The type of a server for this API, given a monad to run effects in.
121+ --
122+ -- Note that the result kind is @*@, so it is /not/ a monad transformer, unlike
123+ -- what the @T@ in the name might suggest.
115124 type ServerT api (m :: * -> *) :: *
116125
117126 route ::
@@ -173,7 +182,7 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont
173182-- > server = getBook
174183-- > where getBook :: Text -> Handler Book
175184-- > getBook isbn = ...
176−instance (KnownSymbol capture, FromHttpApiData a
185+instance (KnownSymbol capture, FromHttpApiData a, Typeable a
177186 , HasServer api context, SBoolI (FoldLenient mods)
178187 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
179188 )
@@ -185,7 +194,7 @@ instance (KnownSymbol capture, FromHttpApiData a
185194 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
186195
187196 route Proxy context d =
188− CaptureRouter $
197+ CaptureRouter [hint] $
189198 route (Proxy :: Proxy api)
190199 context
191200 (addCapture d $ \ txt -> withRequest $ \ request ->
@@ -197,6 +206,7 @@ instance (KnownSymbol capture, FromHttpApiData a
197206 where
198207 rep = typeRep (Proxy :: Proxy Capture')
199208 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
209+ hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy a))
200210
201211-- | If you use 'CaptureAll' in one of the endpoints for your API,
202212-- this automatically requires your server-side handler to be a
@@ -215,7 +225,7 @@ instance (KnownSymbol capture, FromHttpApiData a
215225-- > server = getSourceFile
216226-- > where getSourceFile :: [Text] -> Handler Book
217227-- > getSourceFile pathSegments = ...
218−instance (KnownSymbol capture, FromHttpApiData a
228+instance (KnownSymbol capture, FromHttpApiData a, Typeable a
219229 , HasServer api context
220230 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
221231 )
@@ -227,7 +237,7 @@ instance (KnownSymbol capture, FromHttpApiData a
227237 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
228238
229239 route Proxy context d =
230− CaptureAllRouter $
240+ CaptureAllRouter [hint] $
231241 route (Proxy :: Proxy api)
232242 context
233243 (addCapture d $ \ txts -> withRequest $ \ request ->
@@ -238,6 +248,43 @@ instance (KnownSymbol capture, FromHttpApiData a
238248 where
239249 rep = typeRep (Proxy :: Proxy CaptureAll)
240250 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
251+ hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy [a]))
252+
253+-- | If you use 'WithResource' in one of the endpoints for your API Servant
254+-- will provide the handler for this endpoint an argument of the specified type.
255+-- The lifespan of this resource will be automatically managed by Servant. This
256+-- resource will be created before the handler starts and it will be destoyed
257+-- after it ends. A new resource is created for each request to the endpoint.
258+
259+-- The creation and destruction are done using a 'Data.Acquire.Acquire'
260+-- provided via server 'Context'.
261+--
262+-- Example
263+--
264+-- > type MyApi = WithResource Handle :> "writeToFile" :> Post '[JSON] NoContent
265+-- >
266+-- > server :: Server MyApi
267+-- > server = writeToFile
268+-- > where writeToFile :: (ReleaseKey, Handle) -> Handler NoContent
269+-- > writeToFile (_, h) = hPutStrLn h "message"
270+--
271+-- In addition to the resource, the handler will also receive a 'ReleaseKey'
272+-- which can be used to deallocate the resource before the end of the request
273+-- if desired.
274+
275+instance (HasServer api ctx, HasContextEntry ctx (Acquire a))
276+ => HasServer (WithResource a :> api) ctx where
277+
278+ type ServerT (WithResource a :> api) m = (ReleaseKey, a) -> ServerT api m
279+
280+ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @api) pc nt . s
281+
282+ route Proxy context d = route (Proxy @api) context (d `addParameterCheck` allocateResource)
283+ where
284+ allocateResource :: DelayedIO (ReleaseKey, a)
285+ allocateResource = DelayedIO $ lift $ allocateAcquire (getContextEntry context)
286+
287+
241288
242289allowedMethodHead :: Method -> Request -> Bool
243290allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
@@ -606,6 +653,35 @@ instance HasServer Raw context where
606653 Fail a -> respond $ Fail a
607654 FailFatal e -> respond $ FailFatal e
608655
656+-- | Just pass the request to the underlying application and serve its response.
657+--
658+-- Example:
659+--
660+-- > type MyApi = "images" :> Raw
661+-- >
662+-- > server :: Server MyApi
663+-- > server = serveDirectory "/var/www/images"
664+instance HasServer RawM context where
665+ type ServerT RawM m = Request -> (Response -> IO ResponseReceived) -> m ResponseReceived
666+
667+ route
668+ :: Proxy RawM
669+ -> Context context
670+ -> Delayed env (Request -> (Response -> IO ResponseReceived) -> Handler ResponseReceived) -> Router env
671+ route _ _ handleDelayed = RawRouter $ \env request respond -> runResourceT $ do
672+ routeResult <- runDelayed handleDelayed env request
673+ let respond' = liftIO . respond
674+ liftIO $ case routeResult of
675+ Route handler -> runHandler (handler request (respond . Route)) >>=
676+ \case
677+ Left e -> respond' $ FailFatal e
678+ Right a -> pure a
679+ Fail e -> respond' $ Fail e
680+ FailFatal e -> respond' $ FailFatal e
681+
682+ hoistServerWithContext _ _ f srvM = \req respond -> f (srvM req respond)
683+
684+
609685-- | If you use 'ReqBody' in one of the endpoints for your API,
610686-- this automatically requires your server-side handler to be a function
611687-- that takes an argument of the type specified by 'ReqBody'.
@@ -819,7 +895,11 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
819895-------------------------------------------------------------------------------
820896
821897-- Erroring instance for 'HasServer' when a combinator is not fully applied
822−instance TypeError (PartialApplication HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
898+instance TypeError (PartialApplication
899+#if __GLASGOW_HASKELL__ >= 904
900+ @(Type -> [Type] -> Constraint)
901+#endif
902+ HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
823903 where
824904 type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)
825905 route = error "unreachable"
@@ -863,7 +943,11 @@ type HasServerArrowTypeError a b =
863943-- XXX: This omits the @context@ parameter, e.g.:
864944--
865945-- "There is no instance for HasServer (Bool :> …)". Do we care ?
866−instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub HasServer ty) => HasServer (ty :> sub) context
946+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub
947+#if __GLASGOW_HASKELL__ >= 904
948+ @(Type -> [Type] -> Constraint)
949+#endif
950+ HasServer ty) => HasServer (ty :> sub) context
867951
868952instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context
869953
servant-server/src/Servant/Server/Internal/Handler.hs+7−2
@@ -13,17 +13,19 @@ import Control.Monad.Base
1313import Control.Monad.Catch
1414 (MonadCatch, MonadMask, MonadThrow)
1515import Control.Monad.Error.Class
16− (MonadError)
16+ (MonadError, throwError)
1717import Control.Monad.IO.Class
1818 (MonadIO)
1919import Control.Monad.Trans.Control
2020 (MonadBaseControl (..))
2121import Control.Monad.Trans.Except
2222 (ExceptT, runExceptT)
23+import Data.String
24+ (fromString)
2325import GHC.Generics
2426 (Generic)
2527import Servant.Server.Internal.ServerError
26− (ServerError)
28+ (ServerError, errBody, err500)
2729
2830newtype Handler a = Handler { runHandler' :: ExceptT ServerError IO a }
2931 deriving
@@ -32,6 +34,9 @@ newtype Handler a = Handler { runHandler' :: ExceptT ServerError IO a }
3234 , MonadThrow, MonadCatch, MonadMask
3335 )
3436
37+instance MonadFail Handler where
38+ fail str = throwError err500 { errBody = fromString str }
39+
3540instance MonadBase IO Handler where
3641 liftBase = Handler . liftBase
3742
servant-server/src/Servant/Server/Internal/Router.hs+50−15
@@ -9,12 +9,16 @@ import Prelude.Compat
99
1010import Data.Function
1111 (on)
12+import Data.List
13+ (nub)
1214import Data.Map
1315 (Map)
1416import qualified Data.Map as M
1517import Data.Text
1618 (Text)
1719import qualified Data.Text as T
20+import Data.Typeable
21+ (TypeRep)
1822import Network.Wai
1923 (Response, pathInfo)
2024import Servant.Server.Internal.ErrorFormatter
@@ -24,6 +28,21 @@ import Servant.Server.Internal.ServerError
2428
2529type Router env = Router' env RoutingApplication
2630
31+-- | Holds information about pieces of url that are captured as variables.
32+data CaptureHint = CaptureHint
33+ { captureName :: Text
34+ -- ^ Holds the name of the captured variable
35+ , captureType :: TypeRep
36+ -- ^ Holds the type of the captured variable
37+ }
38+ deriving (Show, Eq)
39+
40+toCaptureTag :: CaptureHint -> Text
41+toCaptureTag hint = captureName hint <> "::" <> (T.pack . show) (captureType hint)
42+
43+toCaptureTags :: [CaptureHint] -> Text
44+toCaptureTags hints = "<" <> T.intercalate "|" (map toCaptureTag hints) <> ">"
45+
2746-- | Internal representation of a router.
2847--
2948-- The first argument describes an environment type that is
@@ -36,12 +55,23 @@ data Router' env a =
3655 -- ^ the map contains routers for subpaths (first path component used
3756 -- for lookup and removed afterwards), the list contains handlers
3857 -- for the empty path, to be tried in order
39− | CaptureRouter (Router' (Text, env) a)
58+ | CaptureRouter [CaptureHint] (Router' (Text, env) a)
4059 -- ^ first path component is passed to the child router in its
41− -- environment and removed afterwards
42− | CaptureAllRouter (Router' ([Text], env) a)
60+ -- environment and removed afterwards.
61+ -- The first argument is a list of hints for all variables that can be
62+ -- captured by the router. The fact that it is a list is counter-intuitive,
63+ -- because the 'Capture' combinator only allows to capture a single varible,
64+ -- with a single name and a single type. However, the 'choice' smart
65+ -- constructor may merge two 'Capture' combinators with different hints, thus
66+ -- forcing the type to be '[CaptureHint]'.
67+ -- Because 'CaptureRouter' is built from a 'Capture' combinator, the list of
68+ -- hints should always be non-empty.
69+ | CaptureAllRouter [CaptureHint] (Router' ([Text], env) a)
4370 -- ^ all path components are passed to the child router in its
4471 -- environment and are removed afterwards
72+ -- The first argument is a hint for the list of variables that can be
73+ -- captured by the router. Note that the 'captureType' field of the hint
74+ -- should always be '[a]' for some 'a'.
4575 | RawRouter (env -> a)
4676 -- ^ to be used for routes we do not know anything about
4777 | Choice (Router' env a) (Router' env a)
@@ -69,8 +99,8 @@ leafRouter l = StaticRouter M.empty [l]
6999choice :: Router' env a -> Router' env a -> Router' env a
70100choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =
71101 StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)
72−choice (CaptureRouter router1) (CaptureRouter router2) =
73− CaptureRouter (choice router1 router2)
102+choice (CaptureRouter hints1 router1) (CaptureRouter hints2 router2) =
103+ CaptureRouter (nub $ hints1 ++ hints2) (choice router1 router2)
74104choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3
75105choice router1 router2 = Choice router1 router2
76106
@@ -84,7 +114,11 @@ choice router1 router2 = Choice router1 router2
84114--
85115data RouterStructure =
86116 StaticRouterStructure (Map Text RouterStructure) Int
87− | CaptureRouterStructure RouterStructure
117+ | CaptureRouterStructure [CaptureHint] RouterStructure
118+ -- ^ The first argument holds information about variables
119+ -- that are captured by the router. There may be several hints
120+ -- if several routers have been aggregated by the 'choice'
121+ -- smart constructor.
88122 | RawRouterStructure
89123 | ChoiceStructure RouterStructure RouterStructure
90124 deriving (Eq, Show)
@@ -98,11 +132,11 @@ data RouterStructure =
98132routerStructure :: Router' env a -> RouterStructure
99133routerStructure (StaticRouter m ls) =
100134 StaticRouterStructure (fmap routerStructure m) (length ls)
101−routerStructure (CaptureRouter router) =
102− CaptureRouterStructure $
135+routerStructure (CaptureRouter hints router) =
136+ CaptureRouterStructure hints $
103137 routerStructure router
104−routerStructure (CaptureAllRouter router) =
105− CaptureRouterStructure $
138+routerStructure (CaptureAllRouter hints router) =
139+ CaptureRouterStructure hints $
106140 routerStructure router
107141routerStructure (RawRouter _) =
108142 RawRouterStructure
@@ -114,8 +148,8 @@ routerStructure (Choice r1 r2) =
114148-- | Compare the structure of two routers.
115149--
116150sameStructure :: Router' env a -> Router' env b -> Bool
117−sameStructure r1 r2 =
118− routerStructure r1 == routerStructure r2
151+sameStructure router1 router2 =
152+ routerStructure router1 == routerStructure router2
119153
120154-- | Provide a textual representation of the
121155-- structure of a router.
@@ -126,7 +160,8 @@ routerLayout router =
126160 where
127161 mkRouterLayout :: Bool -> RouterStructure -> [Text]
128162 mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n
129− mkRouterLayout c (CaptureRouterStructure r) = mkSubTree c "<capture>" (mkRouterLayout False r)
163+ mkRouterLayout c (CaptureRouterStructure hints r) =
164+ mkSubTree c (toCaptureTags hints) (mkRouterLayout False r)
130165 mkRouterLayout c RawRouterStructure =
131166 if c then ["├─ <raw>"] else ["└─ <raw>"]
132167 mkRouterLayout c (ChoiceStructure r1 r2) =
@@ -169,7 +204,7 @@ runRouterEnv fmt router env request respond =
169204 -> let request' = request { pathInfo = rest }
170205 in runRouterEnv fmt router' env request' respond
171206 _ -> respond $ Fail $ fmt request
172− CaptureRouter router' ->
207+ CaptureRouter _ router' ->
173208 case pathInfo request of
174209 [] -> respond $ Fail $ fmt request
175210 -- This case is to handle trailing slashes.
@@ -177,7 +212,7 @@ runRouterEnv fmt router env request respond =
177212 first : rest
178213 -> let request' = request { pathInfo = rest }
179214 in runRouterEnv fmt router' (first, env) request' respond
180− CaptureAllRouter router' ->
215+ CaptureAllRouter _ router' ->
181216 let segments = pathInfo request
182217 request' = request { pathInfo = [] }
183218 in runRouterEnv fmt router' (segments, env) request' respond
servant-server/test/Servant/Server/RouterSpec.hs+127−6
@@ -9,7 +9,9 @@ import Control.Monad
99import Data.Proxy
1010 (Proxy (..))
1111import Data.Text
12− (unpack)
12+ (Text, unpack)
13+import Data.Typeable
14+ (typeRep)
1315import Network.HTTP.Types
1416 (Status (..))
1517import Network.Wai
@@ -27,6 +29,7 @@ spec :: Spec
2729spec = describe "Servant.Server.Internal.Router" $ do
2830 routerSpec
2931 distributivitySpec
32+ serverLayoutSpec
3033
3134routerSpec :: Spec
3235routerSpec = do
@@ -51,7 +54,7 @@ routerSpec = do
5154 toApp = toApplication . runRouter (const err404)
5255
5356 cap :: Router ()
54− cap = CaptureRouter $
57+ cap = CaptureRouter [hint] $
5558 let delayed = addCapture (emptyDelayed $ Route pure) (const $ delayedFail err400)
5659 in leafRouter
5760 $ \env req res ->
@@ -59,6 +62,9 @@ routerSpec = do
5962 . const
6063 $ Route success
6164
65+ hint :: CaptureHint
66+ hint = CaptureHint "anything" $ typeRep (Proxy :: Proxy ())
67+
6268 router :: Router ()
6369 router = leafRouter (\_ _ res -> res $ Route success)
6470 `Choice` cap
@@ -98,12 +104,30 @@ distributivitySpec =
98104 it "properly handles mixing static paths at different levels" $ do
99105 level `shouldHaveSameStructureAs` levelRef
100106
107+serverLayoutSpec :: Spec
108+serverLayoutSpec =
109+ describe "serverLayout" $ do
110+ it "correctly represents the example API" $ do
111+ exampleLayout `shouldHaveLayout` expectedExampleLayout
112+ it "aggregates capture hints when different" $ do
113+ captureDifferentTypes `shouldHaveLayout` expectedCaptureDifferentTypes
114+ it "nubs capture hints when equal" $ do
115+ captureSameType `shouldHaveLayout` expectedCaptureSameType
116+ it "properly displays CaptureAll hints" $ do
117+ captureAllLayout `shouldHaveLayout` expectedCaptureAllLayout
118+
101119shouldHaveSameStructureAs ::
102120 (HasServer api1 '[], HasServer api2 '[]) => Proxy api1 -> Proxy api2 -> Expectation
103121shouldHaveSameStructureAs p1 p2 =
104122 unless (sameStructure (makeTrivialRouter p1) (makeTrivialRouter p2)) $
105123 expectationFailure ("expected:\n" ++ unpack (layout p2) ++ "\nbut got:\n" ++ unpack (layout p1))
106124
125+shouldHaveLayout ::
126+ (HasServer api '[]) => Proxy api -> Text -> Expectation
127+shouldHaveLayout p l =
128+ unless (routerLayout (makeTrivialRouter p) == l) $
129+ expectationFailure ("expected:\n" ++ unpack l ++ "\nbut got:\n" ++ unpack (layout p))
130+
107131makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router ()
108132makeTrivialRouter p =
109133 route p EmptyContext (emptyDelayed (FailFatal err501))
@@ -144,12 +168,12 @@ staticRef = Proxy
144168-- structure:
145169
146170type Dynamic =
147− "a" :> Capture "foo" Int :> "b" :> End
148− :<|> "a" :> Capture "bar" Bool :> "c" :> End
149− :<|> "a" :> Capture "baz" Char :> "d" :> End
171+ "a" :> Capture "foo" Int :> "b" :> End
172+ :<|> "a" :> Capture "foo" Int :> "c" :> End
173+ :<|> "a" :> Capture "foo" Int :> "d" :> End
150174
151175type DynamicRef =
152− "a" :> Capture "anything" () :>
176+ "a" :> Capture "foo" Int :>
153177 ("b" :> End :<|> "c" :> End :<|> "d" :> End)
154178
155179dynamic :: Proxy Dynamic
@@ -339,3 +363,100 @@ level = Proxy
339363
340364levelRef :: Proxy LevelRef
341365levelRef = Proxy
366+
367+-- The example API for the 'layout' function.
368+-- Should get factorized by the 'choice' smart constructor.
369+type ExampleLayout =
370+ "a" :> "d" :> Get '[JSON] NoContent
371+ :<|> "b" :> Capture "x" Int :> Get '[JSON] Bool
372+ :<|> "c" :> Put '[JSON] Bool
373+ :<|> "a" :> "e" :> Get '[JSON] Int
374+ :<|> "b" :> Capture "x" Int :> Put '[JSON] Bool
375+ :<|> Raw
376+
377+exampleLayout :: Proxy ExampleLayout
378+exampleLayout = Proxy
379+
380+-- The expected representation of the example API layout
381+--
382+expectedExampleLayout :: Text
383+expectedExampleLayout =
384+ "/\n\
385+ \├─ a/\n\
386+ \│ ├─ d/\n\
387+ \│ │ └─•\n\
388+ \│ └─ e/\n\
389+ \│ └─•\n\
390+ \├─ b/\n\
391+ \│ └─ <x::Int>/\n\
392+ \│ ├─•\n\
393+ \│ ┆\n\
394+ \│ └─•\n\
395+ \├─ c/\n\
396+ \│ └─•\n\
397+ \┆\n\
398+ \└─ <raw>\n"
399+
400+-- A capture API with all capture types being the same
401+--
402+type CaptureSameType =
403+ "a" :> Capture "foo" Int :> "b" :> End
404+ :<|> "a" :> Capture "foo" Int :> "c" :> End
405+ :<|> "a" :> Capture "foo" Int :> "d" :> End
406+
407+captureSameType :: Proxy CaptureSameType
408+captureSameType = Proxy
409+
410+-- The expected representation of the CaptureSameType API layout.
411+--
412+expectedCaptureSameType :: Text
413+expectedCaptureSameType =
414+ "/\n\
415+ \└─ a/\n\
416+ \ └─ <foo::Int>/\n\
417+ \ ├─ b/\n\
418+ \ │ └─•\n\
419+ \ ├─ c/\n\
420+ \ │ └─•\n\
421+ \ └─ d/\n\
422+ \ └─•\n"
423+
424+-- A capture API capturing different types
425+--
426+type CaptureDifferentTypes =
427+ "a" :> Capture "foo" Int :> "b" :> End
428+ :<|> "a" :> Capture "bar" Bool :> "c" :> End
429+ :<|> "a" :> Capture "baz" Char :> "d" :> End
430+
431+captureDifferentTypes :: Proxy CaptureDifferentTypes
432+captureDifferentTypes = Proxy
433+
434+-- The expected representation of the CaptureDifferentTypes API layout.
435+--
436+expectedCaptureDifferentTypes :: Text
437+expectedCaptureDifferentTypes =
438+ "/\n\
439+ \└─ a/\n\
440+ \ └─ <foo::Int|bar::Bool|baz::Char>/\n\
441+ \ ├─ b/\n\
442+ \ │ └─•\n\
443+ \ ├─ c/\n\
444+ \ │ └─•\n\
445+ \ └─ d/\n\
446+ \ └─•\n"
447+
448+-- An API with a CaptureAll part
449+
450+type CaptureAllLayout = "a" :> CaptureAll "foos" Int :> End
451+
452+captureAllLayout :: Proxy CaptureAllLayout
453+captureAllLayout = Proxy
454+
455+-- The expected representation of the CaptureAllLayout API.
456+--
457+expectedCaptureAllLayout :: Text
458+expectedCaptureAllLayout =
459+ "/\n\
460+ \└─ a/\n\
461+ \ └─ <foos::[Int]>/\n\
462+ \ └─•\n"
servant-server/test/Servant/ServerSpec.hs+54−6
@@ -17,10 +17,14 @@ import Prelude.Compat
1717
1818import Control.Monad
1919 (forM_, unless, when)
20+import Control.Monad.Reader (runReaderT, ask)
2021import Control.Monad.Error.Class
2122 (MonadError (..))
23+import Control.Monad.IO.Class (MonadIO(..))
2224import Data.Aeson
2325 (FromJSON, ToJSON, decode', encode)
26+import Data.Acquire
27+ (Acquire, mkAcquire)
2428import qualified Data.ByteString as BS
2529import qualified Data.ByteString.Base64 as Base64
2630import Data.Char
@@ -52,19 +56,19 @@ import Servant.API
5256 Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,
5357 Headers, HttpVersion, IsSecure (..), JSON, Lenient,
5458 NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,
55− PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,
59+ PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, RawM,
5660 RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,
5761 UVerb, Union, Verb, WithStatus (..), addHeader)
5862import Servant.Server
59− (Context ((:.), EmptyContext), Handler, Server, Tagged (..),
60− emptyServer, err401, err403, err404, respond, serve,
63+ (Context ((:.), EmptyContext), Handler, Server, ServerT, Tagged (..),
64+ emptyServer, err401, err403, err404, hoistServer, respond, serve,
6165 serveWithContext)
6266import Servant.Test.ComprehensiveAPI
6367import qualified Servant.Types.SourceT as S
6468import Test.Hspec
6569 (Spec, context, describe, it, shouldBe, shouldContain)
6670import Test.Hspec.Wai
67− (get, liftIO, matchHeaders, matchStatus, shouldRespondWith,
71+ (get, matchHeaders, matchStatus, shouldRespondWith,
6872 with, (<:>))
6973import qualified Test.Hspec.Wai as THW
7074
@@ -81,8 +85,11 @@ import Servant.Server.Internal.Context
8185-- This declaration simply checks that all instances are in place.
8286_ = serveWithContext comprehensiveAPI comprehensiveApiContext
8387
84−comprehensiveApiContext :: Context '[NamedContext "foo" '[]]
85−comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext
88+comprehensiveApiContext :: Context '[NamedContext "foo" '[], Acquire Int]
89+comprehensiveApiContext =
90+ NamedContext EmptyContext :.
91+ mkAcquire (pure 10) (\_ -> pure ()) :.
92+ EmptyContext
8693
8794-- * Specs
8895
@@ -97,6 +104,7 @@ spec = do
97104 reqBodySpec
98105 headerSpec
99106 rawSpec
107+ rawMSpec
100108 alternativeSpec
101109 responseHeadersSpec
102110 uverbResponseHeadersSpec
@@ -605,6 +613,46 @@ rawSpec = do
605613
606614-- }}}
607615------------------------------------------------------------------------------
616+-- * rawMSpec {{{
617+------------------------------------------------------------------------------
618+
619+type RawMApi = "foo" :> RawM
620+
621+rawMApi :: Proxy RawMApi
622+rawMApi = Proxy
623+
624+rawMServer :: (Monad m, MonadIO m, Show a) => (Request -> m a) -> ServerT RawMApi m
625+rawMServer f req resp = liftIO . resp . responseLBS ok200 [] . cs . show =<< f req
626+
627+rawMSpec :: Spec
628+rawMSpec = do
629+ describe "Servant.API.RawM" $ do
630+ it "gives access to monadic context" $ do
631+ flip runSession (serve rawMApi
632+ (hoistServer rawMApi (flip runReaderT (42 :: Integer)) (rawMServer (const ask)))) $ do
633+ response <- Network.Wai.Test.request defaultRequest{
634+ pathInfo = ["foo"]
635+ }
636+ liftIO $ do
637+ simpleBody response `shouldBe` "42"
638+
639+ it "lets users throw servant errors" $ do
640+ flip runSession (serve rawMApi (rawMServer (const $ throwError err404 >> pure (42 :: Integer)))) $ do
641+ response <- Network.Wai.Test.request defaultRequest{
642+ pathInfo = ["foo"]
643+ }
644+ liftIO $ do
645+ statusCode (simpleStatus response) `shouldBe` 404
646+
647+ it "gets the pathInfo modified" $ do
648+ flip runSession (serve rawMApi (rawMServer (pure . pathInfo))) $ do
649+ response <- Network.Wai.Test.request defaultRequest{
650+ pathInfo = ["foo", "bar"]
651+ }
652+ liftIO $ do
653+ simpleBody response `shouldBe` cs (show ["bar" :: String])
654+-- }}}
655+------------------------------------------------------------------------------
608656-- * alternativeSpec {{{
609657------------------------------------------------------------------------------
610658type AlternativeApi =
servant-swagger/servant-swagger.cabal+13−13
@@ -3,10 +3,10 @@ name: servant-swagger
33version: 1.1.11
44synopsis: Generate a Swagger/OpenAPI/OAS 2.0 specification for your servant API.
55description:
6− Swagger is a project used to describe and document RESTful APIs. The core of the
7− project is the [OpenAPI Specification (OAS)](https://swagger.io/docs/specification/about/).
8− This library implements v2.0 of the spec. Unlike Servant it is language-agnostic and thus is
9− quite popular among developers in different languages. It has also existed for a longer time
6+ Swagger is a project used to describe and document RESTful APIs. The core of the
7+ project is the [OpenAPI Specification (OAS)](https://swagger.io/docs/specification/about/).
8+ This library implements v2.0 of the spec. Unlike Servant it is language-agnostic and thus is
9+ quite popular among developers in different languages. It has also existed for a longer time
1010 and has more helpful tooling.
1111 .
1212 This package provides means to generate a Swagger/OAS specification for a Servant API
@@ -19,7 +19,7 @@ description:
1919 * generating clients and servers in many languages using [Swagger Codegen](http://swagger.io/swagger-codegen/);
2020 .
2121 * and [many others](http://swagger.io/open-source-integrations/).
22−homepage: https://github.com/haskell-servant/servant/servant-swagger
22+homepage: https://github.com/haskell-servant/servant/tree/master/servant-swagger#readme
2323bug-reports: https://github.com/haskell-servant/servant/issues
2424license: BSD-3-Clause
2525license-file: LICENSE
@@ -50,7 +50,7 @@ source-repository head
5050custom-setup
5151 setup-depends:
5252 base >=4.9 && <5,
53− Cabal >= 1.24 && < 3.5,
53+ Cabal >= 1.24,
5454 cabal-doctest >=1.0.6 && <1.1
5555
5656library
@@ -72,12 +72,12 @@ library
7272 build-depends: aeson >=1.4.2.0 && <3
7373 , aeson-pretty >=0.8.7 && <0.9
7474 , base >=4.9.1.0 && <5
75− , base-compat >=0.10.5 && <0.12
76− , bytestring >=0.10.8.1 && <0.11
75+ , base-compat >=0.10.5 && <0.13
76+ , bytestring >=0.10.8.1 && <0.12
7777 , http-media >=0.7.1.3 && <0.9
7878 , insert-ordered-containers >=0.2.1.0 && <0.3
7979 , lens >=4.17 && <6
80− , servant >=0.18.1 && <0.20
80+ , servant >=0.18.2 && <0.20
8181 , singleton-bool >=0.1.4 && <0.2
8282 , swagger2 >=2.3.0.1 && <3
8383 , text >=1.2.3.0 && <2.1
@@ -92,7 +92,7 @@ test-suite doctests
9292 build-depends:
9393 base,
9494 directory >= 1.0,
95− doctest >= 0.17 && <0.19,
95+ doctest >= 0.17 && <0.21,
9696 servant,
9797 QuickCheck,
9898 filepath
@@ -106,14 +106,14 @@ test-suite spec
106106 type: exitcode-stdio-1.0
107107 hs-source-dirs: test
108108 main-is: Spec.hs
109− build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.8
109+ build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.11
110110 build-depends: base
111111 , base-compat
112112 , aeson >=1.4.2.0 && <3
113− , hspec >=2.6.0 && <2.8
113+ , hspec >=2.6.0 && <2.11
114114 , QuickCheck
115115 , lens
116− , lens-aeson >=1.0.2 && <1.2
116+ , lens-aeson >=1.0.2 && <1.3
117117 , servant
118118 , servant-swagger
119119 , swagger2
servant-swagger/src/Servant/Swagger.hs+5−3
@@ -55,6 +55,7 @@ import Servant.Swagger.Internal.Orphans ()
5555-- >>> import Data.Typeable
5656-- >>> import GHC.Generics
5757-- >>> import Servant.API
58+-- >>> import System.Environment
5859-- >>> import Test.Hspec
5960-- >>> import Test.QuickCheck
6061-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL8
@@ -64,6 +65,7 @@ import Servant.Swagger.Internal.Orphans ()
6465-- >>> :set -XGeneralizedNewtypeDeriving
6566-- >>> :set -XOverloadedStrings
6667-- >>> :set -XTypeOperators
68+-- >>> setEnv "HSPEC_COLOR" "no"
6769-- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable)
6870-- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON)
6971-- >>> instance ToJSON User
@@ -160,11 +162,11 @@ import Servant.Swagger.Internal.Orphans ()
160162-- >>> instance Arbitrary UserId where arbitrary = UserId <$> arbitrary
161163-- >>> hspec $ validateEveryToJSON (Proxy :: Proxy UserAPI)
162164-- <BLANKLINE>
163−-- [User]
165+-- [User]...
164166-- ...
165−-- User
167+-- User...
166168-- ...
167−-- UserId
169+-- UserId...
168170-- ...
169171-- Finished in ... seconds
170172-- 3 examples, 0 failures
servant-swagger/src/Servant/Swagger/Internal.hs+15
@@ -3,11 +3,13 @@
33{-# LANGUAGE DataKinds #-}
44{-# LANGUAGE FlexibleContexts #-}
55{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE OverloadedLists #-}
67{-# LANGUAGE OverloadedStrings #-}
78{-# LANGUAGE PolyKinds #-}
89{-# LANGUAGE RankNTypes #-}
910{-# LANGUAGE ScopedTypeVariables #-}
1011{-# LANGUAGE TypeOperators #-}
12+{-# LANGUAGE TypeFamilies #-}
1113#if __GLASGOW_HASKELL__ >= 806
1214{-# LANGUAGE UndecidableInstances #-}
1315#endif
@@ -30,11 +32,13 @@ import qualified Data.Swagger as Swagger
3032import Data.Swagger.Declare
3133import Data.Text (Text)
3234import qualified Data.Text as Text
35+import GHC.Generics (D1, Meta(..), Rep)
3336import GHC.TypeLits
3437import Network.HTTP.Media (MediaType)
3538import Servant.API
3639import Servant.API.Description (FoldDescription,
3740 reflectDescription)
41+import Servant.API.Generic (ToServantApi, AsApi)
3842import Servant.API.Modifiers (FoldRequired)
3943
4044import Servant.Swagger.Internal.TypeLevel.API
@@ -149,6 +153,10 @@ mkEndpointNoContentVerb path _ = mempty
149153addParam :: Param -> Swagger -> Swagger
150154addParam param = allOperations.parameters %~ (Inline param :)
151155
156+-- | Add a tag to every operation in the spec.
157+addTag :: Text -> Swagger -> Swagger
158+addTag tag = allOperations.tags %~ ([tag] <>)
159+
152160-- | Add accepted content types to every operation in the spec.
153161addConsumes :: [MediaType] -> Swagger -> Swagger
154162addConsumes cs = allOperations.consumes %~ (<> Just (MimeList cs))
@@ -296,6 +304,10 @@ instance (HasSwagger sub) => HasSwagger (HttpVersion :> sub) where
296304instance (HasSwagger sub) => HasSwagger (WithNamedContext x c sub) where
297305 toSwagger _ = toSwagger (Proxy :: Proxy sub)
298306
307+-- | @'WithResource'@ combinator does not change our specification at all.
308+instance (HasSwagger sub) => HasSwagger (WithResource res :> sub) where
309+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
310+
299311instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (sym :> sub) where
300312 toSwagger _ = prependPath piece (toSwagger (Proxy :: Proxy sub))
301313 where
@@ -439,6 +451,9 @@ instance (ToSchema a, Accept ct, HasSwagger sub, KnownSymbol (FoldDescription mo
439451 & required ?~ True
440452 & schema .~ ParamBody ref
441453
454+instance (HasSwagger (ToServantApi routes), KnownSymbol datatypeName, Rep (routes AsApi) ~ D1 ('MetaData datatypeName moduleName packageName isNewtype) f) => HasSwagger (NamedRoutes routes) where
455+ toSwagger _ = addTag (Text.pack $ symbolVal (Proxy :: Proxy datatypeName)) (toSwagger (Proxy :: Proxy (ToServantApi routes)))
456+
442457-- =======================================================================
443458-- Below are the definitions that should be in Servant.API.ContentTypes
444459-- =======================================================================
servant-swagger/src/Servant/Swagger/Internal/Test.hs+8−6
@@ -29,10 +29,12 @@ import Servant.Swagger.Internal.TypeLevel
2929-- >>> import Control.Applicative
3030-- >>> import GHC.Generics
3131-- >>> import Test.QuickCheck
32+-- >>> import System.Environment (setEnv)
3233-- >>> :set -XDeriveGeneric
3334-- >>> :set -XGeneralizedNewtypeDeriving
3435-- >>> :set -XDataKinds
3536-- >>> :set -XTypeOperators
37+-- >>> setEnv "HSPEC_COLOR" "no"
3638
3739-- | Verify that every type used with @'JSON'@ content type in a servant API
3840-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSON'@.
@@ -53,10 +55,10 @@ import Servant.Swagger.Internal.TypeLevel
5355--
5456-- >>> hspec $ context "ToJSON matches ToSchema" $ validateEveryToJSON (Proxy :: Proxy UserAPI)
5557-- <BLANKLINE>
56−-- ToJSON matches ToSchema
57−-- User
58+-- ToJSON matches ToSchema...
59+-- User...
5860-- ...
59−-- UserId
61+-- UserId...
6062-- ...
6163-- Finished in ... seconds
6264-- 2 examples, 0 failures
@@ -118,11 +120,11 @@ validateEveryToJSONWithPatternChecker checker _ = props
118120-- :}
119121-- <BLANKLINE>
120122-- read . show == id
121−-- Bool
123+-- Bool...
122124-- ...
123−-- Int
125+-- Int...
124126-- ...
125−-- [Char]
127+-- [Char]...
126128-- ...
127129-- Finished in ... seconds
128130-- 3 examples, 0 failures
servant/CHANGELOG.md+5
@@ -2,6 +2,11 @@
22
33Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions.
44
5+0.19.1
6+------
7+
8+Compatibility with GHC 9.4, see [PR #1592](https://github.com/haskell-servant/servant/pull/1592).
9+
5100.19
611----
712
servant/servant.cabal+10−9
@@ -1,6 +1,6 @@
11cabal-version: 2.2
22name: servant
3−version: 0.19
3+version: 0.19.1
44
55synopsis: A family of combinators for defining webservices APIs
66category: Servant, Web
@@ -62,6 +62,7 @@ library
6262 Servant.API.Vault
6363 Servant.API.Verbs
6464 Servant.API.WithNamedContext
65+ Servant.API.WithResource
6566
6667 -- Types
6768 exposed-modules:
@@ -80,25 +81,25 @@ library
8081 --
8182 -- note: mtl lower bound is so low because of GHC-7.8
8283 build-depends:
83− base >= 4.9 && < 4.16
84+ base >= 4.9 && < 4.18
8485 , bytestring >= 0.10.8.1 && < 0.12
8586 , constraints >= 0.2
86− , mtl >= 2.2.2 && < 2.3
87+ , mtl ^>= 2.2.2 || ^>= 2.3.1
8788 , sop-core >= 0.4.0.0 && < 0.6
88− , transformers >= 0.5.2.0 && < 0.6
89+ , transformers >= 0.5.2.0 && < 0.7
8990 , text >= 1.2.3.0 && < 2.1
9091
9192
9293 -- We depend (heavily) on the API of these packages:
9394 -- i.e. re-export, or allow using without direct dependency
9495 build-depends:
95− http-api-data >= 0.4.1 && < 0.4.4
96+ http-api-data >= 0.4.1 && < 0.5.1
9697 , singleton-bool >= 0.1.4 && < 0.1.7
9798
9899 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
99100 -- Here can be exceptions if we really need features from the newer versions.
100101 build-depends:
101− base-compat >= 0.10.5 && < 0.12
102+ base-compat >= 0.10.5 && < 0.13
102103 , aeson >= 1.4.1.0 && < 3
103104 , attoparsec >= 0.13.2.2 && < 0.15
104105 , bifunctors >= 5.5.3 && < 5.6
@@ -106,7 +107,7 @@ library
106107 , deepseq >= 1.4.2.0 && < 1.5
107108 , http-media >= 0.7.1.3 && < 0.9
108109 , http-types >= 0.12.2 && < 0.13
109− , mmorph >= 1.1.2 && < 1.2
110+ , mmorph >= 1.1.2 && < 1.3
110111 , network-uri >= 2.6.1.0 && < 2.7
111112 , QuickCheck >= 2.12.6.1 && < 2.15
112113 , string-conversions >= 0.4.0.1 && < 0.5
@@ -166,9 +167,9 @@ test-suite spec
166167
167168 -- Additional dependencies
168169 build-depends:
169− hspec >= 2.6.0 && < 2.9
170+ hspec >= 2.6.0 && < 2.10
170171 , QuickCheck >= 2.12.6.1 && < 2.15
171172 , quickcheck-instances >= 0.3.19 && < 0.4
172173
173174 build-tool-depends:
174− hspec-discover:hspec-discover >= 2.6.0 && < 2.9
175+ hspec-discover:hspec-discover >= 2.6.0 && < 2.10
servant/src/Servant/API.hs+11−3
@@ -31,6 +31,8 @@ module Servant.API (
3131 -- | Access the location for arbitrary data to be shared by applications and middleware
3232 module Servant.API.WithNamedContext,
3333 -- | Access context entries in combinators in servant-server
34+ module Servant.API.WithResource,
35+ -- | Access a managed resource scoped to a single request
3436
3537 -- * Actual endpoints, distinguished by HTTP method
3638 module Servant.API.Verbs,
@@ -38,6 +40,7 @@ module Servant.API (
3840
3941 -- * Sub-APIs defined as records of routes
4042 module Servant.API.NamedRoutes,
43+ module Servant.API.Generic,
4144
4245 -- * Streaming endpoints, distinguished by HTTP method
4346 module Servant.API.Stream,
@@ -100,6 +103,9 @@ import Servant.API.Experimental.Auth
100103 (AuthProtect)
101104import Servant.API.Fragment
102105 (Fragment)
106+import Servant.API.Generic
107+ (AsApi, GServantProduct, GenericMode ((:-)), GenericServant,
108+ ToServant, ToServantApi, fromServant, genericApi, toServant)
103109import Servant.API.Header
104110 (Header, Header')
105111import Servant.API.HttpVersion
@@ -108,10 +114,12 @@ import Servant.API.IsSecure
108114 (IsSecure (..))
109115import Servant.API.Modifiers
110116 (Lenient, Optional, Required, Strict)
117+import Servant.API.NamedRoutes
118+ (NamedRoutes)
111119import Servant.API.QueryParam
112120 (QueryFlag, QueryParam, QueryParam', QueryParams)
113121import Servant.API.Raw
114− (Raw)
122+ (Raw, RawM)
115123import Servant.API.RemoteHost
116124 (RemoteHost)
117125import Servant.API.ReqBody
@@ -133,8 +141,6 @@ import Servant.API.UVerb
133141 Unique, WithStatus (..), inject, statusOf)
134142import Servant.API.Vault
135143 (Vault)
136−import Servant.API.NamedRoutes
137− (NamedRoutes)
138144import Servant.API.Verbs
139145 (Delete, DeleteAccepted, DeleteNoContent,
140146 DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,
@@ -146,6 +152,8 @@ import Servant.API.Verbs
146152 ReflectMethod (reflectMethod), StdMethod (..), Verb)
147153import Servant.API.WithNamedContext
148154 (WithNamedContext)
155+import Servant.API.WithResource
156+ (WithResource)
149157import Servant.Links
150158 (HasLink (..), IsElem, IsElem', Link, URI (..), safeLink)
151159import Web.HttpApiData
servant/src/Servant/API/ContentTypes.hs+1−1
@@ -295,7 +295,7 @@ instance {-# OVERLAPPABLE #-}
295295-- then this would be taken care of. However there is no more specific instance
296296-- between that and 'MimeRender JSON a', so we do this instead
297297instance {-# OVERLAPPING #-} ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where
298− allMimeRender _ _ = map (, "") $ NE.toList $ contentTypes pctyp
298+ allMimeRender _ NoContent = map (, "") $ NE.toList $ contentTypes pctyp
299299 where
300300 pctyp = Proxy :: Proxy ctyp
301301
servant/src/Servant/API/Raw.hs+3
@@ -15,3 +15,6 @@ import Data.Typeable
1515-- <https://hackage.haskell.org/package/servant-server/docs/Servant-Server-StaticFiles.html Servant.Server.StaticFiles>
1616-- to serve static files stored in a particular directory on your filesystem
1717data Raw deriving Typeable
18+
19+-- | Variant of 'Raw' that lets you access the underlying monadic context to process the request.
20+data RawM deriving Typeable
servant/src/Servant/API/ResponseHeaders.hs+23
@@ -8,6 +8,7 @@
88{-# LANGUAGE PolyKinds #-}
99{-# LANGUAGE ScopedTypeVariables #-}
1010{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE TypeFamilyDependencies #-}
1112{-# LANGUAGE TypeOperators #-}
1213{-# LANGUAGE UndecidableInstances #-}
1314{-# OPTIONS_HADDOCK not-home #-}
@@ -51,6 +52,9 @@ import Prelude ()
5152import Prelude.Compat
5253import Servant.API.Header
5354 (Header)
55+import Servant.API.UVerb.Union
56+import qualified Data.SOP.BasicFunctors as SOP
57+import qualified Data.SOP.NS as SOP
5458
5559-- | Response Header objects. You should never need to construct one directly.
5660-- Instead, use 'addOptionalHeader'.
@@ -170,6 +174,25 @@ instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '
170174 => AddHeader h v a new where
171175 addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)
172176
177+-- Instances to decorate all responses in a 'Union' with headers. The functional
178+-- dependencies force us to consider singleton lists as the base case in the
179+-- recursion (it is impossible to determine h and v otherwise from old / new
180+-- responses if the list is empty).
181+instance (AddHeader h v old new) => AddHeader h v (Union '[old]) (Union '[new]) where
182+ addOptionalHeader hdr resp =
183+ SOP.Z $ SOP.I $ addOptionalHeader hdr $ SOP.unI $ SOP.unZ $ resp
184+
185+instance
186+ ( AddHeader h v old new, AddHeader h v (Union oldrest) (Union newrest)
187+ -- This ensures that the remainder of the response list is _not_ empty
188+ -- It is necessary to prevent the two instances for union types from
189+ -- overlapping.
190+ , oldrest ~ (a ': as), newrest ~ (b ': bs))
191+ => AddHeader h v (Union (old ': (a ': as))) (Union (new ': (b ': bs))) where
192+ addOptionalHeader hdr resp = case resp of
193+ SOP.Z (SOP.I rHead) -> SOP.Z $ SOP.I $ addOptionalHeader hdr rHead
194+ SOP.S rOthers -> SOP.S $ addOptionalHeader hdr rOthers
195+
173196-- | @addHeader@ adds a header to a response. Note that it changes the type of
174197-- the value in the following ways:
175198--
servant/src/Servant/API/TypeLevel.hs+3−3
@@ -110,7 +110,7 @@ type family IsElem' a s :: Constraint
110110--
111111-- >>> ok (Proxy :: Proxy (IsElem ("bye" :> Get '[JSON] Int) SampleAPI))
112112-- ...
113−-- ... Could not deduce...
113+-- ... Could not ...
114114-- ...
115115--
116116-- An endpoint is considered within an api even if it is missing combinators
@@ -151,7 +151,7 @@ type family IsElem endpoint api :: Constraint where
151151--
152152-- >>> ok (Proxy :: Proxy (IsSubAPI (SampleAPI :<|> Get '[JSON] Int) SampleAPI))
153153-- ...
154−-- ... Could not deduce...
154+-- ... Could not ...
155155-- ...
156156--
157157-- This uses @IsElem@ for checking; thus the note there applies here.
@@ -174,7 +174,7 @@ type family AllIsElem xs api :: Constraint where
174174--
175175-- >>> ok (Proxy :: Proxy (IsIn (Get '[JSON] Int) (Header "h" Bool :> Get '[JSON] Int)))
176176-- ...
177−-- ... Could not deduce...
177+-- ... Could not ...
178178-- ...
179179type family IsIn (endpoint :: *) (api :: *) :: Constraint where
180180 IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb)
servant/src/Servant/API/UVerb.hs+3
@@ -38,6 +38,7 @@ import GHC.TypeLits (Nat)
3838import Network.HTTP.Types (Status, StdMethod)
3939import Servant.API.ContentTypes (JSON, PlainText, FormUrlEncoded, OctetStream, NoContent, MimeRender(mimeRender), MimeUnrender(mimeUnrender))
4040import Servant.API.Status (KnownStatus, statusVal)
41+import Servant.API.ResponseHeaders (Headers)
4142import Servant.API.UVerb.Union
4243
4344class KnownStatus (StatusOf a) => HasStatus (a :: *) where
@@ -86,6 +87,8 @@ newtype WithStatus (k :: Nat) a = WithStatus a
8687instance KnownStatus n => HasStatus (WithStatus n a) where
8788 type StatusOf (WithStatus n a) = n
8889
90+instance HasStatus a => HasStatus (Headers ls a) where
91+ type StatusOf (Headers ls a) = StatusOf a
8992
9093-- | A variant of 'Verb' that can have any of a number of response values and status codes.
9194--
servant/src/Servant/API/UVerb/Union.hs+2−2
@@ -128,9 +128,9 @@ type DuplicateElementError (rs :: [k]) =
128128 ':$$: 'Text " " ':<>: 'ShowType rs
129129
130130type family Elem (x :: k) (xs :: [k]) :: Bool where
131+ Elem x (x ': _) = 'True
132+ Elem x (_ ': xs) = Elem x xs
131133 Elem _ '[] = 'False
132− Elem x (x' ': xs) =
133− If (x == x') 'True (Elem x xs)
134134
135135type family Unique xs :: Constraint where
136136 Unique xs = If (Nubbed xs == 'True) (() :: Constraint) (TypeError (DuplicateElementError xs))
servant/src/Servant/API/WithResource.hsnew file+3
@@ -0,0 +1,3 @@
1+module Servant.API.WithResource (WithResource) where
2+
3+data WithResource res
servant/src/Servant/Links.hs+25−4
@@ -1,5 +1,6 @@
11{-# LANGUAGE AllowAmbiguousTypes #-}
22{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE CPP #-}
34{-# LANGUAGE DataKinds #-}
45{-# LANGUAGE FlexibleContexts #-}
56{-# LANGUAGE FlexibleInstances #-}
@@ -91,7 +92,7 @@
9192-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] NoContent)
9293-- >>> safeLink api bad_link
9394-- ...
94−-- ...Could not deduce...
95+-- ...Could not ...
9596-- ...
9697--
9798-- This error is essentially saying that the type family couldn't find
@@ -174,7 +175,7 @@ import Servant.API.NamedRoutes
174175import Servant.API.QueryParam
175176 (QueryFlag, QueryParam', QueryParams)
176177import Servant.API.Raw
177− (Raw)
178+ (Raw, RawM)
178179import Servant.API.RemoteHost
179180 (RemoteHost)
180181import Servant.API.ReqBody
@@ -192,7 +193,11 @@ import Servant.API.Verbs
192193 (Verb, NoContentVerb)
193194import Servant.API.WithNamedContext
194195 (WithNamedContext)
196+import Servant.API.WithResource
197+ (WithResource)
195198import Web.HttpApiData
199+import Data.Kind
200+ (Type)
196201
197202-- | A safe link datatype.
198203-- The only way of constructing a 'Link' is using 'safeLink', which means any
@@ -555,6 +560,10 @@ instance HasLink sub => HasLink (WithNamedContext name context sub) where
555560 type MkLink (WithNamedContext name context sub) a = MkLink sub a
556561 toLink toA _ = toLink toA (Proxy :: Proxy sub)
557562
563+instance HasLink sub => HasLink (WithResource res :> sub) where
564+ type MkLink (WithResource res :> sub) a = MkLink sub a
565+ toLink toA _ = toLink toA (Proxy :: Proxy sub)
566+
558567instance HasLink sub => HasLink (RemoteHost :> sub) where
559568 type MkLink (RemoteHost :> sub) a = MkLink sub a
560569 toLink = simpleToLink (Proxy :: Proxy sub)
@@ -580,6 +589,10 @@ instance HasLink Raw where
580589 type MkLink Raw a = a
581590 toLink toA _ = toA
582591
592+instance HasLink RawM where
593+ type MkLink RawM a = a
594+ toLink toA _ = toA
595+
583596instance HasLink (Stream m status fr ct a) where
584597 type MkLink (Stream m status fr ct a) r = r
585598 toLink toA _ = toA
@@ -647,12 +660,20 @@ simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub)
647660-- >>> import Data.Text (Text)
648661
649662-- Erroring instance for 'HasLink' when a combinator is not fully applied
650−instance TypeError (PartialApplication HasLink arr) => HasLink ((arr :: a -> b) :> sub)
663+instance TypeError (PartialApplication
664+#if __GLASGOW_HASKELL__ >= 904
665+ @(Type -> Constraint)
666+#endif
667+ HasLink arr) => HasLink ((arr :: a -> b) :> sub)
651668 where
652669 type MkLink (arr :> sub) _ = TypeError (PartialApplication (HasLink :: * -> Constraint) arr)
653670 toLink = error "unreachable"
654671
655672-- Erroring instances for 'HasLink' for unknown API combinators
656−instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub HasLink ty) => HasLink (ty :> sub)
673+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub
674+#if __GLASGOW_HASKELL__ >= 904
675+ @(Type -> Constraint)
676+#endif
677+ HasLink ty) => HasLink (ty :> sub)
657678
658679instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasLink api)) => HasLink api
servant/src/Servant/Test/ComprehensiveAPI.hs+1
@@ -72,6 +72,7 @@ type ComprehensiveAPIWithoutStreamingOrRaw' endpoint =
7272 :<|> "description" :> Description "foo" :> GET
7373 :<|> "alternative" :> ("left" :> GET :<|> "right" :> GET)
7474 :<|> "fragment" :> Fragment Int :> GET
75+ :<|> "resource" :> WithResource Int :> GET
7576 :<|> endpoint
7677
7778type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint
servant/src/Servant/Types/SourceT.hs+3
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DeriveFunctor #-}
23{-# LANGUAGE GADTs #-}
34{-# LANGUAGE RankNTypes #-}
@@ -154,8 +155,10 @@ instance (Applicative m, Show1 m, Show a) => Show (StepT m a) where
154155-- | >>> lift [1,2,3] :: StepT [] Int
155156-- Effect [Yield 1 Stop,Yield 2 Stop,Yield 3 Stop]
156157--
158+#if !MIN_VERSION_transformers(0,6,0)
157159instance MonadTrans StepT where
158160 lift = Effect . fmap (`Yield` Stop)
161+#endif
159162
160163instance MFunctor StepT where
161164 hoist f = go where
servant/test/Servant/API/ContentTypesSpec.hs+11
@@ -33,6 +33,8 @@ import Data.String.Conversions
3333import qualified Data.Text as TextS
3434import qualified Data.Text.Encoding as TextSE
3535import qualified Data.Text.Lazy as TextL
36+import Control.Exception
37+ (evaluate)
3638import GHC.Generics
3739import Test.Hspec
3840import Test.QuickCheck
@@ -78,6 +80,15 @@ spec = describe "Servant.API.ContentTypes" $ do
7880 it "has mimeUnrender reverse mimeRender for valid top-level json " $ do
7981 property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData)
8082
83+ describe "The NoContent Content-Type type" $ do
84+ let p = Proxy :: Proxy '[JSON]
85+
86+ it "does not render any content" $
87+ allMimeRender p NoContent `shouldSatisfy` (all (BSL8.null . snd))
88+
89+ it "evaluates the NoContent value" $
90+ evaluate (allMimeRender p (undefined :: NoContent)) `shouldThrow` anyErrorCall
91+
8192 describe "The PlainText Content-Type type" $ do
8293 let p = Proxy :: Proxy PlainText
8394
servant/test/Servant/API/ResponseHeadersSpec.hs+11
@@ -2,10 +2,14 @@
22{-# LANGUAGE OverloadedStrings #-}
33module Servant.API.ResponseHeadersSpec where
44
5+import Data.Proxy
6+import GHC.TypeLits
57import Test.Hspec
68
9+import Servant.API.ContentTypes
710import Servant.API.Header
811import Servant.API.ResponseHeaders
12+import Servant.API.UVerb
913
1014spec :: Spec
1115spec = describe "Servant.API.ResponseHeaders" $ do
@@ -28,3 +32,10 @@ spec = describe "Servant.API.ResponseHeaders" $ do
2832 it "does not add a header" $ do
2933 let val = noHeader 5 :: Headers '[Header "test" Int] Int
3034 getHeaders val `shouldBe` []
35+
36+ describe "HasStatus Headers" $ do
37+
38+ it "gets the status from the underlying value" $ do
39+ natVal (Proxy :: Proxy (StatusOf (Headers '[Header "first" Int] NoContent))) `shouldBe` 204
40+ natVal (Proxy :: Proxy (StatusOf (Headers '[Header "first" Int] (WithStatus 503 ())))) `shouldBe` 503
41+