Compare commits
26 commits
maksbotan/
...
master
Author | SHA1 | Date | |
---|---|---|---|
|
a2e003367d | ||
|
b3214eac38 | ||
|
f71953e63d | ||
|
c382a1f34e | ||
|
2daae80ea8 | ||
|
a22600979a | ||
|
b8675c0924 | ||
|
751350ba9e | ||
|
a4194dc490 | ||
|
6392dce4bf | ||
|
8f081bd9ad | ||
|
ad25e98e19 | ||
|
0fc6e395cb | ||
|
58aa0d1c0c | ||
|
18bc2cf314 | ||
|
d5b9cbf634 | ||
|
ff135e868b | ||
|
86c61c6dbd | ||
|
3f6886ad2d | ||
|
53c132173c | ||
|
a445fbafd6 | ||
|
52f76ea722 | ||
|
4627683a64 | ||
|
e4650de303 | ||
|
2323906080 | ||
|
f0e2316895 |
55 changed files with 474 additions and 124 deletions
57
.github/workflows/master.yml
vendored
57
.github/workflows/master.yml
vendored
|
@ -20,6 +20,7 @@ jobs:
|
||||||
- "8.10.7"
|
- "8.10.7"
|
||||||
- "9.0.2"
|
- "9.0.2"
|
||||||
- "9.2.2"
|
- "9.2.2"
|
||||||
|
- "9.4.2"
|
||||||
|
|
||||||
steps:
|
steps:
|
||||||
- uses: actions/checkout@v2
|
- uses: actions/checkout@v2
|
||||||
|
@ -75,40 +76,40 @@ jobs:
|
||||||
(cd servant-conduit && eval $DOCTEST)
|
(cd servant-conduit && eval $DOCTEST)
|
||||||
(cd servant-pipes && eval $DOCTEST)
|
(cd servant-pipes && eval $DOCTEST)
|
||||||
|
|
||||||
stack:
|
# stack:
|
||||||
name: stack / ghc ${{ matrix.ghc }}
|
# name: stack / ghc ${{ matrix.ghc }}
|
||||||
runs-on: ubuntu-latest
|
# runs-on: ubuntu-latest
|
||||||
strategy:
|
# strategy:
|
||||||
matrix:
|
# matrix:
|
||||||
stack: ["2.7.5"]
|
# stack: ["2.7.5"]
|
||||||
ghc: ["8.10.7"]
|
# ghc: ["8.10.7"]
|
||||||
|
|
||||||
steps:
|
# steps:
|
||||||
- uses: actions/checkout@v2
|
# - uses: actions/checkout@v2
|
||||||
|
|
||||||
- uses: haskell/actions/setup@v1
|
# - uses: haskell/actions/setup@v1
|
||||||
name: Setup Haskell Stack
|
# name: Setup Haskell Stack
|
||||||
with:
|
# with:
|
||||||
ghc-version: ${{ matrix.ghc }}
|
# ghc-version: ${{ matrix.ghc }}
|
||||||
stack-version: ${{ matrix.stack }}
|
# stack-version: ${{ matrix.stack }}
|
||||||
|
|
||||||
- uses: actions/cache@v2.1.3
|
# - uses: actions/cache@v2.1.3
|
||||||
name: Cache ~/.stack
|
# name: Cache ~/.stack
|
||||||
with:
|
# with:
|
||||||
path: ~/.stack
|
# path: ~/.stack
|
||||||
key: ${{ runner.os }}-${{ matrix.ghc }}-stack
|
# key: ${{ runner.os }}-${{ matrix.ghc }}-stack
|
||||||
|
|
||||||
- name: Install dependencies
|
# - name: Install dependencies
|
||||||
run: |
|
# run: |
|
||||||
stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies
|
# stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies
|
||||||
|
|
||||||
- name: Build
|
# - name: Build
|
||||||
run: |
|
# run: |
|
||||||
stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks
|
# stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks
|
||||||
|
|
||||||
- name: Test
|
# - name: Test
|
||||||
run: |
|
# run: |
|
||||||
stack test --system-ghc
|
# stack test --system-ghc
|
||||||
|
|
||||||
ghcjs:
|
ghcjs:
|
||||||
name: ubuntu-latest / ghcjs 8.6
|
name: ubuntu-latest / ghcjs 8.6
|
||||||
|
|
|
@ -47,6 +47,7 @@ packages:
|
||||||
doc/cookbook/using-custom-monad
|
doc/cookbook/using-custom-monad
|
||||||
doc/cookbook/using-free-client
|
doc/cookbook/using-free-client
|
||||||
-- doc/cookbook/open-id-connect
|
-- doc/cookbook/open-id-connect
|
||||||
|
doc/cookbook/managed-resource
|
||||||
|
|
||||||
tests: True
|
tests: True
|
||||||
optimization: False
|
optimization: False
|
||||||
|
|
2
changelog.d/1573
Normal file
2
changelog.d/1573
Normal file
|
@ -0,0 +1,2 @@
|
||||||
|
synopsis: Add API docs for ServerT
|
||||||
|
prs: #1573
|
10
changelog.d/1606
Normal file
10
changelog.d/1606
Normal file
|
@ -0,0 +1,10 @@
|
||||||
|
synopsis: Handle Cookies correctly for RunStreamingClient
|
||||||
|
prs: #1606
|
||||||
|
issues: #1605
|
||||||
|
|
||||||
|
description: {
|
||||||
|
|
||||||
|
Makes performWithStreamingRequest take into consideration the
|
||||||
|
CookieJar, which it previously didn't.
|
||||||
|
|
||||||
|
}
|
2
changelog.d/1638
Normal file
2
changelog.d/1638
Normal file
|
@ -0,0 +1,2 @@
|
||||||
|
synopsis: Add Functor instance to AuthHandler.
|
||||||
|
prs: #1638
|
8
changelog.d/1649
Normal file
8
changelog.d/1649
Normal file
|
@ -0,0 +1,8 @@
|
||||||
|
synopsis: Add HasStatus instance for Headers (that defers StatusOf to underlying value)
|
||||||
|
prs: #1649
|
||||||
|
|
||||||
|
description: {
|
||||||
|
|
||||||
|
Adds a new HasStatus (Headers hs a) instance (StatusOf (Headers hs a) = StatusOf a)
|
||||||
|
|
||||||
|
}
|
|
@ -37,3 +37,4 @@ you name it!
|
||||||
sentry/Sentry.lhs
|
sentry/Sentry.lhs
|
||||||
testing/Testing.lhs
|
testing/Testing.lhs
|
||||||
open-id-connect/OpenIdConnect.lhs
|
open-id-connect/OpenIdConnect.lhs
|
||||||
|
managed-resource/ManagedResource.lhs
|
||||||
|
|
114
doc/cookbook/managed-resource/ManagedResource.lhs
Normal file
114
doc/cookbook/managed-resource/ManagedResource.lhs
Normal file
|
@ -0,0 +1,114 @@
|
||||||
|
# Request-lifetime Managed Resources
|
||||||
|
|
||||||
|
Let's see how we can write a handle that uses a resource managed by Servant. The resource is created automatically by Servant when the server recieves a request, and the resource is automatically destroyed when the server is finished handling a request.
|
||||||
|
|
||||||
|
As usual, we start with a little bit of throat clearing.
|
||||||
|
|
||||||
|
|
||||||
|
``` haskell
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
import Control.Concurrent
|
||||||
|
import Control.Exception (bracket, throwIO)
|
||||||
|
import Control.Monad.IO.Class
|
||||||
|
import Control.Monad.Trans.Resource
|
||||||
|
import Data.Acquire
|
||||||
|
import Network.HTTP.Client (newManager, defaultManagerSettings)
|
||||||
|
import Network.Wai.Handler.Warp
|
||||||
|
import Servant
|
||||||
|
import Servant.Client
|
||||||
|
import System.IO
|
||||||
|
```
|
||||||
|
|
||||||
|
Here we define an API type that uses the `WithResource` combinator. The server handler for an endpoint with a `WithResource res` component will receive a value of that type as an argument.
|
||||||
|
|
||||||
|
``` haskell
|
||||||
|
type API = WithResource Handle :> ReqBody '[PlainText] String :> Post '[JSON] NoContent
|
||||||
|
|
||||||
|
api :: Proxy API
|
||||||
|
api = Proxy
|
||||||
|
```
|
||||||
|
|
||||||
|
But this resource value has to come from somewhere. Servant obtains the value using an Acquire provided in the context. The Acquire knows how to both create and destroy resources of a particular type.
|
||||||
|
|
||||||
|
``` haskell
|
||||||
|
appContext :: Context '[Acquire Handle]
|
||||||
|
appContext = acquireHandle :. EmptyContext
|
||||||
|
|
||||||
|
acquireHandle :: Acquire Handle
|
||||||
|
acquireHandle = mkAcquire newHandle closeHandle
|
||||||
|
|
||||||
|
newHandle :: IO Handle
|
||||||
|
newHandle = do
|
||||||
|
putStrLn "opening file"
|
||||||
|
h <- openFile "test.txt" AppendMode
|
||||||
|
putStrLn "opened file"
|
||||||
|
return h
|
||||||
|
|
||||||
|
closeHandle :: Handle -> IO ()
|
||||||
|
closeHandle h = do
|
||||||
|
putStrLn "closing file"
|
||||||
|
hClose h
|
||||||
|
putStrLn "closed file"
|
||||||
|
```
|
||||||
|
|
||||||
|
Now we create the handler which will use this resource. This handler will write the request message to the System.IO.Handle which was provided to us. In some situations the handler will succeed, but in some in will fail. In either case, Servant will clean up the resource for us.
|
||||||
|
|
||||||
|
``` haskell
|
||||||
|
server :: Server API
|
||||||
|
server = writeToFile
|
||||||
|
|
||||||
|
where writeToFile :: (ReleaseKey, Handle) -> String -> Handler NoContent
|
||||||
|
writeToFile (_, h) msg = case msg of
|
||||||
|
"illegal" -> error "wait, that's illegal!"
|
||||||
|
legalMsg -> liftIO $ do
|
||||||
|
putStrLn "writing file"
|
||||||
|
hPutStrLn h legalMsg
|
||||||
|
putStrLn "wrote file"
|
||||||
|
return NoContent
|
||||||
|
```
|
||||||
|
|
||||||
|
Finally we run the server in the background while we post messages to it.
|
||||||
|
|
||||||
|
``` haskell
|
||||||
|
runApp :: IO ()
|
||||||
|
runApp = run 8080 (serveWithContext api appContext $ server)
|
||||||
|
|
||||||
|
postMsg :: String -> ClientM NoContent
|
||||||
|
postMsg = client api
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
mgr <- newManager defaultManagerSettings
|
||||||
|
bracket (forkIO $ runApp) killThread $ \_ -> do
|
||||||
|
ms <- flip runClientM (mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ do
|
||||||
|
liftIO $ putStrLn "sending hello message"
|
||||||
|
_ <- postMsg "hello"
|
||||||
|
liftIO $ putStrLn "sending illegal message"
|
||||||
|
_ <- postMsg "illegal"
|
||||||
|
liftIO $ putStrLn "done"
|
||||||
|
print ms
|
||||||
|
```
|
||||||
|
|
||||||
|
This program prints
|
||||||
|
|
||||||
|
```
|
||||||
|
sending hello message
|
||||||
|
opening file
|
||||||
|
opened file
|
||||||
|
writing file
|
||||||
|
wrote file
|
||||||
|
closing file
|
||||||
|
closed file
|
||||||
|
sending illegal message
|
||||||
|
opening file
|
||||||
|
opened file
|
||||||
|
closing file
|
||||||
|
closed file
|
||||||
|
wait, that's illegal!
|
||||||
|
CallStack (from HasCallStack):
|
||||||
|
error, called at ManagedResource.lhs:63:24 in main:Main
|
||||||
|
Left (FailureResponse (Request {requestPath = (BaseUrl {baseUrlScheme = Http, baseUrlHost = "localhost", baseUrlPort = 8080, baseUrlPath = ""},""), requestQueryString = fromList [], requestBody = Just ((),text/plain;charset=utf-8), requestAccept = fromList [], requestHeaders = fromList [], requestHttpVersion = HTTP/1.1, requestMethod = "POST"}) (Response {responseStatusCode = Status {statusCode = 500, statusMessage = "Internal Server Error"}, responseHeaders = fromList [("Transfer-Encoding","chunked"),("Date","Thu, 24 Nov 2022 21:04:47 GMT"),("Server","Warp/3.3.23"),("Content-Type","text/plain; charset=utf-8")], responseHttpVersion = HTTP/1.1, responseBody = "Something went wrong"}))
|
||||||
|
```
|
||||||
|
|
||||||
|
and appends to a file called `test.txt`. We can see from the output that when a legal message is sent, the file is opened, written to, and closed. We can also see that when an illegal message is sent, the file is opened but not written to. Crucially, it is still closed even though the handler threw an exception.
|
30
doc/cookbook/managed-resource/managed-resource.cabal
Normal file
30
doc/cookbook/managed-resource/managed-resource.cabal
Normal file
|
@ -0,0 +1,30 @@
|
||||||
|
cabal-version: 2.2
|
||||||
|
name: cookbook-managed-resource
|
||||||
|
version: 0.1
|
||||||
|
synopsis: Simple managed resource cookbook example
|
||||||
|
homepage: http://docs.servant.dev/
|
||||||
|
license: BSD-3-Clause
|
||||||
|
license-file: ../../../servant/LICENSE
|
||||||
|
author: Servant Contributors
|
||||||
|
maintainer: haskell-servant-maintainers@googlegroups.com
|
||||||
|
build-type: Simple
|
||||||
|
tested-with: GHC==9.4.2
|
||||||
|
|
||||||
|
executable cookbook-managed-resource
|
||||||
|
main-is: ManagedResource.lhs
|
||||||
|
build-depends: base == 4.*
|
||||||
|
, text >= 1.2
|
||||||
|
, aeson >= 1.2
|
||||||
|
, servant
|
||||||
|
, servant-client
|
||||||
|
, servant-server
|
||||||
|
, warp >= 3.2
|
||||||
|
, wai >= 3.2
|
||||||
|
, http-types >= 0.12
|
||||||
|
, markdown-unlit >= 0.4
|
||||||
|
, http-client >= 0.5
|
||||||
|
, transformers
|
||||||
|
, resourcet
|
||||||
|
default-language: Haskell2010
|
||||||
|
ghc-options: -Wall -pgmL markdown-unlit
|
||||||
|
build-tool-depends: markdown-unlit:markdown-unlit
|
|
@ -330,7 +330,7 @@ data Customer = Customer {
|
||||||
```
|
```
|
||||||
|
|
||||||
Here is the code that displays the homepage.
|
Here is the code that displays the homepage.
|
||||||
It should contain a link to the the `/login` URL.
|
It should contain a link to the `/login` URL.
|
||||||
When the user clicks on this link it will be redirected to Google login page
|
When the user clicks on this link it will be redirected to Google login page
|
||||||
with some generated information.
|
with some generated information.
|
||||||
|
|
||||||
|
|
|
@ -199,7 +199,7 @@ parsers in the hope that the ones that should will always error out so
|
||||||
you can try until the right one returns a value.)
|
you can try until the right one returns a value.)
|
||||||
|
|
||||||
[servant-exceptions](https://github.com/ch1bo/servant-exceptions) is
|
[servant-exceptions](https://github.com/ch1bo/servant-exceptions) is
|
||||||
another shot at at the problem. It is inspired by
|
another shot at the problem. It is inspired by
|
||||||
servant-checked-exceptions, so it may be worth taking a closer look.
|
servant-checked-exceptions, so it may be worth taking a closer look.
|
||||||
The README claims that
|
The README claims that
|
||||||
[cardano-sl](https://github.com/input-output-hk/cardano-sl) also has
|
[cardano-sl](https://github.com/input-output-hk/cardano-sl) also has
|
||||||
|
|
|
@ -1,3 +1,4 @@
|
||||||
recommonmark==0.5.0
|
recommonmark==0.5.0
|
||||||
Sphinx==1.8.4
|
Sphinx==1.8.4
|
||||||
sphinx_rtd_theme>=0.4.2
|
sphinx_rtd_theme>=0.4.2
|
||||||
|
jinja2<3.1.0
|
||||||
|
|
|
@ -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
|
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall
|
||||||
build-depends:
|
build-depends:
|
||||||
base >= 4.10 && < 4.17
|
base >= 4.10 && < 4.18
|
||||||
, bytestring >= 0.10.6.0 && < 0.12
|
, bytestring >= 0.10.6.0 && < 0.12
|
||||||
, containers >= 0.5.6.2 && < 0.7
|
, containers >= 0.5.6.2 && < 0.7
|
||||||
, servant-auth == 0.4.*
|
, servant-auth == 0.4.*
|
||||||
|
@ -74,7 +74,7 @@ test-suite spec
|
||||||
, transformers >= 0.4.2.0 && < 0.6
|
, transformers >= 0.4.2.0 && < 0.6
|
||||||
, wai >= 3.2.1.2 && < 3.3
|
, wai >= 3.2.1.2 && < 3.3
|
||||||
, warp >= 3.2.25 && < 3.4
|
, warp >= 3.2.25 && < 3.4
|
||||||
, jose >= 0.7.0.0 && < 0.10
|
, jose >= 0.10 && < 0.11
|
||||||
other-modules:
|
other-modules:
|
||||||
Servant.Auth.ClientSpec
|
Servant.Auth.ClientSpec
|
||||||
default-language: Haskell2010
|
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
|
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall
|
||||||
build-depends:
|
build-depends:
|
||||||
base >= 4.10 && < 4.17
|
base >= 4.10 && < 4.18
|
||||||
, servant-docs >= 0.11.2 && < 0.13
|
, servant-docs >= 0.11.2 && < 0.13
|
||||||
, servant >= 0.13 && < 0.20
|
, servant >= 0.13 && < 0.20
|
||||||
, servant-auth == 0.4.*
|
, servant-auth == 0.4.*
|
||||||
, lens >= 4.16.1 && <5.2
|
, lens >= 4.16.1 && <5.3
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
Servant.Auth.Docs
|
Servant.Auth.Docs
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
@ -50,7 +50,7 @@ test-suite doctests
|
||||||
build-depends:
|
build-depends:
|
||||||
base,
|
base,
|
||||||
servant-auth-docs,
|
servant-auth-docs,
|
||||||
doctest >= 0.16 && < 0.19,
|
doctest >= 0.16 && < 0.21,
|
||||||
QuickCheck >= 2.11.3 && < 2.15,
|
QuickCheck >= 2.11.3 && < 2.15,
|
||||||
template-haskell
|
template-haskell
|
||||||
ghc-options: -Wall -threaded
|
ghc-options: -Wall -threaded
|
||||||
|
|
|
@ -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
|
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall
|
||||||
build-depends:
|
build-depends:
|
||||||
base >= 4.10 && < 4.17
|
base >= 4.10 && < 4.18
|
||||||
, aeson >= 1.0.0.1 && < 3
|
, aeson >= 1.0.0.1 && < 3
|
||||||
, base64-bytestring >= 1.0.0.1 && < 2
|
, base64-bytestring >= 1.0.0.1 && < 2
|
||||||
, blaze-builder >= 0.4.1.0 && < 0.5
|
, blaze-builder >= 0.4.1.0 && < 0.5
|
||||||
|
@ -41,17 +41,17 @@ library
|
||||||
, data-default-class >= 0.1.2.0 && < 0.2
|
, data-default-class >= 0.1.2.0 && < 0.2
|
||||||
, entropy >= 0.4.1.3 && < 0.5
|
, entropy >= 0.4.1.3 && < 0.5
|
||||||
, http-types >= 0.12.2 && < 0.13
|
, http-types >= 0.12.2 && < 0.13
|
||||||
, jose >= 0.7.0.0 && < 0.10
|
, jose >= 0.10 && < 0.11
|
||||||
, lens >= 4.16.1 && < 5.2
|
, lens >= 4.16.1 && < 5.3
|
||||||
, memory >= 0.14.16 && < 0.18
|
, memory >= 0.14.16 && < 0.19
|
||||||
, monad-time >= 0.3.1.0 && < 0.4
|
, monad-time >= 0.3.1.0 && < 0.4
|
||||||
, mtl >= 2.2.2 && < 2.3
|
, mtl ^>= 2.2.2 || ^>= 2.3.1
|
||||||
, servant >= 0.13 && < 0.20
|
, servant >= 0.13 && < 0.20
|
||||||
, servant-auth == 0.4.*
|
, servant-auth == 0.4.*
|
||||||
, servant-server >= 0.13 && < 0.20
|
, servant-server >= 0.13 && < 0.20
|
||||||
, tagged >= 0.8.4 && < 0.9
|
, tagged >= 0.8.4 && < 0.9
|
||||||
, text >= 1.2.3.0 && < 2.1
|
, text >= 1.2.3.0 && < 2.1
|
||||||
, time >= 1.5.0.1 && < 1.12
|
, time >= 1.5.0.1 && < 1.13
|
||||||
, unordered-containers >= 0.2.9.0 && < 0.3
|
, unordered-containers >= 0.2.9.0 && < 0.3
|
||||||
, wai >= 3.2.1.2 && < 3.3
|
, wai >= 3.2.1.2 && < 3.3
|
||||||
|
|
||||||
|
|
|
@ -2,6 +2,7 @@
|
||||||
module Servant.Auth.Server.Internal.Cookie where
|
module Servant.Auth.Server.Internal.Cookie where
|
||||||
|
|
||||||
import Blaze.ByteString.Builder (toByteString)
|
import Blaze.ByteString.Builder (toByteString)
|
||||||
|
import Control.Monad (MonadPlus(..), guard)
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import qualified Crypto.JOSE as Jose
|
import qualified Crypto.JOSE as Jose
|
||||||
|
|
|
@ -1,18 +1,14 @@
|
||||||
module Servant.Auth.Server.Internal.JWT where
|
module Servant.Auth.Server.Internal.JWT where
|
||||||
|
|
||||||
import Control.Lens
|
import Control.Lens
|
||||||
import Control.Monad.Except
|
import Control.Monad (MonadPlus(..), guard)
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import qualified Crypto.JOSE as Jose
|
import qualified Crypto.JOSE as Jose
|
||||||
import qualified Crypto.JWT as Jose
|
import qualified Crypto.JWT as Jose
|
||||||
import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON,
|
|
||||||
toJSON)
|
|
||||||
import Data.ByteArray (constEq)
|
import Data.ByteArray (constEq)
|
||||||
import qualified Data.ByteString as BS
|
import qualified Data.ByteString as BS
|
||||||
import qualified Data.ByteString.Lazy as BSL
|
import qualified Data.ByteString.Lazy as BSL
|
||||||
import qualified Data.HashMap.Strict as HM
|
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
import qualified Data.Text as T
|
|
||||||
import Data.Time (UTCTime)
|
import Data.Time (UTCTime)
|
||||||
import Network.Wai (requestHeaders)
|
import Network.Wai (requestHeaders)
|
||||||
|
|
||||||
|
@ -42,7 +38,7 @@ jwtAuthCheck jwtSettings = do
|
||||||
-- token expires.
|
-- token expires.
|
||||||
makeJWT :: ToJWT a
|
makeJWT :: ToJWT a
|
||||||
=> a -> JWTSettings -> Maybe UTCTime -> IO (Either Jose.Error BSL.ByteString)
|
=> a -> JWTSettings -> Maybe UTCTime -> IO (Either Jose.Error BSL.ByteString)
|
||||||
makeJWT v cfg expiry = runExceptT $ do
|
makeJWT v cfg expiry = Jose.runJOSE $ do
|
||||||
bestAlg <- Jose.bestJWSAlg $ signingKey cfg
|
bestAlg <- Jose.bestJWSAlg $ signingKey cfg
|
||||||
let alg = fromMaybe bestAlg $ jwtAlg cfg
|
let alg = fromMaybe bestAlg $ jwtAlg cfg
|
||||||
ejwt <- Jose.signClaims (signingKey cfg)
|
ejwt <- Jose.signClaims (signingKey cfg)
|
||||||
|
@ -59,7 +55,7 @@ makeJWT v cfg expiry = runExceptT $ do
|
||||||
verifyJWT :: FromJWT a => JWTSettings -> BS.ByteString -> IO (Maybe a)
|
verifyJWT :: FromJWT a => JWTSettings -> BS.ByteString -> IO (Maybe a)
|
||||||
verifyJWT jwtCfg input = do
|
verifyJWT jwtCfg input = do
|
||||||
keys <- validationKeys jwtCfg
|
keys <- validationKeys jwtCfg
|
||||||
verifiedJWT <- runExceptT $ do
|
verifiedJWT <- Jose.runJOSE $ do
|
||||||
unverifiedJWT <- Jose.decodeCompact (BSL.fromStrict input)
|
unverifiedJWT <- Jose.decodeCompact (BSL.fromStrict input)
|
||||||
Jose.verifyClaims
|
Jose.verifyClaims
|
||||||
(jwtSettingsToJwtValidationSettings jwtCfg)
|
(jwtSettingsToJwtValidationSettings jwtCfg)
|
||||||
|
|
|
@ -2,6 +2,7 @@
|
||||||
module Servant.Auth.Server.Internal.Types where
|
module Servant.Auth.Server.Internal.Types where
|
||||||
|
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
|
import Control.Monad (MonadPlus(..), ap)
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import Control.Monad.Time
|
import Control.Monad.Time
|
||||||
import Data.Monoid (Monoid (..))
|
import Data.Monoid (Monoid (..))
|
||||||
|
|
|
@ -6,13 +6,12 @@ module Servant.Auth.ServerSpec (spec) where
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
import Control.Lens
|
import Control.Lens
|
||||||
import Control.Monad.Except (runExceptT)
|
|
||||||
import Control.Monad.IO.Class (liftIO)
|
import Control.Monad.IO.Class (liftIO)
|
||||||
import Crypto.JOSE (Alg (HS256, None), Error,
|
import Crypto.JOSE (Alg (HS256, None), Error,
|
||||||
JWK, JWSHeader,
|
JWK, JWSHeader,
|
||||||
KeyMaterialGenParam (OctGenParam),
|
KeyMaterialGenParam (OctGenParam),
|
||||||
ToCompact, encodeCompact,
|
ToCompact, encodeCompact,
|
||||||
genJWK, newJWSHeader)
|
genJWK, newJWSHeader, runJOSE)
|
||||||
import Crypto.JWT (Audience (..), ClaimsSet,
|
import Crypto.JWT (Audience (..), ClaimsSet,
|
||||||
NumericDate (NumericDate),
|
NumericDate (NumericDate),
|
||||||
SignedJWT,
|
SignedJWT,
|
||||||
|
@ -540,7 +539,7 @@ addJwtToHeader jwt = case jwt of
|
||||||
$ defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v]
|
$ defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v]
|
||||||
|
|
||||||
createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT)
|
createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT)
|
||||||
createJWT k a b = runExceptT $ signClaims k a b
|
createJWT k a b = runJOSE $ signClaims k a b
|
||||||
|
|
||||||
addJwtToCookie :: ToCompact a => CookieSettings -> Either Error a -> IO Options
|
addJwtToCookie :: ToCompact a => CookieSettings -> Either Error a -> IO Options
|
||||||
addJwtToCookie ccfg jwt = case jwt >>= (return . encodeCompact) of
|
addJwtToCookie ccfg jwt = case jwt >>= (return . encodeCompact) of
|
||||||
|
|
|
@ -31,13 +31,13 @@ library
|
||||||
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
|
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall
|
||||||
build-depends:
|
build-depends:
|
||||||
base >= 4.10 && < 4.17
|
base >= 4.10 && < 4.18
|
||||||
, text >= 1.2.3.0 && < 2.1
|
, text >= 1.2.3.0 && < 2.1
|
||||||
, servant-swagger >= 1.1.5 && < 2
|
, servant-swagger >= 1.1.5 && < 2
|
||||||
, swagger2 >= 2.2.2 && < 3
|
, swagger2 >= 2.2.2 && < 3
|
||||||
, servant >= 0.13 && < 0.20
|
, servant >= 0.13 && < 0.20
|
||||||
, servant-auth == 0.4.*
|
, servant-auth == 0.4.*
|
||||||
, lens >= 4.16.1 && < 5.2
|
, lens >= 4.16.1 && < 5.3
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
Servant.Auth.Swagger
|
Servant.Auth.Swagger
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
|
@ -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
|
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall
|
||||||
build-depends:
|
build-depends:
|
||||||
base >= 4.10 && < 4.17
|
base >= 4.10 && < 4.18
|
||||||
, containers >= 0.6 && < 0.7
|
, containers >= 0.6 && < 0.7
|
||||||
, aeson >= 1.3.1.1 && < 3
|
, aeson >= 1.3.1.1 && < 3
|
||||||
, jose >= 0.7.0.0 && < 0.10
|
, jose >= 0.10 && < 0.11
|
||||||
, lens >= 4.16.1 && < 5.2
|
, lens >= 4.16.1 && < 5.3
|
||||||
, servant >= 0.15 && < 0.20
|
, servant >= 0.15 && < 0.20
|
||||||
, text >= 1.2.3.0 && < 2.1
|
, text >= 1.2.3.0 && < 2.1
|
||||||
, unordered-containers >= 0.2.9.0 && < 0.3
|
, unordered-containers >= 0.2.9.0 && < 0.3
|
||||||
|
|
|
@ -27,7 +27,7 @@ instance HasLink sub => HasLink (Auth (tag :: [*]) value :> sub) where
|
||||||
|
|
||||||
-- ** Combinators
|
-- ** Combinators
|
||||||
|
|
||||||
-- | A JSON Web Token (JWT) in the the Authorization header:
|
-- | A JSON Web Token (JWT) in the Authorization header:
|
||||||
--
|
--
|
||||||
-- @Authorization: Bearer \<token\>@
|
-- @Authorization: Bearer \<token\>@
|
||||||
--
|
--
|
||||||
|
|
|
@ -50,14 +50,14 @@ library
|
||||||
--
|
--
|
||||||
-- note: mtl lower bound is so low because of GHC-7.8
|
-- note: mtl lower bound is so low because of GHC-7.8
|
||||||
build-depends:
|
build-depends:
|
||||||
base >= 4.9 && < 4.17
|
base >= 4.9 && < 4.18
|
||||||
, bytestring >= 0.10.8.1 && < 0.12
|
, bytestring >= 0.10.8.1 && < 0.12
|
||||||
, constraints >= 0.2 && < 0.14
|
, constraints >= 0.2 && < 0.14
|
||||||
, containers >= 0.5.7.1 && < 0.7
|
, containers >= 0.5.7.1 && < 0.7
|
||||||
, deepseq >= 1.4.2.0 && < 1.5
|
, deepseq >= 1.4.2.0 && < 1.5
|
||||||
, text >= 1.2.3.0 && < 2.1
|
, text >= 1.2.3.0 && < 2.1
|
||||||
, transformers >= 0.5.2.0 && < 0.6
|
, transformers >= 0.5.2.0 && < 0.7
|
||||||
, template-haskell >= 2.11.1.0 && < 2.19
|
, template-haskell >= 2.11.1.0 && < 2.20
|
||||||
|
|
||||||
if !impl(ghc >= 8.2)
|
if !impl(ghc >= 8.2)
|
||||||
build-depends:
|
build-depends:
|
||||||
|
|
|
@ -77,7 +77,7 @@ import Servant.API
|
||||||
NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,
|
NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,
|
||||||
ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
|
ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
|
||||||
StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
|
StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
|
||||||
Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,
|
Verb, WithNamedContext, WithResource, WithStatus (..), contentType, getHeadersHList,
|
||||||
getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)
|
getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)
|
||||||
import Servant.API.Generic
|
import Servant.API.Generic
|
||||||
(GenericMode(..), ToServant, ToServantApi
|
(GenericMode(..), ToServant, ToServantApi
|
||||||
|
@ -776,6 +776,14 @@ instance HasClient m subapi =>
|
||||||
|
|
||||||
hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl
|
hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl
|
||||||
|
|
||||||
|
instance HasClient m subapi =>
|
||||||
|
HasClient m (WithResource res :> subapi) where
|
||||||
|
|
||||||
|
type Client m (WithResource res :> subapi) = Client m subapi
|
||||||
|
clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi)
|
||||||
|
|
||||||
|
hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl
|
||||||
|
|
||||||
instance ( HasClient m api
|
instance ( HasClient m api
|
||||||
) => HasClient m (AuthProtect tag :> api) where
|
) => HasClient m (AuthProtect tag :> api) where
|
||||||
type Client m (AuthProtect tag :> api)
|
type Client m (AuthProtect tag :> api)
|
||||||
|
@ -894,7 +902,7 @@ infixl 2 /:
|
||||||
-- rootClient = client api
|
-- rootClient = client api
|
||||||
--
|
--
|
||||||
-- endpointClient :: ClientM Person
|
-- endpointClient :: ClientM Person
|
||||||
-- endpointClient = client // subApi // endpoint
|
-- endpointClient = client \/\/ subApi \/\/ endpoint
|
||||||
-- @
|
-- @
|
||||||
(//) :: a -> (a -> b) -> b
|
(//) :: a -> (a -> b) -> b
|
||||||
x // f = f x
|
x // f = f x
|
||||||
|
@ -927,10 +935,10 @@ x // f = f x
|
||||||
-- rootClient = client api
|
-- rootClient = client api
|
||||||
--
|
--
|
||||||
-- hello :: String -> ClientM String
|
-- hello :: String -> ClientM String
|
||||||
-- hello name = rootClient // hello /: name
|
-- hello name = rootClient \/\/ hello \/: name
|
||||||
--
|
--
|
||||||
-- endpointClient :: ClientM Person
|
-- endpointClient :: ClientM Person
|
||||||
-- endpointClient = client // subApi /: "foobar123" // endpoint
|
-- endpointClient = client \/\/ subApi \/: "foobar123" \/\/ endpoint
|
||||||
-- @
|
-- @
|
||||||
(/:) :: (a -> b -> c) -> b -> a -> c
|
(/:) :: (a -> b -> c) -> b -> a -> c
|
||||||
(/:) = flip
|
(/:) = flip
|
||||||
|
|
|
@ -48,7 +48,7 @@ library
|
||||||
, http-media >=0.6.2 && <0.9
|
, http-media >=0.6.2 && <0.9
|
||||||
, http-types >=0.12 && <0.13
|
, http-types >=0.12 && <0.13
|
||||||
, monad-control >=1.0.0.4 && <1.1
|
, monad-control >=1.0.0.4 && <1.1
|
||||||
, mtl >=2.2.2 && <2.3
|
, mtl ^>=2.2.2 || ^>=2.3.1
|
||||||
, semigroupoids >=5.3 && <5.4
|
, semigroupoids >=5.3 && <5.4
|
||||||
, string-conversions >=0.3 && <0.5
|
, string-conversions >=0.3 && <0.5
|
||||||
, transformers >=0.3 && <0.6
|
, transformers >=0.3 && <0.6
|
||||||
|
|
|
@ -41,15 +41,15 @@ library
|
||||||
-- Bundled with GHC: Lower bound to not force re-installs
|
-- Bundled with GHC: Lower bound to not force re-installs
|
||||||
-- text and mtl are bundled starting with GHC-8.4
|
-- text and mtl are bundled starting with GHC-8.4
|
||||||
build-depends:
|
build-depends:
|
||||||
base >= 4.9 && < 4.17
|
base >= 4.9 && < 4.18
|
||||||
, bytestring >= 0.10.8.1 && < 0.12
|
, bytestring >= 0.10.8.1 && < 0.12
|
||||||
, containers >= 0.5.7.1 && < 0.7
|
, containers >= 0.5.7.1 && < 0.7
|
||||||
, deepseq >= 1.4.2.0 && < 1.5
|
, deepseq >= 1.4.2.0 && < 1.5
|
||||||
, mtl >= 2.2.2 && < 2.3
|
, mtl ^>= 2.2.2 || ^>= 2.3.1
|
||||||
, stm >= 2.4.5.1 && < 2.6
|
, stm >= 2.4.5.1 && < 2.6
|
||||||
, text >= 1.2.3.0 && < 2.1
|
, text >= 1.2.3.0 && < 2.1
|
||||||
, time >= 1.6.0.1 && < 1.12
|
, time >= 1.6.0.1 && < 1.13
|
||||||
, transformers >= 0.5.2.0 && < 0.6
|
, transformers >= 0.5.2.0 && < 0.7
|
||||||
|
|
||||||
if !impl(ghc >= 8.2)
|
if !impl(ghc >= 8.2)
|
||||||
build-depends:
|
build-depends:
|
||||||
|
|
|
@ -24,7 +24,8 @@ import Control.DeepSeq
|
||||||
(NFData, force)
|
(NFData, force)
|
||||||
import Control.Exception
|
import Control.Exception
|
||||||
(evaluate, throwIO)
|
(evaluate, throwIO)
|
||||||
import Control.Monad ()
|
import Control.Monad
|
||||||
|
(unless)
|
||||||
import Control.Monad.Base
|
import Control.Monad.Base
|
||||||
(MonadBase (..))
|
(MonadBase (..))
|
||||||
import Control.Monad.Codensity
|
import Control.Monad.Codensity
|
||||||
|
@ -174,10 +175,21 @@ performRequest acceptStatus req = do
|
||||||
-- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above).
|
-- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above).
|
||||||
performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a
|
performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a
|
||||||
performWithStreamingRequest req k = do
|
performWithStreamingRequest req k = do
|
||||||
m <- asks manager
|
ClientEnv m burl cookieJar' createClientRequest <- ask
|
||||||
burl <- asks baseUrl
|
clientRequest <- liftIO $ createClientRequest burl req
|
||||||
createClientRequest <- asks makeClientRequest
|
request <- case cookieJar' of
|
||||||
request <- liftIO $ createClientRequest burl req
|
Nothing -> pure clientRequest
|
||||||
|
Just cj -> liftIO $ do
|
||||||
|
now <- getCurrentTime
|
||||||
|
atomically $ do
|
||||||
|
oldCookieJar <- readTVar cj
|
||||||
|
let (newRequest, newCookieJar) =
|
||||||
|
Client.insertCookiesIntoRequest
|
||||||
|
clientRequest
|
||||||
|
oldCookieJar
|
||||||
|
now
|
||||||
|
writeTVar cj newCookieJar
|
||||||
|
pure newRequest
|
||||||
ClientM $ lift $ lift $ Codensity $ \k1 ->
|
ClientM $ lift $ lift $ Codensity $ \k1 ->
|
||||||
Client.withResponse request m $ \res -> do
|
Client.withResponse request m $ \res -> do
|
||||||
let status = Client.responseStatus res
|
let status = Client.responseStatus res
|
||||||
|
|
|
@ -31,8 +31,8 @@ library
|
||||||
base >=4.9 && <5
|
base >=4.9 && <5
|
||||||
, bytestring >=0.10.8.1 && <0.12
|
, bytestring >=0.10.8.1 && <0.12
|
||||||
, conduit >=1.3.1 && <1.4
|
, conduit >=1.3.1 && <1.4
|
||||||
, mtl >=2.2.2 && <2.3
|
, mtl ^>=2.2.2 || ^>=2.3.1
|
||||||
, resourcet >=1.2.2 && <1.3
|
, resourcet >=1.2.2 && <1.4
|
||||||
, servant >=0.15 && <0.20
|
, servant >=0.15 && <0.20
|
||||||
, unliftio-core >=0.1.2.0 && <0.3
|
, unliftio-core >=0.1.2.0 && <0.3
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
|
|
|
@ -530,6 +530,24 @@
|
||||||
|
|
||||||
```
|
```
|
||||||
|
|
||||||
|
## GET /resource
|
||||||
|
|
||||||
|
### Response:
|
||||||
|
|
||||||
|
- Status code 200
|
||||||
|
- Headers: []
|
||||||
|
|
||||||
|
- Supported content types are:
|
||||||
|
|
||||||
|
- `application/json;charset=utf-8`
|
||||||
|
- `application/json`
|
||||||
|
|
||||||
|
- Example (`application/json;charset=utf-8`, `application/json`):
|
||||||
|
|
||||||
|
```javascript
|
||||||
|
|
||||||
|
```
|
||||||
|
|
||||||
## GET /streaming
|
## GET /streaming
|
||||||
|
|
||||||
### Request:
|
### Request:
|
||||||
|
|
|
@ -41,7 +41,7 @@ library
|
||||||
--
|
--
|
||||||
-- note: mtl lower bound is so low because of GHC-7.8
|
-- note: mtl lower bound is so low because of GHC-7.8
|
||||||
build-depends:
|
build-depends:
|
||||||
base >= 4.9 && < 4.17
|
base >= 4.9 && < 4.18
|
||||||
, bytestring >= 0.10.8.1 && < 0.12
|
, bytestring >= 0.10.8.1 && < 0.12
|
||||||
, text >= 1.2.3.0 && < 2.1
|
, text >= 1.2.3.0 && < 2.1
|
||||||
|
|
||||||
|
@ -59,7 +59,7 @@ library
|
||||||
, hashable >= 1.2.7.0 && < 1.5
|
, hashable >= 1.2.7.0 && < 1.5
|
||||||
, http-media >= 0.7.1.3 && < 0.9
|
, http-media >= 0.7.1.3 && < 0.9
|
||||||
, http-types >= 0.12.2 && < 0.13
|
, http-types >= 0.12.2 && < 0.13
|
||||||
, lens >= 4.17 && < 5.2
|
, lens >= 4.17 && < 5.3
|
||||||
, string-conversions >= 0.4.0.1 && < 0.5
|
, string-conversions >= 0.4.0.1 && < 0.5
|
||||||
, universe-base >= 1.1.1 && < 1.2
|
, universe-base >= 1.1.1 && < 1.2
|
||||||
, unordered-containers >= 0.2.9.0 && < 0.3
|
, unordered-containers >= 0.2.9.0 && < 0.3
|
||||||
|
|
|
@ -447,7 +447,7 @@ docsWith opts intros (ExtraInfo endpoints) p =
|
||||||
& apiEndpoints %~ HM.unionWith (flip combineAction) endpoints
|
& apiEndpoints %~ HM.unionWith (flip combineAction) endpoints
|
||||||
|
|
||||||
|
|
||||||
-- | Generate the docs for a given API that implements 'HasDocs' with with any
|
-- | Generate the docs for a given API that implements 'HasDocs' with any
|
||||||
-- number of introduction(s)
|
-- number of introduction(s)
|
||||||
docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API
|
docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API
|
||||||
docsWithIntros intros = docsWith defaultDocOptions intros mempty
|
docsWithIntros intros = docsWith defaultDocOptions intros mempty
|
||||||
|
@ -1144,6 +1144,9 @@ instance HasDocs api => HasDocs (Vault :> api) where
|
||||||
instance HasDocs api => HasDocs (WithNamedContext name context api) where
|
instance HasDocs api => HasDocs (WithNamedContext name context api) where
|
||||||
docsFor Proxy = docsFor (Proxy :: Proxy api)
|
docsFor Proxy = docsFor (Proxy :: Proxy api)
|
||||||
|
|
||||||
|
instance HasDocs api => HasDocs (WithResource res :> api) where
|
||||||
|
docsFor Proxy = docsFor (Proxy :: Proxy api)
|
||||||
|
|
||||||
instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth realm usr :> api) where
|
instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth realm usr :> api) where
|
||||||
docsFor Proxy (endpoint, action) =
|
docsFor Proxy (endpoint, action) =
|
||||||
docsFor (Proxy :: Proxy api) (endpoint, action')
|
docsFor (Proxy :: Proxy api) (endpoint, action')
|
||||||
|
|
|
@ -41,7 +41,7 @@ library
|
||||||
--
|
--
|
||||||
-- note: mtl lower bound is so low because of GHC-7.8
|
-- note: mtl lower bound is so low because of GHC-7.8
|
||||||
build-depends:
|
build-depends:
|
||||||
base >= 4.9 && < 4.17
|
base >= 4.9 && < 4.18
|
||||||
, text >= 1.2.3.0 && < 2.1
|
, text >= 1.2.3.0 && < 2.1
|
||||||
|
|
||||||
-- Servant dependencies
|
-- Servant dependencies
|
||||||
|
@ -52,7 +52,7 @@ library
|
||||||
-- Here can be exceptions if we really need features from the newer versions.
|
-- Here can be exceptions if we really need features from the newer versions.
|
||||||
build-depends:
|
build-depends:
|
||||||
base-compat >= 0.10.5 && < 0.13
|
base-compat >= 0.10.5 && < 0.13
|
||||||
, lens >= 4.17 && < 5.2
|
, lens >= 4.17 && < 5.3
|
||||||
, http-types >= 0.12.2 && < 0.13
|
, http-types >= 0.12.2 && < 0.13
|
||||||
|
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
|
|
|
@ -487,6 +487,13 @@ instance HasForeign lang ftype api =>
|
||||||
|
|
||||||
foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)
|
foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)
|
||||||
|
|
||||||
|
instance HasForeign lang ftype api =>
|
||||||
|
HasForeign lang ftype (WithResource res :> api) where
|
||||||
|
|
||||||
|
type Foreign ftype (WithResource res :> api) = Foreign ftype api
|
||||||
|
|
||||||
|
foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)
|
||||||
|
|
||||||
instance HasForeign lang ftype api
|
instance HasForeign lang ftype api
|
||||||
=> HasForeign lang ftype (HttpVersion :> api) where
|
=> HasForeign lang ftype (HttpVersion :> api) where
|
||||||
type Foreign ftype (HttpVersion :> api) = Foreign ftype api
|
type Foreign ftype (HttpVersion :> api) = Foreign ftype api
|
||||||
|
|
|
@ -38,14 +38,14 @@ library
|
||||||
-- Bundled with GHC: Lower bound to not force re-installs
|
-- Bundled with GHC: Lower bound to not force re-installs
|
||||||
-- text and mtl are bundled starting with GHC-8.4
|
-- text and mtl are bundled starting with GHC-8.4
|
||||||
build-depends:
|
build-depends:
|
||||||
base >= 4.9 && < 4.17
|
base >= 4.9 && < 4.18
|
||||||
, bytestring >= 0.10.8.1 && < 0.12
|
, bytestring >= 0.10.8.1 && < 0.12
|
||||||
, containers >= 0.5.7.1 && < 0.7
|
, containers >= 0.5.7.1 && < 0.7
|
||||||
, deepseq >= 1.4.2.0 && < 1.5
|
, deepseq >= 1.4.2.0 && < 1.5
|
||||||
, mtl >= 2.2.2 && < 2.3
|
, mtl ^>= 2.2.2 || ^>= 2.3.1
|
||||||
, text >= 1.2.3.0 && < 2.1
|
, text >= 1.2.3.0 && < 2.1
|
||||||
, time >= 1.6.0.1 && < 1.12
|
, time >= 1.6.0.1 && < 1.13
|
||||||
, transformers >= 0.5.2.0 && < 0.6
|
, transformers >= 0.5.2.0 && < 0.7
|
||||||
|
|
||||||
if !impl(ghc >= 8.2)
|
if !impl(ghc >= 8.2)
|
||||||
build-depends:
|
build-depends:
|
||||||
|
|
|
@ -31,7 +31,7 @@ library
|
||||||
base >=4.9 && <5
|
base >=4.9 && <5
|
||||||
, bytestring >=0.10.8.1 && <0.12
|
, bytestring >=0.10.8.1 && <0.12
|
||||||
, machines >=0.6.4 && <0.8
|
, machines >=0.6.4 && <0.8
|
||||||
, mtl >=2.2.2 && <2.3
|
, mtl ^>=2.2.2 || ^>=2.3.1
|
||||||
, servant >=0.15 && <0.20
|
, servant >=0.15 && <0.20
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
|
@ -32,7 +32,7 @@ library
|
||||||
, bytestring >=0.10.8.1 && <0.12
|
, bytestring >=0.10.8.1 && <0.12
|
||||||
, pipes >=4.3.9 && <4.4
|
, pipes >=4.3.9 && <4.4
|
||||||
, pipes-safe >=2.3.1 && <2.4
|
, pipes-safe >=2.3.1 && <2.4
|
||||||
, mtl >=2.2.2 && <2.3
|
, mtl ^>=2.2.2 || ^>=2.3.1
|
||||||
, monad-control >=1.0.2.3 && <1.1
|
, monad-control >=1.0.2.3 && <1.1
|
||||||
, servant >=0.15 && <0.20
|
, servant >=0.15 && <0.20
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
|
|
|
@ -3,11 +3,17 @@
|
||||||
|
|
||||||
Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions.
|
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
|
0.19.1
|
||||||
------
|
------
|
||||||
|
|
||||||
- Add `MonadFail` instance for `Handler` wrt [#1545](https://github.com/haskell-servant/servant/issues/1545)
|
- 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)
|
- 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
|
0.19
|
||||||
----
|
----
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
cabal-version: 2.2
|
cabal-version: 2.2
|
||||||
name: servant-server
|
name: servant-server
|
||||||
version: 0.19.1
|
version: 0.19.2
|
||||||
|
|
||||||
synopsis: A family of combinators for defining webservices APIs and serving them
|
synopsis: A family of combinators for defining webservices APIs and serving them
|
||||||
category: Servant, Web
|
category: Servant, Web
|
||||||
|
@ -23,7 +23,7 @@ author: Servant Contributors
|
||||||
maintainer: haskell-servant-maintainers@googlegroups.com
|
maintainer: haskell-servant-maintainers@googlegroups.com
|
||||||
copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
|
copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
|
||||||
build-type: Simple
|
build-type: Simple
|
||||||
tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
|
tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.3
|
||||||
|
|
||||||
extra-source-files:
|
extra-source-files:
|
||||||
CHANGELOG.md
|
CHANGELOG.md
|
||||||
|
@ -60,20 +60,20 @@ library
|
||||||
-- Bundled with GHC: Lower bound to not force re-installs
|
-- Bundled with GHC: Lower bound to not force re-installs
|
||||||
-- text and mtl are bundled starting with GHC-8.4
|
-- text and mtl are bundled starting with GHC-8.4
|
||||||
build-depends:
|
build-depends:
|
||||||
base >= 4.9 && < 4.17
|
base >= 4.9 && < 4.18
|
||||||
, bytestring >= 0.10.8.1 && < 0.12
|
, bytestring >= 0.10.8.1 && < 0.12
|
||||||
, constraints >= 0.2 && < 0.14
|
, constraints >= 0.2 && < 0.14
|
||||||
, containers >= 0.5.7.1 && < 0.7
|
, containers >= 0.5.7.1 && < 0.7
|
||||||
, mtl >= 2.2.2 && < 2.3
|
, mtl ^>= 2.2.2 || ^>= 2.3.1
|
||||||
, text >= 1.2.3.0 && < 2.1
|
, text >= 1.2.3.0 && < 2.1
|
||||||
, transformers >= 0.5.2.0 && < 0.6
|
, transformers >= 0.5.2.0 && < 0.7
|
||||||
, filepath >= 1.4.1.1 && < 1.5
|
, filepath >= 1.4.1.1 && < 1.5
|
||||||
|
|
||||||
-- Servant dependencies
|
-- Servant dependencies
|
||||||
-- strict dependency as we re-export 'servant' things.
|
-- strict dependency as we re-export 'servant' things.
|
||||||
build-depends:
|
build-depends:
|
||||||
servant >= 0.19 && < 0.20
|
servant >= 0.19 && < 0.20
|
||||||
, http-api-data >= 0.4.1 && < 0.4.4
|
, http-api-data >= 0.4.1 && < 0.5.1
|
||||||
|
|
||||||
-- Other dependencies: Lower bound around what is in the latest Stackage LTS.
|
-- Other dependencies: Lower bound around what is in the latest Stackage LTS.
|
||||||
-- Here can be exceptions if we really need features from the newer versions.
|
-- Here can be exceptions if we really need features from the newer versions.
|
||||||
|
@ -88,10 +88,10 @@ library
|
||||||
, network >= 2.8 && < 3.2
|
, network >= 2.8 && < 3.2
|
||||||
, sop-core >= 0.4.0.0 && < 0.6
|
, sop-core >= 0.4.0.0 && < 0.6
|
||||||
, string-conversions >= 0.4.0.1 && < 0.5
|
, string-conversions >= 0.4.0.1 && < 0.5
|
||||||
, resourcet >= 1.2.2 && < 1.3
|
, resourcet >= 1.2.2 && < 1.4
|
||||||
, tagged >= 0.8.6 && < 0.9
|
, tagged >= 0.8.6 && < 0.9
|
||||||
, transformers-base >= 0.4.5.2 && < 0.5
|
, transformers-base >= 0.4.5.2 && < 0.5
|
||||||
, wai >= 3.2.1.2 && < 3.3
|
, wai >= 3.2.2.1 && < 3.3
|
||||||
, wai-app-static >= 3.1.6.2 && < 3.2
|
, wai-app-static >= 3.1.6.2 && < 3.2
|
||||||
, word8 >= 0.1.3 && < 0.2
|
, word8 >= 0.1.3 && < 0.2
|
||||||
|
|
||||||
|
|
|
@ -1,5 +1,6 @@
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
{-# LANGUAGE DeriveDataTypeable #-}
|
||||||
|
{-# LANGUAGE DeriveFunctor #-}
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
@ -44,7 +45,7 @@ type family AuthServerData a :: *
|
||||||
-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
|
-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
|
||||||
newtype AuthHandler r usr = AuthHandler
|
newtype AuthHandler r usr = AuthHandler
|
||||||
{ unAuthHandler :: r -> Handler usr }
|
{ unAuthHandler :: r -> Handler usr }
|
||||||
deriving (Generic, Typeable)
|
deriving (Functor, Generic, Typeable)
|
||||||
|
|
||||||
-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
|
-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
|
||||||
mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr
|
mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr
|
||||||
|
|
|
@ -1,5 +1,6 @@
|
||||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||||
{-# LANGUAGE ConstraintKinds #-}
|
{-# LANGUAGE ConstraintKinds #-}
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
{-# LANGUAGE DeriveDataTypeable #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
@ -34,9 +35,10 @@ module Servant.Server.Internal
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
(join, when)
|
(join, when)
|
||||||
import Control.Monad.Trans
|
import Control.Monad.Trans
|
||||||
(liftIO)
|
(liftIO, lift)
|
||||||
import Control.Monad.Trans.Resource
|
import Control.Monad.Trans.Resource
|
||||||
(runResourceT)
|
(runResourceT, ReleaseKey)
|
||||||
|
import Data.Acquire
|
||||||
import qualified Data.ByteString as B
|
import qualified Data.ByteString as B
|
||||||
import qualified Data.ByteString.Builder as BB
|
import qualified Data.ByteString.Builder as BB
|
||||||
import qualified Data.ByteString.Char8 as BC8
|
import qualified Data.ByteString.Char8 as BC8
|
||||||
|
@ -76,7 +78,7 @@ import Servant.API
|
||||||
QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),
|
QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),
|
||||||
RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
|
RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
|
||||||
Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
|
Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
|
||||||
WithNamedContext, NamedRoutes)
|
WithNamedContext, WithResource, NamedRoutes)
|
||||||
import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
|
import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
|
||||||
import Servant.API.ContentTypes
|
import Servant.API.ContentTypes
|
||||||
(AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
|
(AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
|
||||||
|
@ -94,6 +96,8 @@ import Servant.API.TypeErrors
|
||||||
import Web.HttpApiData
|
import Web.HttpApiData
|
||||||
(FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
|
(FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
|
||||||
parseUrlPieces)
|
parseUrlPieces)
|
||||||
|
import Data.Kind
|
||||||
|
(Type)
|
||||||
|
|
||||||
import Servant.Server.Internal.BasicAuth
|
import Servant.Server.Internal.BasicAuth
|
||||||
import Servant.Server.Internal.Context
|
import Servant.Server.Internal.Context
|
||||||
|
@ -112,6 +116,10 @@ import Servant.API.TypeLevel
|
||||||
(AtLeastOneFragment, FragmentUnique)
|
(AtLeastOneFragment, FragmentUnique)
|
||||||
|
|
||||||
class HasServer api context where
|
class HasServer api context where
|
||||||
|
-- | The type of a server for this API, given a monad to run effects in.
|
||||||
|
--
|
||||||
|
-- Note that the result kind is @*@, so it is /not/ a monad transformer, unlike
|
||||||
|
-- what the @T@ in the name might suggest.
|
||||||
type ServerT api (m :: * -> *) :: *
|
type ServerT api (m :: * -> *) :: *
|
||||||
|
|
||||||
route ::
|
route ::
|
||||||
|
@ -241,6 +249,42 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a
|
||||||
formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
|
formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
|
||||||
hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy [a]))
|
hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy [a]))
|
||||||
|
|
||||||
|
-- | If you use 'WithResource' in one of the endpoints for your API Servant
|
||||||
|
-- will provide the handler for this endpoint an argument of the specified type.
|
||||||
|
-- The lifespan of this resource will be automatically managed by Servant. This
|
||||||
|
-- resource will be created before the handler starts and it will be destoyed
|
||||||
|
-- after it ends. A new resource is created for each request to the endpoint.
|
||||||
|
|
||||||
|
-- The creation and destruction are done using a 'Data.Acquire.Acquire'
|
||||||
|
-- provided via server 'Context'.
|
||||||
|
--
|
||||||
|
-- Example
|
||||||
|
--
|
||||||
|
-- > type MyApi = WithResource Handle :> "writeToFile" :> Post '[JSON] NoContent
|
||||||
|
-- >
|
||||||
|
-- > server :: Server MyApi
|
||||||
|
-- > server = writeToFile
|
||||||
|
-- > where writeToFile :: (ReleaseKey, Handle) -> Handler NoContent
|
||||||
|
-- > writeToFile (_, h) = hPutStrLn h "message"
|
||||||
|
--
|
||||||
|
-- In addition to the resource, the handler will also receive a 'ReleaseKey'
|
||||||
|
-- which can be used to deallocate the resource before the end of the request
|
||||||
|
-- if desired.
|
||||||
|
|
||||||
|
instance (HasServer api ctx, HasContextEntry ctx (Acquire a))
|
||||||
|
=> HasServer (WithResource a :> api) ctx where
|
||||||
|
|
||||||
|
type ServerT (WithResource a :> api) m = (ReleaseKey, a) -> ServerT api m
|
||||||
|
|
||||||
|
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @api) pc nt . s
|
||||||
|
|
||||||
|
route Proxy context d = route (Proxy @api) context (d `addParameterCheck` allocateResource)
|
||||||
|
where
|
||||||
|
allocateResource :: DelayedIO (ReleaseKey, a)
|
||||||
|
allocateResource = DelayedIO $ lift $ allocateAcquire (getContextEntry context)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
allowedMethodHead :: Method -> Request -> Bool
|
allowedMethodHead :: Method -> Request -> Bool
|
||||||
allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
|
allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
|
||||||
|
|
||||||
|
@ -821,7 +865,11 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
|
||||||
-------------------------------------------------------------------------------
|
-------------------------------------------------------------------------------
|
||||||
|
|
||||||
-- Erroring instance for 'HasServer' when a combinator is not fully applied
|
-- Erroring instance for 'HasServer' when a combinator is not fully applied
|
||||||
instance TypeError (PartialApplication HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
|
instance TypeError (PartialApplication
|
||||||
|
#if __GLASGOW_HASKELL__ >= 904
|
||||||
|
@(Type -> [Type] -> Constraint)
|
||||||
|
#endif
|
||||||
|
HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
|
||||||
where
|
where
|
||||||
type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)
|
type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)
|
||||||
route = error "unreachable"
|
route = error "unreachable"
|
||||||
|
@ -865,7 +913,11 @@ type HasServerArrowTypeError a b =
|
||||||
-- XXX: This omits the @context@ parameter, e.g.:
|
-- XXX: This omits the @context@ parameter, e.g.:
|
||||||
--
|
--
|
||||||
-- "There is no instance for HasServer (Bool :> …)". Do we care ?
|
-- "There is no instance for HasServer (Bool :> …)". Do we care ?
|
||||||
instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub HasServer ty) => HasServer (ty :> sub) context
|
instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub
|
||||||
|
#if __GLASGOW_HASKELL__ >= 904
|
||||||
|
@(Type -> [Type] -> Constraint)
|
||||||
|
#endif
|
||||||
|
HasServer ty) => HasServer (ty :> sub) context
|
||||||
|
|
||||||
instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context
|
instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context
|
||||||
|
|
||||||
|
|
|
@ -28,9 +28,12 @@ import Servant.Server.Internal.ServerError
|
||||||
|
|
||||||
type Router env = Router' env RoutingApplication
|
type Router env = Router' env RoutingApplication
|
||||||
|
|
||||||
|
-- | Holds information about pieces of url that are captured as variables.
|
||||||
data CaptureHint = CaptureHint
|
data CaptureHint = CaptureHint
|
||||||
{ captureName :: Text
|
{ captureName :: Text
|
||||||
|
-- ^ Holds the name of the captured variable
|
||||||
, captureType :: TypeRep
|
, captureType :: TypeRep
|
||||||
|
-- ^ Holds the type of the captured variable
|
||||||
}
|
}
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
|
@ -54,10 +57,21 @@ data Router' env a =
|
||||||
-- for the empty path, to be tried in order
|
-- for the empty path, to be tried in order
|
||||||
| CaptureRouter [CaptureHint] (Router' (Text, env) a)
|
| CaptureRouter [CaptureHint] (Router' (Text, env) a)
|
||||||
-- ^ first path component is passed to the child router in its
|
-- ^ first path component is passed to the child router in its
|
||||||
-- environment and removed afterwards
|
-- environment and removed afterwards.
|
||||||
|
-- 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)
|
| CaptureAllRouter [CaptureHint] (Router' ([Text], env) a)
|
||||||
-- ^ all path components are passed to the child router in its
|
-- ^ all path components are passed to the child router in its
|
||||||
-- environment and are removed afterwards
|
-- environment and are removed afterwards
|
||||||
|
-- The first argument is a hint for the list of variables that can be
|
||||||
|
-- captured by the router. Note that the 'captureType' field of the hint
|
||||||
|
-- should always be '[a]' for some 'a'.
|
||||||
| RawRouter (env -> a)
|
| RawRouter (env -> a)
|
||||||
-- ^ to be used for routes we do not know anything about
|
-- ^ to be used for routes we do not know anything about
|
||||||
| Choice (Router' env a) (Router' env a)
|
| Choice (Router' env a) (Router' env a)
|
||||||
|
@ -101,6 +115,10 @@ choice router1 router2 = Choice router1 router2
|
||||||
data RouterStructure =
|
data RouterStructure =
|
||||||
StaticRouterStructure (Map Text RouterStructure) Int
|
StaticRouterStructure (Map Text RouterStructure) Int
|
||||||
| CaptureRouterStructure [CaptureHint] RouterStructure
|
| CaptureRouterStructure [CaptureHint] RouterStructure
|
||||||
|
-- ^ The first argument holds information about variables
|
||||||
|
-- that are captured by the router. There may be several hints
|
||||||
|
-- if several routers have been aggregated by the 'choice'
|
||||||
|
-- smart constructor.
|
||||||
| RawRouterStructure
|
| RawRouterStructure
|
||||||
| ChoiceStructure RouterStructure RouterStructure
|
| ChoiceStructure RouterStructure RouterStructure
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
|
@ -21,6 +21,8 @@ import Control.Monad.Error.Class
|
||||||
(MonadError (..))
|
(MonadError (..))
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
(FromJSON, ToJSON, decode', encode)
|
(FromJSON, ToJSON, decode', encode)
|
||||||
|
import Data.Acquire
|
||||||
|
(Acquire, mkAcquire)
|
||||||
import qualified Data.ByteString as BS
|
import qualified Data.ByteString as BS
|
||||||
import qualified Data.ByteString.Base64 as Base64
|
import qualified Data.ByteString.Base64 as Base64
|
||||||
import Data.Char
|
import Data.Char
|
||||||
|
@ -81,8 +83,11 @@ import Servant.Server.Internal.Context
|
||||||
-- This declaration simply checks that all instances are in place.
|
-- This declaration simply checks that all instances are in place.
|
||||||
_ = serveWithContext comprehensiveAPI comprehensiveApiContext
|
_ = serveWithContext comprehensiveAPI comprehensiveApiContext
|
||||||
|
|
||||||
comprehensiveApiContext :: Context '[NamedContext "foo" '[]]
|
comprehensiveApiContext :: Context '[NamedContext "foo" '[], Acquire Int]
|
||||||
comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext
|
comprehensiveApiContext =
|
||||||
|
NamedContext EmptyContext :.
|
||||||
|
mkAcquire (pure 10) (\_ -> pure ()) :.
|
||||||
|
EmptyContext
|
||||||
|
|
||||||
-- * Specs
|
-- * Specs
|
||||||
|
|
||||||
|
|
|
@ -106,11 +106,11 @@ test-suite spec
|
||||||
type: exitcode-stdio-1.0
|
type: exitcode-stdio-1.0
|
||||||
hs-source-dirs: test
|
hs-source-dirs: test
|
||||||
main-is: Spec.hs
|
main-is: Spec.hs
|
||||||
build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.10
|
build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.11
|
||||||
build-depends: base
|
build-depends: base
|
||||||
, base-compat
|
, base-compat
|
||||||
, aeson >=1.4.2.0 && <3
|
, aeson >=1.4.2.0 && <3
|
||||||
, hspec >=2.6.0 && <2.10
|
, hspec >=2.6.0 && <2.11
|
||||||
, QuickCheck
|
, QuickCheck
|
||||||
, lens
|
, lens
|
||||||
, lens-aeson >=1.0.2 && <1.3
|
, lens-aeson >=1.0.2 && <1.3
|
||||||
|
|
|
@ -304,6 +304,10 @@ instance (HasSwagger sub) => HasSwagger (HttpVersion :> sub) where
|
||||||
instance (HasSwagger sub) => HasSwagger (WithNamedContext x c sub) where
|
instance (HasSwagger sub) => HasSwagger (WithNamedContext x c sub) where
|
||||||
toSwagger _ = toSwagger (Proxy :: Proxy sub)
|
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
|
instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (sym :> sub) where
|
||||||
toSwagger _ = prependPath piece (toSwagger (Proxy :: Proxy sub))
|
toSwagger _ = prependPath piece (toSwagger (Proxy :: Proxy sub))
|
||||||
where
|
where
|
||||||
|
|
|
@ -2,6 +2,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.
|
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
|
0.19
|
||||||
----
|
----
|
||||||
|
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
cabal-version: 2.2
|
cabal-version: 2.2
|
||||||
name: servant
|
name: servant
|
||||||
version: 0.19
|
version: 0.19.1
|
||||||
|
|
||||||
synopsis: A family of combinators for defining webservices APIs
|
synopsis: A family of combinators for defining webservices APIs
|
||||||
category: Servant, Web
|
category: Servant, Web
|
||||||
|
@ -62,6 +62,7 @@ library
|
||||||
Servant.API.Vault
|
Servant.API.Vault
|
||||||
Servant.API.Verbs
|
Servant.API.Verbs
|
||||||
Servant.API.WithNamedContext
|
Servant.API.WithNamedContext
|
||||||
|
Servant.API.WithResource
|
||||||
|
|
||||||
-- Types
|
-- Types
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
|
@ -80,19 +81,19 @@ library
|
||||||
--
|
--
|
||||||
-- note: mtl lower bound is so low because of GHC-7.8
|
-- note: mtl lower bound is so low because of GHC-7.8
|
||||||
build-depends:
|
build-depends:
|
||||||
base >= 4.9 && < 4.17
|
base >= 4.9 && < 4.18
|
||||||
, bytestring >= 0.10.8.1 && < 0.12
|
, bytestring >= 0.10.8.1 && < 0.12
|
||||||
, constraints >= 0.2
|
, constraints >= 0.2
|
||||||
, mtl >= 2.2.2 && < 2.3
|
, mtl ^>= 2.2.2 || ^>= 2.3.1
|
||||||
, sop-core >= 0.4.0.0 && < 0.6
|
, sop-core >= 0.4.0.0 && < 0.6
|
||||||
, transformers >= 0.5.2.0 && < 0.6
|
, transformers >= 0.5.2.0 && < 0.7
|
||||||
, text >= 1.2.3.0 && < 2.1
|
, text >= 1.2.3.0 && < 2.1
|
||||||
|
|
||||||
|
|
||||||
-- We depend (heavily) on the API of these packages:
|
-- We depend (heavily) on the API of these packages:
|
||||||
-- i.e. re-export, or allow using without direct dependency
|
-- i.e. re-export, or allow using without direct dependency
|
||||||
build-depends:
|
build-depends:
|
||||||
http-api-data >= 0.4.1 && < 0.4.4
|
http-api-data >= 0.4.1 && < 0.5.1
|
||||||
, singleton-bool >= 0.1.4 && < 0.1.7
|
, singleton-bool >= 0.1.4 && < 0.1.7
|
||||||
|
|
||||||
-- Other dependencies: Lower bound around what is in the latest Stackage LTS.
|
-- Other dependencies: Lower bound around what is in the latest Stackage LTS.
|
||||||
|
|
|
@ -31,6 +31,8 @@ module Servant.API (
|
||||||
-- | Access the location for arbitrary data to be shared by applications and middleware
|
-- | Access the location for arbitrary data to be shared by applications and middleware
|
||||||
module Servant.API.WithNamedContext,
|
module Servant.API.WithNamedContext,
|
||||||
-- | Access context entries in combinators in servant-server
|
-- | 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
|
-- * Actual endpoints, distinguished by HTTP method
|
||||||
module Servant.API.Verbs,
|
module Servant.API.Verbs,
|
||||||
|
@ -101,17 +103,19 @@ import Servant.API.Experimental.Auth
|
||||||
(AuthProtect)
|
(AuthProtect)
|
||||||
import Servant.API.Fragment
|
import Servant.API.Fragment
|
||||||
(Fragment)
|
(Fragment)
|
||||||
|
import Servant.API.Generic
|
||||||
|
(AsApi, GServantProduct, GenericMode ((:-)), GenericServant,
|
||||||
|
ToServant, ToServantApi, fromServant, genericApi, toServant)
|
||||||
import Servant.API.Header
|
import Servant.API.Header
|
||||||
(Header, Header')
|
(Header, Header')
|
||||||
import Servant.API.Generic
|
|
||||||
(GenericMode ((:-)), AsApi, ToServant, ToServantApi, GServantProduct,
|
|
||||||
GenericServant, fromServant, toServant, genericApi)
|
|
||||||
import Servant.API.HttpVersion
|
import Servant.API.HttpVersion
|
||||||
(HttpVersion (..))
|
(HttpVersion (..))
|
||||||
import Servant.API.IsSecure
|
import Servant.API.IsSecure
|
||||||
(IsSecure (..))
|
(IsSecure (..))
|
||||||
import Servant.API.Modifiers
|
import Servant.API.Modifiers
|
||||||
(Lenient, Optional, Required, Strict)
|
(Lenient, Optional, Required, Strict)
|
||||||
|
import Servant.API.NamedRoutes
|
||||||
|
(NamedRoutes)
|
||||||
import Servant.API.QueryParam
|
import Servant.API.QueryParam
|
||||||
(QueryFlag, QueryParam, QueryParam', QueryParams)
|
(QueryFlag, QueryParam, QueryParam', QueryParams)
|
||||||
import Servant.API.Raw
|
import Servant.API.Raw
|
||||||
|
@ -137,8 +141,6 @@ import Servant.API.UVerb
|
||||||
Unique, WithStatus (..), inject, statusOf)
|
Unique, WithStatus (..), inject, statusOf)
|
||||||
import Servant.API.Vault
|
import Servant.API.Vault
|
||||||
(Vault)
|
(Vault)
|
||||||
import Servant.API.NamedRoutes
|
|
||||||
(NamedRoutes)
|
|
||||||
import Servant.API.Verbs
|
import Servant.API.Verbs
|
||||||
(Delete, DeleteAccepted, DeleteNoContent,
|
(Delete, DeleteAccepted, DeleteNoContent,
|
||||||
DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,
|
DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,
|
||||||
|
@ -150,6 +152,8 @@ import Servant.API.Verbs
|
||||||
ReflectMethod (reflectMethod), StdMethod (..), Verb)
|
ReflectMethod (reflectMethod), StdMethod (..), Verb)
|
||||||
import Servant.API.WithNamedContext
|
import Servant.API.WithNamedContext
|
||||||
(WithNamedContext)
|
(WithNamedContext)
|
||||||
|
import Servant.API.WithResource
|
||||||
|
(WithResource)
|
||||||
import Servant.Links
|
import Servant.Links
|
||||||
(HasLink (..), IsElem, IsElem', Link, URI (..), safeLink)
|
(HasLink (..), IsElem, IsElem', Link, URI (..), safeLink)
|
||||||
import Web.HttpApiData
|
import Web.HttpApiData
|
||||||
|
|
|
@ -110,7 +110,7 @@ type family IsElem' a s :: Constraint
|
||||||
--
|
--
|
||||||
-- >>> ok (Proxy :: Proxy (IsElem ("bye" :> Get '[JSON] Int) SampleAPI))
|
-- >>> ok (Proxy :: Proxy (IsElem ("bye" :> Get '[JSON] Int) SampleAPI))
|
||||||
-- ...
|
-- ...
|
||||||
-- ... Could not deduce...
|
-- ... Could not ...
|
||||||
-- ...
|
-- ...
|
||||||
--
|
--
|
||||||
-- An endpoint is considered within an api even if it is missing combinators
|
-- 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))
|
-- >>> ok (Proxy :: Proxy (IsSubAPI (SampleAPI :<|> Get '[JSON] Int) SampleAPI))
|
||||||
-- ...
|
-- ...
|
||||||
-- ... Could not deduce...
|
-- ... Could not ...
|
||||||
-- ...
|
-- ...
|
||||||
--
|
--
|
||||||
-- This uses @IsElem@ for checking; thus the note there applies here.
|
-- 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)))
|
-- >>> ok (Proxy :: Proxy (IsIn (Get '[JSON] Int) (Header "h" Bool :> Get '[JSON] Int)))
|
||||||
-- ...
|
-- ...
|
||||||
-- ... Could not deduce...
|
-- ... Could not ...
|
||||||
-- ...
|
-- ...
|
||||||
type family IsIn (endpoint :: *) (api :: *) :: Constraint where
|
type family IsIn (endpoint :: *) (api :: *) :: Constraint where
|
||||||
IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb)
|
IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb)
|
||||||
|
|
|
@ -38,6 +38,7 @@ import GHC.TypeLits (Nat)
|
||||||
import Network.HTTP.Types (Status, StdMethod)
|
import Network.HTTP.Types (Status, StdMethod)
|
||||||
import Servant.API.ContentTypes (JSON, PlainText, FormUrlEncoded, OctetStream, NoContent, MimeRender(mimeRender), MimeUnrender(mimeUnrender))
|
import Servant.API.ContentTypes (JSON, PlainText, FormUrlEncoded, OctetStream, NoContent, MimeRender(mimeRender), MimeUnrender(mimeUnrender))
|
||||||
import Servant.API.Status (KnownStatus, statusVal)
|
import Servant.API.Status (KnownStatus, statusVal)
|
||||||
|
import Servant.API.ResponseHeaders (Headers)
|
||||||
import Servant.API.UVerb.Union
|
import Servant.API.UVerb.Union
|
||||||
|
|
||||||
class KnownStatus (StatusOf a) => HasStatus (a :: *) where
|
class KnownStatus (StatusOf a) => HasStatus (a :: *) where
|
||||||
|
@ -52,6 +53,9 @@ statusOf = const (statusVal (Proxy :: Proxy (StatusOf a)))
|
||||||
instance HasStatus NoContent where
|
instance HasStatus NoContent where
|
||||||
type StatusOf NoContent = 204
|
type StatusOf NoContent = 204
|
||||||
|
|
||||||
|
instance HasStatus a => HasStatus (Headers hs a) where
|
||||||
|
type StatusOf (Headers hs a) = StatusOf a
|
||||||
|
|
||||||
class HasStatuses (as :: [*]) where
|
class HasStatuses (as :: [*]) where
|
||||||
type Statuses (as :: [*]) :: [Nat]
|
type Statuses (as :: [*]) :: [Nat]
|
||||||
statuses :: Proxy as -> [Status]
|
statuses :: Proxy as -> [Status]
|
||||||
|
|
|
@ -128,9 +128,9 @@ type DuplicateElementError (rs :: [k]) =
|
||||||
':$$: 'Text " " ':<>: 'ShowType rs
|
':$$: 'Text " " ':<>: 'ShowType rs
|
||||||
|
|
||||||
type family Elem (x :: k) (xs :: [k]) :: Bool where
|
type family Elem (x :: k) (xs :: [k]) :: Bool where
|
||||||
|
Elem x (x ': _) = 'True
|
||||||
|
Elem x (_ ': xs) = Elem x xs
|
||||||
Elem _ '[] = 'False
|
Elem _ '[] = 'False
|
||||||
Elem x (x' ': xs) =
|
|
||||||
If (x == x') 'True (Elem x xs)
|
|
||||||
|
|
||||||
type family Unique xs :: Constraint where
|
type family Unique xs :: Constraint where
|
||||||
Unique xs = If (Nubbed xs == 'True) (() :: Constraint) (TypeError (DuplicateElementError xs))
|
Unique xs = If (Nubbed xs == 'True) (() :: Constraint) (TypeError (DuplicateElementError xs))
|
||||||
|
|
3
servant/src/Servant/API/WithResource.hs
Normal file
3
servant/src/Servant/API/WithResource.hs
Normal file
|
@ -0,0 +1,3 @@
|
||||||
|
module Servant.API.WithResource (WithResource) where
|
||||||
|
|
||||||
|
data WithResource res
|
|
@ -1,5 +1,6 @@
|
||||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||||
{-# LANGUAGE ConstraintKinds #-}
|
{-# LANGUAGE ConstraintKinds #-}
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
@ -91,7 +92,7 @@
|
||||||
-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] NoContent)
|
-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] NoContent)
|
||||||
-- >>> safeLink api bad_link
|
-- >>> safeLink api bad_link
|
||||||
-- ...
|
-- ...
|
||||||
-- ...Could not deduce...
|
-- ...Could not ...
|
||||||
-- ...
|
-- ...
|
||||||
--
|
--
|
||||||
-- This error is essentially saying that the type family couldn't find
|
-- This error is essentially saying that the type family couldn't find
|
||||||
|
@ -192,7 +193,11 @@ import Servant.API.Verbs
|
||||||
(Verb, NoContentVerb)
|
(Verb, NoContentVerb)
|
||||||
import Servant.API.WithNamedContext
|
import Servant.API.WithNamedContext
|
||||||
(WithNamedContext)
|
(WithNamedContext)
|
||||||
|
import Servant.API.WithResource
|
||||||
|
(WithResource)
|
||||||
import Web.HttpApiData
|
import Web.HttpApiData
|
||||||
|
import Data.Kind
|
||||||
|
(Type)
|
||||||
|
|
||||||
-- | A safe link datatype.
|
-- | A safe link datatype.
|
||||||
-- The only way of constructing a 'Link' is using 'safeLink', which means any
|
-- The only way of constructing a 'Link' is using 'safeLink', which means any
|
||||||
|
@ -555,6 +560,10 @@ instance HasLink sub => HasLink (WithNamedContext name context sub) where
|
||||||
type MkLink (WithNamedContext name context sub) a = MkLink sub a
|
type MkLink (WithNamedContext name context sub) a = MkLink sub a
|
||||||
toLink toA _ = toLink toA (Proxy :: Proxy sub)
|
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
|
instance HasLink sub => HasLink (RemoteHost :> sub) where
|
||||||
type MkLink (RemoteHost :> sub) a = MkLink sub a
|
type MkLink (RemoteHost :> sub) a = MkLink sub a
|
||||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||||
|
@ -647,12 +656,20 @@ simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub)
|
||||||
-- >>> import Data.Text (Text)
|
-- >>> import Data.Text (Text)
|
||||||
|
|
||||||
-- Erroring instance for 'HasLink' when a combinator is not fully applied
|
-- Erroring instance for 'HasLink' when a combinator is not fully applied
|
||||||
instance TypeError (PartialApplication HasLink arr) => HasLink ((arr :: a -> b) :> sub)
|
instance TypeError (PartialApplication
|
||||||
|
#if __GLASGOW_HASKELL__ >= 904
|
||||||
|
@(Type -> Constraint)
|
||||||
|
#endif
|
||||||
|
HasLink arr) => HasLink ((arr :: a -> b) :> sub)
|
||||||
where
|
where
|
||||||
type MkLink (arr :> sub) _ = TypeError (PartialApplication (HasLink :: * -> Constraint) arr)
|
type MkLink (arr :> sub) _ = TypeError (PartialApplication (HasLink :: * -> Constraint) arr)
|
||||||
toLink = error "unreachable"
|
toLink = error "unreachable"
|
||||||
|
|
||||||
-- Erroring instances for 'HasLink' for unknown API combinators
|
-- Erroring instances for 'HasLink' for unknown API combinators
|
||||||
instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub HasLink ty) => HasLink (ty :> sub)
|
instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub
|
||||||
|
#if __GLASGOW_HASKELL__ >= 904
|
||||||
|
@(Type -> Constraint)
|
||||||
|
#endif
|
||||||
|
HasLink ty) => HasLink (ty :> sub)
|
||||||
|
|
||||||
instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasLink api)) => HasLink api
|
instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasLink api)) => HasLink api
|
||||||
|
|
|
@ -72,6 +72,7 @@ type ComprehensiveAPIWithoutStreamingOrRaw' endpoint =
|
||||||
:<|> "description" :> Description "foo" :> GET
|
:<|> "description" :> Description "foo" :> GET
|
||||||
:<|> "alternative" :> ("left" :> GET :<|> "right" :> GET)
|
:<|> "alternative" :> ("left" :> GET :<|> "right" :> GET)
|
||||||
:<|> "fragment" :> Fragment Int :> GET
|
:<|> "fragment" :> Fragment Int :> GET
|
||||||
|
:<|> "resource" :> WithResource Int :> GET
|
||||||
:<|> endpoint
|
:<|> endpoint
|
||||||
|
|
||||||
type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint
|
type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint
|
||||||
|
|
|
@ -1,3 +1,4 @@
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
{-# LANGUAGE DeriveFunctor #-}
|
{-# LANGUAGE DeriveFunctor #-}
|
||||||
{-# LANGUAGE GADTs #-}
|
{-# LANGUAGE GADTs #-}
|
||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
|
@ -154,8 +155,10 @@ instance (Applicative m, Show1 m, Show a) => Show (StepT m a) where
|
||||||
-- | >>> lift [1,2,3] :: StepT [] Int
|
-- | >>> lift [1,2,3] :: StepT [] Int
|
||||||
-- Effect [Yield 1 Stop,Yield 2 Stop,Yield 3 Stop]
|
-- Effect [Yield 1 Stop,Yield 2 Stop,Yield 3 Stop]
|
||||||
--
|
--
|
||||||
|
#if !MIN_VERSION_transformers(0,6,0)
|
||||||
instance MonadTrans StepT where
|
instance MonadTrans StepT where
|
||||||
lift = Effect . fmap (`Yield` Stop)
|
lift = Effect . fmap (`Yield` Stop)
|
||||||
|
#endif
|
||||||
|
|
||||||
instance MFunctor StepT where
|
instance MFunctor StepT where
|
||||||
hoist f = go where
|
hoist f = go where
|
||||||
|
|
|
@ -2,10 +2,14 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
module Servant.API.ResponseHeadersSpec where
|
module Servant.API.ResponseHeadersSpec where
|
||||||
|
|
||||||
|
import Data.Proxy
|
||||||
|
import GHC.TypeLits
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
|
|
||||||
|
import Servant.API.ContentTypes
|
||||||
import Servant.API.Header
|
import Servant.API.Header
|
||||||
import Servant.API.ResponseHeaders
|
import Servant.API.ResponseHeaders
|
||||||
|
import Servant.API.UVerb
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = describe "Servant.API.ResponseHeaders" $ do
|
spec = describe "Servant.API.ResponseHeaders" $ do
|
||||||
|
@ -28,3 +32,10 @@ spec = describe "Servant.API.ResponseHeaders" $ do
|
||||||
it "does not add a header" $ do
|
it "does not add a header" $ do
|
||||||
let val = noHeader 5 :: Headers '[Header "test" Int] Int
|
let val = noHeader 5 :: Headers '[Header "test" Int] Int
|
||||||
getHeaders val `shouldBe` []
|
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