Compare commits

..

No commits in common. "master" and "cookbook_namedRoutes" have entirely different histories.

83 changed files with 682 additions and 1133 deletions

View file

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

View file

@ -34,7 +34,6 @@ packages:
doc/cookbook/db-postgres-pool
doc/cookbook/db-sqlite-simple
doc/cookbook/file-upload
doc/cookbook/generic
doc/cookbook/hoist-server-with-context
doc/cookbook/https
doc/cookbook/jwt-and-basic-auth
@ -47,8 +46,15 @@ packages:
doc/cookbook/using-custom-monad
doc/cookbook/using-free-client
-- doc/cookbook/open-id-connect
doc/cookbook/managed-resource
doc/cookbook/namedRoutes
tests: True
optimization: False
-- reorder-goals: True
-- needed for doctests
write-ghc-environment-files: always
-- https://github.com/chordify/haskell-servant-pagination/pull/12
allow-newer: servant-pagination-2.2.2:servant
allow-newer: servant-pagination-2.2.2:servant-server

View file

@ -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)
```
}

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -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)
}

View file

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

View file

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

View file

@ -11,9 +11,6 @@ build-type: Simple
tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
executable cookbock-curl-mock
if impl(ghc >= 9.2)
-- generic-arbitrary is incompatible
buildable: False
main-is: CurlMock.lhs
build-depends: base == 4.*
, aeson

View file

@ -1,141 +0,0 @@
# Using generics
```haskell
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
module Main (main, api, getLink, routesLinks, cliGet) where
import Control.Exception (throwIO)
import Control.Monad.Trans.Reader (ReaderT, runReaderT)
import Data.Proxy (Proxy (..))
import Network.Wai.Handler.Warp (run)
import System.Environment (getArgs)
import Servant
import Servant.Client
import Servant.API.Generic
import Servant.Client.Generic
import Servant.Server.Generic
```
The usage is simple, if you only need a collection of routes.
First you define a record with field types prefixed by a parameter `route`:
```haskell
data Routes route = Routes
{ _get :: route :- Capture "id" Int :> Get '[JSON] String
, _put :: route :- ReqBody '[JSON] Int :> Put '[JSON] Bool
}
deriving (Generic)
```
Then we'll use this data type to define API, links, server and client.
## API
You can get a `Proxy` of the API using `genericApi`:
```haskell
api :: Proxy (ToServantApi Routes)
api = genericApi (Proxy :: Proxy Routes)
```
It's recommended to use `genericApi` function, as then you'll get
better error message, for example if you forget to `derive Generic`.
## Links
The clear advantage of record-based generics approach, is that
we can get safe links very conveniently. We don't need to define endpoint types,
as field accessors work as proxies:
```haskell
getLink :: Int -> Link
getLink = fieldLink _get
```
We can also get all links at once, as a record:
```haskell
routesLinks :: Routes (AsLink Link)
routesLinks = allFieldLinks
```
## Client
Even more power starts to show when we generate a record of client functions.
Here we use `genericClientHoist` function, which lets us simultaneously
hoist the monad, in this case from `ClientM` to `IO`.
```haskell
cliRoutes :: Routes (AsClientT IO)
cliRoutes = genericClientHoist
(\x -> runClientM x env >>= either throwIO return)
where
env = error "undefined environment"
cliGet :: Int -> IO String
cliGet = _get cliRoutes
```
## Server
Finally, probably the most handy usage: we can convert record of handlers into
the server implementation:
```haskell
record :: Routes AsServer
record = Routes
{ _get = return . show
, _put = return . odd
}
app :: Application
app = genericServe record
main :: IO ()
main = do
args <- getArgs
case args of
("run":_) -> do
putStrLn "Starting cookbook-generic at http://localhost:8000"
run 8000 app
-- see this cookbook below for custom-monad explanation
("run-custom-monad":_) -> do
putStrLn "Starting cookbook-generic with a custom monad at http://localhost:8000"
run 8000 (appMyMonad AppCustomState)
_ -> putStrLn "To run, pass 'run' argument: cabal new-run cookbook-generic run"
```
## Using generics together with a custom monad
If your app uses a custom monad, here's how you can combine it with
generics.
```haskell
data AppCustomState =
AppCustomState
type AppM = ReaderT AppCustomState Handler
apiMyMonad :: Proxy (ToServantApi Routes)
apiMyMonad = genericApi (Proxy :: Proxy Routes)
getRouteMyMonad :: Int -> AppM String
getRouteMyMonad = return . show
putRouteMyMonad :: Int -> AppM Bool
putRouteMyMonad = return . odd
recordMyMonad :: Routes (AsServerT AppM)
recordMyMonad = Routes {_get = getRouteMyMonad, _put = putRouteMyMonad}
-- natural transformation
nt :: AppCustomState -> AppM a -> Handler a
nt s x = runReaderT x s
appMyMonad :: AppCustomState -> Application
appMyMonad state = genericServeT (nt state) recordMyMonad

View file

@ -37,4 +37,3 @@ you name it!
sentry/Sentry.lhs
testing/Testing.lhs
open-id-connect/OpenIdConnect.lhs
managed-resource/ManagedResource.lhs

View file

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

View file

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

View file

@ -0,0 +1,373 @@
# NamedRoutes - Using records to define APIs
*Available in Servant 0.19 or higher*
Servant offers a very natural way of constructing APIs with nested records, called `NamedRoutes`.
This cookbook explains how to implement such nested-record-APIs using `NamedRoutes` through the example of a Movie Catalog.
First, we start by constructing the domain types of our Movie Catalog.
After, we show you how to implement the API type with the NamedRoutes records.
Lastly, we make a Server and a Client out of the API type.
However, it should be understood that this cookbook does _not_ dwell on the built-in servant combinators as the [<Structuring APIs> cookbook ](<https://docs.servant.dev/en/stable/cookbook/structuring-apis/StructuringApis.html>) already covers that angle.
## Why would I want to use `NamedRoutes` over the alternative `:<|>` operator?
With `NamedRoutes`, we dont need to care about the declaration order of the endpoints.
For example, with the `:<|>` operator theres room for error when the order of the API type
```haskell,ignore
type API1 = "version" :> Get '[JSON] Version
:<|> "movies" :> Get '[JSON] [Movie]
```
does not follow the `Handler` implementation order
```haskell,ignore
apiHandler :: ServerT API1 Handler
apiHandler = getMovies
:<|> getVersion
```
GHC could scold you with a very tedious message such as :
```console
• Couldn't match type 'Handler NoContent'
with 'Movie -> Handler NoContent'
Expected type: ServerT MovieCatalogAPI Handler
Actual type: Handler Version
:<|> ((Maybe SortBy -> Handler [Movie])
:<|> ((MovieId -> Handler (Maybe Movie))
:<|> ((MovieId -> Movie -> Handler NoContent)
:<|> (MovieId -> Handler NoContent))))
• In the expression:
versionHandler
:<|>
movieListHandler
:<|>
getMovieHandler :<|> updateMovieHandler :<|> deleteMovieHandler
In an equation for 'server':
server
= versionHandler
:<|>
movieListHandler
:<|>
getMovieHandler :<|> updateMovieHandler :<|> deleteMovieHandler
|
226 | server = versionHandler
```
On the contrary, with the `NamedRoutes` technique, we refer to the routes by their name:
```haskell,ignore
data API mode = API
{ list :: "list" :> ...
, delete :: "delete" :> ...
}
```
and GHC follows the lead :
```console
• Couldn't match type 'NoContent' with 'Movie'
Expected type: AsServerT Handler :- Delete '[JSON] Movie
Actual type: Handler NoContent
• In the 'delete' field of a record
In the expression:
MovieAPI
{get = getMovieHandler movieId,
update = updateMovieHandler movieId,
delete = deleteMovieHandler movieId}
In an equation for 'movieHandler':
movieHandler movieId
= MovieAPI
{get = getMovieHandler movieId,
update = updateMovieHandler movieId,
delete = deleteMovieHandler movieId}
|
252 | , delete = deleteMovieHandler movieId
```
So, NamedRoutes is more readable for a human, and GHC gives you more accurate error messages.
What are we waiting for?
## Boilerplate time!
First, lets get rid of the the extensions and imports boilerplate in order to focus on our new technique:
```haskell
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
import GHC.Generics ( Generic )
import Data.Aeson ( FromJSON, ToJSON )
import Data.Proxy ( Proxy(..) )
import Network.Wai.Handler.Warp ( run )
import Servant ( NamedRoutes
, Handler, serve )
import Servant.API (Capture, Delete, Get, Put, QueryParam, ReqBody
, JSON, NoContent (..)
, FromHttpApiData (..),ToHttpApiData(..)
, (:>) )
import Servant.API.Generic ( (:-) )
import Servant.Client ( AsClientT, ClientM, client
, (//), (/:) )
import Servant.Client.Generic ()
import Servant.Server ( Application, ServerT )
import Servant.Server.Generic ( AsServerT )
```
## Domain context
Now that weve handled the boilerplate, we can dive into our Movie Catalog domain.
Consider a `Movie` constructed from a `Title` and a `Year` of publication.
``` haskell
data Movie = Movie
{ movieId :: MovieId
, title :: Title
, year :: Year
}
deriving stock Generic
deriving anyclass (FromJSON, ToJSON)
type MovieId = String
type Title = String
type Year = Int
```
Lets forget about the deriving stuff for now and think about the API that we want to make.
```
"version" -> Get Version
/
api "list" -> Get [Movie] ?sortBy= Title | Year (sort by the Title or the Year)
\ /
"movies" Get Movie
\ /
Capture MovieId - Put Movie
\
Delete MovieId
```
In this example, we create a very simple endpoint for the Version,
and several complex endpoints that use nested records for the CRUD part of the movie.
So, the URLs would look like
- GET …/version
- GET …/movies/list?sortby=Title
- GET …/movies/<MovieId>/
- PUT …/movies/<MovieId>/
- DELETE …/movies/<MovieId>
### API Type
Now that we have a very clear idea of the API we want to make, we need to transform it into usable Haskell code:
``` haskell
data API mode = API
{ version :: mode :- "version" :> Get '[JSON] Version
, movies :: mode :- "movies" :> NamedRoutes MoviesAPI
} deriving stock Generic
type Version = String -- This will do for the sake of example.
```
Here, we see the first node of our tree. It contains the two branches “version” and “movies” respectively:
The “version” branch is very simple and self-explanatory.
The “movies” branch will contain another node, represented by another record (see above). That is why we need the `NameRoutes` helper.
Note:
The `mode` type parameter indicates into which implementation the records `Generic` representation will be transformed—as a client or as a server. We will discuss that later.
Let's jump into the "movies" subtree node:
``` haskell
data MoviesAPI mode = MoviesAPI
{ list :: mode :- "list" :> QueryParam "SortBy" SortBy :> Get '[JSON] [Movie]
, movie :: mode :- Capture "movieId" MovieId :> NamedRoutes MovieAPI
} deriving stock Generic
data SortBy = Year | Title
instance ToHttpApiData SortBy where
toQueryParam Year = "year"
toQueryParam Title = "title"
instance FromHttpApiData SortBy where
parseQueryParam "year" = Right Year
parseQueryParam "title" = Right Title
parseQueryParam param = Left $ param <> " is not a valid value"
```
So, remember, this type represents the `MoviesAPI` node that weve connected earlier to the main `API` tree.
In this subtree, we illustrated both an endpoint with a **query param** and also, a **capture** with a subtree underneath it.
So, let's go deeper into our API tree.
``` haskell
data MovieAPI mode = MovieAPI
{ get :: mode :- Get '[JSON] (Maybe Movie)
, update :: mode :- ReqBody '[JSON] Movie :> Put '[JSON] NoContent
, delete :: mode :- Delete '[JSON] NoContent
} deriving stock Generic
```
As you can see, we end up implementing the deepest routes of our API.
Small detail: as our main API tree is also a record, we need the `NamedRoutes` helper.
To improve readability, we suggest you create a type alias:
``` haskell
type MovieCatalogAPI = NamedRoutes API
```
That's it, we have our `MovieCatalogAPI` type!
Let's make a server and a client out of it!
### The Server
As you know, we cant talk about a server, without addressing the handlers.
First, we take our handlers…
```haskell
versionHandler :: Handler Version
versionHandler = pure "0.0.1"
movieListHandler :: Maybe SortBy -> Handler [Movie]
movieListHandler _ = pure moviesDB
moviesDB :: [Movie]
moviesDB =
[ Movie "1" "Se7en" 1995
, Movie "2" "Minority Report" 2002
, Movie "3" "The Godfather" 1972
]
getMovieHandler :: MovieId -> Handler (Maybe Movie)
getMovieHandler requestMovieId = go moviesDB
where
go [] = pure Nothing
go (movie:ms) | movieId movie == requestMovieId = pure $ Just movie
go (m:ms) = go ms
updateMovieHandler :: MovieId -> Movie -> Handler NoContent
updateMovieHandler requestedMovieId newMovie =
-- update the movie list in the database...
pure NoContent
deleteMovieHandler :: MovieId -> Handler NoContent
deleteMovieHandler _ =
-- delete the movie from the database...
pure NoContent
```
And assemble them together with the record structure, which is the glue here.
```haskell
server :: ServerT MovieCatalogAPI Handler
server =
API
{ version = versionHandler
, movies = moviesHandler
}
moviesHandler :: MoviesAPI (AsServerT Handler)
moviesHandler =
MoviesAPI
{ list = movieListHandler
, movie = movieHandler
}
movieHandler :: MovieId -> MovieAPI (AsServerT Handler)
movieHandler movieId = MovieAPI
{ get = getMovieHandler movieId
, update = updateMovieHandler movieId
, delete = deleteMovieHandler movieId
}
```
As you might have noticed, we build our handlers out of the same record types we used to define our API: `MoviesAPI` and `MovieAPI`. What kind of magic is this ?
Remember the `mode` type parameter we saw earlier? Since we need to transform our API type into a _server_, we need to provide a server `mode`, which is `AsServerT Handler` here.
Finally, we can run the server and connect the API routes to the handlers as usual:
``` haskell
api :: Proxy MovieCatalogAPI
api = Proxy
main :: IO ()
main = run 8081 app
app :: Application
app = serve api server
```
Yay! Thats done and weve got our server!
## The Client
The client, so to speak, is very easy to implement:
``` haskell
movieCatalogClient :: API (AsClientT ClientM)
movieCatalogClient = client api -- remember: api: Proxy MovieCatalogAPI
```
Have you noticed the `mode` `AsClient ClientM`?
Weve also introduced some operators that help navigate through the nested records.
`(//)` is used to jump from one record to another.
`(/:)` is used to provide a parameter, whether it be a query param or a capture.
Lets use those nice helpers for our movie catalog:
```haskell
listMovies :: Maybe SortBy -> ClientM [Movie]
listMovies sortBy = movieCatalogClient // movies // list /: sortBy
getMovie :: MovieId -> ClientM (Maybe Movie)
getMovie movieId = movieCatalogClient // movies // movie /: movieId // get
updateMovie :: MovieId -> Movie -> ClientM NoContent
updateMovie movieId newMovie = movieCatalogClient // movies // movie /: movieId // update /: newMovie
deleteMovie :: MovieId -> ClientM NoContent
deleteMovie movieId = movieCatalogClient // movies // movie /: movieId // delete
```
Done! Weve got our client!
## Conclusion
We hope that you found this workbook helpful, and that you now feel more confident using the `NamedRoutes` technique.
If you are interested in further understanding the built-in Servant combinators, see [Structuring APIs](https://docs.servant.dev/en/stable/cookbook/structuring-apis/StructuringApis.html).
Since `NamedRoutes` is based on the Generic mechanism, you might want to have a look at [Sandy Maguires _Thinking with Types_ book](https://doku.pub/download/sandy-maguire-thinking-with-typesz-liborgpdf-4lo5ne7kdj0x).

View file

@ -1,25 +1,27 @@
cabal-version: 2.2
name: cookbook-generic
name: namedRoutes
version: 0.1
synopsis: Using custom monad to pass a state between handlers
synopsis: NamedRoutes - Generic servant API implementation cookbook example
homepage: http://docs.servant.dev/
license: BSD-3-Clause
license: BSD3
license-file: ../../../servant/LICENSE
author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple
tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
cabal-version: >=1.10
tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
executable cookbook-using-custom-monad
main-is: Generic.lhs
executable namedRoutes
main-is: NamedRoutes.lhs
build-depends: base == 4.*
, aeson >= 1.2
, text
, servant
, servant-client
, servant-client-core
, servant-server
, base-compat
, wai >= 3.2
, warp >= 3.2
, transformers >= 0.3
default-language: Haskell2010
ghc-options: -Wall -pgmL markdown-unlit
build-tool-depends: markdown-unlit:markdown-unlit >= 0.4
build-tool-depends: markdown-unlit:markdown-unlit

View file

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

View file

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

View file

@ -199,7 +199,7 @@ parsers in the hope that the ones that should will always error out so
you can try until the right one returns a value.)
[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

View file

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

View file

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

View file

@ -64,7 +64,7 @@ library
, blaze-markup >= 0.8.0.0 && < 0.9
, cookie >= 0.4.3 && < 0.5
, js-jquery >= 3.3.1 && < 3.4
, lucid >= 2.9.11 && < 2.12
, lucid >= 2.9.11 && < 2.10
, random >= 1.1 && < 1.3
, servant-js >= 0.9 && < 0.10
, time >= 1.6.0.1 && < 1.13

View file

@ -7,9 +7,9 @@ description: This package provides instances that allow generating clients fr
APIs that use
<https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.
.
For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
For a quick overview of the usage, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>.
category: Web, Servant, Authentication
homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
homepage: http://github.com/haskell-servant/servant/servant-auth#readme
bug-reports: https://github.com/haskell-servant/servant/issues
author: Julian K. Arni
maintainer: jkarni@gmail.com
@ -31,8 +31,8 @@ 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
, bytestring >= 0.10.6.0 && < 0.12
base >= 4.10 && < 4.16
, bytestring >= 0.10.6.0 && < 0.11
, containers >= 0.5.6.2 && < 0.7
, servant-auth == 0.4.*
, servant >= 0.13 && < 0.20
@ -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,10 +62,10 @@ 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
, bytestring >= 0.10.6.0 && < 0.11
, http-client >= 0.5.13.1 && < 0.8
, http-types >= 0.12.2 && < 0.13
, servant-auth-server >= 0.4.2.0 && < 0.5
@ -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

View file

@ -7,9 +7,9 @@ description: This package provides instances that allow generating docs from
APIs that use
<https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.
.
For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
For a quick overview of the usage, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>.
category: Web, Servant, Authentication
homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
homepage: http://github.com/haskell-servant/servant/servant-auth#readme
bug-reports: https://github.com/haskell-servant/servant/issues
author: Julian K. Arni
maintainer: jkarni@gmail.com
@ -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.16
, 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

View file

@ -7,9 +7,9 @@ description: This package provides the required instances for using the @Auth
.
Both cookie- and token- (REST API) based authentication is provided.
.
For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
For a quick overview of the usage, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>.
category: Web, Servant, Authentication
homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
homepage: http://github.com/haskell-servant/servant/servant-auth#readme
bug-reports: https://github.com/haskell-servant/servant/issues
author: Julian K. Arni
maintainer: jkarni@gmail.com
@ -31,27 +31,27 @@ library
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
ghc-options: -Wall
build-depends:
base >= 4.10 && < 4.18
base >= 4.10 && < 4.16
, aeson >= 1.0.0.1 && < 3
, base64-bytestring >= 1.0.0.1 && < 2
, blaze-builder >= 0.4.1.0 && < 0.5
, bytestring >= 0.10.6.0 && < 0.12
, bytestring >= 0.10.6.0 && < 0.11
, case-insensitive >= 1.2.0.11 && < 1.3
, cookie >= 0.4.4 && < 0.5
, 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.17
, 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.10
, 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,10 +123,10 @@ 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
other-modules:

View file

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

View file

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

View file

@ -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,12 +58,11 @@ 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

View file

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

View file

@ -6,12 +6,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,
@ -539,7 +540,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

View file

@ -7,9 +7,9 @@ description: This package provides instances that allow generating swagger2 s
APIs that use
<https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.
.
For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
For a quick overview of the usage, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>.
category: Web, Servant, Authentication
homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
homepage: http://github.com/haskell-servant/servant/servant-auth#readme
bug-reports: https://github.com/haskell-servant/servant/issues
author: Julian K. Arni
maintainer: jkarni@gmail.com
@ -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

View file

@ -9,9 +9,9 @@ description: This package provides an @Auth@ combinator for 'servant'. This c
'servant-auth' additionally provides concrete authentication schemes, such
as Basic Access Authentication, JSON Web Tokens, and Cookies.
.
For more details on how to use this, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
For more details on how to use this, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>.
category: Web, Servant, Authentication
homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
homepage: http://github.com/haskell-servant/servant/servant-auth#readme
bug-reports: https://github.com/haskell-servant/servant/issues
author: Julian K. Arni
maintainer: jkarni@gmail.com
@ -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.16
, 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

View file

@ -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\>@
--

View file

@ -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.16
, 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.18
if !impl(ghc >= 8.2)
build-depends:
@ -71,7 +71,7 @@ library
-- Here can be exceptions if we really need features from the newer versions.
build-depends:
aeson >= 1.4.1.0 && < 3
, base-compat >= 0.10.5 && < 0.13
, base-compat >= 0.10.5 && < 0.12
, base64-bytestring >= 1.0.0.1 && < 1.3
, exceptions >= 0.10.0 && < 0.11
, free >= 5.1 && < 5.2
@ -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

View file

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

View file

@ -33,6 +33,8 @@ import Control.Arrow
import Control.Monad
(unless)
import qualified Data.ByteString as BS
import Data.ByteString.Builder
(toLazyByteString)
import qualified Data.ByteString.Lazy as BL
import Data.Either
(partitionEithers)
@ -77,7 +79,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 +210,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 +245,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)
@ -569,7 +571,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire
(Proxy :: Proxy mods) add (maybe req add) mparam
where
add :: a -> Request
add param = appendToQueryString pname (Just $ encodeQueryParamValue param) req
add param = appendToQueryString pname (Just $ encodeQueryParam param) req
pname :: Text
pname = pack $ symbolVal (Proxy :: Proxy sym)
@ -577,6 +579,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire
hoistClientMonad pm _ f cl = \arg ->
hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)
encodeQueryParam :: ToHttpApiData a => a -> BS.ByteString
encodeQueryParam = BL.toStrict . toLazyByteString . toEncodedUrlPiece
-- | If you use a 'QueryParams' in one of your endpoints in your API,
-- the corresponding querying function will automatically take
-- an additional argument, a list of values of the type specified
@ -618,7 +623,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
)
where pname = pack $ symbolVal (Proxy :: Proxy sym)
paramlist' = map (Just . encodeQueryParamValue) paramlist
paramlist' = map (Just . encodeQueryParam) paramlist
hoistClientMonad pm _ f cl = \as ->
hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
@ -740,7 +745,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 +781,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)
@ -882,7 +879,7 @@ infixl 2 /:
--
-- Example:
--
-- @
-- @@
-- type Api = NamedRoutes RootApi
--
-- data RootApi mode = RootApi
@ -902,8 +899,8 @@ infixl 2 /:
-- rootClient = client api
--
-- endpointClient :: ClientM Person
-- endpointClient = client \/\/ subApi \/\/ endpoint
-- @
-- endpointClient = client // subApi // endpoint
-- @@
(//) :: a -> (a -> b) -> b
x // f = f x
@ -914,7 +911,7 @@ x // f = f x
--
-- Example:
--
-- @
-- @@
-- type Api = NamedRoutes RootApi
--
-- data RootApi mode = RootApi
@ -935,11 +932,11 @@ 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

View file

@ -17,7 +17,6 @@ module Servant.Client.Core.Request (
addHeader,
appendToPath,
appendToQueryString,
encodeQueryParamValue,
setRequestBody,
setRequestBodyLBS,
) where
@ -34,8 +33,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 +111,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
@ -145,30 +142,18 @@ defaultRequest = Request
, requestMethod = methodGet
}
-- | 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.
--
appendToQueryString :: Text -- ^ query param name
-> Maybe BS.ByteString -- ^ query param value
appendToQueryString :: Text -- ^ param name
-> Maybe BS.ByteString -- ^ param value
-> Request
-> Request
appendToQueryString pname pvalue req
= req { requestQueryString = requestQueryString req
Seq.|> (encodeUtf8 pname, pvalue)}
-- | Encode a query parameter value.
--
encodeQueryParamValue :: ToHttpApiData a => a -> BS.ByteString
encodeQueryParamValue = LBS.toStrict . Builder.toLazyByteString . toEncodedUrlPiece
-- | Add header to the request being constructed.
--
addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request
addHeader name val req
= req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}

View file

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

View file

@ -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.16
, 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.10
, transformers >= 0.5.2.0 && < 0.6
if !impl(ghc >= 8.2)
build-depends:
@ -64,7 +64,7 @@ library
-- 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.
build-depends:
base-compat >= 0.10.5 && < 0.13
base-compat >= 0.10.5 && < 0.12
, http-client >= 0.5.13.1 && < 0.8
, http-media >= 0.7.1.3 && < 0.9
, http-types >= 0.12.2 && < 0.13
@ -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

View file

@ -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
@ -246,7 +246,7 @@ defaultMakeClientRequest burl r = return Client.defaultRequest
where
-- Content-Type and Accept are specified by requestBody and requestAccept
headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $
toList $ requestHeaders r
toList $requestHeaders r
acceptHdr
| null hs = Nothing
@ -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

View file

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

View file

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

View file

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

View file

@ -23,7 +23,7 @@ extra-source-files:
source-repository head
type: git
location: http://github.com/haskell-servant/servant.git
location: http://github.com/haskell-servant/servant-conduit.git
library
exposed-modules: Servant.Conduit
@ -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

View file

@ -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:

View file

@ -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.16
, bytestring >= 0.10.8.1 && < 0.12
, text >= 1.2.3.0 && < 2.1
@ -54,12 +54,12 @@ library
build-depends:
aeson >= 1.4.1.0 && < 3
, aeson-pretty >= 0.8.5 && < 0.9
, base-compat >= 0.10.5 && < 0.13
, base-compat >= 0.10.5 && < 0.12
, case-insensitive >= 1.2.0.11 && < 1.3
, 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

View file

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

View file

@ -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.16
, text >= 1.2.3.0 && < 2.1
-- Servant dependencies
@ -51,8 +51,8 @@ library
-- 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.
build-depends:
base-compat >= 0.10.5 && < 0.13
, lens >= 4.17 && < 5.3
base-compat >= 0.10.5 && < 0.12
, 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

View file

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

View file

@ -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.16
, 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.10
, transformers >= 0.5.2.0 && < 0.6
if !impl(ghc >= 8.2)
build-depends:
@ -60,19 +60,19 @@ library
-- 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.
build-depends:
base-compat >= 0.10.5 && < 0.13
base-compat >= 0.10.5 && < 0.12
, case-insensitive
, http-streams >= 0.8.6.1 && < 0.9
, http-media >= 0.7.1.3 && < 0.9
, io-streams >= 1.5.0.1 && < 1.6
, http-types >= 0.12.2 && < 0.13
, http-common >= 0.8.2.0 && < 0.9
, http-common >= 0.8.2.0 && < 0.8.3
, exceptions >= 0.10.0 && < 0.11
, kan-extensions >= 5.2 && < 5.3
, monad-control >= 1.0.2.3 && < 1.1
, semigroupoids >= 5.3.1 && < 5.4
, transformers-base >= 0.4.5.2 && < 0.5
, transformers-compat >= 0.6.2 && < 0.8
, transformers-compat >= 0.6.2 && < 0.7
hs-source-dirs: src
default-language: Haskell2010
@ -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

View file

@ -23,7 +23,7 @@ extra-source-files:
source-repository head
type: git
location: http://github.com/haskell-servant/servant.git
location: http://github.com/haskell-servant/servant-machines.git
library
exposed-modules: Servant.Machines
@ -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

View file

@ -23,7 +23,7 @@ extra-source-files:
source-repository head
type: git
location: http://github.com/haskell-servant/servant.git
location: http://github.com/haskell-servant/servant-pipes.git
library
exposed-modules: Servant.Pipes
@ -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

View file

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

View file

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

View file

@ -1,6 +1,6 @@
cabal-version: 2.2
name: servant-server
version: 0.19.2
version: 0.19
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,25 +60,25 @@ 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.16
, 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.
build-depends:
base-compat >= 0.10.5 && < 0.13
base-compat >= 0.10.5 && < 0.12
, base64-bytestring >= 1.0.0.1 && < 1.3
, exceptions >= 0.10.0 && < 0.11
, http-media >= 0.7.1.3 && < 0.9
@ -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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -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))
@ -169,11 +145,11 @@ staticRef = Proxy
type Dynamic =
"a" :> Capture "foo" Int :> "b" :> End
:<|> "a" :> Capture "foo" Int :> "c" :> End
:<|> "a" :> Capture "foo" Int :> "d" :> 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"

View file

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

View file

@ -19,7 +19,7 @@ description:
* generating clients and servers in many languages using [Swagger Codegen](http://swagger.io/swagger-codegen/);
.
* and [many others](http://swagger.io/open-source-integrations/).
homepage: https://github.com/haskell-servant/servant/tree/master/servant-swagger#readme
homepage: https://github.com/haskell-servant/servant/servant-swagger
bug-reports: https://github.com/haskell-servant/servant/issues
license: BSD-3-Clause
license-file: LICENSE
@ -50,7 +50,7 @@ source-repository head
custom-setup
setup-depends:
base >=4.9 && <5,
Cabal >= 1.24,
Cabal >= 1.24 && < 3.5,
cabal-doctest >=1.0.6 && <1.1
library
@ -72,12 +72,12 @@ library
build-depends: aeson >=1.4.2.0 && <3
, aeson-pretty >=0.8.7 && <0.9
, base >=4.9.1.0 && <5
, base-compat >=0.10.5 && <0.13
, bytestring >=0.10.8.1 && <0.12
, base-compat >=0.10.5 && <0.12
, bytestring >=0.10.8.1 && <0.11
, 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
@ -92,7 +92,7 @@ test-suite doctests
build-depends:
base,
directory >= 1.0,
doctest >= 0.17 && <0.21,
doctest >= 0.17 && <0.19,
servant,
QuickCheck,
filepath
@ -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

View file

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

View file

@ -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
-- =======================================================================

View file

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

View file

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

View file

@ -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,25 +80,25 @@ library
--
-- note: mtl lower bound is so low because of GHC-7.8
build-depends:
base >= 4.9 && < 4.18
base >= 4.9 && < 4.16
, 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.
-- Here can be exceptions if we really need features from the newer versions.
build-depends:
base-compat >= 0.10.5 && < 0.13
base-compat >= 0.10.5 && < 0.12
, aeson >= 1.4.1.0 && < 3
, attoparsec >= 0.13.2.2 && < 0.15
, bifunctors >= 5.5.3 && < 5.6
@ -107,7 +106,7 @@ library
, deepseq >= 1.4.2.0 && < 1.5
, http-media >= 0.7.1.3 && < 0.9
, http-types >= 0.12.2 && < 0.13
, mmorph >= 1.1.2 && < 1.3
, mmorph >= 1.1.2 && < 1.2
, network-uri >= 2.6.1.0 && < 2.7
, QuickCheck >= 2.12.6.1 && < 2.15
, string-conversions >= 0.4.0.1 && < 0.5
@ -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

View file

@ -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,
@ -40,7 +38,6 @@ module Servant.API (
-- * Sub-APIs defined as records of routes
module Servant.API.NamedRoutes,
module Servant.API.Generic,
-- * Streaming endpoints, distinguished by HTTP method
module Servant.API.Stream,
@ -103,9 +100,6 @@ 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.HttpVersion
@ -114,8 +108,6 @@ 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 +133,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 +146,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

View file

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

View file

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

View file

@ -38,7 +38,6 @@ import GHC.TypeLits (Nat)
import Network.HTTP.Types (Status, StdMethod)
import Servant.API.ContentTypes (JSON, PlainText, FormUrlEncoded, OctetStream, NoContent, MimeRender(mimeRender), MimeUnrender(mimeUnrender))
import Servant.API.Status (KnownStatus, statusVal)
import Servant.API.ResponseHeaders (Headers)
import Servant.API.UVerb.Union
class KnownStatus (StatusOf a) => HasStatus (a :: *) where
@ -53,9 +52,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]

View file

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

View file

@ -1,3 +0,0 @@
module Servant.API.WithResource (WithResource) where
data WithResource res

View file

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

View file

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

View file

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

View file

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

View file

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