Compare commits
6 commits
master
...
servant-au
| Author | SHA1 | Date | |
|---|---|---|---|
|
24531ac333 | ||
|
|
426d3ce39b | ||
|
|
c5a3bc1b51 | ||
|
|
b84095ee5a | ||
|
|
04ba7e7a6b | ||
|
|
030d852883 |
76 changed files with 297 additions and 875 deletions
60
.github/workflows/master.yml
vendored
60
.github/workflows/master.yml
vendored
|
|
@ -20,7 +20,6 @@ jobs:
|
|||
- "8.10.7"
|
||||
- "9.0.2"
|
||||
- "9.2.2"
|
||||
- "9.4.2"
|
||||
|
||||
steps:
|
||||
- uses: actions/checkout@v2
|
||||
|
|
@ -60,6 +59,9 @@ jobs:
|
|||
cabal test all
|
||||
|
||||
- name: Run doctests
|
||||
# doctests are broken on GHC 9 due to compiler bug:
|
||||
# https://gitlab.haskell.org/ghc/ghc/-/issues/19460
|
||||
continue-on-error: ${{ matrix.ghc == '9.0.1' }}
|
||||
run: |
|
||||
# Necessary for doctest to be found in $PATH
|
||||
export PATH="$HOME/.cabal/bin:$PATH"
|
||||
|
|
@ -76,40 +78,40 @@ jobs:
|
|||
(cd servant-conduit && eval $DOCTEST)
|
||||
(cd servant-pipes && eval $DOCTEST)
|
||||
|
||||
# stack:
|
||||
# name: stack / ghc ${{ matrix.ghc }}
|
||||
# runs-on: ubuntu-latest
|
||||
# strategy:
|
||||
# matrix:
|
||||
# stack: ["2.7.5"]
|
||||
# ghc: ["8.10.7"]
|
||||
stack:
|
||||
name: stack / ghc ${{ matrix.ghc }}
|
||||
runs-on: ubuntu-latest
|
||||
strategy:
|
||||
matrix:
|
||||
stack: ["2.7.3"]
|
||||
ghc: ["8.10.7"]
|
||||
|
||||
# steps:
|
||||
# - uses: actions/checkout@v2
|
||||
steps:
|
||||
- uses: actions/checkout@v2
|
||||
|
||||
# - uses: haskell/actions/setup@v1
|
||||
# name: Setup Haskell Stack
|
||||
# with:
|
||||
# ghc-version: ${{ matrix.ghc }}
|
||||
# stack-version: ${{ matrix.stack }}
|
||||
- uses: haskell/actions/setup@v1
|
||||
name: Setup Haskell Stack
|
||||
with:
|
||||
ghc-version: ${{ matrix.ghc }}
|
||||
stack-version: ${{ matrix.stack }}
|
||||
|
||||
# - uses: actions/cache@v2.1.3
|
||||
# name: Cache ~/.stack
|
||||
# with:
|
||||
# path: ~/.stack
|
||||
# key: ${{ runner.os }}-${{ matrix.ghc }}-stack
|
||||
- uses: actions/cache@v2.1.3
|
||||
name: Cache ~/.stack
|
||||
with:
|
||||
path: ~/.stack
|
||||
key: ${{ runner.os }}-${{ matrix.ghc }}-stack
|
||||
|
||||
# - name: Install dependencies
|
||||
# run: |
|
||||
# stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies
|
||||
- name: Install dependencies
|
||||
run: |
|
||||
stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies
|
||||
|
||||
# - name: Build
|
||||
# run: |
|
||||
# stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks
|
||||
- name: Build
|
||||
run: |
|
||||
stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks
|
||||
|
||||
# - name: Test
|
||||
# run: |
|
||||
# stack test --system-ghc
|
||||
- name: Test
|
||||
run: |
|
||||
stack test --system-ghc
|
||||
|
||||
ghcjs:
|
||||
name: ubuntu-latest / ghcjs 8.6
|
||||
|
|
|
|||
|
|
@ -47,7 +47,6 @@ packages:
|
|||
doc/cookbook/using-custom-monad
|
||||
doc/cookbook/using-free-client
|
||||
-- doc/cookbook/open-id-connect
|
||||
doc/cookbook/managed-resource
|
||||
|
||||
tests: True
|
||||
optimization: False
|
||||
|
|
|
|||
|
|
@ -1,81 +0,0 @@
|
|||
synopsis: Display capture hints in router layout
|
||||
prs: #1556
|
||||
|
||||
description: {
|
||||
|
||||
This PR enhances the `Servant.Server.layout` function, which produces a textual description of the routing layout of an API. More precisely, it changes `<capture>` blocks, so that they display the name and type of the variable being captured instead.
|
||||
|
||||
Example:
|
||||
|
||||
For the following API
|
||||
```haskell
|
||||
type API =
|
||||
"a" :> "d" :> Get '[JSON] NoContent
|
||||
:<|> "b" :> Capture "x" Int :> Get '[JSON] Bool
|
||||
:<|> "a" :> "e" :> Get '[JSON] Int
|
||||
```
|
||||
|
||||
we previously got the following output:
|
||||
|
||||
```
|
||||
/
|
||||
├─ a/
|
||||
│ ├─ d/
|
||||
│ │ └─•
|
||||
│ └─ e/
|
||||
│ └─•
|
||||
└─ b/
|
||||
└─ <capture>/
|
||||
├─•
|
||||
┆
|
||||
└─•
|
||||
```
|
||||
|
||||
now we get:
|
||||
|
||||
```
|
||||
/
|
||||
├─ a/
|
||||
│ ├─ d/
|
||||
│ │ └─•
|
||||
│ └─ e/
|
||||
│ └─•
|
||||
└─ b/
|
||||
└─ <x::Int>/
|
||||
├─•
|
||||
┆
|
||||
└─•
|
||||
```
|
||||
|
||||
This change is achieved by the introduction of a CaptureHint type, which is passed as an extra argument to the CaptureRouter and CaptureAllRouter constructors for the Router' type.
|
||||
CaptureHint values are then used in routerLayout, to display the name and type of captured values, instead of just `<capture>` previously.
|
||||
|
||||
N.B.:
|
||||
Because the choice smart constructor for routers can aggregate Capture combinators with different capture hints, the Capture*Router constructors actually take a list of CaptureHint, instead of a single one.
|
||||
|
||||
This PR also introduces Spec tests for the routerLayout function.
|
||||
|
||||
Warning:
|
||||
This change is potentially breaking, because it adds the constraint `Typeable a` to all types that are to be captured. Because all types are typeable since GHC 7.10, this is not as bad as it sounds ; it only break expressions where `a` is quantified in an expression with `Capture a`.
|
||||
In those cases, the fix is easy: it suffices to add `Typeable a` to the left-hand side of the quantification constraint.
|
||||
|
||||
For instance, the following code will no longer compile:
|
||||
```haskell
|
||||
type MyAPI a = Capture "foo" a :> Get '[JSON] ()
|
||||
|
||||
myServer :: forall a. Server (MyAPI a)
|
||||
myServer = const $ return ()
|
||||
|
||||
myApi :: forall a. Proxy (MyAPI a)
|
||||
myApi = Proxy
|
||||
|
||||
app :: forall a. (FromHttpApiData a) => Application
|
||||
app = serve (myApi @a) (myServer @a)
|
||||
```
|
||||
|
||||
Indeed, `app` should be replaced with:
|
||||
```haskell
|
||||
app :: forall a. (FromHttpApiData a, Typeable a) => Application
|
||||
app = serve (myApi @a) (myServer @a)
|
||||
```
|
||||
}
|
||||
|
|
@ -1,13 +0,0 @@
|
|||
synopsis: Encode captures using toEncodedUrlPiece
|
||||
prs: #1569
|
||||
issues: #1511
|
||||
|
||||
description: {
|
||||
The `servant-client` library now makes direct use of `toEncodedUrlPiece` from `ToHttpApiData`
|
||||
to encode captured values when building the request path. It gives user freedom to implement
|
||||
URL-encoding however they need.
|
||||
|
||||
Previous behavior was to use `toUrlPiece` and URL-encode its output using `toEncodedUrlPiece`
|
||||
from the `Text` instance of `ToHttpApiData`. The issue with this approach is that
|
||||
`ToHttpApiData Text` is overly zealous and also encodes characters, such as `*`, which are perfectly valid in a URL.
|
||||
}
|
||||
8
changelog.d/1571
Normal file
8
changelog.d/1571
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
synopsis: Support UVerb in servant-auth-server
|
||||
prs: #1571
|
||||
issues: #1570
|
||||
description: {
|
||||
UVerb endpoints are now supported by servant-auth-server and can be used under the
|
||||
Auth combinator when writing servers. It is still unsupported by
|
||||
servant-auth-client.
|
||||
}
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
synopsis: Add API docs for ServerT
|
||||
prs: #1573
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
synopsis: Allow IO in validationKeys
|
||||
prs: #1580
|
||||
issues: #1579
|
||||
|
||||
description: {
|
||||
|
||||
Currently validationKeys are a fixed JWKSet. This does not work with OIDC
|
||||
providers such as AWS Cognito or Okta, which regularly fetching jwks_uri to
|
||||
discover new and expired keys.
|
||||
|
||||
This change alters the type of validationKeys from JWKSet to IO JWKSet.
|
||||
}
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
synopsis: Only include question mark for nonempty query strings
|
||||
prs: 1589
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
synopsis: Run ClientEnv's makeClientRequest in IO.
|
||||
prs: #1595
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
synopsis: Handle Cookies correctly for RunStreamingClient
|
||||
prs: #1606
|
||||
issues: #1605
|
||||
|
||||
description: {
|
||||
|
||||
Makes performWithStreamingRequest take into consideration the
|
||||
CookieJar, which it previously didn't.
|
||||
|
||||
}
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
synopsis: Add Functor instance to AuthHandler.
|
||||
prs: #1638
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
synopsis: Add HasStatus instance for Headers (that defers StatusOf to underlying value)
|
||||
prs: #1649
|
||||
|
||||
description: {
|
||||
|
||||
Adds a new HasStatus (Headers hs a) instance (StatusOf (Headers hs a) = StatusOf a)
|
||||
|
||||
}
|
||||
|
|
@ -37,4 +37,3 @@ you name it!
|
|||
sentry/Sentry.lhs
|
||||
testing/Testing.lhs
|
||||
open-id-connect/OpenIdConnect.lhs
|
||||
managed-resource/ManagedResource.lhs
|
||||
|
|
|
|||
|
|
@ -1,114 +0,0 @@
|
|||
# Request-lifetime Managed Resources
|
||||
|
||||
Let's see how we can write a handle that uses a resource managed by Servant. The resource is created automatically by Servant when the server recieves a request, and the resource is automatically destroyed when the server is finished handling a request.
|
||||
|
||||
As usual, we start with a little bit of throat clearing.
|
||||
|
||||
|
||||
``` haskell
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
import Control.Concurrent
|
||||
import Control.Exception (bracket, throwIO)
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.Acquire
|
||||
import Network.HTTP.Client (newManager, defaultManagerSettings)
|
||||
import Network.Wai.Handler.Warp
|
||||
import Servant
|
||||
import Servant.Client
|
||||
import System.IO
|
||||
```
|
||||
|
||||
Here we define an API type that uses the `WithResource` combinator. The server handler for an endpoint with a `WithResource res` component will receive a value of that type as an argument.
|
||||
|
||||
``` haskell
|
||||
type API = WithResource Handle :> ReqBody '[PlainText] String :> Post '[JSON] NoContent
|
||||
|
||||
api :: Proxy API
|
||||
api = Proxy
|
||||
```
|
||||
|
||||
But this resource value has to come from somewhere. Servant obtains the value using an Acquire provided in the context. The Acquire knows how to both create and destroy resources of a particular type.
|
||||
|
||||
``` haskell
|
||||
appContext :: Context '[Acquire Handle]
|
||||
appContext = acquireHandle :. EmptyContext
|
||||
|
||||
acquireHandle :: Acquire Handle
|
||||
acquireHandle = mkAcquire newHandle closeHandle
|
||||
|
||||
newHandle :: IO Handle
|
||||
newHandle = do
|
||||
putStrLn "opening file"
|
||||
h <- openFile "test.txt" AppendMode
|
||||
putStrLn "opened file"
|
||||
return h
|
||||
|
||||
closeHandle :: Handle -> IO ()
|
||||
closeHandle h = do
|
||||
putStrLn "closing file"
|
||||
hClose h
|
||||
putStrLn "closed file"
|
||||
```
|
||||
|
||||
Now we create the handler which will use this resource. This handler will write the request message to the System.IO.Handle which was provided to us. In some situations the handler will succeed, but in some in will fail. In either case, Servant will clean up the resource for us.
|
||||
|
||||
``` haskell
|
||||
server :: Server API
|
||||
server = writeToFile
|
||||
|
||||
where writeToFile :: (ReleaseKey, Handle) -> String -> Handler NoContent
|
||||
writeToFile (_, h) msg = case msg of
|
||||
"illegal" -> error "wait, that's illegal!"
|
||||
legalMsg -> liftIO $ do
|
||||
putStrLn "writing file"
|
||||
hPutStrLn h legalMsg
|
||||
putStrLn "wrote file"
|
||||
return NoContent
|
||||
```
|
||||
|
||||
Finally we run the server in the background while we post messages to it.
|
||||
|
||||
``` haskell
|
||||
runApp :: IO ()
|
||||
runApp = run 8080 (serveWithContext api appContext $ server)
|
||||
|
||||
postMsg :: String -> ClientM NoContent
|
||||
postMsg = client api
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
mgr <- newManager defaultManagerSettings
|
||||
bracket (forkIO $ runApp) killThread $ \_ -> do
|
||||
ms <- flip runClientM (mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ do
|
||||
liftIO $ putStrLn "sending hello message"
|
||||
_ <- postMsg "hello"
|
||||
liftIO $ putStrLn "sending illegal message"
|
||||
_ <- postMsg "illegal"
|
||||
liftIO $ putStrLn "done"
|
||||
print ms
|
||||
```
|
||||
|
||||
This program prints
|
||||
|
||||
```
|
||||
sending hello message
|
||||
opening file
|
||||
opened file
|
||||
writing file
|
||||
wrote file
|
||||
closing file
|
||||
closed file
|
||||
sending illegal message
|
||||
opening file
|
||||
opened file
|
||||
closing file
|
||||
closed file
|
||||
wait, that's illegal!
|
||||
CallStack (from HasCallStack):
|
||||
error, called at ManagedResource.lhs:63:24 in main:Main
|
||||
Left (FailureResponse (Request {requestPath = (BaseUrl {baseUrlScheme = Http, baseUrlHost = "localhost", baseUrlPort = 8080, baseUrlPath = ""},""), requestQueryString = fromList [], requestBody = Just ((),text/plain;charset=utf-8), requestAccept = fromList [], requestHeaders = fromList [], requestHttpVersion = HTTP/1.1, requestMethod = "POST"}) (Response {responseStatusCode = Status {statusCode = 500, statusMessage = "Internal Server Error"}, responseHeaders = fromList [("Transfer-Encoding","chunked"),("Date","Thu, 24 Nov 2022 21:04:47 GMT"),("Server","Warp/3.3.23"),("Content-Type","text/plain; charset=utf-8")], responseHttpVersion = HTTP/1.1, responseBody = "Something went wrong"}))
|
||||
```
|
||||
|
||||
and appends to a file called `test.txt`. We can see from the output that when a legal message is sent, the file is opened, written to, and closed. We can also see that when an illegal message is sent, the file is opened but not written to. Crucially, it is still closed even though the handler threw an exception.
|
||||
|
|
@ -1,30 +0,0 @@
|
|||
cabal-version: 2.2
|
||||
name: cookbook-managed-resource
|
||||
version: 0.1
|
||||
synopsis: Simple managed resource cookbook example
|
||||
homepage: http://docs.servant.dev/
|
||||
license: BSD-3-Clause
|
||||
license-file: ../../../servant/LICENSE
|
||||
author: Servant Contributors
|
||||
maintainer: haskell-servant-maintainers@googlegroups.com
|
||||
build-type: Simple
|
||||
tested-with: GHC==9.4.2
|
||||
|
||||
executable cookbook-managed-resource
|
||||
main-is: ManagedResource.lhs
|
||||
build-depends: base == 4.*
|
||||
, text >= 1.2
|
||||
, aeson >= 1.2
|
||||
, servant
|
||||
, servant-client
|
||||
, servant-server
|
||||
, warp >= 3.2
|
||||
, wai >= 3.2
|
||||
, http-types >= 0.12
|
||||
, markdown-unlit >= 0.4
|
||||
, http-client >= 0.5
|
||||
, transformers
|
||||
, resourcet
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -pgmL markdown-unlit
|
||||
build-tool-depends: markdown-unlit:markdown-unlit
|
||||
|
|
@ -330,7 +330,7 @@ data Customer = Customer {
|
|||
```
|
||||
|
||||
Here is the code that displays the homepage.
|
||||
It should contain a link to the `/login` URL.
|
||||
It should contain a link to the the `/login` URL.
|
||||
When the user clicks on this link it will be redirected to Google login page
|
||||
with some generated information.
|
||||
|
||||
|
|
|
|||
|
|
@ -119,7 +119,7 @@ Now we can use `servant-client`'s internals to convert servant's `Request`
|
|||
to http-client's `Request`, and we can inspect it:
|
||||
|
||||
```haskell
|
||||
req' <- I.defaultMakeClientRequest burl req
|
||||
let req' = I.defaultMakeClientRequest burl req
|
||||
putStrLn $ "Making request: " ++ show req'
|
||||
```
|
||||
|
||||
|
|
|
|||
|
|
@ -199,7 +199,7 @@ parsers in the hope that the ones that should will always error out so
|
|||
you can try until the right one returns a value.)
|
||||
|
||||
[servant-exceptions](https://github.com/ch1bo/servant-exceptions) is
|
||||
another shot at the problem. It is inspired by
|
||||
another shot at at the problem. It is inspired by
|
||||
servant-checked-exceptions, so it may be worth taking a closer look.
|
||||
The README claims that
|
||||
[cardano-sl](https://github.com/input-output-hk/cardano-sl) also has
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
recommonmark==0.5.0
|
||||
Sphinx==1.8.4
|
||||
sphinx_rtd_theme>=0.4.2
|
||||
jinja2<3.1.0
|
||||
|
|
|
|||
|
|
@ -31,7 +31,7 @@ library
|
|||
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
|
||||
ghc-options: -Wall
|
||||
build-depends:
|
||||
base >= 4.10 && < 4.18
|
||||
base >= 4.10 && < 4.17
|
||||
, bytestring >= 0.10.6.0 && < 0.12
|
||||
, containers >= 0.5.6.2 && < 0.7
|
||||
, servant-auth == 0.4.*
|
||||
|
|
@ -50,7 +50,7 @@ test-suite spec
|
|||
test
|
||||
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
|
||||
ghc-options: -Wall
|
||||
build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.10
|
||||
build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.9
|
||||
|
||||
-- dependencies with bounds inherited from the library stanza
|
||||
build-depends:
|
||||
|
|
@ -62,7 +62,7 @@ test-suite spec
|
|||
|
||||
-- test dependencies
|
||||
build-depends:
|
||||
hspec >= 2.5.5 && < 2.10
|
||||
hspec >= 2.5.5 && < 2.9
|
||||
, QuickCheck >= 2.11.3 && < 2.15
|
||||
, aeson >= 1.3.1.1 && < 3
|
||||
, bytestring >= 0.10.6.0 && < 0.12
|
||||
|
|
@ -74,7 +74,7 @@ test-suite spec
|
|||
, transformers >= 0.4.2.0 && < 0.6
|
||||
, wai >= 3.2.1.2 && < 3.3
|
||||
, warp >= 3.2.25 && < 3.4
|
||||
, jose >= 0.10 && < 0.11
|
||||
, jose >= 0.7.0.0 && < 0.10
|
||||
other-modules:
|
||||
Servant.Auth.ClientSpec
|
||||
default-language: Haskell2010
|
||||
|
|
|
|||
|
|
@ -35,11 +35,11 @@ library
|
|||
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
|
||||
ghc-options: -Wall
|
||||
build-depends:
|
||||
base >= 4.10 && < 4.18
|
||||
base >= 4.10 && < 4.17
|
||||
, servant-docs >= 0.11.2 && < 0.13
|
||||
, servant >= 0.13 && < 0.20
|
||||
, servant-auth == 0.4.*
|
||||
, lens >= 4.16.1 && <5.3
|
||||
, lens >= 4.16.1 && <5.2
|
||||
exposed-modules:
|
||||
Servant.Auth.Docs
|
||||
default-language: Haskell2010
|
||||
|
|
@ -50,7 +50,7 @@ test-suite doctests
|
|||
build-depends:
|
||||
base,
|
||||
servant-auth-docs,
|
||||
doctest >= 0.16 && < 0.21,
|
||||
doctest >= 0.16 && < 0.19,
|
||||
QuickCheck >= 2.11.3 && < 2.15,
|
||||
template-haskell
|
||||
ghc-options: -Wall -threaded
|
||||
|
|
@ -64,7 +64,7 @@ test-suite spec
|
|||
test
|
||||
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
|
||||
ghc-options: -Wall
|
||||
build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.10
|
||||
build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.9
|
||||
|
||||
-- dependencies with bounds inherited from the library stanza
|
||||
build-depends:
|
||||
|
|
@ -78,7 +78,7 @@ test-suite spec
|
|||
-- test dependencies
|
||||
build-depends:
|
||||
servant-auth-docs
|
||||
, hspec >= 2.5.5 && < 2.10
|
||||
, hspec >= 2.5.5 && < 2.9
|
||||
, QuickCheck >= 2.11.3 && < 2.15
|
||||
|
||||
default-language: Haskell2010
|
||||
|
|
|
|||
|
|
@ -31,7 +31,7 @@ library
|
|||
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
|
||||
ghc-options: -Wall
|
||||
build-depends:
|
||||
base >= 4.10 && < 4.18
|
||||
base >= 4.10 && < 4.17
|
||||
, aeson >= 1.0.0.1 && < 3
|
||||
, base64-bytestring >= 1.0.0.1 && < 2
|
||||
, blaze-builder >= 0.4.1.0 && < 0.5
|
||||
|
|
@ -41,17 +41,17 @@ library
|
|||
, data-default-class >= 0.1.2.0 && < 0.2
|
||||
, entropy >= 0.4.1.3 && < 0.5
|
||||
, http-types >= 0.12.2 && < 0.13
|
||||
, jose >= 0.10 && < 0.11
|
||||
, lens >= 4.16.1 && < 5.3
|
||||
, memory >= 0.14.16 && < 0.19
|
||||
, jose >= 0.7.0.0 && < 0.10
|
||||
, lens >= 4.16.1 && < 5.2
|
||||
, memory >= 0.14.16 && < 0.18
|
||||
, monad-time >= 0.3.1.0 && < 0.4
|
||||
, mtl ^>= 2.2.2 || ^>= 2.3.1
|
||||
, mtl >= 2.2.2 && < 2.3
|
||||
, servant >= 0.13 && < 0.20
|
||||
, servant-auth == 0.4.*
|
||||
, servant-server >= 0.13 && < 0.20
|
||||
, tagged >= 0.8.4 && < 0.9
|
||||
, text >= 1.2.3.0 && < 2.1
|
||||
, time >= 1.5.0.1 && < 1.13
|
||||
, time >= 1.5.0.1 && < 1.12
|
||||
, unordered-containers >= 0.2.9.0 && < 0.3
|
||||
, wai >= 3.2.1.2 && < 3.3
|
||||
|
||||
|
|
@ -102,7 +102,7 @@ test-suite spec
|
|||
test
|
||||
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
|
||||
ghc-options: -Wall
|
||||
build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.10
|
||||
build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.8
|
||||
|
||||
-- dependencies with bounds inherited from the library stanza
|
||||
build-depends:
|
||||
|
|
@ -123,12 +123,13 @@ test-suite spec
|
|||
-- test dependencies
|
||||
build-depends:
|
||||
servant-auth-server
|
||||
, hspec >= 2.5.5 && < 2.10
|
||||
, hspec >= 2.5.5 && < 2.8
|
||||
, QuickCheck >= 2.11.3 && < 2.15
|
||||
, http-client >= 0.5.13.1 && < 0.8
|
||||
, lens-aeson >= 1.0.2 && < 1.3
|
||||
, lens-aeson >= 1.0.2 && < 1.2
|
||||
, warp >= 3.2.25 && < 3.4
|
||||
, wreq >= 0.5.2.1 && < 0.6
|
||||
, text >= 1.2.3.0 && < 2.1
|
||||
other-modules:
|
||||
Servant.Auth.ServerSpec
|
||||
default-language: Haskell2010
|
||||
|
|
|
|||
|
|
@ -54,15 +54,12 @@ instance ( n ~ 'S ('S 'Z)
|
|||
|
||||
makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z)))
|
||||
makeCookies authResult = do
|
||||
xsrf <- makeXsrfCookie cookieSettings
|
||||
fmap (Just xsrf `SetCookieCons`) $
|
||||
case authResult of
|
||||
(Authenticated v) -> do
|
||||
ejwt <- makeSessionCookie cookieSettings jwtSettings v
|
||||
case ejwt of
|
||||
Nothing -> return $ Nothing `SetCookieCons` SetCookieNil
|
||||
Just jwt -> return $ Just jwt `SetCookieCons` SetCookieNil
|
||||
_ -> return $ Nothing `SetCookieCons` SetCookieNil
|
||||
case authResult of
|
||||
(Authenticated v) -> do
|
||||
ejwt <- makeSessionCookie cookieSettings jwtSettings v
|
||||
xsrf <- makeXsrfCookie cookieSettings
|
||||
return $ Just xsrf `SetCookieCons` (ejwt `SetCookieCons` SetCookieNil)
|
||||
_ -> return $ Nothing `SetCookieCons` (Nothing `SetCookieCons` SetCookieNil)
|
||||
|
||||
go :: (AuthResult v -> ServerT api Handler)
|
||||
-> (AuthResult v, SetCookieList n)
|
||||
|
|
|
|||
|
|
@ -11,6 +11,7 @@ import Data.Tagged (Tagged (..))
|
|||
import qualified Network.HTTP.Types as HTTP
|
||||
import Network.Wai (mapResponseHeaders)
|
||||
import Servant
|
||||
import Servant.API.UVerb.Union
|
||||
import Servant.API.Generic
|
||||
import Servant.Server.Generic
|
||||
import Web.Cookie
|
||||
|
|
@ -33,12 +34,24 @@ type family AddSetCookieApiVerb a where
|
|||
AddSetCookieApiVerb (Headers ls a) = Headers (Header "Set-Cookie" SetCookie ': ls) a
|
||||
AddSetCookieApiVerb a = Headers '[Header "Set-Cookie" SetCookie] a
|
||||
|
||||
#if MIN_VERSION_servant_server(0,18,1)
|
||||
type family MapAddSetCookieApiVerb (as :: [*]) where
|
||||
MapAddSetCookieApiVerb '[] = '[]
|
||||
MapAddSetCookieApiVerb (a ': as) = (AddSetCookieApiVerb a ': MapAddSetCookieApiVerb as)
|
||||
#endif
|
||||
|
||||
type family AddSetCookieApi a :: *
|
||||
type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b
|
||||
type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b
|
||||
#if MIN_VERSION_servant_server(0,19,0)
|
||||
type instance AddSetCookieApi (NamedRoutes api) = AddSetCookieApi (ToServantApi api)
|
||||
#endif
|
||||
type instance AddSetCookieApi (Verb method stat ctyps a)
|
||||
= Verb method stat ctyps (AddSetCookieApiVerb a)
|
||||
#if MIN_VERSION_servant_server(0,18,1)
|
||||
type instance AddSetCookieApi (UVerb method ctyps as)
|
||||
= UVerb method ctyps (MapAddSetCookieApiVerb as)
|
||||
#endif
|
||||
type instance AddSetCookieApi Raw = Raw
|
||||
#if MIN_VERSION_servant_server(0,15,0)
|
||||
type instance AddSetCookieApi (Stream method stat framing ctyps a)
|
||||
|
|
@ -57,7 +70,7 @@ instance {-# OVERLAPS #-} AddSetCookies ('S n) oldb newb
|
|||
=> AddSetCookies ('S n) (a -> oldb) (a -> newb) where
|
||||
addSetCookies cookies oldfn = addSetCookies cookies . oldfn
|
||||
|
||||
instance AddSetCookies 'Z orig orig where
|
||||
instance (orig1 ~ orig2) => AddSetCookies 'Z orig1 orig2 where
|
||||
addSetCookies _ = id
|
||||
|
||||
instance {-# OVERLAPPABLE #-}
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ data JWTSettings = JWTSettings
|
|||
-- | Algorithm used to sign JWT.
|
||||
, jwtAlg :: Maybe Jose.Alg
|
||||
-- | Keys used to validate JWT.
|
||||
, validationKeys :: IO Jose.JWKSet
|
||||
, validationKeys :: Jose.JWKSet
|
||||
-- | An @aud@ predicate. The @aud@ is a string or URI that identifies the
|
||||
-- intended recipient of the JWT.
|
||||
, audienceMatches :: Jose.StringOrURI -> IsMatch
|
||||
|
|
@ -44,7 +44,7 @@ defaultJWTSettings :: Jose.JWK -> JWTSettings
|
|||
defaultJWTSettings k = JWTSettings
|
||||
{ signingKey = k
|
||||
, jwtAlg = Nothing
|
||||
, validationKeys = pure $ Jose.JWKSet [k]
|
||||
, validationKeys = Jose.JWKSet [k]
|
||||
, audienceMatches = const Matches }
|
||||
|
||||
-- | The policies to use when generating cookies.
|
||||
|
|
|
|||
|
|
@ -2,7 +2,6 @@
|
|||
module Servant.Auth.Server.Internal.Cookie where
|
||||
|
||||
import Blaze.ByteString.Builder (toByteString)
|
||||
import Control.Monad (MonadPlus(..), guard)
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import qualified Crypto.JOSE as Jose
|
||||
|
|
|
|||
|
|
@ -1,14 +1,18 @@
|
|||
module Servant.Auth.Server.Internal.JWT where
|
||||
|
||||
import Control.Lens
|
||||
import Control.Monad (MonadPlus(..), guard)
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import qualified Crypto.JOSE as Jose
|
||||
import qualified Crypto.JWT as Jose
|
||||
import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON,
|
||||
toJSON)
|
||||
import Data.ByteArray (constEq)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time (UTCTime)
|
||||
import Network.Wai (requestHeaders)
|
||||
|
||||
|
|
@ -38,7 +42,7 @@ jwtAuthCheck jwtSettings = do
|
|||
-- token expires.
|
||||
makeJWT :: ToJWT a
|
||||
=> a -> JWTSettings -> Maybe UTCTime -> IO (Either Jose.Error BSL.ByteString)
|
||||
makeJWT v cfg expiry = Jose.runJOSE $ do
|
||||
makeJWT v cfg expiry = runExceptT $ do
|
||||
bestAlg <- Jose.bestJWSAlg $ signingKey cfg
|
||||
let alg = fromMaybe bestAlg $ jwtAlg cfg
|
||||
ejwt <- Jose.signClaims (signingKey cfg)
|
||||
|
|
@ -54,15 +58,14 @@ makeJWT v cfg expiry = Jose.runJOSE $ do
|
|||
|
||||
verifyJWT :: FromJWT a => JWTSettings -> BS.ByteString -> IO (Maybe a)
|
||||
verifyJWT jwtCfg input = do
|
||||
keys <- validationKeys jwtCfg
|
||||
verifiedJWT <- Jose.runJOSE $ do
|
||||
verifiedJWT <- liftIO $ runExceptT $ do
|
||||
unverifiedJWT <- Jose.decodeCompact (BSL.fromStrict input)
|
||||
Jose.verifyClaims
|
||||
(jwtSettingsToJwtValidationSettings jwtCfg)
|
||||
keys
|
||||
(validationKeys jwtCfg)
|
||||
unverifiedJWT
|
||||
return $ case verifiedJWT of
|
||||
Left (_ :: Jose.JWTError) -> Nothing
|
||||
Right v -> case decodeJWT v of
|
||||
Left _ -> Nothing
|
||||
Right v' -> Just v'
|
||||
Right v' -> Just v'
|
||||
|
|
@ -2,7 +2,6 @@
|
|||
module Servant.Auth.Server.Internal.Types where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad (MonadPlus(..), ap)
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Time
|
||||
import Data.Monoid (Monoid (..))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
module Servant.Auth.ServerSpec (spec) where
|
||||
|
||||
#if !MIN_VERSION_servant_server(0,16,0)
|
||||
|
|
@ -6,12 +7,13 @@ module Servant.Auth.ServerSpec (spec) where
|
|||
#endif
|
||||
|
||||
import Control.Lens
|
||||
import Control.Monad.Except (runExceptT)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Crypto.JOSE (Alg (HS256, None), Error,
|
||||
JWK, JWSHeader,
|
||||
KeyMaterialGenParam (OctGenParam),
|
||||
ToCompact, encodeCompact,
|
||||
genJWK, newJWSHeader, runJOSE)
|
||||
genJWK, newJWSHeader)
|
||||
import Crypto.JWT (Audience (..), ClaimsSet,
|
||||
NumericDate (NumericDate),
|
||||
SignedJWT,
|
||||
|
|
@ -24,6 +26,7 @@ import Data.Aeson (FromJSON, ToJSON, Value,
|
|||
import Data.Aeson.Lens (_JSON)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
import Data.Text (Text, pack)
|
||||
import Data.CaseInsensitive (mk)
|
||||
import Data.Foldable (find)
|
||||
import Data.Monoid
|
||||
|
|
@ -39,6 +42,7 @@ import Network.HTTP.Types (Status, status200,
|
|||
import Network.Wai (responseLBS)
|
||||
import Network.Wai.Handler.Warp (testWithApplication)
|
||||
import Network.Wreq (Options, auth, basicAuth,
|
||||
checkResponse,
|
||||
cookieExpiryTime, cookies,
|
||||
defaults, get, getWith, postWith,
|
||||
header, oauth2Bearer,
|
||||
|
|
@ -182,8 +186,21 @@ cookieAuthSpec
|
|||
it "fails with no XSRF header or cookie" $ \port -> property
|
||||
$ \(user :: User) -> do
|
||||
jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
|
||||
opts <- addJwtToCookie cookieCfg jwt
|
||||
getWith opts (url port) `shouldHTTPErrorWith` status401
|
||||
opts' <- addJwtToCookie cookieCfg jwt
|
||||
let opts = opts' & checkResponse .~ Just mempty
|
||||
resp <- getWith opts (url port)
|
||||
resp ^. responseStatus `shouldBe` status401
|
||||
(resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"]
|
||||
|
||||
-- Validating that the XSRF cookie isn't added for UVerb routes either.
|
||||
-- These routes can return a 401 response directly without using throwError / throwAll,
|
||||
-- which revealed a bug:
|
||||
--
|
||||
-- https://github.com/haskell-servant/servant/issues/1570#issuecomment-1076374449
|
||||
resp <- getWith opts (url port ++ "/uverb")
|
||||
resp ^. responseStatus `shouldBe` status401
|
||||
(resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"]
|
||||
|
||||
|
||||
it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property
|
||||
$ \(user :: User) -> do
|
||||
|
|
@ -405,13 +422,14 @@ type API auths
|
|||
= Auth auths User :>
|
||||
( Get '[JSON] Int
|
||||
:<|> ReqBody '[JSON] Int :> Post '[JSON] Int
|
||||
:<|> NamedRoutes DummyRoutes
|
||||
:<|> "named" :> NamedRoutes DummyRoutes
|
||||
:<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)
|
||||
#if MIN_VERSION_servant_server(0,15,0)
|
||||
:<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
|
||||
#endif
|
||||
:<|> "raw" :> Raw
|
||||
)
|
||||
:<|> "uverb" :> Auth auths User :> UVerb 'GET '[JSON] '[WithStatus 200 Int, WithStatus 401 Text, WithStatus 403 Text]
|
||||
:<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
|
||||
, Header "Set-Cookie" SetCookie ] NoContent)
|
||||
:<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
|
||||
|
|
@ -489,6 +507,11 @@ server ccfg =
|
|||
:<|> raw
|
||||
Indefinite -> throwAll err401
|
||||
_ -> throwAll err403
|
||||
) :<|>
|
||||
(\authResult -> case authResult of
|
||||
Authenticated usr -> respond (WithStatus @200 (42 :: Int))
|
||||
Indefinite -> respond (WithStatus @401 $ pack "Authentication required")
|
||||
_ -> respond (WithStatus @403 $ pack "Forbidden")
|
||||
)
|
||||
:<|> getLogin
|
||||
:<|> getLogout
|
||||
|
|
@ -539,7 +562,7 @@ addJwtToHeader jwt = case jwt of
|
|||
$ defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v]
|
||||
|
||||
createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT)
|
||||
createJWT k a b = runJOSE $ signClaims k a b
|
||||
createJWT k a b = runExceptT $ signClaims k a b
|
||||
|
||||
addJwtToCookie :: ToCompact a => CookieSettings -> Either Error a -> IO Options
|
||||
addJwtToCookie ccfg jwt = case jwt >>= (return . encodeCompact) of
|
||||
|
|
@ -569,6 +592,12 @@ shouldMatchCookieNames cj patterns
|
|||
= fmap cookie_name (destroyCookieJar cj)
|
||||
`shouldMatchList` patterns
|
||||
|
||||
shouldNotHaveCookies :: HCli.CookieJar -> [BS.ByteString] -> Expectation
|
||||
shouldNotHaveCookies cj patterns =
|
||||
sequence_ $ (\cookieName -> cookieNames `shouldNotContain` [cookieName]) <$> patterns
|
||||
where cookieNames :: [BS.ByteString]
|
||||
cookieNames = cookie_name <$> destroyCookieJar cj
|
||||
|
||||
shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation
|
||||
shouldMatchCookieNameValues cj patterns
|
||||
= fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj)
|
||||
|
|
|
|||
|
|
@ -31,13 +31,15 @@ library
|
|||
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
|
||||
ghc-options: -Wall
|
||||
build-depends:
|
||||
base >= 4.10 && < 4.18
|
||||
base >= 4.10 && < 4.16
|
||||
, text >= 1.2.3.0 && < 2.1
|
||||
, servant-swagger >= 1.1.5 && < 2
|
||||
, swagger2 >= 2.2.2 && < 3
|
||||
, servant >= 0.13 && < 0.20
|
||||
, servant-auth == 0.4.*
|
||||
, lens >= 4.16.1 && < 5.3
|
||||
, lens >= 4.16.1 && < 5.2
|
||||
if impl(ghc >= 9)
|
||||
buildable: False
|
||||
exposed-modules:
|
||||
Servant.Auth.Swagger
|
||||
default-language: Haskell2010
|
||||
|
|
@ -49,7 +51,7 @@ test-suite spec
|
|||
test
|
||||
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
|
||||
ghc-options: -Wall
|
||||
build-tool-depends: hspec-discover:hspec-discover >= 2.5.5 && <2.10
|
||||
build-tool-depends: hspec-discover:hspec-discover >= 2.5.5 && <2.9
|
||||
-- dependencies with bounds inherited from the library stanza
|
||||
build-depends:
|
||||
base
|
||||
|
|
@ -59,11 +61,13 @@ test-suite spec
|
|||
, servant
|
||||
, servant-auth
|
||||
, lens
|
||||
if impl(ghc >= 9)
|
||||
buildable: False
|
||||
|
||||
-- test dependencies
|
||||
build-depends:
|
||||
servant-auth-swagger
|
||||
, hspec >= 2.5.5 && < 2.10
|
||||
, hspec >= 2.5.5 && < 2.9
|
||||
, QuickCheck >= 2.11.3 && < 2.15
|
||||
other-modules:
|
||||
Servant.Auth.SwaggerSpec
|
||||
|
|
|
|||
|
|
@ -33,11 +33,11 @@ library
|
|||
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
|
||||
ghc-options: -Wall
|
||||
build-depends:
|
||||
base >= 4.10 && < 4.18
|
||||
base >= 4.10 && < 4.17
|
||||
, containers >= 0.6 && < 0.7
|
||||
, aeson >= 1.3.1.1 && < 3
|
||||
, jose >= 0.10 && < 0.11
|
||||
, lens >= 4.16.1 && < 5.3
|
||||
, jose >= 0.7.0.0 && < 0.10
|
||||
, lens >= 4.16.1 && < 5.2
|
||||
, servant >= 0.15 && < 0.20
|
||||
, text >= 1.2.3.0 && < 2.1
|
||||
, unordered-containers >= 0.2.9.0 && < 0.3
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ instance HasLink sub => HasLink (Auth (tag :: [*]) value :> sub) where
|
|||
|
||||
-- ** Combinators
|
||||
|
||||
-- | A JSON Web Token (JWT) in the Authorization header:
|
||||
-- | A JSON Web Token (JWT) in the the Authorization header:
|
||||
--
|
||||
-- @Authorization: Bearer \<token\>@
|
||||
--
|
||||
|
|
|
|||
|
|
@ -50,14 +50,14 @@ library
|
|||
--
|
||||
-- note: mtl lower bound is so low because of GHC-7.8
|
||||
build-depends:
|
||||
base >= 4.9 && < 4.18
|
||||
base >= 4.9 && < 4.17
|
||||
, bytestring >= 0.10.8.1 && < 0.12
|
||||
, constraints >= 0.2 && < 0.14
|
||||
, containers >= 0.5.7.1 && < 0.7
|
||||
, deepseq >= 1.4.2.0 && < 1.5
|
||||
, text >= 1.2.3.0 && < 2.1
|
||||
, transformers >= 0.5.2.0 && < 0.7
|
||||
, template-haskell >= 2.11.1.0 && < 2.20
|
||||
, transformers >= 0.5.2.0 && < 0.6
|
||||
, template-haskell >= 2.11.1.0 && < 2.19
|
||||
|
||||
if !impl(ghc >= 8.2)
|
||||
build-depends:
|
||||
|
|
@ -104,8 +104,8 @@ test-suite spec
|
|||
-- Additional dependencies
|
||||
build-depends:
|
||||
deepseq >= 1.4.2.0 && < 1.5
|
||||
, hspec >= 2.6.0 && < 2.10
|
||||
, hspec >= 2.6.0 && < 2.9
|
||||
, QuickCheck >= 2.12.6.1 && < 2.15
|
||||
|
||||
build-tool-depends:
|
||||
hspec-discover:hspec-discover >= 2.6.0 && <2.10
|
||||
hspec-discover:hspec-discover >= 2.6.0 && <2.9
|
||||
|
|
|
|||
|
|
@ -77,7 +77,7 @@ import Servant.API
|
|||
NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,
|
||||
ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
|
||||
StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
|
||||
Verb, WithNamedContext, WithResource, WithStatus (..), contentType, getHeadersHList,
|
||||
Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,
|
||||
getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)
|
||||
import Servant.API.Generic
|
||||
(GenericMode(..), ToServant, ToServantApi
|
||||
|
|
@ -208,7 +208,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)
|
|||
clientWithRoute pm (Proxy :: Proxy api)
|
||||
(appendToPath p req)
|
||||
|
||||
where p = toEncodedUrlPiece val
|
||||
where p = (toUrlPiece val)
|
||||
|
||||
hoistClientMonad pm _ f cl = \a ->
|
||||
hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
|
||||
|
|
@ -243,7 +243,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
|
|||
clientWithRoute pm (Proxy :: Proxy sublayout)
|
||||
(foldl' (flip appendToPath) req ps)
|
||||
|
||||
where ps = map toEncodedUrlPiece vals
|
||||
where ps = map (toUrlPiece) vals
|
||||
|
||||
hoistClientMonad pm _ f cl = \as ->
|
||||
hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)
|
||||
|
|
@ -740,7 +740,7 @@ instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
|
|||
clientWithRoute pm (Proxy :: Proxy api)
|
||||
(appendToPath p req)
|
||||
|
||||
where p = toEncodedUrlPiece $ pack $ symbolVal (Proxy :: Proxy path)
|
||||
where p = pack $ symbolVal (Proxy :: Proxy path)
|
||||
|
||||
hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
|
||||
|
||||
|
|
@ -776,14 +776,6 @@ instance HasClient m subapi =>
|
|||
|
||||
hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl
|
||||
|
||||
instance HasClient m subapi =>
|
||||
HasClient m (WithResource res :> subapi) where
|
||||
|
||||
type Client m (WithResource res :> subapi) = Client m subapi
|
||||
clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi)
|
||||
|
||||
hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl
|
||||
|
||||
instance ( HasClient m api
|
||||
) => HasClient m (AuthProtect tag :> api) where
|
||||
type Client m (AuthProtect tag :> api)
|
||||
|
|
@ -902,7 +894,7 @@ infixl 2 /:
|
|||
-- rootClient = client api
|
||||
--
|
||||
-- endpointClient :: ClientM Person
|
||||
-- endpointClient = client \/\/ subApi \/\/ endpoint
|
||||
-- endpointClient = client // subApi // endpoint
|
||||
-- @
|
||||
(//) :: a -> (a -> b) -> b
|
||||
x // f = f x
|
||||
|
|
@ -935,10 +927,10 @@ x // f = f x
|
|||
-- rootClient = client api
|
||||
--
|
||||
-- hello :: String -> ClientM String
|
||||
-- hello name = rootClient \/\/ hello \/: name
|
||||
-- hello name = rootClient // hello /: name
|
||||
--
|
||||
-- endpointClient :: ClientM Person
|
||||
-- endpointClient = client \/\/ subApi \/: "foobar123" \/\/ endpoint
|
||||
-- endpointClient = client // subApi /: "foobar123" // endpoint
|
||||
-- @
|
||||
(/:) :: (a -> b -> c) -> b -> a -> c
|
||||
(/:) = flip
|
||||
|
|
|
|||
|
|
@ -34,8 +34,6 @@ import Data.Bifunctor
|
|||
import Data.Bitraversable
|
||||
(Bitraversable (..), bifoldMapDefault, bimapDefault)
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.ByteString.Builder
|
||||
(Builder)
|
||||
import qualified Data.ByteString.Builder as Builder
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Data.Sequence as Seq
|
||||
|
|
@ -114,7 +112,7 @@ instance (NFData path, NFData body) => NFData (RequestF body path) where
|
|||
rnfB Nothing = ()
|
||||
rnfB (Just (b, mt)) = rnf b `seq` mediaTypeRnf mt
|
||||
|
||||
type Request = RequestF RequestBody Builder
|
||||
type Request = RequestF RequestBody Builder.Builder
|
||||
|
||||
-- | The request body. R replica of the @http-client@ @RequestBody@.
|
||||
data RequestBody
|
||||
|
|
@ -147,10 +145,9 @@ defaultRequest = Request
|
|||
|
||||
-- | Append extra path to the request being constructed.
|
||||
--
|
||||
-- Warning: This function assumes that the path fragment is already URL-encoded.
|
||||
appendToPath :: Builder -> Request -> Request
|
||||
appendToPath :: Text -> Request -> Request
|
||||
appendToPath p req
|
||||
= req { requestPath = requestPath req <> "/" <> p }
|
||||
= req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p }
|
||||
|
||||
-- | Append a query parameter to the request being constructed.
|
||||
--
|
||||
|
|
|
|||
|
|
@ -48,7 +48,7 @@ library
|
|||
, http-media >=0.6.2 && <0.9
|
||||
, http-types >=0.12 && <0.13
|
||||
, monad-control >=1.0.0.4 && <1.1
|
||||
, mtl ^>=2.2.2 || ^>=2.3.1
|
||||
, mtl >=2.2.2 && <2.3
|
||||
, semigroupoids >=5.3 && <5.4
|
||||
, string-conversions >=0.3 && <0.5
|
||||
, transformers >=0.3 && <0.6
|
||||
|
|
|
|||
|
|
@ -41,15 +41,15 @@ library
|
|||
-- Bundled with GHC: Lower bound to not force re-installs
|
||||
-- text and mtl are bundled starting with GHC-8.4
|
||||
build-depends:
|
||||
base >= 4.9 && < 4.18
|
||||
base >= 4.9 && < 4.17
|
||||
, bytestring >= 0.10.8.1 && < 0.12
|
||||
, containers >= 0.5.7.1 && < 0.7
|
||||
, deepseq >= 1.4.2.0 && < 1.5
|
||||
, mtl ^>= 2.2.2 || ^>= 2.3.1
|
||||
, mtl >= 2.2.2 && < 2.3
|
||||
, stm >= 2.4.5.1 && < 2.6
|
||||
, text >= 1.2.3.0 && < 2.1
|
||||
, time >= 1.6.0.1 && < 1.13
|
||||
, transformers >= 0.5.2.0 && < 0.7
|
||||
, time >= 1.6.0.1 && < 1.12
|
||||
, transformers >= 0.5.2.0 && < 0.6
|
||||
|
||||
if !impl(ghc >= 8.2)
|
||||
build-depends:
|
||||
|
|
@ -124,7 +124,7 @@ test-suite spec
|
|||
-- Additional dependencies
|
||||
build-depends:
|
||||
entropy >= 0.4.1.3 && < 0.5
|
||||
, hspec >= 2.6.0 && < 2.10
|
||||
, hspec >= 2.6.0 && < 2.9
|
||||
, HUnit >= 1.6.0.0 && < 1.7
|
||||
, network >= 2.8.0.0 && < 3.2
|
||||
, QuickCheck >= 2.12.6.1 && < 2.15
|
||||
|
|
@ -133,7 +133,7 @@ test-suite spec
|
|||
, tdigest >= 0.2 && < 0.3
|
||||
|
||||
build-tool-depends:
|
||||
hspec-discover:hspec-discover >= 2.6.0 && < 2.10
|
||||
hspec-discover:hspec-discover >= 2.6.0 && < 2.9
|
||||
|
||||
test-suite readme
|
||||
type: exitcode-stdio-1.0
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ import Control.Monad
|
|||
import Control.Monad.Base
|
||||
(MonadBase (..))
|
||||
import Control.Monad.Catch
|
||||
(MonadCatch, MonadThrow, MonadMask)
|
||||
(MonadCatch, MonadThrow)
|
||||
import Control.Monad.Error.Class
|
||||
(MonadError (..))
|
||||
import Control.Monad.IO.Class
|
||||
|
|
@ -80,7 +80,7 @@ data ClientEnv
|
|||
{ manager :: Client.Manager
|
||||
, baseUrl :: BaseUrl
|
||||
, cookieJar :: Maybe (TVar Client.CookieJar)
|
||||
, makeClientRequest :: BaseUrl -> Request -> IO Client.Request
|
||||
, makeClientRequest :: BaseUrl -> Request -> Client.Request
|
||||
-- ^ this function can be used to customize the creation of @http-client@ requests from @servant@ requests. Default value: 'defaultMakeClientRequest'
|
||||
-- Note that:
|
||||
-- 1. 'makeClientRequest' exists to allow overriding operational semantics e.g. 'responseTimeout' per request,
|
||||
|
|
@ -136,7 +136,7 @@ newtype ClientM a = ClientM
|
|||
{ unClientM :: ReaderT ClientEnv (ExceptT ClientError IO) a }
|
||||
deriving ( Functor, Applicative, Monad, MonadIO, Generic
|
||||
, MonadReader ClientEnv, MonadError ClientError, MonadThrow
|
||||
, MonadCatch, MonadMask)
|
||||
, MonadCatch)
|
||||
|
||||
instance MonadBase IO ClientM where
|
||||
liftBase = ClientM . liftBase
|
||||
|
|
@ -162,7 +162,7 @@ runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm
|
|||
performRequest :: Maybe [Status] -> Request -> ClientM Response
|
||||
performRequest acceptStatus req = do
|
||||
ClientEnv m burl cookieJar' createClientRequest <- ask
|
||||
clientRequest <- liftIO $ createClientRequest burl req
|
||||
let clientRequest = createClientRequest burl req
|
||||
request <- case cookieJar' of
|
||||
Nothing -> pure clientRequest
|
||||
Just cj -> liftIO $ do
|
||||
|
|
@ -229,8 +229,8 @@ clientResponseToResponse f r = Response
|
|||
-- | Create a @http-client@ 'Client.Request' from a @servant@ 'Request'
|
||||
-- The 'Client.host', 'Client.path' and 'Client.port' fields are extracted from the 'BaseUrl'
|
||||
-- otherwise the body, headers and query string are derived from the @servant@ 'Request'
|
||||
defaultMakeClientRequest :: BaseUrl -> Request -> IO Client.Request
|
||||
defaultMakeClientRequest burl r = return Client.defaultRequest
|
||||
defaultMakeClientRequest :: BaseUrl -> Request -> Client.Request
|
||||
defaultMakeClientRequest burl r = Client.defaultRequest
|
||||
{ Client.method = requestMethod r
|
||||
, Client.host = fromString $ baseUrlHost burl
|
||||
, Client.port = baseUrlPort burl
|
||||
|
|
@ -289,8 +289,7 @@ defaultMakeClientRequest burl r = return Client.defaultRequest
|
|||
Https -> True
|
||||
|
||||
-- Query string builder which does not do any encoding
|
||||
buildQueryString [] = mempty
|
||||
buildQueryString qps = "?" <> foldl' addQueryParam mempty qps
|
||||
buildQueryString = ("?" <>) . foldl' addQueryParam mempty
|
||||
|
||||
addQueryParam qs (k, v) =
|
||||
qs <> (if BS.null qs then mempty else "&") <> urlEncode True k <> foldMap ("=" <>) v
|
||||
|
|
|
|||
|
|
@ -24,8 +24,7 @@ import Control.DeepSeq
|
|||
(NFData, force)
|
||||
import Control.Exception
|
||||
(evaluate, throwIO)
|
||||
import Control.Monad
|
||||
(unless)
|
||||
import Control.Monad ()
|
||||
import Control.Monad.Base
|
||||
(MonadBase (..))
|
||||
import Control.Monad.Codensity
|
||||
|
|
@ -141,7 +140,7 @@ performRequest :: Maybe [Status] -> Request -> ClientM Response
|
|||
performRequest acceptStatus req = do
|
||||
-- TODO: should use Client.withResponse here too
|
||||
ClientEnv m burl cookieJar' createClientRequest <- ask
|
||||
clientRequest <- liftIO $ createClientRequest burl req
|
||||
let clientRequest = createClientRequest burl req
|
||||
request <- case cookieJar' of
|
||||
Nothing -> pure clientRequest
|
||||
Just cj -> liftIO $ do
|
||||
|
|
@ -175,21 +174,10 @@ performRequest acceptStatus req = do
|
|||
-- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above).
|
||||
performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a
|
||||
performWithStreamingRequest req k = do
|
||||
ClientEnv m burl cookieJar' createClientRequest <- ask
|
||||
clientRequest <- liftIO $ createClientRequest burl req
|
||||
request <- case cookieJar' of
|
||||
Nothing -> pure clientRequest
|
||||
Just cj -> liftIO $ do
|
||||
now <- getCurrentTime
|
||||
atomically $ do
|
||||
oldCookieJar <- readTVar cj
|
||||
let (newRequest, newCookieJar) =
|
||||
Client.insertCookiesIntoRequest
|
||||
clientRequest
|
||||
oldCookieJar
|
||||
now
|
||||
writeTVar cj newCookieJar
|
||||
pure newRequest
|
||||
m <- asks manager
|
||||
burl <- asks baseUrl
|
||||
createClientRequest <- asks makeClientRequest
|
||||
let request = createClientRequest burl req
|
||||
ClientM $ lift $ lift $ Codensity $ \k1 ->
|
||||
Client.withResponse request m $ \res -> do
|
||||
let status = Client.responseStatus res
|
||||
|
|
|
|||
|
|
@ -160,7 +160,6 @@ type Api =
|
|||
WithStatus 301 Text]
|
||||
:<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]
|
||||
:<|> NamedRoutes RecordRoutes
|
||||
:<|> "captureVerbatim" :> Capture "someString" Verbatim :> Get '[PlainText] Text
|
||||
|
||||
api :: Proxy Api
|
||||
api = Proxy
|
||||
|
|
@ -215,8 +214,7 @@ getRoot
|
|||
:<|> EmptyClient
|
||||
:<|> uverbGetSuccessOrRedirect
|
||||
:<|> uverbGetCreated
|
||||
:<|> recordRoutes
|
||||
:<|> captureVerbatim = client api
|
||||
:<|> recordRoutes = client api
|
||||
|
||||
server :: Application
|
||||
server = serve api (
|
||||
|
|
@ -261,7 +259,6 @@ server = serve api (
|
|||
{ something = pure ["foo", "bar", "pweet"]
|
||||
}
|
||||
}
|
||||
:<|> pure . decodeUtf8 . unVerbatim
|
||||
)
|
||||
|
||||
-- * api for testing failures
|
||||
|
|
@ -373,12 +370,3 @@ instance ToHttpApiData UrlEncodedByteString where
|
|||
|
||||
instance FromHttpApiData UrlEncodedByteString where
|
||||
parseUrlPiece = pure . UrlEncodedByteString . HTTP.urlDecode True . encodeUtf8
|
||||
|
||||
newtype Verbatim = Verbatim { unVerbatim :: ByteString }
|
||||
|
||||
instance ToHttpApiData Verbatim where
|
||||
toEncodedUrlPiece = byteString . unVerbatim
|
||||
toUrlPiece = decodeUtf8 . unVerbatim
|
||||
|
||||
instance FromHttpApiData Verbatim where
|
||||
parseUrlPiece = pure . Verbatim . encodeUtf8
|
||||
|
|
|
|||
|
|
@ -36,8 +36,6 @@ import Data.Maybe
|
|||
import Data.Monoid ()
|
||||
import Data.Text
|
||||
(Text)
|
||||
import Data.Text.Encoding
|
||||
(encodeUtf8)
|
||||
import qualified Network.HTTP.Client as C
|
||||
import qualified Network.HTTP.Types as HTTP
|
||||
import Test.Hspec
|
||||
|
|
@ -162,8 +160,7 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
|
|||
mgr <- C.newManager C.defaultManagerSettings
|
||||
-- In proper situation, extra headers should probably be visible in API type.
|
||||
-- However, testing for response timeout is difficult, so we test with something which is easy to observe
|
||||
let createClientRequest url r = fmap (\req -> req { C.requestHeaders = [("X-Added-Header", "XXX")] })
|
||||
(defaultMakeClientRequest url r)
|
||||
let createClientRequest url r = (defaultMakeClientRequest url r) { C.requestHeaders = [("X-Added-Header", "XXX")] }
|
||||
clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }
|
||||
res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv
|
||||
case res of
|
||||
|
|
@ -199,10 +196,3 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
|
|||
case eitherResponse of
|
||||
Left clientError -> fail $ show clientError
|
||||
Right response -> matchUnion response `shouldBe` Just (WithStatus @201 carol)
|
||||
|
||||
it "encodes URL pieces following ToHttpApiData instance" $ \(_, baseUrl) -> do
|
||||
let textOrig = "*"
|
||||
eitherResponse <- runClient (captureVerbatim $ Verbatim $ encodeUtf8 textOrig) baseUrl
|
||||
case eitherResponse of
|
||||
Left clientError -> fail $ show clientError
|
||||
Right textBack -> textBack `shouldBe` textOrig
|
||||
|
|
|
|||
|
|
@ -31,8 +31,8 @@ library
|
|||
base >=4.9 && <5
|
||||
, bytestring >=0.10.8.1 && <0.12
|
||||
, conduit >=1.3.1 && <1.4
|
||||
, mtl ^>=2.2.2 || ^>=2.3.1
|
||||
, resourcet >=1.2.2 && <1.4
|
||||
, mtl >=2.2.2 && <2.3
|
||||
, resourcet >=1.2.2 && <1.3
|
||||
, servant >=0.15 && <0.20
|
||||
, unliftio-core >=0.1.2.0 && <0.3
|
||||
hs-source-dirs: src
|
||||
|
|
|
|||
|
|
@ -530,24 +530,6 @@
|
|||
|
||||
```
|
||||
|
||||
## GET /resource
|
||||
|
||||
### Response:
|
||||
|
||||
- Status code 200
|
||||
- Headers: []
|
||||
|
||||
- Supported content types are:
|
||||
|
||||
- `application/json;charset=utf-8`
|
||||
- `application/json`
|
||||
|
||||
- Example (`application/json;charset=utf-8`, `application/json`):
|
||||
|
||||
```javascript
|
||||
|
||||
```
|
||||
|
||||
## GET /streaming
|
||||
|
||||
### Request:
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@ library
|
|||
--
|
||||
-- note: mtl lower bound is so low because of GHC-7.8
|
||||
build-depends:
|
||||
base >= 4.9 && < 4.18
|
||||
base >= 4.9 && < 4.17
|
||||
, bytestring >= 0.10.8.1 && < 0.12
|
||||
, text >= 1.2.3.0 && < 2.1
|
||||
|
||||
|
|
@ -59,7 +59,7 @@ library
|
|||
, hashable >= 1.2.7.0 && < 1.5
|
||||
, http-media >= 0.7.1.3 && < 0.9
|
||||
, http-types >= 0.12.2 && < 0.13
|
||||
, lens >= 4.17 && < 5.3
|
||||
, lens >= 4.17 && < 5.2
|
||||
, string-conversions >= 0.4.0.1 && < 0.5
|
||||
, universe-base >= 1.1.1 && < 1.2
|
||||
, unordered-containers >= 0.2.9.0 && < 0.3
|
||||
|
|
|
|||
|
|
@ -62,7 +62,6 @@ import GHC.TypeLits
|
|||
import Servant.API
|
||||
import Servant.API.ContentTypes
|
||||
import Servant.API.TypeLevel
|
||||
import Servant.API.Generic
|
||||
|
||||
import qualified Data.Universe.Helpers as U
|
||||
|
||||
|
|
@ -447,7 +446,7 @@ docsWith opts intros (ExtraInfo endpoints) p =
|
|||
& apiEndpoints %~ HM.unionWith (flip combineAction) endpoints
|
||||
|
||||
|
||||
-- | Generate the docs for a given API that implements 'HasDocs' with any
|
||||
-- | Generate the docs for a given API that implements 'HasDocs' with with any
|
||||
-- number of introduction(s)
|
||||
docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API
|
||||
docsWithIntros intros = docsWith defaultDocOptions intros mempty
|
||||
|
|
@ -1144,9 +1143,6 @@ instance HasDocs api => HasDocs (Vault :> api) where
|
|||
instance HasDocs api => HasDocs (WithNamedContext name context api) where
|
||||
docsFor Proxy = docsFor (Proxy :: Proxy api)
|
||||
|
||||
instance HasDocs api => HasDocs (WithResource res :> api) where
|
||||
docsFor Proxy = docsFor (Proxy :: Proxy api)
|
||||
|
||||
instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth realm usr :> api) where
|
||||
docsFor Proxy (endpoint, action) =
|
||||
docsFor (Proxy :: Proxy api) (endpoint, action')
|
||||
|
|
@ -1154,9 +1150,6 @@ instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth r
|
|||
authProxy = Proxy :: Proxy (BasicAuth realm usr)
|
||||
action' = over authInfo (|> toAuthInfo authProxy) action
|
||||
|
||||
instance HasDocs (ToServantApi api) => HasDocs (NamedRoutes api) where
|
||||
docsFor Proxy = docsFor (Proxy :: Proxy (ToServantApi api))
|
||||
|
||||
-- ToSample instances for simple types
|
||||
instance ToSample NoContent
|
||||
instance ToSample Bool
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@ library
|
|||
--
|
||||
-- note: mtl lower bound is so low because of GHC-7.8
|
||||
build-depends:
|
||||
base >= 4.9 && < 4.18
|
||||
base >= 4.9 && < 4.17
|
||||
, text >= 1.2.3.0 && < 2.1
|
||||
|
||||
-- Servant dependencies
|
||||
|
|
@ -52,7 +52,7 @@ library
|
|||
-- Here can be exceptions if we really need features from the newer versions.
|
||||
build-depends:
|
||||
base-compat >= 0.10.5 && < 0.13
|
||||
, lens >= 4.17 && < 5.3
|
||||
, lens >= 4.17 && < 5.2
|
||||
, http-types >= 0.12.2 && < 0.13
|
||||
|
||||
hs-source-dirs: src
|
||||
|
|
@ -74,7 +74,7 @@ test-suite spec
|
|||
|
||||
-- Additional dependencies
|
||||
build-depends:
|
||||
hspec >= 2.6.0 && <2.10
|
||||
hspec >= 2.6.0 && <2.9
|
||||
build-tool-depends:
|
||||
hspec-discover:hspec-discover >=2.6.0 && <2.10
|
||||
hspec-discover:hspec-discover >=2.6.0 && <2.9
|
||||
default-language: Haskell2010
|
||||
|
|
|
|||
|
|
@ -487,13 +487,6 @@ instance HasForeign lang ftype api =>
|
|||
|
||||
foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)
|
||||
|
||||
instance HasForeign lang ftype api =>
|
||||
HasForeign lang ftype (WithResource res :> api) where
|
||||
|
||||
type Foreign ftype (WithResource res :> api) = Foreign ftype api
|
||||
|
||||
foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)
|
||||
|
||||
instance HasForeign lang ftype api
|
||||
=> HasForeign lang ftype (HttpVersion :> api) where
|
||||
type Foreign ftype (HttpVersion :> api) = Foreign ftype api
|
||||
|
|
|
|||
|
|
@ -38,14 +38,14 @@ library
|
|||
-- Bundled with GHC: Lower bound to not force re-installs
|
||||
-- text and mtl are bundled starting with GHC-8.4
|
||||
build-depends:
|
||||
base >= 4.9 && < 4.18
|
||||
base >= 4.9 && < 4.17
|
||||
, bytestring >= 0.10.8.1 && < 0.12
|
||||
, containers >= 0.5.7.1 && < 0.7
|
||||
, deepseq >= 1.4.2.0 && < 1.5
|
||||
, mtl ^>= 2.2.2 || ^>= 2.3.1
|
||||
, mtl >= 2.2.2 && < 2.3
|
||||
, text >= 1.2.3.0 && < 2.1
|
||||
, time >= 1.6.0.1 && < 1.13
|
||||
, transformers >= 0.5.2.0 && < 0.7
|
||||
, time >= 1.6.0.1 && < 1.12
|
||||
, transformers >= 0.5.2.0 && < 0.6
|
||||
|
||||
if !impl(ghc >= 8.2)
|
||||
build-depends:
|
||||
|
|
@ -112,7 +112,7 @@ test-suite spec
|
|||
-- Additional dependencies
|
||||
build-depends:
|
||||
entropy >= 0.4.1.3 && < 0.5
|
||||
, hspec >= 2.6.0 && < 2.10
|
||||
, hspec >= 2.6.0 && < 2.9
|
||||
, HUnit >= 1.6.0.0 && < 1.7
|
||||
, network >= 2.8.0.0 && < 3.2
|
||||
, QuickCheck >= 2.12.6.1 && < 2.15
|
||||
|
|
@ -121,7 +121,7 @@ test-suite spec
|
|||
, tdigest >= 0.2 && < 0.3
|
||||
|
||||
build-tool-depends:
|
||||
hspec-discover:hspec-discover >= 2.6.0 && < 2.10
|
||||
hspec-discover:hspec-discover >= 2.6.0 && < 2.9
|
||||
|
||||
test-suite readme
|
||||
type: exitcode-stdio-1.0
|
||||
|
|
|
|||
|
|
@ -31,7 +31,7 @@ library
|
|||
base >=4.9 && <5
|
||||
, bytestring >=0.10.8.1 && <0.12
|
||||
, machines >=0.6.4 && <0.8
|
||||
, mtl ^>=2.2.2 || ^>=2.3.1
|
||||
, mtl >=2.2.2 && <2.3
|
||||
, servant >=0.15 && <0.20
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ library
|
|||
, bytestring >=0.10.8.1 && <0.12
|
||||
, pipes >=4.3.9 && <4.4
|
||||
, pipes-safe >=2.3.1 && <2.4
|
||||
, mtl ^>=2.2.2 || ^>=2.3.1
|
||||
, mtl >=2.2.2 && <2.3
|
||||
, monad-control >=1.0.2.3 && <1.1
|
||||
, servant >=0.15 && <0.20
|
||||
hs-source-dirs: src
|
||||
|
|
|
|||
|
|
@ -3,17 +3,11 @@
|
|||
|
||||
Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions.
|
||||
|
||||
0.19.2
|
||||
------
|
||||
|
||||
Compatibility with GHC 9.4, see [PR #1592](https://github.com/haskell-servant/servant/pull/1592).
|
||||
|
||||
0.19.1
|
||||
------
|
||||
|
||||
- Add `MonadFail` instance for `Handler` wrt [#1545](https://github.com/haskell-servant/servant/issues/1545)
|
||||
- Support GHC 9.2 [#1525](https://github.com/haskell-servant/servant/issues/1525)
|
||||
- Add capture hints in `Router` type for debug and display purposes [PR #1556] (https://github.com/haskell-servant/servant/pull/1556)
|
||||
|
||||
0.19
|
||||
----
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
cabal-version: 2.2
|
||||
name: servant-server
|
||||
version: 0.19.2
|
||||
version: 0.19.1
|
||||
|
||||
synopsis: A family of combinators for defining webservices APIs and serving them
|
||||
category: Servant, Web
|
||||
|
|
@ -23,7 +23,7 @@ author: Servant Contributors
|
|||
maintainer: haskell-servant-maintainers@googlegroups.com
|
||||
copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
|
||||
build-type: Simple
|
||||
tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.3
|
||||
tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
|
||||
|
||||
extra-source-files:
|
||||
CHANGELOG.md
|
||||
|
|
@ -60,20 +60,20 @@ library
|
|||
-- Bundled with GHC: Lower bound to not force re-installs
|
||||
-- text and mtl are bundled starting with GHC-8.4
|
||||
build-depends:
|
||||
base >= 4.9 && < 4.18
|
||||
base >= 4.9 && < 4.17
|
||||
, bytestring >= 0.10.8.1 && < 0.12
|
||||
, constraints >= 0.2 && < 0.14
|
||||
, containers >= 0.5.7.1 && < 0.7
|
||||
, mtl ^>= 2.2.2 || ^>= 2.3.1
|
||||
, mtl >= 2.2.2 && < 2.3
|
||||
, text >= 1.2.3.0 && < 2.1
|
||||
, transformers >= 0.5.2.0 && < 0.7
|
||||
, transformers >= 0.5.2.0 && < 0.6
|
||||
, filepath >= 1.4.1.1 && < 1.5
|
||||
|
||||
-- Servant dependencies
|
||||
-- strict dependency as we re-export 'servant' things.
|
||||
build-depends:
|
||||
servant >= 0.19 && < 0.20
|
||||
, http-api-data >= 0.4.1 && < 0.5.1
|
||||
servant >= 0.19
|
||||
, http-api-data >= 0.4.1 && < 0.4.4
|
||||
|
||||
-- Other dependencies: Lower bound around what is in the latest Stackage LTS.
|
||||
-- Here can be exceptions if we really need features from the newer versions.
|
||||
|
|
@ -88,10 +88,10 @@ library
|
|||
, network >= 2.8 && < 3.2
|
||||
, sop-core >= 0.4.0.0 && < 0.6
|
||||
, string-conversions >= 0.4.0.1 && < 0.5
|
||||
, resourcet >= 1.2.2 && < 1.4
|
||||
, resourcet >= 1.2.2 && < 1.3
|
||||
, tagged >= 0.8.6 && < 0.9
|
||||
, transformers-base >= 0.4.5.2 && < 0.5
|
||||
, wai >= 3.2.2.1 && < 3.3
|
||||
, wai >= 3.2.1.2 && < 3.3
|
||||
, wai-app-static >= 3.1.6.2 && < 3.2
|
||||
, word8 >= 0.1.3 && < 0.2
|
||||
|
||||
|
|
@ -159,7 +159,7 @@ test-suite spec
|
|||
build-depends:
|
||||
aeson >= 1.4.1.0 && < 3
|
||||
, directory >= 1.3.0.0 && < 1.4
|
||||
, hspec >= 2.6.0 && < 2.10
|
||||
, hspec >= 2.6.0 && < 2.9
|
||||
, hspec-wai >= 0.10.1 && < 0.12
|
||||
, QuickCheck >= 2.12.6.1 && < 2.15
|
||||
, should-not-typecheck >= 2.1.0 && < 2.2
|
||||
|
|
@ -167,4 +167,4 @@ test-suite spec
|
|||
, wai-extra >= 3.0.24.3 && < 3.2
|
||||
|
||||
build-tool-depends:
|
||||
hspec-discover:hspec-discover >= 2.6.0 && <2.10
|
||||
hspec-discover:hspec-discover >= 2.6.0 && <2.9
|
||||
|
|
|
|||
|
|
@ -235,7 +235,7 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])
|
|||
-- > │ └─ e/
|
||||
-- > │ └─•
|
||||
-- > ├─ b/
|
||||
-- > │ └─ <x::Int>/
|
||||
-- > │ └─ <capture>/
|
||||
-- > │ ├─•
|
||||
-- > │ ┆
|
||||
-- > │ └─•
|
||||
|
|
@ -252,8 +252,7 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])
|
|||
--
|
||||
-- [@─•@] Leaves reflect endpoints.
|
||||
--
|
||||
-- [@\<x::Int\>/@] This is a delayed capture of a single
|
||||
-- path component named @x@, of expected type @Int@.
|
||||
-- [@\<capture\>/@] This is a delayed capture of a path component.
|
||||
--
|
||||
-- [@\<raw\>@] This is a part of the API we do not know anything about.
|
||||
--
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
|
|
@ -45,7 +44,7 @@ type family AuthServerData a :: *
|
|||
-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
|
||||
newtype AuthHandler r usr = AuthHandler
|
||||
{ unAuthHandler :: r -> Handler usr }
|
||||
deriving (Functor, Generic, Typeable)
|
||||
deriving (Generic, Typeable)
|
||||
|
||||
-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
|
||||
mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
|
@ -35,10 +34,9 @@ module Servant.Server.Internal
|
|||
import Control.Monad
|
||||
(join, when)
|
||||
import Control.Monad.Trans
|
||||
(liftIO, lift)
|
||||
(liftIO)
|
||||
import Control.Monad.Trans.Resource
|
||||
(runResourceT, ReleaseKey)
|
||||
import Data.Acquire
|
||||
(runResourceT)
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Builder as BB
|
||||
import qualified Data.ByteString.Char8 as BC8
|
||||
|
|
@ -78,7 +76,7 @@ import Servant.API
|
|||
QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),
|
||||
RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
|
||||
Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
|
||||
WithNamedContext, WithResource, NamedRoutes)
|
||||
WithNamedContext, NamedRoutes)
|
||||
import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
|
||||
import Servant.API.ContentTypes
|
||||
(AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
|
||||
|
|
@ -96,8 +94,6 @@ import Servant.API.TypeErrors
|
|||
import Web.HttpApiData
|
||||
(FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
|
||||
parseUrlPieces)
|
||||
import Data.Kind
|
||||
(Type)
|
||||
|
||||
import Servant.Server.Internal.BasicAuth
|
||||
import Servant.Server.Internal.Context
|
||||
|
|
@ -116,10 +112,6 @@ import Servant.API.TypeLevel
|
|||
(AtLeastOneFragment, FragmentUnique)
|
||||
|
||||
class HasServer api context where
|
||||
-- | The type of a server for this API, given a monad to run effects in.
|
||||
--
|
||||
-- Note that the result kind is @*@, so it is /not/ a monad transformer, unlike
|
||||
-- what the @T@ in the name might suggest.
|
||||
type ServerT api (m :: * -> *) :: *
|
||||
|
||||
route ::
|
||||
|
|
@ -181,7 +173,7 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont
|
|||
-- > server = getBook
|
||||
-- > where getBook :: Text -> Handler Book
|
||||
-- > getBook isbn = ...
|
||||
instance (KnownSymbol capture, FromHttpApiData a, Typeable a
|
||||
instance (KnownSymbol capture, FromHttpApiData a
|
||||
, HasServer api context, SBoolI (FoldLenient mods)
|
||||
, HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
|
||||
)
|
||||
|
|
@ -193,7 +185,7 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a
|
|||
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
|
||||
|
||||
route Proxy context d =
|
||||
CaptureRouter [hint] $
|
||||
CaptureRouter $
|
||||
route (Proxy :: Proxy api)
|
||||
context
|
||||
(addCapture d $ \ txt -> withRequest $ \ request ->
|
||||
|
|
@ -205,7 +197,6 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a
|
|||
where
|
||||
rep = typeRep (Proxy :: Proxy Capture')
|
||||
formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
|
||||
hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy a))
|
||||
|
||||
-- | If you use 'CaptureAll' in one of the endpoints for your API,
|
||||
-- this automatically requires your server-side handler to be a
|
||||
|
|
@ -224,7 +215,7 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a
|
|||
-- > server = getSourceFile
|
||||
-- > where getSourceFile :: [Text] -> Handler Book
|
||||
-- > getSourceFile pathSegments = ...
|
||||
instance (KnownSymbol capture, FromHttpApiData a, Typeable a
|
||||
instance (KnownSymbol capture, FromHttpApiData a
|
||||
, HasServer api context
|
||||
, HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
|
||||
)
|
||||
|
|
@ -236,7 +227,7 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a
|
|||
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
|
||||
|
||||
route Proxy context d =
|
||||
CaptureAllRouter [hint] $
|
||||
CaptureAllRouter $
|
||||
route (Proxy :: Proxy api)
|
||||
context
|
||||
(addCapture d $ \ txts -> withRequest $ \ request ->
|
||||
|
|
@ -247,43 +238,6 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a
|
|||
where
|
||||
rep = typeRep (Proxy :: Proxy CaptureAll)
|
||||
formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
|
||||
hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy [a]))
|
||||
|
||||
-- | If you use 'WithResource' in one of the endpoints for your API Servant
|
||||
-- will provide the handler for this endpoint an argument of the specified type.
|
||||
-- The lifespan of this resource will be automatically managed by Servant. This
|
||||
-- resource will be created before the handler starts and it will be destoyed
|
||||
-- after it ends. A new resource is created for each request to the endpoint.
|
||||
|
||||
-- The creation and destruction are done using a 'Data.Acquire.Acquire'
|
||||
-- provided via server 'Context'.
|
||||
--
|
||||
-- Example
|
||||
--
|
||||
-- > type MyApi = WithResource Handle :> "writeToFile" :> Post '[JSON] NoContent
|
||||
-- >
|
||||
-- > server :: Server MyApi
|
||||
-- > server = writeToFile
|
||||
-- > where writeToFile :: (ReleaseKey, Handle) -> Handler NoContent
|
||||
-- > writeToFile (_, h) = hPutStrLn h "message"
|
||||
--
|
||||
-- In addition to the resource, the handler will also receive a 'ReleaseKey'
|
||||
-- which can be used to deallocate the resource before the end of the request
|
||||
-- if desired.
|
||||
|
||||
instance (HasServer api ctx, HasContextEntry ctx (Acquire a))
|
||||
=> HasServer (WithResource a :> api) ctx where
|
||||
|
||||
type ServerT (WithResource a :> api) m = (ReleaseKey, a) -> ServerT api m
|
||||
|
||||
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @api) pc nt . s
|
||||
|
||||
route Proxy context d = route (Proxy @api) context (d `addParameterCheck` allocateResource)
|
||||
where
|
||||
allocateResource :: DelayedIO (ReleaseKey, a)
|
||||
allocateResource = DelayedIO $ lift $ allocateAcquire (getContextEntry context)
|
||||
|
||||
|
||||
|
||||
allowedMethodHead :: Method -> Request -> Bool
|
||||
allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
|
||||
|
|
@ -865,11 +819,7 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
|
|||
-------------------------------------------------------------------------------
|
||||
|
||||
-- Erroring instance for 'HasServer' when a combinator is not fully applied
|
||||
instance TypeError (PartialApplication
|
||||
#if __GLASGOW_HASKELL__ >= 904
|
||||
@(Type -> [Type] -> Constraint)
|
||||
#endif
|
||||
HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
|
||||
instance TypeError (PartialApplication HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
|
||||
where
|
||||
type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)
|
||||
route = error "unreachable"
|
||||
|
|
@ -913,11 +863,7 @@ type HasServerArrowTypeError a b =
|
|||
-- XXX: This omits the @context@ parameter, e.g.:
|
||||
--
|
||||
-- "There is no instance for HasServer (Bool :> …)". Do we care ?
|
||||
instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub
|
||||
#if __GLASGOW_HASKELL__ >= 904
|
||||
@(Type -> [Type] -> Constraint)
|
||||
#endif
|
||||
HasServer ty) => HasServer (ty :> sub) context
|
||||
instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub HasServer ty) => HasServer (ty :> sub) context
|
||||
|
||||
instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context
|
||||
|
||||
|
|
|
|||
|
|
@ -9,16 +9,12 @@ import Prelude.Compat
|
|||
|
||||
import Data.Function
|
||||
(on)
|
||||
import Data.List
|
||||
(nub)
|
||||
import Data.Map
|
||||
(Map)
|
||||
import qualified Data.Map as M
|
||||
import Data.Text
|
||||
(Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Typeable
|
||||
(TypeRep)
|
||||
import Network.Wai
|
||||
(Response, pathInfo)
|
||||
import Servant.Server.Internal.ErrorFormatter
|
||||
|
|
@ -28,21 +24,6 @@ import Servant.Server.Internal.ServerError
|
|||
|
||||
type Router env = Router' env RoutingApplication
|
||||
|
||||
-- | Holds information about pieces of url that are captured as variables.
|
||||
data CaptureHint = CaptureHint
|
||||
{ captureName :: Text
|
||||
-- ^ Holds the name of the captured variable
|
||||
, captureType :: TypeRep
|
||||
-- ^ Holds the type of the captured variable
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
toCaptureTag :: CaptureHint -> Text
|
||||
toCaptureTag hint = captureName hint <> "::" <> (T.pack . show) (captureType hint)
|
||||
|
||||
toCaptureTags :: [CaptureHint] -> Text
|
||||
toCaptureTags hints = "<" <> T.intercalate "|" (map toCaptureTag hints) <> ">"
|
||||
|
||||
-- | Internal representation of a router.
|
||||
--
|
||||
-- The first argument describes an environment type that is
|
||||
|
|
@ -55,23 +36,12 @@ data Router' env a =
|
|||
-- ^ the map contains routers for subpaths (first path component used
|
||||
-- for lookup and removed afterwards), the list contains handlers
|
||||
-- for the empty path, to be tried in order
|
||||
| CaptureRouter [CaptureHint] (Router' (Text, env) a)
|
||||
| CaptureRouter (Router' (Text, env) a)
|
||||
-- ^ first path component is passed to the child router in its
|
||||
-- environment and removed afterwards.
|
||||
-- The first argument is a list of hints for all variables that can be
|
||||
-- captured by the router. The fact that it is a list is counter-intuitive,
|
||||
-- because the 'Capture' combinator only allows to capture a single varible,
|
||||
-- with a single name and a single type. However, the 'choice' smart
|
||||
-- constructor may merge two 'Capture' combinators with different hints, thus
|
||||
-- forcing the type to be '[CaptureHint]'.
|
||||
-- Because 'CaptureRouter' is built from a 'Capture' combinator, the list of
|
||||
-- hints should always be non-empty.
|
||||
| CaptureAllRouter [CaptureHint] (Router' ([Text], env) a)
|
||||
-- environment and removed afterwards
|
||||
| CaptureAllRouter (Router' ([Text], env) a)
|
||||
-- ^ all path components are passed to the child router in its
|
||||
-- environment and are removed afterwards
|
||||
-- The first argument is a hint for the list of variables that can be
|
||||
-- captured by the router. Note that the 'captureType' field of the hint
|
||||
-- should always be '[a]' for some 'a'.
|
||||
| RawRouter (env -> a)
|
||||
-- ^ to be used for routes we do not know anything about
|
||||
| Choice (Router' env a) (Router' env a)
|
||||
|
|
@ -99,8 +69,8 @@ leafRouter l = StaticRouter M.empty [l]
|
|||
choice :: Router' env a -> Router' env a -> Router' env a
|
||||
choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =
|
||||
StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)
|
||||
choice (CaptureRouter hints1 router1) (CaptureRouter hints2 router2) =
|
||||
CaptureRouter (nub $ hints1 ++ hints2) (choice router1 router2)
|
||||
choice (CaptureRouter router1) (CaptureRouter router2) =
|
||||
CaptureRouter (choice router1 router2)
|
||||
choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3
|
||||
choice router1 router2 = Choice router1 router2
|
||||
|
||||
|
|
@ -114,11 +84,7 @@ choice router1 router2 = Choice router1 router2
|
|||
--
|
||||
data RouterStructure =
|
||||
StaticRouterStructure (Map Text RouterStructure) Int
|
||||
| CaptureRouterStructure [CaptureHint] RouterStructure
|
||||
-- ^ The first argument holds information about variables
|
||||
-- that are captured by the router. There may be several hints
|
||||
-- if several routers have been aggregated by the 'choice'
|
||||
-- smart constructor.
|
||||
| CaptureRouterStructure RouterStructure
|
||||
| RawRouterStructure
|
||||
| ChoiceStructure RouterStructure RouterStructure
|
||||
deriving (Eq, Show)
|
||||
|
|
@ -132,11 +98,11 @@ data RouterStructure =
|
|||
routerStructure :: Router' env a -> RouterStructure
|
||||
routerStructure (StaticRouter m ls) =
|
||||
StaticRouterStructure (fmap routerStructure m) (length ls)
|
||||
routerStructure (CaptureRouter hints router) =
|
||||
CaptureRouterStructure hints $
|
||||
routerStructure (CaptureRouter router) =
|
||||
CaptureRouterStructure $
|
||||
routerStructure router
|
||||
routerStructure (CaptureAllRouter hints router) =
|
||||
CaptureRouterStructure hints $
|
||||
routerStructure (CaptureAllRouter router) =
|
||||
CaptureRouterStructure $
|
||||
routerStructure router
|
||||
routerStructure (RawRouter _) =
|
||||
RawRouterStructure
|
||||
|
|
@ -148,8 +114,8 @@ routerStructure (Choice r1 r2) =
|
|||
-- | Compare the structure of two routers.
|
||||
--
|
||||
sameStructure :: Router' env a -> Router' env b -> Bool
|
||||
sameStructure router1 router2 =
|
||||
routerStructure router1 == routerStructure router2
|
||||
sameStructure r1 r2 =
|
||||
routerStructure r1 == routerStructure r2
|
||||
|
||||
-- | Provide a textual representation of the
|
||||
-- structure of a router.
|
||||
|
|
@ -160,8 +126,7 @@ routerLayout router =
|
|||
where
|
||||
mkRouterLayout :: Bool -> RouterStructure -> [Text]
|
||||
mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n
|
||||
mkRouterLayout c (CaptureRouterStructure hints r) =
|
||||
mkSubTree c (toCaptureTags hints) (mkRouterLayout False r)
|
||||
mkRouterLayout c (CaptureRouterStructure r) = mkSubTree c "<capture>" (mkRouterLayout False r)
|
||||
mkRouterLayout c RawRouterStructure =
|
||||
if c then ["├─ <raw>"] else ["└─ <raw>"]
|
||||
mkRouterLayout c (ChoiceStructure r1 r2) =
|
||||
|
|
@ -204,7 +169,7 @@ runRouterEnv fmt router env request respond =
|
|||
-> let request' = request { pathInfo = rest }
|
||||
in runRouterEnv fmt router' env request' respond
|
||||
_ -> respond $ Fail $ fmt request
|
||||
CaptureRouter _ router' ->
|
||||
CaptureRouter router' ->
|
||||
case pathInfo request of
|
||||
[] -> respond $ Fail $ fmt request
|
||||
-- This case is to handle trailing slashes.
|
||||
|
|
@ -212,7 +177,7 @@ runRouterEnv fmt router env request respond =
|
|||
first : rest
|
||||
-> let request' = request { pathInfo = rest }
|
||||
in runRouterEnv fmt router' (first, env) request' respond
|
||||
CaptureAllRouter _ router' ->
|
||||
CaptureAllRouter router' ->
|
||||
let segments = pathInfo request
|
||||
request' = request { pathInfo = [] }
|
||||
in runRouterEnv fmt router' (segments, env) request' respond
|
||||
|
|
|
|||
|
|
@ -9,9 +9,7 @@ import Control.Monad
|
|||
import Data.Proxy
|
||||
(Proxy (..))
|
||||
import Data.Text
|
||||
(Text, unpack)
|
||||
import Data.Typeable
|
||||
(typeRep)
|
||||
(unpack)
|
||||
import Network.HTTP.Types
|
||||
(Status (..))
|
||||
import Network.Wai
|
||||
|
|
@ -29,7 +27,6 @@ spec :: Spec
|
|||
spec = describe "Servant.Server.Internal.Router" $ do
|
||||
routerSpec
|
||||
distributivitySpec
|
||||
serverLayoutSpec
|
||||
|
||||
routerSpec :: Spec
|
||||
routerSpec = do
|
||||
|
|
@ -54,7 +51,7 @@ routerSpec = do
|
|||
toApp = toApplication . runRouter (const err404)
|
||||
|
||||
cap :: Router ()
|
||||
cap = CaptureRouter [hint] $
|
||||
cap = CaptureRouter $
|
||||
let delayed = addCapture (emptyDelayed $ Route pure) (const $ delayedFail err400)
|
||||
in leafRouter
|
||||
$ \env req res ->
|
||||
|
|
@ -62,9 +59,6 @@ routerSpec = do
|
|||
. const
|
||||
$ Route success
|
||||
|
||||
hint :: CaptureHint
|
||||
hint = CaptureHint "anything" $ typeRep (Proxy :: Proxy ())
|
||||
|
||||
router :: Router ()
|
||||
router = leafRouter (\_ _ res -> res $ Route success)
|
||||
`Choice` cap
|
||||
|
|
@ -104,30 +98,12 @@ distributivitySpec =
|
|||
it "properly handles mixing static paths at different levels" $ do
|
||||
level `shouldHaveSameStructureAs` levelRef
|
||||
|
||||
serverLayoutSpec :: Spec
|
||||
serverLayoutSpec =
|
||||
describe "serverLayout" $ do
|
||||
it "correctly represents the example API" $ do
|
||||
exampleLayout `shouldHaveLayout` expectedExampleLayout
|
||||
it "aggregates capture hints when different" $ do
|
||||
captureDifferentTypes `shouldHaveLayout` expectedCaptureDifferentTypes
|
||||
it "nubs capture hints when equal" $ do
|
||||
captureSameType `shouldHaveLayout` expectedCaptureSameType
|
||||
it "properly displays CaptureAll hints" $ do
|
||||
captureAllLayout `shouldHaveLayout` expectedCaptureAllLayout
|
||||
|
||||
shouldHaveSameStructureAs ::
|
||||
(HasServer api1 '[], HasServer api2 '[]) => Proxy api1 -> Proxy api2 -> Expectation
|
||||
shouldHaveSameStructureAs p1 p2 =
|
||||
unless (sameStructure (makeTrivialRouter p1) (makeTrivialRouter p2)) $
|
||||
expectationFailure ("expected:\n" ++ unpack (layout p2) ++ "\nbut got:\n" ++ unpack (layout p1))
|
||||
|
||||
shouldHaveLayout ::
|
||||
(HasServer api '[]) => Proxy api -> Text -> Expectation
|
||||
shouldHaveLayout p l =
|
||||
unless (routerLayout (makeTrivialRouter p) == l) $
|
||||
expectationFailure ("expected:\n" ++ unpack l ++ "\nbut got:\n" ++ unpack (layout p))
|
||||
|
||||
makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router ()
|
||||
makeTrivialRouter p =
|
||||
route p EmptyContext (emptyDelayed (FailFatal err501))
|
||||
|
|
@ -168,12 +144,12 @@ staticRef = Proxy
|
|||
-- structure:
|
||||
|
||||
type Dynamic =
|
||||
"a" :> Capture "foo" Int :> "b" :> End
|
||||
:<|> "a" :> Capture "foo" Int :> "c" :> End
|
||||
:<|> "a" :> Capture "foo" Int :> "d" :> End
|
||||
"a" :> Capture "foo" Int :> "b" :> End
|
||||
:<|> "a" :> Capture "bar" Bool :> "c" :> End
|
||||
:<|> "a" :> Capture "baz" Char :> "d" :> End
|
||||
|
||||
type DynamicRef =
|
||||
"a" :> Capture "foo" Int :>
|
||||
"a" :> Capture "anything" () :>
|
||||
("b" :> End :<|> "c" :> End :<|> "d" :> End)
|
||||
|
||||
dynamic :: Proxy Dynamic
|
||||
|
|
@ -363,100 +339,3 @@ level = Proxy
|
|||
|
||||
levelRef :: Proxy LevelRef
|
||||
levelRef = Proxy
|
||||
|
||||
-- The example API for the 'layout' function.
|
||||
-- Should get factorized by the 'choice' smart constructor.
|
||||
type ExampleLayout =
|
||||
"a" :> "d" :> Get '[JSON] NoContent
|
||||
:<|> "b" :> Capture "x" Int :> Get '[JSON] Bool
|
||||
:<|> "c" :> Put '[JSON] Bool
|
||||
:<|> "a" :> "e" :> Get '[JSON] Int
|
||||
:<|> "b" :> Capture "x" Int :> Put '[JSON] Bool
|
||||
:<|> Raw
|
||||
|
||||
exampleLayout :: Proxy ExampleLayout
|
||||
exampleLayout = Proxy
|
||||
|
||||
-- The expected representation of the example API layout
|
||||
--
|
||||
expectedExampleLayout :: Text
|
||||
expectedExampleLayout =
|
||||
"/\n\
|
||||
\├─ a/\n\
|
||||
\│ ├─ d/\n\
|
||||
\│ │ └─•\n\
|
||||
\│ └─ e/\n\
|
||||
\│ └─•\n\
|
||||
\├─ b/\n\
|
||||
\│ └─ <x::Int>/\n\
|
||||
\│ ├─•\n\
|
||||
\│ ┆\n\
|
||||
\│ └─•\n\
|
||||
\├─ c/\n\
|
||||
\│ └─•\n\
|
||||
\┆\n\
|
||||
\└─ <raw>\n"
|
||||
|
||||
-- A capture API with all capture types being the same
|
||||
--
|
||||
type CaptureSameType =
|
||||
"a" :> Capture "foo" Int :> "b" :> End
|
||||
:<|> "a" :> Capture "foo" Int :> "c" :> End
|
||||
:<|> "a" :> Capture "foo" Int :> "d" :> End
|
||||
|
||||
captureSameType :: Proxy CaptureSameType
|
||||
captureSameType = Proxy
|
||||
|
||||
-- The expected representation of the CaptureSameType API layout.
|
||||
--
|
||||
expectedCaptureSameType :: Text
|
||||
expectedCaptureSameType =
|
||||
"/\n\
|
||||
\└─ a/\n\
|
||||
\ └─ <foo::Int>/\n\
|
||||
\ ├─ b/\n\
|
||||
\ │ └─•\n\
|
||||
\ ├─ c/\n\
|
||||
\ │ └─•\n\
|
||||
\ └─ d/\n\
|
||||
\ └─•\n"
|
||||
|
||||
-- A capture API capturing different types
|
||||
--
|
||||
type CaptureDifferentTypes =
|
||||
"a" :> Capture "foo" Int :> "b" :> End
|
||||
:<|> "a" :> Capture "bar" Bool :> "c" :> End
|
||||
:<|> "a" :> Capture "baz" Char :> "d" :> End
|
||||
|
||||
captureDifferentTypes :: Proxy CaptureDifferentTypes
|
||||
captureDifferentTypes = Proxy
|
||||
|
||||
-- The expected representation of the CaptureDifferentTypes API layout.
|
||||
--
|
||||
expectedCaptureDifferentTypes :: Text
|
||||
expectedCaptureDifferentTypes =
|
||||
"/\n\
|
||||
\└─ a/\n\
|
||||
\ └─ <foo::Int|bar::Bool|baz::Char>/\n\
|
||||
\ ├─ b/\n\
|
||||
\ │ └─•\n\
|
||||
\ ├─ c/\n\
|
||||
\ │ └─•\n\
|
||||
\ └─ d/\n\
|
||||
\ └─•\n"
|
||||
|
||||
-- An API with a CaptureAll part
|
||||
|
||||
type CaptureAllLayout = "a" :> CaptureAll "foos" Int :> End
|
||||
|
||||
captureAllLayout :: Proxy CaptureAllLayout
|
||||
captureAllLayout = Proxy
|
||||
|
||||
-- The expected representation of the CaptureAllLayout API.
|
||||
--
|
||||
expectedCaptureAllLayout :: Text
|
||||
expectedCaptureAllLayout =
|
||||
"/\n\
|
||||
\└─ a/\n\
|
||||
\ └─ <foos::[Int]>/\n\
|
||||
\ └─•\n"
|
||||
|
|
|
|||
|
|
@ -21,8 +21,6 @@ import Control.Monad.Error.Class
|
|||
(MonadError (..))
|
||||
import Data.Aeson
|
||||
(FromJSON, ToJSON, decode', encode)
|
||||
import Data.Acquire
|
||||
(Acquire, mkAcquire)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Base64 as Base64
|
||||
import Data.Char
|
||||
|
|
@ -83,11 +81,8 @@ import Servant.Server.Internal.Context
|
|||
-- This declaration simply checks that all instances are in place.
|
||||
_ = serveWithContext comprehensiveAPI comprehensiveApiContext
|
||||
|
||||
comprehensiveApiContext :: Context '[NamedContext "foo" '[], Acquire Int]
|
||||
comprehensiveApiContext =
|
||||
NamedContext EmptyContext :.
|
||||
mkAcquire (pure 10) (\_ -> pure ()) :.
|
||||
EmptyContext
|
||||
comprehensiveApiContext :: Context '[NamedContext "foo" '[]]
|
||||
comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext
|
||||
|
||||
-- * Specs
|
||||
|
||||
|
|
|
|||
|
|
@ -77,7 +77,7 @@ library
|
|||
, http-media >=0.7.1.3 && <0.9
|
||||
, insert-ordered-containers >=0.2.1.0 && <0.3
|
||||
, lens >=4.17 && <6
|
||||
, servant >=0.18.2 && <0.20
|
||||
, servant >=0.18.1 && <0.20
|
||||
, singleton-bool >=0.1.4 && <0.2
|
||||
, swagger2 >=2.3.0.1 && <3
|
||||
, text >=1.2.3.0 && <2.1
|
||||
|
|
@ -106,14 +106,14 @@ test-suite spec
|
|||
type: exitcode-stdio-1.0
|
||||
hs-source-dirs: test
|
||||
main-is: Spec.hs
|
||||
build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.11
|
||||
build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.8
|
||||
build-depends: base
|
||||
, base-compat
|
||||
, aeson >=1.4.2.0 && <3
|
||||
, hspec >=2.6.0 && <2.11
|
||||
, hspec >=2.6.0 && <2.8
|
||||
, QuickCheck
|
||||
, lens
|
||||
, lens-aeson >=1.0.2 && <1.3
|
||||
, lens-aeson >=1.0.2 && <1.2
|
||||
, servant
|
||||
, servant-swagger
|
||||
, swagger2
|
||||
|
|
|
|||
|
|
@ -55,7 +55,6 @@ import Servant.Swagger.Internal.Orphans ()
|
|||
-- >>> import Data.Typeable
|
||||
-- >>> import GHC.Generics
|
||||
-- >>> import Servant.API
|
||||
-- >>> import System.Environment
|
||||
-- >>> import Test.Hspec
|
||||
-- >>> import Test.QuickCheck
|
||||
-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL8
|
||||
|
|
@ -65,7 +64,6 @@ import Servant.Swagger.Internal.Orphans ()
|
|||
-- >>> :set -XGeneralizedNewtypeDeriving
|
||||
-- >>> :set -XOverloadedStrings
|
||||
-- >>> :set -XTypeOperators
|
||||
-- >>> setEnv "HSPEC_COLOR" "no"
|
||||
-- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable)
|
||||
-- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON)
|
||||
-- >>> instance ToJSON User
|
||||
|
|
@ -162,11 +160,11 @@ import Servant.Swagger.Internal.Orphans ()
|
|||
-- >>> instance Arbitrary UserId where arbitrary = UserId <$> arbitrary
|
||||
-- >>> hspec $ validateEveryToJSON (Proxy :: Proxy UserAPI)
|
||||
-- <BLANKLINE>
|
||||
-- [User]...
|
||||
-- [User]
|
||||
-- ...
|
||||
-- User...
|
||||
-- User
|
||||
-- ...
|
||||
-- UserId...
|
||||
-- UserId
|
||||
-- ...
|
||||
-- Finished in ... seconds
|
||||
-- 3 examples, 0 failures
|
||||
|
|
|
|||
|
|
@ -3,13 +3,11 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
#if __GLASGOW_HASKELL__ >= 806
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
#endif
|
||||
|
|
@ -32,13 +30,11 @@ import qualified Data.Swagger as Swagger
|
|||
import Data.Swagger.Declare
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import GHC.Generics (D1, Meta(..), Rep)
|
||||
import GHC.TypeLits
|
||||
import Network.HTTP.Media (MediaType)
|
||||
import Servant.API
|
||||
import Servant.API.Description (FoldDescription,
|
||||
reflectDescription)
|
||||
import Servant.API.Generic (ToServantApi, AsApi)
|
||||
import Servant.API.Modifiers (FoldRequired)
|
||||
|
||||
import Servant.Swagger.Internal.TypeLevel.API
|
||||
|
|
@ -153,10 +149,6 @@ mkEndpointNoContentVerb path _ = mempty
|
|||
addParam :: Param -> Swagger -> Swagger
|
||||
addParam param = allOperations.parameters %~ (Inline param :)
|
||||
|
||||
-- | Add a tag to every operation in the spec.
|
||||
addTag :: Text -> Swagger -> Swagger
|
||||
addTag tag = allOperations.tags %~ ([tag] <>)
|
||||
|
||||
-- | Add accepted content types to every operation in the spec.
|
||||
addConsumes :: [MediaType] -> Swagger -> Swagger
|
||||
addConsumes cs = allOperations.consumes %~ (<> Just (MimeList cs))
|
||||
|
|
@ -304,10 +296,6 @@ instance (HasSwagger sub) => HasSwagger (HttpVersion :> sub) where
|
|||
instance (HasSwagger sub) => HasSwagger (WithNamedContext x c sub) where
|
||||
toSwagger _ = toSwagger (Proxy :: Proxy sub)
|
||||
|
||||
-- | @'WithResource'@ combinator does not change our specification at all.
|
||||
instance (HasSwagger sub) => HasSwagger (WithResource res :> sub) where
|
||||
toSwagger _ = toSwagger (Proxy :: Proxy sub)
|
||||
|
||||
instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (sym :> sub) where
|
||||
toSwagger _ = prependPath piece (toSwagger (Proxy :: Proxy sub))
|
||||
where
|
||||
|
|
@ -451,9 +439,6 @@ instance (ToSchema a, Accept ct, HasSwagger sub, KnownSymbol (FoldDescription mo
|
|||
& required ?~ True
|
||||
& schema .~ ParamBody ref
|
||||
|
||||
instance (HasSwagger (ToServantApi routes), KnownSymbol datatypeName, Rep (routes AsApi) ~ D1 ('MetaData datatypeName moduleName packageName isNewtype) f) => HasSwagger (NamedRoutes routes) where
|
||||
toSwagger _ = addTag (Text.pack $ symbolVal (Proxy :: Proxy datatypeName)) (toSwagger (Proxy :: Proxy (ToServantApi routes)))
|
||||
|
||||
-- =======================================================================
|
||||
-- Below are the definitions that should be in Servant.API.ContentTypes
|
||||
-- =======================================================================
|
||||
|
|
|
|||
|
|
@ -29,12 +29,10 @@ import Servant.Swagger.Internal.TypeLevel
|
|||
-- >>> import Control.Applicative
|
||||
-- >>> import GHC.Generics
|
||||
-- >>> import Test.QuickCheck
|
||||
-- >>> import System.Environment (setEnv)
|
||||
-- >>> :set -XDeriveGeneric
|
||||
-- >>> :set -XGeneralizedNewtypeDeriving
|
||||
-- >>> :set -XDataKinds
|
||||
-- >>> :set -XTypeOperators
|
||||
-- >>> setEnv "HSPEC_COLOR" "no"
|
||||
|
||||
-- | Verify that every type used with @'JSON'@ content type in a servant API
|
||||
-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSON'@.
|
||||
|
|
@ -55,10 +53,10 @@ import Servant.Swagger.Internal.TypeLevel
|
|||
--
|
||||
-- >>> hspec $ context "ToJSON matches ToSchema" $ validateEveryToJSON (Proxy :: Proxy UserAPI)
|
||||
-- <BLANKLINE>
|
||||
-- ToJSON matches ToSchema...
|
||||
-- User...
|
||||
-- ToJSON matches ToSchema
|
||||
-- User
|
||||
-- ...
|
||||
-- UserId...
|
||||
-- UserId
|
||||
-- ...
|
||||
-- Finished in ... seconds
|
||||
-- 2 examples, 0 failures
|
||||
|
|
@ -120,11 +118,11 @@ validateEveryToJSONWithPatternChecker checker _ = props
|
|||
-- :}
|
||||
-- <BLANKLINE>
|
||||
-- read . show == id
|
||||
-- Bool...
|
||||
-- Bool
|
||||
-- ...
|
||||
-- Int...
|
||||
-- Int
|
||||
-- ...
|
||||
-- [Char]...
|
||||
-- [Char]
|
||||
-- ...
|
||||
-- Finished in ... seconds
|
||||
-- 3 examples, 0 failures
|
||||
|
|
|
|||
|
|
@ -2,11 +2,6 @@
|
|||
|
||||
Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions.
|
||||
|
||||
0.19.1
|
||||
------
|
||||
|
||||
Compatibility with GHC 9.4, see [PR #1592](https://github.com/haskell-servant/servant/pull/1592).
|
||||
|
||||
0.19
|
||||
----
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
cabal-version: 2.2
|
||||
name: servant
|
||||
version: 0.19.1
|
||||
version: 0.19
|
||||
|
||||
synopsis: A family of combinators for defining webservices APIs
|
||||
category: Servant, Web
|
||||
|
|
@ -62,7 +62,6 @@ library
|
|||
Servant.API.Vault
|
||||
Servant.API.Verbs
|
||||
Servant.API.WithNamedContext
|
||||
Servant.API.WithResource
|
||||
|
||||
-- Types
|
||||
exposed-modules:
|
||||
|
|
@ -81,19 +80,19 @@ library
|
|||
--
|
||||
-- note: mtl lower bound is so low because of GHC-7.8
|
||||
build-depends:
|
||||
base >= 4.9 && < 4.18
|
||||
base >= 4.9 && < 4.17
|
||||
, bytestring >= 0.10.8.1 && < 0.12
|
||||
, constraints >= 0.2
|
||||
, mtl ^>= 2.2.2 || ^>= 2.3.1
|
||||
, mtl >= 2.2.2 && < 2.3
|
||||
, sop-core >= 0.4.0.0 && < 0.6
|
||||
, transformers >= 0.5.2.0 && < 0.7
|
||||
, transformers >= 0.5.2.0 && < 0.6
|
||||
, text >= 1.2.3.0 && < 2.1
|
||||
|
||||
|
||||
-- We depend (heavily) on the API of these packages:
|
||||
-- i.e. re-export, or allow using without direct dependency
|
||||
build-depends:
|
||||
http-api-data >= 0.4.1 && < 0.5.1
|
||||
http-api-data >= 0.4.1 && < 0.4.4
|
||||
, singleton-bool >= 0.1.4 && < 0.1.7
|
||||
|
||||
-- Other dependencies: Lower bound around what is in the latest Stackage LTS.
|
||||
|
|
@ -167,9 +166,9 @@ test-suite spec
|
|||
|
||||
-- Additional dependencies
|
||||
build-depends:
|
||||
hspec >= 2.6.0 && < 2.10
|
||||
hspec >= 2.6.0 && < 2.9
|
||||
, QuickCheck >= 2.12.6.1 && < 2.15
|
||||
, quickcheck-instances >= 0.3.19 && < 0.4
|
||||
|
||||
build-tool-depends:
|
||||
hspec-discover:hspec-discover >= 2.6.0 && < 2.10
|
||||
hspec-discover:hspec-discover >= 2.6.0 && < 2.9
|
||||
|
|
|
|||
|
|
@ -31,8 +31,6 @@ module Servant.API (
|
|||
-- | Access the location for arbitrary data to be shared by applications and middleware
|
||||
module Servant.API.WithNamedContext,
|
||||
-- | Access context entries in combinators in servant-server
|
||||
module Servant.API.WithResource,
|
||||
-- | Access a managed resource scoped to a single request
|
||||
|
||||
-- * Actual endpoints, distinguished by HTTP method
|
||||
module Servant.API.Verbs,
|
||||
|
|
@ -103,19 +101,17 @@ import Servant.API.Experimental.Auth
|
|||
(AuthProtect)
|
||||
import Servant.API.Fragment
|
||||
(Fragment)
|
||||
import Servant.API.Generic
|
||||
(AsApi, GServantProduct, GenericMode ((:-)), GenericServant,
|
||||
ToServant, ToServantApi, fromServant, genericApi, toServant)
|
||||
import Servant.API.Header
|
||||
(Header, Header')
|
||||
import Servant.API.Generic
|
||||
(GenericMode ((:-)), AsApi, ToServant, ToServantApi, GServantProduct,
|
||||
GenericServant, fromServant, toServant, genericApi)
|
||||
import Servant.API.HttpVersion
|
||||
(HttpVersion (..))
|
||||
import Servant.API.IsSecure
|
||||
(IsSecure (..))
|
||||
import Servant.API.Modifiers
|
||||
(Lenient, Optional, Required, Strict)
|
||||
import Servant.API.NamedRoutes
|
||||
(NamedRoutes)
|
||||
import Servant.API.QueryParam
|
||||
(QueryFlag, QueryParam, QueryParam', QueryParams)
|
||||
import Servant.API.Raw
|
||||
|
|
@ -141,6 +137,8 @@ import Servant.API.UVerb
|
|||
Unique, WithStatus (..), inject, statusOf)
|
||||
import Servant.API.Vault
|
||||
(Vault)
|
||||
import Servant.API.NamedRoutes
|
||||
(NamedRoutes)
|
||||
import Servant.API.Verbs
|
||||
(Delete, DeleteAccepted, DeleteNoContent,
|
||||
DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,
|
||||
|
|
@ -152,8 +150,6 @@ import Servant.API.Verbs
|
|||
ReflectMethod (reflectMethod), StdMethod (..), Verb)
|
||||
import Servant.API.WithNamedContext
|
||||
(WithNamedContext)
|
||||
import Servant.API.WithResource
|
||||
(WithResource)
|
||||
import Servant.Links
|
||||
(HasLink (..), IsElem, IsElem', Link, URI (..), safeLink)
|
||||
import Web.HttpApiData
|
||||
|
|
|
|||
|
|
@ -295,7 +295,7 @@ instance {-# OVERLAPPABLE #-}
|
|||
-- then this would be taken care of. However there is no more specific instance
|
||||
-- between that and 'MimeRender JSON a', so we do this instead
|
||||
instance {-# OVERLAPPING #-} ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where
|
||||
allMimeRender _ NoContent = map (, "") $ NE.toList $ contentTypes pctyp
|
||||
allMimeRender _ _ = map (, "") $ NE.toList $ contentTypes pctyp
|
||||
where
|
||||
pctyp = Proxy :: Proxy ctyp
|
||||
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@
|
|||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeFamilyDependencies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_HADDOCK not-home #-}
|
||||
|
|
@ -51,6 +52,9 @@ import Prelude ()
|
|||
import Prelude.Compat
|
||||
import Servant.API.Header
|
||||
(Header)
|
||||
import Servant.API.UVerb.Union
|
||||
import qualified Data.SOP.BasicFunctors as SOP
|
||||
import qualified Data.SOP.NS as SOP
|
||||
|
||||
-- | Response Header objects. You should never need to construct one directly.
|
||||
-- Instead, use 'addOptionalHeader'.
|
||||
|
|
@ -170,6 +174,25 @@ instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '
|
|||
=> AddHeader h v a new where
|
||||
addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)
|
||||
|
||||
-- Instances to decorate all responses in a 'Union' with headers. The functional
|
||||
-- dependencies force us to consider singleton lists as the base case in the
|
||||
-- recursion (it is impossible to determine h and v otherwise from old / new
|
||||
-- responses if the list is empty).
|
||||
instance (AddHeader h v old new) => AddHeader h v (Union '[old]) (Union '[new]) where
|
||||
addOptionalHeader hdr resp =
|
||||
SOP.Z $ SOP.I $ addOptionalHeader hdr $ SOP.unI $ SOP.unZ $ resp
|
||||
|
||||
instance
|
||||
( AddHeader h v old new, AddHeader h v (Union oldrest) (Union newrest)
|
||||
-- This ensures that the remainder of the response list is _not_ empty
|
||||
-- It is necessary to prevent the two instances for union types from
|
||||
-- overlapping.
|
||||
, oldrest ~ (a ': as), newrest ~ (b ': bs))
|
||||
=> AddHeader h v (Union (old ': (a ': as))) (Union (new ': (b ': bs))) where
|
||||
addOptionalHeader hdr resp = case resp of
|
||||
SOP.Z (SOP.I rHead) -> SOP.Z $ SOP.I $ addOptionalHeader hdr rHead
|
||||
SOP.S rOthers -> SOP.S $ addOptionalHeader hdr rOthers
|
||||
|
||||
-- | @addHeader@ adds a header to a response. Note that it changes the type of
|
||||
-- the value in the following ways:
|
||||
--
|
||||
|
|
|
|||
|
|
@ -110,7 +110,7 @@ type family IsElem' a s :: Constraint
|
|||
--
|
||||
-- >>> ok (Proxy :: Proxy (IsElem ("bye" :> Get '[JSON] Int) SampleAPI))
|
||||
-- ...
|
||||
-- ... Could not ...
|
||||
-- ... Could not deduce...
|
||||
-- ...
|
||||
--
|
||||
-- An endpoint is considered within an api even if it is missing combinators
|
||||
|
|
@ -151,7 +151,7 @@ type family IsElem endpoint api :: Constraint where
|
|||
--
|
||||
-- >>> ok (Proxy :: Proxy (IsSubAPI (SampleAPI :<|> Get '[JSON] Int) SampleAPI))
|
||||
-- ...
|
||||
-- ... Could not ...
|
||||
-- ... Could not deduce...
|
||||
-- ...
|
||||
--
|
||||
-- This uses @IsElem@ for checking; thus the note there applies here.
|
||||
|
|
@ -174,7 +174,7 @@ type family AllIsElem xs api :: Constraint where
|
|||
--
|
||||
-- >>> ok (Proxy :: Proxy (IsIn (Get '[JSON] Int) (Header "h" Bool :> Get '[JSON] Int)))
|
||||
-- ...
|
||||
-- ... Could not ...
|
||||
-- ... Could not deduce...
|
||||
-- ...
|
||||
type family IsIn (endpoint :: *) (api :: *) :: Constraint where
|
||||
IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb)
|
||||
|
|
|
|||
|
|
@ -53,9 +53,6 @@ statusOf = const (statusVal (Proxy :: Proxy (StatusOf a)))
|
|||
instance HasStatus NoContent where
|
||||
type StatusOf NoContent = 204
|
||||
|
||||
instance HasStatus a => HasStatus (Headers hs a) where
|
||||
type StatusOf (Headers hs a) = StatusOf a
|
||||
|
||||
class HasStatuses (as :: [*]) where
|
||||
type Statuses (as :: [*]) :: [Nat]
|
||||
statuses :: Proxy as -> [Status]
|
||||
|
|
@ -90,6 +87,8 @@ newtype WithStatus (k :: Nat) a = WithStatus a
|
|||
instance KnownStatus n => HasStatus (WithStatus n a) where
|
||||
type StatusOf (WithStatus n a) = n
|
||||
|
||||
instance HasStatus a => HasStatus (Headers ls a) where
|
||||
type StatusOf (Headers ls a) = StatusOf a
|
||||
|
||||
-- | A variant of 'Verb' that can have any of a number of response values and status codes.
|
||||
--
|
||||
|
|
|
|||
|
|
@ -128,9 +128,9 @@ type DuplicateElementError (rs :: [k]) =
|
|||
':$$: 'Text " " ':<>: 'ShowType rs
|
||||
|
||||
type family Elem (x :: k) (xs :: [k]) :: Bool where
|
||||
Elem x (x ': _) = 'True
|
||||
Elem x (_ ': xs) = Elem x xs
|
||||
Elem _ '[] = 'False
|
||||
Elem x (x' ': xs) =
|
||||
If (x == x') 'True (Elem x xs)
|
||||
|
||||
type family Unique xs :: Constraint where
|
||||
Unique xs = If (Nubbed xs == 'True) (() :: Constraint) (TypeError (DuplicateElementError xs))
|
||||
|
|
|
|||
|
|
@ -1,3 +0,0 @@
|
|||
module Servant.API.WithResource (WithResource) where
|
||||
|
||||
data WithResource res
|
||||
|
|
@ -1,6 +1,5 @@
|
|||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
|
|
@ -92,7 +91,7 @@
|
|||
-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] NoContent)
|
||||
-- >>> safeLink api bad_link
|
||||
-- ...
|
||||
-- ...Could not ...
|
||||
-- ...Could not deduce...
|
||||
-- ...
|
||||
--
|
||||
-- This error is essentially saying that the type family couldn't find
|
||||
|
|
@ -193,11 +192,7 @@ import Servant.API.Verbs
|
|||
(Verb, NoContentVerb)
|
||||
import Servant.API.WithNamedContext
|
||||
(WithNamedContext)
|
||||
import Servant.API.WithResource
|
||||
(WithResource)
|
||||
import Web.HttpApiData
|
||||
import Data.Kind
|
||||
(Type)
|
||||
|
||||
-- | A safe link datatype.
|
||||
-- The only way of constructing a 'Link' is using 'safeLink', which means any
|
||||
|
|
@ -560,10 +555,6 @@ instance HasLink sub => HasLink (WithNamedContext name context sub) where
|
|||
type MkLink (WithNamedContext name context sub) a = MkLink sub a
|
||||
toLink toA _ = toLink toA (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (WithResource res :> sub) where
|
||||
type MkLink (WithResource res :> sub) a = MkLink sub a
|
||||
toLink toA _ = toLink toA (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (RemoteHost :> sub) where
|
||||
type MkLink (RemoteHost :> sub) a = MkLink sub a
|
||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||
|
|
@ -656,20 +647,12 @@ simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub)
|
|||
-- >>> import Data.Text (Text)
|
||||
|
||||
-- Erroring instance for 'HasLink' when a combinator is not fully applied
|
||||
instance TypeError (PartialApplication
|
||||
#if __GLASGOW_HASKELL__ >= 904
|
||||
@(Type -> Constraint)
|
||||
#endif
|
||||
HasLink arr) => HasLink ((arr :: a -> b) :> sub)
|
||||
instance TypeError (PartialApplication HasLink arr) => HasLink ((arr :: a -> b) :> sub)
|
||||
where
|
||||
type MkLink (arr :> sub) _ = TypeError (PartialApplication (HasLink :: * -> Constraint) arr)
|
||||
toLink = error "unreachable"
|
||||
|
||||
-- Erroring instances for 'HasLink' for unknown API combinators
|
||||
instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub
|
||||
#if __GLASGOW_HASKELL__ >= 904
|
||||
@(Type -> Constraint)
|
||||
#endif
|
||||
HasLink ty) => HasLink (ty :> sub)
|
||||
instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub HasLink ty) => HasLink (ty :> sub)
|
||||
|
||||
instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasLink api)) => HasLink api
|
||||
|
|
|
|||
|
|
@ -72,7 +72,6 @@ type ComprehensiveAPIWithoutStreamingOrRaw' endpoint =
|
|||
:<|> "description" :> Description "foo" :> GET
|
||||
:<|> "alternative" :> ("left" :> GET :<|> "right" :> GET)
|
||||
:<|> "fragment" :> Fragment Int :> GET
|
||||
:<|> "resource" :> WithResource Int :> GET
|
||||
:<|> endpoint
|
||||
|
||||
type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
|
@ -155,10 +154,8 @@ instance (Applicative m, Show1 m, Show a) => Show (StepT m a) where
|
|||
-- | >>> lift [1,2,3] :: StepT [] Int
|
||||
-- Effect [Yield 1 Stop,Yield 2 Stop,Yield 3 Stop]
|
||||
--
|
||||
#if !MIN_VERSION_transformers(0,6,0)
|
||||
instance MonadTrans StepT where
|
||||
lift = Effect . fmap (`Yield` Stop)
|
||||
#endif
|
||||
|
||||
instance MFunctor StepT where
|
||||
hoist f = go where
|
||||
|
|
|
|||
|
|
@ -33,8 +33,6 @@ import Data.String.Conversions
|
|||
import qualified Data.Text as TextS
|
||||
import qualified Data.Text.Encoding as TextSE
|
||||
import qualified Data.Text.Lazy as TextL
|
||||
import Control.Exception
|
||||
(evaluate)
|
||||
import GHC.Generics
|
||||
import Test.Hspec
|
||||
import Test.QuickCheck
|
||||
|
|
@ -80,15 +78,6 @@ spec = describe "Servant.API.ContentTypes" $ do
|
|||
it "has mimeUnrender reverse mimeRender for valid top-level json " $ do
|
||||
property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData)
|
||||
|
||||
describe "The NoContent Content-Type type" $ do
|
||||
let p = Proxy :: Proxy '[JSON]
|
||||
|
||||
it "does not render any content" $
|
||||
allMimeRender p NoContent `shouldSatisfy` (all (BSL8.null . snd))
|
||||
|
||||
it "evaluates the NoContent value" $
|
||||
evaluate (allMimeRender p (undefined :: NoContent)) `shouldThrow` anyErrorCall
|
||||
|
||||
describe "The PlainText Content-Type type" $ do
|
||||
let p = Proxy :: Proxy PlainText
|
||||
|
||||
|
|
|
|||
|
|
@ -2,14 +2,10 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Servant.API.ResponseHeadersSpec where
|
||||
|
||||
import Data.Proxy
|
||||
import GHC.TypeLits
|
||||
import Test.Hspec
|
||||
|
||||
import Servant.API.ContentTypes
|
||||
import Servant.API.Header
|
||||
import Servant.API.ResponseHeaders
|
||||
import Servant.API.UVerb
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "Servant.API.ResponseHeaders" $ do
|
||||
|
|
@ -32,10 +28,3 @@ spec = describe "Servant.API.ResponseHeaders" $ do
|
|||
it "does not add a header" $ do
|
||||
let val = noHeader 5 :: Headers '[Header "test" Int] Int
|
||||
getHeaders val `shouldBe` []
|
||||
|
||||
describe "HasStatus Headers" $ do
|
||||
|
||||
it "gets the status from the underlying value" $ do
|
||||
natVal (Proxy :: Proxy (StatusOf (Headers '[Header "first" Int] NoContent))) `shouldBe` 204
|
||||
natVal (Proxy :: Proxy (StatusOf (Headers '[Header "first" Int] (WithStatus 503 ())))) `shouldBe` 503
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue