eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/master' into client-ghcjs_update-stack-file

Browse source
This commit is contained in:
Sönke Hahn 2016-07-09 11:11:52 +02:00
commit 6c5afe8fb3
90 changed files with 1543 additions and 1305 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
.travis.yml
View file

@ -3,8 +3,9 @@ sudo: false
language: c
env:
- GHCVER=7.8.4
- GHCVER=7.10.2
- GHCVER=7.8.4 CABALVER=1.22
- GHCVER=7.10.3 CABALVER=1.22
- GHCVER=8.0.1 CABALVER=1.24
addons:
apt:
@ -12,13 +13,15 @@ addons:
- hvr-ghc
packages:
- ghc-7.8.4
- ghc-7.10.2
- ghc-7.10.3
- ghc-8.0.1
- cabal-install-1.22
- cabal-install-1.24
- libgmp-dev
install:
- (mkdir -p $HOME/.local/bin && cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc)
- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.22/bin:$PATH
- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
- ghc --version
- cabal --version
- travis_retry cabal update

3
README.md
View file

@ -4,11 +4,12 @@
## Getting Started
We have a [tutorial](http://haskell-servant.github.io/tutorial) that
We have a [tutorial](http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html) that
introduces the core features of servant. After this article, you should be able
to write your first servant webservices, learning the rest from the haddocks'
examples.
The central documentation can be found [here](http://haskell-servant.readthedocs.org/).
Other blog posts, videos and slides can be found on the
[website](http://haskell-servant.github.io/).

37
doc/examples.md Normal file
View file

@ -0,0 +1,37 @@
# Example Projects
- **[example-servant-minimal](https://github.com/haskell-servant/example-servant-minimal)**:
A minimal example for a web server written using **servant-server**,
including a test-suite using [**hspec**](http://hspec.github.io/) and
**servant-client**.
- **[stack-templates](https://github.com/commercialhaskell/stack-templates)**
Repository for templates for haskell projects, including some templates using
**servant**. These templates can be used with `stack new`.
- **[custom-monad](https://github.com/themoritz/diener)**:
A custom monad that can replace `IO` in servant applications. It adds among
other things logging functionality and a reader monad (for database connections).
A full usage example of servant/diener is also provided.
- **[example-servant-elm](https://github.com/haskell-servant/example-servant-elm)**:
An example for a project consisting of
- a backend web server written using **servant-server**,
- a frontend written in [elm](http://elm-lang.org/) using
[servant-elm](https://github.com/mattjbray/servant-elm) to generate client
functions in elm for the API,
- test-suites for both the backend and the frontend.
- **[example-servant-persistent](https://github.com/haskell-servant/example-servant-persistent)**:
An example for a web server written with **servant-server** and
[persistent](https://www.stackage.org/package/persistent) for writing data
into a database.

1
doc/index.rst
View file

@ -19,4 +19,5 @@ All in a type-safe manner.
introduction.rst
tutorial/index.rst
examples.md
links.rst

2
doc/tutorial/ApiType.lhs
View file

@ -297,7 +297,7 @@ Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication).
When protecting endpoints with basic authentication, we need to specify two items:
1. The **realm** of authentication as per the Basic Authentictaion spec.
1. The **realm** of authentication as per the Basic Authentication spec.
2. The datatype returned by the server after authentication is verified. This
is usually a `User` or `Customer` type datatype.

26
doc/tutorial/Authentication.lhs
View file

@ -44,7 +44,6 @@ You can use this combinator to protect an API as follows:
module Authentication where
import Control.Monad.Trans.Except (ExceptT, throwE)
import Data.Aeson (ToJSON)
import Data.ByteString (ByteString)
import Data.Map (Map, fromList)
@ -59,13 +58,14 @@ import Servant.API ((:<|>) ((:<|>)), (:>), BasicAuth,
Get, JSON)
import Servant.API.BasicAuth (BasicAuthData (BasicAuthData))
import Servant.API.Experimental.Auth (AuthProtect)
import Servant (throwError)
import Servant.Server (BasicAuthCheck (BasicAuthCheck),
BasicAuthResult( Authorized
, Unauthorized
),
Context ((:.), EmptyContext),
err401, err403, errBody, Server,
ServantErr, serveWithContext)
serveWithContext, Handler)
import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData,
mkAuthHandler)
import Servant.Server.Experimental.Auth()
@ -117,22 +117,22 @@ or dictated the structure of a response (e.g. a `Capture` param is pulled from
the request path). Now consider an API resource protected by basic
authentication. Once the required `WWW-Authenticate` header is checked, we need
to verify the username and password. But how? One solution would be to force an
API author to provide a function of type `BasicAuthData -> ExceptT ServantErr IO User`
API author to provide a function of type `BasicAuthData -> Handler User`
and servant should use this function to authenticate a request. Unfortunately
this didn't work prior to `0.5` because all of servant's machinery was
engineered around the idea that each combinator can extract information from
only the request. We cannot extract the function
`BasicAuthData -> ExceptT ServantErr IO User` from a request! Are we doomed?
`BasicAuthData -> Handler User` from a request! Are we doomed?
Servant `0.5` introduced `Context` to handle this. The type machinery is beyond
the scope of this tutorial, but the idea is simple: provide some data to the
`serve` function, and that data is propagated to the functions that handle each
combinator. Using `Context`, we can supply a function of type
`BasicAuthData -> ExceptT ServantErr IO User` to the `BasicAuth` combinator
`BasicAuthData -> Handler User` to the `BasicAuth` combinator
handler. This will allow the handler to check authentication and return a `User`
to downstream handlers if successful.
In practice we wrap `BasicAuthData -> ExceptT ServantErr IO` into a slightly
In practice we wrap `BasicAuthData -> Handler` into a slightly
different function to better capture the semantics of basic authentication:
``` haskell ignore
@ -246,7 +246,7 @@ your feedback!
### What is Generalized Authentication?
**TL;DR**: you throw a tagged `AuthProtect` combinator in front of the endpoints
you want protected and then supply a function `Request -> ExceptT IO ServantErr user`
you want protected and then supply a function `Request -> Handler user`
which we run anytime a request matches a protected endpoint. It precisely solves
the "I just need to protect these endpoints with a function that does some
complicated business logic" and nothing more. Behind the scenes we use a type
@ -272,24 +272,24 @@ database = fromList [ ("key1", Account "Anne Briggs")
-- | A method that, when given a password, will return a Account.
-- This is our bespoke (and bad) authentication logic.
lookupAccount :: ByteString -> ExceptT ServantErr IO Account
lookupAccount :: ByteString -> Handler Account
lookupAccount key = case Map.lookup key database of
Nothing -> throwE (err403 { errBody = "Invalid Cookie" })
Nothing -> throwError (err403 { errBody = "Invalid Cookie" })
Just usr -> return usr
```
For generalized authentication, servant exposes the `AuthHandler` type,
which is used to wrap the `Request -> ExceptT IO ServantErr user` logic. Let's
which is used to wrap the `Request -> Handler user` logic. Let's
create a value of type `AuthHandler Request Account` using the above `lookupAccount`
method:
```haskell
-- | The auth handler wraps a function from Request -> ExceptT ServantErr IO Account
-- | The auth handler wraps a function from Request -> Handler Account
-- we look for a Cookie and pass the value of the cookie to `lookupAccount`.
authHandler :: AuthHandler Request Account
authHandler =
let handler req = case lookup "servant-auth-cookie" (requestHeaders req) of
Nothing -> throwE (err401 { errBody = "Missing auth header" })
Nothing -> throwError (err401 { errBody = "Missing auth header" })
Just authCookieKey -> lookupAccount authCookieKey
in mkAuthHandler handler
```
@ -379,7 +379,7 @@ forward:
2. choose a application-specific data type used by your server when
authentication is successful (in our case this was `User`).
3. Create a value of `AuthHandler Request User` which encapsulates the
authentication logic (`Request -> ExceptT IO ServantErr User`). This function
authentication logic (`Request -> Handler User`). This function
will be executed everytime a request matches a protected route.
4. Provide an instance of the `AuthServerData` type family, specifying your
application-specific data type returned when authentication is successful (in

112
doc/tutorial/Server.lhs
View file

@ -111,11 +111,11 @@ corresponding API type.
The first thing to know about the `Server` type family is that behind the
scenes it will drive the routing, letting you focus only on the business
logic. The second thing to know is that for each endpoint, your handlers will
by default run in the `ExceptT ServantErr IO` monad. This is overridable very
by default run in the `Handler` monad. This is overridable very
easily, as explained near the end of this guide. Third thing, the type of the
value returned in that monad must be the same as the second argument of the
HTTP method combinator used for the corresponding endpoint. In our case, it
means we must provide a handler of type `ExceptT ServantErr IO [User]`. Well,
means we must provide a handler of type `Handler [User]`. Well,
we have a monad, let's just `return` our list:
``` haskell
@ -269,15 +269,15 @@ server3 = position
:<|> hello
:<|> marketing
where position :: Int -> Int -> ExceptT ServantErr IO Position
where position :: Int -> Int -> Handler Position
position x y = return (Position x y)
hello :: Maybe String -> ExceptT ServantErr IO HelloMessage
hello :: Maybe String -> Handler HelloMessage
hello mname = return . HelloMessage $ case mname of
Nothing -> "Hello, anonymous coward"
Just n -> "Hello, " ++ n
marketing :: ClientInfo -> ExceptT ServantErr IO Email
marketing :: ClientInfo -> Handler Email
marketing clientinfo = return (emailForClient clientinfo)
```
@ -307,7 +307,7 @@ $ curl -X POST -d '{"clientName":"Alp Mestanogullari", "clientEmail" : "alp@foo.
For reference, here's a list of some combinators from **servant**:
> - `Delete`, `Get`, `Patch`, `Post`, `Put`: these do not become arguments. They provide the return type of handlers, which usually is `ExceptT ServantErr IO <something>`.
> - `Delete`, `Get`, `Patch`, `Post`, `Put`: these do not become arguments. They provide the return type of handlers, which usually is `Handler <something>`.
> - `Capture "something" a` becomes an argument of type `a`.
> - `QueryParam "something" a`, `Header "something" a` all become arguments of type `Maybe a`, because there might be no value at all specified by the client for these.
> - `QueryFlag "something"` gets turned into an argument of type `Bool`.
@ -601,11 +601,10 @@ $ curl -H 'Accept: text/html' http://localhost:8081/persons
# or just point your browser to http://localhost:8081/persons
```
## The `ExceptT ServantErr IO` monad
## The `Handler` monad
At the heart of the handlers is the monad they run in, namely `ExceptT
ServantErr IO`
([haddock documentation for `ExceptT`](http://hackage.haskell.org/package/mtl-2.2.1/docs/Control-Monad-Except.html#t:ExceptT)).
At the heart of the handlers is the monad they run in, namely `ExceptT ServantErr IO`
([haddock documentation for `ExceptT`](http://hackage.haskell.org/package/mtl-2.2.1/docs/Control-Monad-Except.html#t:ExceptT)), which is aliased as `Handler`.
One might wonder: why this monad? The answer is that it is the
simplest monad with the following properties:
@ -621,7 +620,7 @@ Let's recall some definitions.
newtype ExceptT e m a = ExceptT (m (Either e a))
```
In short, this means that a handler of type `ExceptT ServantErr IO a` is simply
In short, this means that a handler of type `Handler a` is simply
equivalent to a computation of type `IO (Either ServantErr a)`, that is, an IO
action that either returns an error or a result.
@ -688,7 +687,7 @@ module. If you want to use these values but add a body or some headers, just
use record update syntax:
``` haskell
failingHandler :: ExceptT ServantErr IO ()
failingHandler :: Handler ()
failingHandler = throwError myerr
where myerr :: ServantErr
@ -810,7 +809,7 @@ type UserAPI3 = -- view the user with given userid, in JSON
Capture "userid" Int :> Get '[JSON] User
:<|> -- delete the user with given userid. empty response
Capture "userid" Int :> Delete '[] ()
Capture "userid" Int :> DeleteNoContent '[JSON] NoContent
```
We can instead factor out the `userid`:
@ -818,7 +817,7 @@ We can instead factor out the `userid`:
``` haskell
type UserAPI4 = Capture "userid" Int :>
( Get '[JSON] User
:<|> Delete '[] ()
:<|> DeleteNoContent '[JSON] NoContent
)
```
@ -826,11 +825,11 @@ However, you have to be aware that this has an effect on the type of the
corresponding `Server`:
``` haskell ignore
Server UserAPI3 = (Int -> ExceptT ServantErr IO User)
:<|> (Int -> ExceptT ServantErr IO ())
Server UserAPI3 = (Int -> Handler User)
:<|> (Int -> Handler NoContent)
Server UserAPI4 = Int -> ( ExceptT ServantErr IO User
:<|> ExceptT ServantErr IO ()
Server UserAPI4 = Int -> ( Handler User
:<|> Handler NoContent
)
```
@ -842,10 +841,10 @@ computations in `ExceptT`, with no arguments. In other words:
server8 :: Server UserAPI3
server8 = getUser :<|> deleteUser
where getUser :: Int -> ExceptT ServantErr IO User
where getUser :: Int -> Handler User
getUser _userid = error "..."
deleteUser :: Int -> ExceptT ServantErr IO ()
deleteUser :: Int -> Handler NoContent
deleteUser _userid = error "..."
-- notice how getUser and deleteUser
@ -854,10 +853,10 @@ server8 = getUser :<|> deleteUser
server9 :: Server UserAPI4
server9 userid = getUser userid :<|> deleteUser userid
where getUser :: Int -> ExceptT ServantErr IO User
where getUser :: Int -> Handler User
getUser = error "..."
deleteUser :: Int -> ExceptT ServantErr IO ()
deleteUser :: Int -> Handler NoContent
deleteUser = error "..."
```
@ -876,13 +875,13 @@ type API1 = "users" :>
-- we factor out the Request Body
type API2 = ReqBody '[JSON] User :>
( Get '[JSON] User -- just display the same user back, don't register it
:<|> Post '[JSON] () -- register the user. empty response
:<|> PostNoContent '[JSON] NoContent -- register the user. empty response
)
-- we factor out a Header
type API3 = Header "Authorization" Token :>
( Get '[JSON] SecretData -- get some secret data, if authorized
:<|> ReqBody '[JSON] SecretData :> Post '[] () -- add some secret data, if authorized
:<|> ReqBody '[JSON] SecretData :> PostNoContent '[JSON] NoContent -- add some secret data, if authorized
)
newtype Token = Token ByteString
@ -895,44 +894,44 @@ API type only at the end.
``` haskell
type UsersAPI =
Get '[JSON] [User] -- list users
:<|> ReqBody '[JSON] User :> Post '[] () -- add a user
:<|> ReqBody '[JSON] User :> PostNoContent '[JSON] NoContent -- add a user
:<|> Capture "userid" Int :>
( Get '[JSON] User -- view a user
:<|> ReqBody '[JSON] User :> Put '[] () -- update a user
:<|> Delete '[] () -- delete a user
:<|> ReqBody '[JSON] User :> PutNoContent '[JSON] NoContent -- update a user
:<|> DeleteNoContent '[JSON] NoContent -- delete a user
)
usersServer :: Server UsersAPI
usersServer = getUsers :<|> newUser :<|> userOperations
where getUsers :: ExceptT ServantErr IO [User]
where getUsers :: Handler [User]
getUsers = error "..."
newUser :: User -> ExceptT ServantErr IO ()
newUser :: User -> Handler NoContent
newUser = error "..."
userOperations userid =
viewUser userid :<|> updateUser userid :<|> deleteUser userid
where
viewUser :: Int -> ExceptT ServantErr IO User
viewUser :: Int -> Handler User
viewUser = error "..."
updateUser :: Int -> User -> ExceptT ServantErr IO ()
updateUser :: Int -> User -> Handler NoContent
updateUser = error "..."
deleteUser :: Int -> ExceptT ServantErr IO ()
deleteUser :: Int -> Handler NoContent
deleteUser = error "..."
```
``` haskell
type ProductsAPI =
Get '[JSON] [Product] -- list products
:<|> ReqBody '[JSON] Product :> Post '[] () -- add a product
:<|> ReqBody '[JSON] Product :> PostNoContent '[JSON] NoContent -- add a product
:<|> Capture "productid" Int :>
( Get '[JSON] Product -- view a product
:<|> ReqBody '[JSON] Product :> Put '[] () -- update a product
:<|> Delete '[] () -- delete a product
:<|> ReqBody '[JSON] Product :> PutNoContent '[JSON] NoContent -- update a product
:<|> DeleteNoContent '[JSON] NoContent -- delete a product
)
data Product = Product { productId :: Int }
@ -940,23 +939,23 @@ data Product = Product { productId :: Int }
productsServer :: Server ProductsAPI
productsServer = getProducts :<|> newProduct :<|> productOperations
where getProducts :: ExceptT ServantErr IO [Product]
where getProducts :: Handler [Product]
getProducts = error "..."
newProduct :: Product -> ExceptT ServantErr IO ()
newProduct :: Product -> Handler NoContent
newProduct = error "..."
productOperations productid =
viewProduct productid :<|> updateProduct productid :<|> deleteProduct productid
where
viewProduct :: Int -> ExceptT ServantErr IO Product
viewProduct :: Int -> Handler Product
viewProduct = error "..."
updateProduct :: Int -> Product -> ExceptT ServantErr IO ()
updateProduct :: Int -> Product -> Handler NoContent
updateProduct = error "..."
deleteProduct :: Int -> ExceptT ServantErr IO ()
deleteProduct :: Int -> Handler NoContent
deleteProduct = error "..."
```
@ -976,20 +975,20 @@ abstract that away:
-- indexed by values of type 'i'
type APIFor a i =
Get '[JSON] [a] -- list 'a's
:<|> ReqBody '[JSON] a :> Post '[] () -- add an 'a'
:<|> ReqBody '[JSON] a :> PostNoContent '[JSON] NoContent -- add an 'a'
:<|> Capture "id" i :>
( Get '[JSON] a -- view an 'a' given its "identifier" of type 'i'
:<|> ReqBody '[JSON] a :> Put '[] () -- update an 'a'
:<|> Delete '[] () -- delete an 'a'
:<|> ReqBody '[JSON] a :> PutNoContent '[JSON] NoContent -- update an 'a'
:<|> DeleteNoContent '[JSON] NoContent -- delete an 'a'
)
-- Build the appropriate 'Server'
-- given the handlers of the right type.
serverFor :: ExceptT ServantErr IO [a] -- handler for listing of 'a's
-> (a -> ExceptT ServantErr IO ()) -- handler for adding an 'a'
-> (i -> ExceptT ServantErr IO a) -- handler for viewing an 'a' given its identifier of type 'i'
-> (i -> a -> ExceptT ServantErr IO ()) -- updating an 'a' with given id
-> (i -> ExceptT ServantErr IO ()) -- deleting an 'a' given its id
serverFor :: Handler [a] -- handler for listing of 'a's
-> (a -> Handler NoContent) -- handler for adding an 'a'
-> (i -> Handler a) -- handler for viewing an 'a' given its identifier of type 'i'
-> (i -> a -> Handler NoContent) -- updating an 'a' with given id
-> (i -> Handler NoContent) -- deleting an 'a' given its id
-> Server (APIFor a i)
serverFor = error "..."
-- implementation left as an exercise. contact us on IRC
@ -998,12 +997,11 @@ serverFor = error "..."
## Using another monad for your handlers
Remember how `Server` turns combinators for HTTP methods into `ExceptT
ServantErr IO`? Well, actually, there's more to that. `Server` is actually a
Remember how `Server` turns combinators for HTTP methods into `Handler`? Well, actually, there's more to that. `Server` is actually a
simple type synonym.
``` haskell ignore
type Server api = ServerT api (ExceptT ServantErr IO)
type Server api = ServerT api Handler
```
`ServerT` is the actual type family that computes the required types for the
@ -1036,12 +1034,11 @@ listToMaybeNat = Nat listToMaybe -- from Data.Maybe
(`Nat` comes from "natural transformation", in case you're wondering.)
So if you want to write handlers using another monad/type than `ExceptT
ServantErr IO`, say the `Reader String` monad, the first thing you have to
So if you want to write handlers using another monad/type than `Handler`, say the `Reader String` monad, the first thing you have to
prepare is a function:
``` haskell ignore
readerToHandler :: Reader String :~> ExceptT ServantErr IO
readerToHandler :: Reader String :~> Handler
```
Let's start with `readerToHandler'`. We obviously have to run the `Reader`
@ -1050,10 +1047,10 @@ from that and can then just `return` it into `ExceptT`. We can then just wrap
that function with the `Nat` constructor to make it have the fancier type.
``` haskell
readerToHandler' :: forall a. Reader String a -> ExceptT ServantErr IO a
readerToHandler' :: forall a. Reader String a -> Handler a
readerToHandler' r = return (runReader r "hi")
readerToHandler :: Reader String :~> ExceptT ServantErr IO
readerToHandler :: Reader String :~> Handler
readerToHandler = Nat readerToHandler'
```
@ -1077,8 +1074,7 @@ readerServerT = a :<|> b
```
We unfortunately can't use `readerServerT` as an argument of `serve`, because
`serve` wants a `Server ReaderAPI`, i.e., with handlers running in `ExceptT
ServantErr IO`. But there's a simple solution to this.
`serve` wants a `Server ReaderAPI`, i.e., with handlers running in `Handler`. But there's a simple solution to this.
### Enter `enter`

10
doc/tutorial/index.rst
View file

@ -3,14 +3,8 @@ Tutorial
This is an introductory tutorial to **servant**.
.. note::
This tutorial is for the latest version of servant. The tutorial for
servant-0.4 can be viewed
`here <https://haskell-servant.github.io/tutorial/>`_.
(Any comments, issues or feedback about the tutorial can be handled
through
`servant's issue tracker <http://github.com/haskell-servant/servant/issues>`_.)
(Any comments, issues or feedback about the tutorial can be submitted
to `servant's issue tracker <http://github.com/haskell-servant/servant/issues>`_.)
.. toctree::

22
doc/tutorial/tutorial.cabal
View file

@ -1,7 +1,7 @@
name: tutorial
version: 0.6
version: 0.7.1
synopsis: The servant tutorial
homepage: http://haskell-servant.github.io/
homepage: http://haskell-servant.readthedocs.org/
license: BSD3
license-file: LICENSE
author: Servant Contributors
@ -25,11 +25,11 @@ library
, directory
, blaze-markup
, containers
, servant == 0.6.*
, servant-server == 0.6.*
, servant-client == 0.6.*
, servant-docs == 0.6.*
, servant-js == 0.6.*
, servant == 0.7.*
, servant-server == 0.7.*
, servant-client == 0.7.*
, servant-docs == 0.7.*
, servant-js == 0.7.*
, warp
, http-media
, lucid
@ -46,15 +46,11 @@ library
, markdown-unlit >= 0.4
, http-client
default-language: Haskell2010
ghc-options: -Wall -Werror -pgmL markdown-unlit
-- to silence aeson-0.10 warnings:
ghc-options: -fno-warn-missing-methods
ghc-options: -fno-warn-name-shadowing
ghc-options: -Wall -pgmL markdown-unlit
test-suite spec
type: exitcode-stdio-1.0
ghc-options:
-Wall -fno-warn-name-shadowing -fno-warn-missing-signatures
ghc-options: -Wall
default-language: Haskell2010
hs-source-dirs: test
main-is: Spec.hs

11
scripts/test-stack.sh Executable file
View file

@ -0,0 +1,11 @@
#!/usr/bin/env bash
set -o nounset
set -o errexit
for stack_file in stack*.yaml ; do
echo testing $stack_file...
export STACK_YAML=$stack_file
stack setup
stack test --fast --ghc-options="-Werror"
done

2
scripts/upload.hs
View file

@ -11,4 +11,4 @@ main :: IO ()
main = do
sources <- words <$> readFile "sources.txt"
forM_ sources $ \ source -> do
callCommand ("stack upload " ++ source)
callCommand ("stack upload --no-signature " ++ source)

30
servant-blaze/LICENSE
View file

@ -1,30 +0,0 @@
Copyright (c) 2015-2016, Servant Contributors
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Julian K. Arni nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

2
servant-blaze/Setup.hs
View file

@ -1,2 +0,0 @@
import Distribution.Simple
main = defaultMain

8
servant-blaze/include/overlapping-compat.h
View file

@ -1,8 +0,0 @@
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

33
servant-blaze/servant-blaze.cabal
View file

@ -1,33 +0,0 @@
-- Initial servant-blaze.cabal generated by cabal init. For further
-- documentation, see http://haskell.org/cabal/users-guide/
name: servant-blaze
version: 0.6
synopsis: Blaze-html support for servant
-- description:
homepage: http://haskell-servant.github.io/
license: BSD3
license-file: LICENSE
author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com
copyright: 2015-2016 Servant Contributors
category: Web
build-type: Simple
extra-source-files: include/*.h
cabal-version: >=1.10
bug-reports: http://github.com/haskell-servant/servant/issues
source-repository head
type: git
location: http://github.com/haskell-servant/servant.git
library
exposed-modules: Servant.HTML.Blaze
-- other-modules:
-- other-extensions:
build-depends: base >=4.7 && <5
, servant == 0.6.*
, http-media
, blaze-html
hs-source-dirs: src
default-language: Haskell2010
include-dirs: include

35
servant-blaze/src/Servant/HTML/Blaze.hs
View file

@ -1,35 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
#include "overlapping-compat.h"
-- | An @HTML@ empty data type with `MimeRender` instances for @blaze-html@'s
-- `ToMarkup` class and `Html` datatype.
-- You should only need to import this module for it's instances and the
-- `HTML` datatype.:
--
-- >>> type Eg = Get '[HTML] a
--
-- Will then check that @a@ has a `ToMarkup` instance, or is `Html`.
module Servant.HTML.Blaze where
import Data.Typeable (Typeable)
import qualified Network.HTTP.Media as M
import Servant.API (Accept (..), MimeRender (..))
import Text.Blaze.Html (Html, ToMarkup, toHtml)
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
data HTML deriving Typeable
-- | @text/html;charset=utf-8@
instance Accept HTML where
contentType _ = "text" M.// "html" M./: ("charset", "utf-8")
instance OVERLAPPABLE_ ToMarkup a => MimeRender HTML a where
mimeRender _ = renderHtml . toHtml
instance OVERLAPPING_ MimeRender HTML Html where
mimeRender _ = renderHtml

3
servant-blaze/tinc.yaml
View file

@ -1,3 +0,0 @@
dependencies:
- name: servant
path: ../servant

30
servant-cassava/LICENSE
View file

@ -1,30 +0,0 @@
Copyright (c) 2015-2016, Servant Contributors
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Julian K. Arni nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

2
servant-cassava/Setup.hs
View file

@ -1,2 +0,0 @@
import Distribution.Simple
main = defaultMain

8
servant-cassava/include/overlapping-compat.h
View file

@ -1,8 +0,0 @@
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

30
servant-cassava/servant-cassava.cabal
View file

@ -1,30 +0,0 @@
-- Initial servant-cassava.cabal generated by cabal init. For further
-- documentation, see http://haskell.org/cabal/users-guide/
name: servant-cassava
version: 0.6
synopsis: Servant CSV content-type for cassava
-- description:
homepage: http://haskell-servant.github.io/
license: BSD3
license-file: LICENSE
author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com
copyright: 2015-2016 Servant Contributors
-- category:
build-type: Simple
extra-source-files: include/*.h
cabal-version: >=1.10
library
exposed-modules: Servant.CSV.Cassava
-- other-modules:
-- other-extensions:
build-depends: base >=4.6 && <5
, cassava >0.4 && <0.5
, servant == 0.6.*
, http-media
, vector
hs-source-dirs: src
default-language: Haskell2010
include-dirs: include

115
servant-cassava/src/Servant/CSV/Cassava.hs
View file

@ -1,115 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | A @CSV@ empty datatype with `MimeRender` and `MimeUnrender` instances for
-- @cassava@'s encoding and decoding classes.
--
-- >>> type Eg = Get '[(CSV', MyEncodeOptions)] [(Int, String)]
--
-- Default encoding and decoding options are also provided, along with the
-- @CSV@ type synonym that uses them.
--
-- >>> type EgDefault = Get '[CSV] [(Int, String)]
module Servant.CSV.Cassava where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Data.Csv
import Data.Proxy (Proxy (..))
import Data.Typeable (Typeable)
import Data.Vector (Vector, toList)
import GHC.Generics (Generic)
import qualified Network.HTTP.Media as M
import Servant.API (Accept (..), MimeRender (..),
MimeUnrender (..))
data CSV' deriving (Typeable, Generic)
type CSV = (CSV', DefaultDecodeOpts)
-- | @text/csv;charset=utf-8@
instance Accept (CSV', a) where
contentType _ = "text" M.// "csv" M./: ("charset", "utf-8")
-- * Encoding
-- ** Instances
-- | Encode with 'encodeByNameWith'. The 'Header' param is used for determining
-- the order of headers and fields.
instance ( ToNamedRecord a, EncodeOpts opt
) => MimeRender (CSV', opt) (Header, [a]) where
mimeRender _ (hdr, vals) = encodeByNameWith (encodeOpts p) hdr vals
where p = Proxy :: Proxy opt
-- | Encode with 'encodeDefaultOrderedByNameWith'
instance ( DefaultOrdered a, ToNamedRecord a, EncodeOpts opt
) => MimeRender (CSV', opt) [a] where
mimeRender _ = encodeDefaultOrderedByNameWith (encodeOpts p)
where p = Proxy :: Proxy opt
-- | Encode with 'encodeByNameWith'. The 'Header' param is used for determining
-- the order of headers and fields.
instance ( ToNamedRecord a, EncodeOpts opt
) => MimeRender (CSV', opt) (Header, Vector a) where
mimeRender _ (hdr, vals) = encodeByNameWith (encodeOpts p) hdr (toList vals)
where p = Proxy :: Proxy opt
-- | Encode with 'encodeDefaultOrderedByNameWith'
instance ( DefaultOrdered a, ToNamedRecord a, EncodeOpts opt
) => MimeRender (CSV', opt) (Vector a) where
mimeRender _ = encodeDefaultOrderedByNameWith (encodeOpts p) . toList
where p = Proxy :: Proxy opt
-- ** Encode Options
class EncodeOpts a where
encodeOpts :: Proxy a -> EncodeOptions
data DefaultEncodeOpts deriving (Typeable, Generic)
instance EncodeOpts DefaultEncodeOpts where
encodeOpts _ = defaultEncodeOptions
-- * Decoding
-- ** Instances
-- | Decode with 'decodeByNameWith'
instance ( FromNamedRecord a, DecodeOpts opt
) => MimeUnrender (CSV', opt) (Header, [a]) where
mimeUnrender _ bs = fmap toList <$> decodeByNameWith (decodeOpts p) bs
where p = Proxy :: Proxy opt
-- | Decode with 'decodeWith'. Assumes data has headers, which are stripped.
instance ( FromRecord a, DecodeOpts opt
) => MimeUnrender (CSV', opt) [a] where
mimeUnrender _ bs = toList <$> decodeWith (decodeOpts p) HasHeader bs
where p = Proxy :: Proxy opt
instance ( FromNamedRecord a, DecodeOpts opt
) => MimeUnrender (CSV', opt) (Header, Vector a) where
mimeUnrender _ = decodeByNameWith (decodeOpts p)
where p = Proxy :: Proxy opt
-- | Decode with 'decodeWith'. Assumes data has headers, which are stripped.
instance ( FromRecord a, DecodeOpts opt
) => MimeUnrender (CSV', opt) (Vector a) where
mimeUnrender _ = decodeWith (decodeOpts p) HasHeader
where p = Proxy :: Proxy opt
-- ** Decode Options
class DecodeOpts a where
decodeOpts :: Proxy a -> DecodeOptions
data DefaultDecodeOpts deriving (Typeable, Generic)
instance DecodeOpts DefaultDecodeOpts where
decodeOpts _ = defaultDecodeOptions

3
servant-cassava/tinc.yaml
View file

@ -1,3 +0,0 @@
dependencies:
- name: servant
path: ../servant

6
servant-client/CHANGELOG.md
View file

@ -1,3 +1,9 @@
0.7.1
-----
* Support GHC 8.0
* `ServantError` has an `Eq` instance now.
0.6
---

7
servant-client/README.md
View file

@ -13,9 +13,8 @@ type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
myApi :: Proxy MyApi
myApi = Proxy
getAllBooks :: ExceptT String IO [Book]
postNewBook :: Book -> ExceptT String IO Book
getAllBooks :: Manager -> BaseUrl -> ExceptT String IO [Book]
postNewBook :: Book -> Manager -> BaseUrl -> ExceptT String IO Book
-- 'client' allows you to produce operations to query an API from a client.
(getAllBooks :<|> postNewBook) = client myApi host
where host = BaseUrl Http "localhost" 8080
(getAllBooks :<|> postNewBook) = client myApi
```

25
servant-client/servant-client.cabal
View file

@ -1,11 +1,11 @@
name: servant-client
version: 0.6
version: 0.7.1
synopsis: automatical derivation of querying functions for servant webservices
description:
This library lets you derive automatically Haskell functions that
let you query each endpoint of a <http://hackage.haskell.org/package/servant servant> webservice.
.
See <http://haskell-servant.github.io/tutorial/client.html the client section of the tutorial>.
See <http://haskell-servant.readthedocs.org/en/stable/tutorial/Client.html the client section of the tutorial>.
.
<https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG>
license: BSD3
@ -15,11 +15,14 @@ maintainer: haskell-servant-maintainers@googlegroups.com
copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors
category: Web
build-type: Simple
extra-source-files: include/*.h
cabal-version: >=1.10
tested-with: GHC >= 7.8
homepage: http://haskell-servant.github.io/
homepage: http://haskell-servant.readthedocs.org/
Bug-reports: http://github.com/haskell-servant/servant/issues
extra-source-files:
include/*.h
CHANGELOG.md
README.md
source-repository head
type: git
location: http://github.com/haskell-servant/servant.git
@ -49,13 +52,13 @@ library
, case-insensitive
, exceptions
, http-api-data >= 0.1 && < 0.3
, http-client
, http-client <0.5
, http-client-tls
, http-media
, http-types
, network-uri >= 2.6
, safe
, servant == 0.6.*
, servant == 0.7.*
, string-conversions
, text
, transformers
@ -67,12 +70,13 @@ library
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall
if impl(ghc >= 8.0)
ghc-options: -Wno-redundant-constraints
include-dirs: include
test-suite spec
type: exitcode-stdio-1.0
ghc-options:
-Wall -fno-warn-name-shadowing -fno-warn-missing-signatures
ghc-options: -Wall -fno-warn-name-shadowing
default-language: Haskell2010
hs-source-dirs: test, src
main-is: Spec.hs
@ -92,6 +96,7 @@ test-suite spec
Servant.Client.TestServer.GHC
build-depends:
base == 4.*
, base-compat
, transformers
, transformers-compat
, aeson
@ -105,8 +110,8 @@ test-suite spec
, HUnit
, network >= 2.6
, QuickCheck >= 2.7
, servant == 0.6.*
, servant-server == 0.6.*
, servant == 0.7.*
, servant-server == 0.7.*
, text
, wai
, warp

85
servant-client/src/Servant/Client.hs
View file

@ -19,6 +19,7 @@ module Servant.Client
, AuthenticateReq(..)
, client
, HasClient(..)
, ClientM
, mkAuthenticateReq
, ServantError(..)
, module Servant.Common.BaseUrl
@ -57,15 +58,15 @@ import Servant.Client.PerformRequest (ServantError(..))
-- > getAllBooks :: Manager -> BaseUrl -> ClientM [Book]
-- > postNewBook :: Book -> Manager -> BaseUrl -> ClientM Book
-- > (getAllBooks :<|> postNewBook) = client myApi
client :: HasClient layout => Proxy layout -> Client layout
client :: HasClient api => Proxy api -> Client api
client p = clientWithRoute p defReq
-- | This class lets us define how each API combinator
-- influences the creation of an HTTP request. It's mostly
-- an internal class, you can just use 'client'.
class HasClient layout where
type Client layout :: *
clientWithRoute :: Proxy layout -> Req -> Client layout
class HasClient api where
type Client api :: *
clientWithRoute :: Proxy api -> Req -> Client api
-- | A client querying function for @a ':<|>' b@ will actually hand you
@ -106,14 +107,14 @@ instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
-- > getBook :: Text -> Manager -> BaseUrl -> ClientM Book
-- > getBook = client myApi
-- > -- then you can just use "getBook" to query that endpoint
instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout)
=> HasClient (Capture capture a :> sublayout) where
instance (KnownSymbol capture, ToHttpApiData a, HasClient api)
=> HasClient (Capture capture a :> api) where
type Client (Capture capture a :> sublayout) =
a -> Client sublayout
type Client (Capture capture a :> api) =
a -> Client api
clientWithRoute Proxy req val =
clientWithRoute (Proxy :: Proxy sublayout)
clientWithRoute (Proxy :: Proxy api)
(appendToPath p req)
where p = unpack (toUrlPiece val)
@ -186,14 +187,14 @@ instance OVERLAPPING_
-- > viewReferer = client myApi
-- > -- then you can just use "viewRefer" to query that endpoint
-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
=> HasClient (Header sym a :> sublayout) where
instance (KnownSymbol sym, ToHttpApiData a, HasClient api)
=> HasClient (Header sym a :> api) where
type Client (Header sym a :> sublayout) =
Maybe a -> Client sublayout
type Client (Header sym a :> api) =
Maybe a -> Client api
clientWithRoute Proxy req mval =
clientWithRoute (Proxy :: Proxy sublayout)
clientWithRoute (Proxy :: Proxy api)
(maybe req
(\value -> Servant.Common.Req.addHeader hname value req)
mval
@ -203,14 +204,14 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
-- | Using a 'HttpVersion' combinator in your API doesn't affect the client
-- functions.
instance HasClient sublayout
=> HasClient (HttpVersion :> sublayout) where
instance HasClient api
=> HasClient (HttpVersion :> api) where
type Client (HttpVersion :> sublayout) =
Client sublayout
type Client (HttpVersion :> api) =
Client api
clientWithRoute Proxy =
clientWithRoute (Proxy :: Proxy sublayout)
clientWithRoute (Proxy :: Proxy api)
-- | If you use a 'QueryParam' in one of your endpoints in your API,
-- the corresponding querying function will automatically take
@ -237,15 +238,15 @@ instance HasClient sublayout
-- > -- then you can just use "getBooksBy" to query that endpoint.
-- > -- 'getBooksBy Nothing' for all books
-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
=> HasClient (QueryParam sym a :> sublayout) where
instance (KnownSymbol sym, ToHttpApiData a, HasClient api)
=> HasClient (QueryParam sym a :> api) where
type Client (QueryParam sym a :> sublayout) =
Maybe a -> Client sublayout
type Client (QueryParam sym a :> api) =
Maybe a -> Client api
-- if mparam = Nothing, we don't add it to the query string
clientWithRoute Proxy req mparam =
clientWithRoute (Proxy :: Proxy sublayout)
clientWithRoute (Proxy :: Proxy api)
(maybe req
(flip (appendToQueryString pname) req . Just)
mparamText
@ -282,14 +283,14 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
-- > -- 'getBooksBy []' for all books
-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
-- > -- to get all books by Asimov and Heinlein
instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
=> HasClient (QueryParams sym a :> sublayout) where
instance (KnownSymbol sym, ToHttpApiData a, HasClient api)
=> HasClient (QueryParams sym a :> api) where
type Client (QueryParams sym a :> sublayout) =
[a] -> Client sublayout
type Client (QueryParams sym a :> api) =
[a] -> Client api
clientWithRoute Proxy req paramlist =
clientWithRoute (Proxy :: Proxy sublayout)
clientWithRoute (Proxy :: Proxy api)
(foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))
req
paramlist'
@ -320,14 +321,14 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
-- > -- then you can just use "getBooks" to query that endpoint.
-- > -- 'getBooksBy False' for all books
-- > -- 'getBooksBy True' to only get _already published_ books
instance (KnownSymbol sym, HasClient sublayout)
=> HasClient (QueryFlag sym :> sublayout) where
instance (KnownSymbol sym, HasClient api)
=> HasClient (QueryFlag sym :> api) where
type Client (QueryFlag sym :> sublayout) =
Bool -> Client sublayout
type Client (QueryFlag sym :> api) =
Bool -> Client api
clientWithRoute Proxy req flag =
clientWithRoute (Proxy :: Proxy sublayout)
clientWithRoute (Proxy :: Proxy api)
(if flag
then appendToQueryString paramname Nothing req
else req
@ -364,14 +365,14 @@ instance HasClient Raw where
-- > addBook :: Book -> Manager -> BaseUrl -> ClientM Book
-- > addBook = client myApi
-- > -- then you can just use "addBook" to query that endpoint
instance (MimeRender ct a, HasClient sublayout)
=> HasClient (ReqBody (ct ': cts) a :> sublayout) where
instance (MimeRender ct a, HasClient api)
=> HasClient (ReqBody (ct ': cts) a :> api) where
type Client (ReqBody (ct ': cts) a :> sublayout) =
a -> Client sublayout
type Client (ReqBody (ct ': cts) a :> api) =
a -> Client api
clientWithRoute Proxy req body =
clientWithRoute (Proxy :: Proxy sublayout)
clientWithRoute (Proxy :: Proxy api)
(let ctProxy = Proxy :: Proxy ct
in setRQBody (mimeRender ctProxy body)
(contentType ctProxy)
@ -379,11 +380,11 @@ instance (MimeRender ct a, HasClient sublayout)
)
-- | Make the querying function append @path@ to the request path.
instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
type Client (path :> sublayout) = Client sublayout
instance (KnownSymbol path, HasClient api) => HasClient (path :> api) where
type Client (path :> api) = Client api
clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy sublayout)
clientWithRoute (Proxy :: Proxy api)
(appendToPath p req)
where p = symbolVal (Proxy :: Proxy path)

13
servant-client/src/Servant/Client/PerformRequest/Base.hs
View file

@ -32,4 +32,17 @@ data ServantError
}
deriving (Show, Typeable)
instance Eq ServantError where
FailureResponse a b c == FailureResponse x y z =
(a, b, c) == (x, y, z)
DecodeFailure a b c == DecodeFailure x y z =
(a, b, c) == (x, y, z)
UnsupportedContentType a b == UnsupportedContentType x y =
(a, b) == (x, y)
InvalidContentTypeHeader a b == InvalidContentTypeHeader x y =
(a, b) == (x, y)
ConnectionError a == ConnectionError x =
show a == show x
_ == _ = False
instance Exception ServantError

10
servant-client/src/Servant/Common/Req.hs
View file

@ -2,6 +2,11 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
#if MIN_VERSION_base(4,9,0)
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
#endif
module Servant.Common.Req where
#if !MIN_VERSION_base(4,8,0)
@ -63,7 +68,7 @@ setRQBody b t req = req { reqBody = Just (b, t) }
reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
setheaders . setAccept . setrqb . setQS <$> parseUrl url
setheaders . setAccept . setrqb . setQS <$> parseUrlThrow url
where url = show $ nullURI { uriScheme = case reqScheme of
Http -> "http:"
@ -89,6 +94,9 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
| not . null . reqAccept $ req] }
toProperHeader (name, val) =
(fromString name, encodeUtf8 val)
#if !MIN_VERSION_http_client(0,4,30)
parseUrlThrow = parseUrl
#endif
-- * performing requests

13
servant-client/test/Servant/ClientSpec.hs
View file

@ -13,14 +13,18 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#if __GLASGOW_HASKELL__ >= 800
{-# OPTIONS_GHC -freduction-depth=100 #-}
#else
{-# OPTIONS_GHC -fcontext-stack=100 #-}
#endif
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Servant.ClientSpec where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Prelude ()
import Prelude.Compat
import Control.Arrow (left)
import Control.Monad.Trans.Except (runExceptT, throwE)
import Data.Aeson
@ -36,7 +40,7 @@ import Network.HTTP.Media
import qualified Network.HTTP.Types as HTTP
import Network.Wai (responseLBS)
import qualified Network.Wai as Wai
import System.Exit
import System.Exit.Compat
import System.IO.Unsafe (unsafePerformIO)
import Test.HUnit
import Test.Hspec
@ -432,7 +436,6 @@ failSpec = around (withTestServer "failServer") $ do
InvalidContentTypeHeader "fooooo" _ -> return ()
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
-- * utils
pathGen :: Gen (NonEmptyList Char)

10
servant-docs/CHANGELOG.md
View file

@ -1,3 +1,13 @@
0.7.1
-----
* Support GHC 8.0
0.7
---
* Use `throwError` instead of `throwE` in documentation
0.5
----

9
servant-docs/servant-docs.cabal
View file

@ -1,5 +1,5 @@
name: servant-docs
version: 0.6
version: 0.7.1
synopsis: generate API docs for your servant webservice
description:
Library for generating API docs from a servant API definition.
@ -16,7 +16,7 @@ category: Web
build-type: Simple
cabal-version: >=1.10
tested-with: GHC >= 7.8
homepage: http://haskell-servant.github.io/
homepage: http://haskell-servant.readthedocs.org/
Bug-reports: http://github.com/haskell-servant/servant/issues
extra-source-files:
include/*.h
@ -42,7 +42,7 @@ library
, http-media >= 0.6
, http-types >= 0.7
, lens
, servant == 0.6.*
, servant == 0.7.*
, string-conversions
, text
, unordered-containers
@ -50,6 +50,8 @@ library
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall
if impl(ghc >= 8.0)
ghc-options: -Wno-redundant-constraints
include-dirs: include
executable greet-docs
@ -82,4 +84,3 @@ test-suite spec
, servant-docs
, string-conversions
default-language: Haskell2010

106
servant-docs/src/Servant/Docs/Internal.hs
View file

@ -163,7 +163,7 @@ data DocNote = DocNote
--
-- These are intended to be built using extraInfo.
-- Multiple ExtraInfo may be combined with the monoid instance.
newtype ExtraInfo layout = ExtraInfo (HashMap Endpoint Action)
newtype ExtraInfo api = ExtraInfo (HashMap Endpoint Action)
instance Monoid (ExtraInfo a) where
mempty = ExtraInfo mempty
ExtraInfo a `mappend` ExtraInfo b =
@ -300,11 +300,11 @@ makeLenses ''Action
-- default way to create documentation.
--
-- prop> docs == docsWithOptions defaultDocOptions
docs :: HasDocs layout => Proxy layout -> API
docs :: HasDocs api => Proxy api -> API
docs p = docsWithOptions p defaultDocOptions
-- | Generate the docs for a given API that implements 'HasDocs'.
docsWithOptions :: HasDocs layout => Proxy layout -> DocOptions -> API
docsWithOptions :: HasDocs api => Proxy api -> DocOptions -> API
docsWithOptions p = docsFor p (defEndpoint, defAction)
-- | Closed type family, check if endpoint is exactly within API.
@ -316,7 +316,7 @@ type family IsIn (endpoint :: *) (api :: *) :: Constraint where
IsIn (e :> sa) (e :> sb) = IsIn sa sb
IsIn e e = ()
-- | Create an 'ExtraInfo' that is garunteed to be within the given API layout.
-- | Create an 'ExtraInfo' that is guaranteed to be within the given API layout.
--
-- The safety here is to ensure that you only add custom documentation to an
-- endpoint that actually exists within your API.
@ -329,8 +329,8 @@ type family IsIn (endpoint :: *) (api :: *) :: Constraint where
-- > , DocNote "Second secton" ["And some more"]
-- > ]
extraInfo :: (IsIn endpoint layout, HasLink endpoint, HasDocs endpoint)
=> Proxy endpoint -> Action -> ExtraInfo layout
extraInfo :: (IsIn endpoint api, HasLink endpoint, HasDocs endpoint)
=> Proxy endpoint -> Action -> ExtraInfo api
extraInfo p action =
let api = docsFor p (defEndpoint, defAction) defaultDocOptions
-- Assume one endpoint, HasLink constraint means that we should only ever
@ -349,7 +349,7 @@ extraInfo p action =
-- 'extraInfo'.
--
-- If you only want to add an introduction, use 'docsWithIntros'.
docsWith :: HasDocs layout => DocOptions -> [DocIntro] -> ExtraInfo layout -> Proxy layout -> API
docsWith :: HasDocs api => DocOptions -> [DocIntro] -> ExtraInfo api -> Proxy api -> API
docsWith opts intros (ExtraInfo endpoints) p =
docsWithOptions p opts
& apiIntros <>~ intros
@ -358,13 +358,13 @@ docsWith opts intros (ExtraInfo endpoints) p =
-- | Generate the docs for a given API that implements 'HasDocs' with with any
-- number of introduction(s)
docsWithIntros :: HasDocs layout => [DocIntro] -> Proxy layout -> API
docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API
docsWithIntros intros = docsWith defaultDocOptions intros mempty
-- | The class that abstracts away the impact of API combinators
-- on documentation generation.
class HasDocs layout where
docsFor :: Proxy layout -> (Endpoint, Action) -> DocOptions -> API
class HasDocs api where
docsFor :: Proxy api -> (Endpoint, Action) -> DocOptions -> API
-- | The class that lets us display a sample input or output in the supported
-- content-types when generating documentation for endpoints that either:
@ -675,26 +675,26 @@ markdown api = unlines $
-- | The generated docs for @a ':<|>' b@ just appends the docs
-- for @a@ with the docs for @b@.
instance OVERLAPPABLE_
(HasDocs layout1, HasDocs layout2)
=> HasDocs (layout1 :<|> layout2) where
(HasDocs a, HasDocs b)
=> HasDocs (a :<|> b) where
docsFor Proxy (ep, action) = docsFor p1 (ep, action) <> docsFor p2 (ep, action)
where p1 :: Proxy layout1
where p1 :: Proxy a
p1 = Proxy
p2 :: Proxy layout2
p2 :: Proxy b
p2 = Proxy
-- | @"books" :> 'Capture' "isbn" Text@ will appear as
-- @/books/:isbn@ in the docs.
instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout)
=> HasDocs (Capture sym a :> sublayout) where
instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)
=> HasDocs (Capture sym a :> api) where
docsFor Proxy (endpoint, action) =
docsFor sublayoutP (endpoint', action')
docsFor subApiP (endpoint', action')
where sublayoutP = Proxy :: Proxy sublayout
where subApiP = Proxy :: Proxy api
captureP = Proxy :: Proxy (Capture sym a)
action' = over captures (|> toCapture captureP) action
@ -736,43 +736,43 @@ instance OVERLAPPING_
status = fromInteger $ natVal (Proxy :: Proxy status)
p = Proxy :: Proxy a
instance (KnownSymbol sym, HasDocs sublayout)
=> HasDocs (Header sym a :> sublayout) where
instance (KnownSymbol sym, HasDocs api)
=> HasDocs (Header sym a :> api) where
docsFor Proxy (endpoint, action) =
docsFor sublayoutP (endpoint, action')
docsFor subApiP (endpoint, action')
where sublayoutP = Proxy :: Proxy sublayout
where subApiP = Proxy :: Proxy api
action' = over headers (|> headername) action
headername = T.pack $ symbolVal (Proxy :: Proxy sym)
instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
=> HasDocs (QueryParam sym a :> sublayout) where
instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs api)
=> HasDocs (QueryParam sym a :> api) where
docsFor Proxy (endpoint, action) =
docsFor sublayoutP (endpoint, action')
docsFor subApiP (endpoint, action')
where sublayoutP = Proxy :: Proxy sublayout
where subApiP = Proxy :: Proxy api
paramP = Proxy :: Proxy (QueryParam sym a)
action' = over params (|> toParam paramP) action
instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs sublayout)
=> HasDocs (QueryParams sym a :> sublayout) where
instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs api)
=> HasDocs (QueryParams sym a :> api) where
docsFor Proxy (endpoint, action) =
docsFor sublayoutP (endpoint, action')
docsFor subApiP (endpoint, action')
where sublayoutP = Proxy :: Proxy sublayout
where subApiP = Proxy :: Proxy api
paramP = Proxy :: Proxy (QueryParams sym a)
action' = over params (|> toParam paramP) action
instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs sublayout)
=> HasDocs (QueryFlag sym :> sublayout) where
instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs api)
=> HasDocs (QueryFlag sym :> api) where
docsFor Proxy (endpoint, action) =
docsFor sublayoutP (endpoint, action')
docsFor subApiP (endpoint, action')
where sublayoutP = Proxy :: Proxy sublayout
where subApiP = Proxy :: Proxy api
paramP = Proxy :: Proxy (QueryFlag sym)
action' = over params (|> toParam paramP) action
@ -785,49 +785,49 @@ instance HasDocs Raw where
-- example data. However, there's no reason to believe that the instances of
-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
-- both are even defined) for any particular type.
instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs sublayout)
=> HasDocs (ReqBody (ct ': cts) a :> sublayout) where
instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api)
=> HasDocs (ReqBody (ct ': cts) a :> api) where
docsFor Proxy (endpoint, action) =
docsFor sublayoutP (endpoint, action')
docsFor subApiP (endpoint, action')
where sublayoutP = Proxy :: Proxy sublayout
where subApiP = Proxy :: Proxy api
action' = action & rqbody .~ sampleByteString t p
& rqtypes .~ allMime t
t = Proxy :: Proxy (ct ': cts)
p = Proxy :: Proxy a
instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where
instance (KnownSymbol path, HasDocs api) => HasDocs (path :> api) where
docsFor Proxy (endpoint, action) =
docsFor sublayoutP (endpoint', action)
docsFor subApiP (endpoint', action)
where sublayoutP = Proxy :: Proxy sublayout
where subApiP = Proxy :: Proxy api
endpoint' = endpoint & path <>~ [symbolVal pa]
pa = Proxy :: Proxy path
instance HasDocs sublayout => HasDocs (RemoteHost :> sublayout) where
instance HasDocs api => HasDocs (RemoteHost :> api) where
docsFor Proxy ep =
docsFor (Proxy :: Proxy sublayout) ep
docsFor (Proxy :: Proxy api) ep
instance HasDocs sublayout => HasDocs (IsSecure :> sublayout) where
instance HasDocs api => HasDocs (IsSecure :> api) where
docsFor Proxy ep =
docsFor (Proxy :: Proxy sublayout) ep
docsFor (Proxy :: Proxy api) ep
instance HasDocs sublayout => HasDocs (HttpVersion :> sublayout) where
instance HasDocs api => HasDocs (HttpVersion :> api) where
docsFor Proxy ep =
docsFor (Proxy :: Proxy sublayout) ep
docsFor (Proxy :: Proxy api) ep
instance HasDocs sublayout => HasDocs (Vault :> sublayout) where
instance HasDocs api => HasDocs (Vault :> api) where
docsFor Proxy ep =
docsFor (Proxy :: Proxy sublayout) ep
docsFor (Proxy :: Proxy api) ep
instance HasDocs sublayout => HasDocs (WithNamedContext name context sublayout) where
docsFor Proxy = docsFor (Proxy :: Proxy sublayout)
instance HasDocs api => HasDocs (WithNamedContext name context api) where
docsFor Proxy = docsFor (Proxy :: Proxy api)
instance (ToAuthInfo (BasicAuth realm usr), HasDocs sublayout) => HasDocs (BasicAuth realm usr :> sublayout) where
instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth realm usr :> api) where
docsFor Proxy (endpoint, action) =
docsFor (Proxy :: Proxy sublayout) (endpoint, action')
docsFor (Proxy :: Proxy api) (endpoint, action')
where
authProxy = Proxy :: Proxy (BasicAuth realm usr)
action' = over authInfo (|> toAuthInfo authProxy) action

4
servant-docs/src/Servant/Docs/Internal/Pretty.hs
View file

@ -29,12 +29,12 @@ instance ToJSON a => MimeRender PrettyJSON a where
-- @
-- 'docs' ('pretty' ('Proxy' :: 'Proxy' MyAPI))
-- @
pretty :: Proxy layout -> Proxy (Pretty layout)
pretty :: Proxy api -> Proxy (Pretty api)
pretty Proxy = Proxy
-- | Replace all JSON content types with PrettyJSON.
-- Kind-polymorphic so it can operate on kinds @*@ and @[*]@.
type family Pretty (layout :: k) :: k where
type family Pretty (api :: k) :: k where
Pretty (x :<|> y) = Pretty x :<|> Pretty y
Pretty (x :> y) = Pretty x :> Pretty y
Pretty (Get cs r) = Get (Pretty cs) r

5
servant-foreign/CHANGELOG.md
View file

@ -1,3 +1,8 @@
0.7.1
-----
* Support GHC 8.0
0.5
-----
* Use the `text` package instead of `String`.

7
servant-foreign/servant-foreign.cabal
View file

@ -1,5 +1,5 @@
name: servant-foreign
version: 0.6
version: 0.7.1
synopsis: Helpers for generating clients for servant APIs in any programming language
description:
Helper types and functions for generating client functions for servant APIs in any programming language
@ -21,6 +21,7 @@ extra-source-files:
include/*.h
CHANGELOG.md
README.md
bug-reports: http://github.com/haskell-servant/servant/issues
source-repository head
type: git
location: http://github.com/haskell-servant/servant.git
@ -31,12 +32,14 @@ library
, Servant.Foreign.Inflections
build-depends: base == 4.*
, lens == 4.*
, servant == 0.6.*
, servant == 0.7.*
, text >= 1.2 && < 1.3
, http-types
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall
if impl(ghc >= 8.0)
ghc-options: -Wno-redundant-constraints
include-dirs: include
default-extensions: CPP
, ConstraintKinds

103
servant-foreign/src/Servant/Foreign/Internal.hs
View file

@ -7,7 +7,8 @@
-- arbitrary programming languages.
module Servant.Foreign.Internal where
import Control.Lens hiding (cons, List)
import Control.Lens (makePrisms, makeLenses, Getter, (&), (<>~), (%~),
(.~))
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
#endif
@ -183,9 +184,9 @@ data NoTypes
instance HasForeignType NoTypes () ftype where
typeFor _ _ _ = ()
class HasForeign lang ftype (layout :: *) where
type Foreign ftype layout :: *
foreignFor :: Proxy lang -> Proxy ftype -> Proxy layout -> Req ftype -> Foreign ftype layout
class HasForeign lang ftype (api :: *) where
type Foreign ftype api :: *
foreignFor :: Proxy lang -> Proxy ftype -> Proxy api -> Req ftype -> Foreign ftype api
instance (HasForeign lang ftype a, HasForeign lang ftype b)
=> HasForeign lang ftype (a :<|> b) where
@ -195,12 +196,12 @@ instance (HasForeign lang ftype a, HasForeign lang ftype b)
foreignFor lang ftype (Proxy :: Proxy a) req
:<|> foreignFor lang ftype (Proxy :: Proxy b) req
instance (KnownSymbol sym, HasForeignType lang ftype t, HasForeign lang ftype sublayout)
=> HasForeign lang ftype (Capture sym t :> sublayout) where
type Foreign ftype (Capture sym a :> sublayout) = Foreign ftype sublayout
instance (KnownSymbol sym, HasForeignType lang ftype t, HasForeign lang ftype api)
=> HasForeign lang ftype (Capture sym t :> api) where
type Foreign ftype (Capture sym a :> api) = Foreign ftype api
foreignFor lang Proxy Proxy req =
foreignFor lang Proxy (Proxy :: Proxy sublayout) $
foreignFor lang Proxy (Proxy :: Proxy api) $
req & reqUrl . path <>~ [Segment (Cap arg)]
& reqFuncName . _FunctionName %~ (++ ["by", str])
where
@ -223,9 +224,9 @@ instance (Elem JSON list, HasForeignType lang ftype a, ReflectMethod method)
method = reflectMethod (Proxy :: Proxy method)
methodLC = toLower $ decodeUtf8 method
instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype sublayout)
=> HasForeign lang ftype (Header sym a :> sublayout) where
type Foreign ftype (Header sym a :> sublayout) = Foreign ftype sublayout
instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype api)
=> HasForeign lang ftype (Header sym a :> api) where
type Foreign ftype (Header sym a :> api) = Foreign ftype api
foreignFor lang Proxy Proxy req =
foreignFor lang Proxy subP $ req & reqHeaders <>~ [HeaderArg arg]
@ -234,14 +235,14 @@ instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype su
arg = Arg
{ _argName = PathSegment hname
, _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a) }
subP = Proxy :: Proxy sublayout
subP = Proxy :: Proxy api
instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype sublayout)
=> HasForeign lang ftype (QueryParam sym a :> sublayout) where
type Foreign ftype (QueryParam sym a :> sublayout) = Foreign ftype sublayout
instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype api)
=> HasForeign lang ftype (QueryParam sym a :> api) where
type Foreign ftype (QueryParam sym a :> api) = Foreign ftype api
foreignFor lang Proxy Proxy req =
foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy sublayout) $
foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy api) $
req & reqUrl.queryStr <>~ [QueryArg arg Normal]
where
str = pack . symbolVal $ (Proxy :: Proxy sym)
@ -250,11 +251,11 @@ instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype su
, _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a) }
instance
(KnownSymbol sym, HasForeignType lang ftype [a], HasForeign lang ftype sublayout)
=> HasForeign lang ftype (QueryParams sym a :> sublayout) where
type Foreign ftype (QueryParams sym a :> sublayout) = Foreign ftype sublayout
(KnownSymbol sym, HasForeignType lang ftype [a], HasForeign lang ftype api)
=> HasForeign lang ftype (QueryParams sym a :> api) where
type Foreign ftype (QueryParams sym a :> api) = Foreign ftype api
foreignFor lang Proxy Proxy req =
foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy sublayout) $
foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy api) $
req & reqUrl.queryStr <>~ [QueryArg arg List]
where
str = pack . symbolVal $ (Proxy :: Proxy sym)
@ -263,12 +264,12 @@ instance
, _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy [a]) }
instance
(KnownSymbol sym, HasForeignType lang ftype Bool, HasForeign lang ftype sublayout)
=> HasForeign lang ftype (QueryFlag sym :> sublayout) where
type Foreign ftype (QueryFlag sym :> sublayout) = Foreign ftype sublayout
(KnownSymbol sym, HasForeignType lang ftype Bool, HasForeign lang ftype api)
=> HasForeign lang ftype (QueryFlag sym :> api) where
type Foreign ftype (QueryFlag sym :> api) = Foreign ftype api
foreignFor lang ftype Proxy req =
foreignFor lang ftype (Proxy :: Proxy sublayout) $
foreignFor lang ftype (Proxy :: Proxy api) $
req & reqUrl.queryStr <>~ [QueryArg arg Flag]
where
str = pack . symbolVal $ (Proxy :: Proxy sym)
@ -283,20 +284,20 @@ instance HasForeign lang ftype Raw where
req & reqFuncName . _FunctionName %~ ((toLower $ decodeUtf8 method) :)
& reqMethod .~ method
instance (Elem JSON list, HasForeignType lang ftype a, HasForeign lang ftype sublayout)
=> HasForeign lang ftype (ReqBody list a :> sublayout) where
type Foreign ftype (ReqBody list a :> sublayout) = Foreign ftype sublayout
instance (Elem JSON list, HasForeignType lang ftype a, HasForeign lang ftype api)
=> HasForeign lang ftype (ReqBody list a :> api) where
type Foreign ftype (ReqBody list a :> api) = Foreign ftype api
foreignFor lang ftype Proxy req =
foreignFor lang ftype (Proxy :: Proxy sublayout) $
foreignFor lang ftype (Proxy :: Proxy api) $
req & reqBody .~ (Just $ typeFor lang ftype (Proxy :: Proxy a))
instance (KnownSymbol path, HasForeign lang ftype sublayout)
=> HasForeign lang ftype (path :> sublayout) where
type Foreign ftype (path :> sublayout) = Foreign ftype sublayout
instance (KnownSymbol path, HasForeign lang ftype api)
=> HasForeign lang ftype (path :> api) where
type Foreign ftype (path :> api) = Foreign ftype api
foreignFor lang ftype Proxy req =
foreignFor lang ftype (Proxy :: Proxy sublayout) $
foreignFor lang ftype (Proxy :: Proxy api) $
req & reqUrl . path <>~ [Segment (Static (PathSegment str))]
& reqFuncName . _FunctionName %~ (++ [str])
where
@ -304,39 +305,39 @@ instance (KnownSymbol path, HasForeign lang ftype sublayout)
Data.Text.map (\c -> if c == '.' then '_' else c)
. pack . symbolVal $ (Proxy :: Proxy path)
instance HasForeign lang ftype sublayout
=> HasForeign lang ftype (RemoteHost :> sublayout) where
type Foreign ftype (RemoteHost :> sublayout) = Foreign ftype sublayout
instance HasForeign lang ftype api
=> HasForeign lang ftype (RemoteHost :> api) where
type Foreign ftype (RemoteHost :> api) = Foreign ftype api
foreignFor lang ftype Proxy req =
foreignFor lang ftype (Proxy :: Proxy sublayout) req
foreignFor lang ftype (Proxy :: Proxy api) req
instance HasForeign lang ftype sublayout
=> HasForeign lang ftype (IsSecure :> sublayout) where
type Foreign ftype (IsSecure :> sublayout) = Foreign ftype sublayout
instance HasForeign lang ftype api
=> HasForeign lang ftype (IsSecure :> api) where
type Foreign ftype (IsSecure :> api) = Foreign ftype api
foreignFor lang ftype Proxy req =
foreignFor lang ftype (Proxy :: Proxy sublayout) req
foreignFor lang ftype (Proxy :: Proxy api) req
instance HasForeign lang ftype sublayout => HasForeign lang ftype (Vault :> sublayout) where
type Foreign ftype (Vault :> sublayout) = Foreign ftype sublayout
instance HasForeign lang ftype api => HasForeign lang ftype (Vault :> api) where
type Foreign ftype (Vault :> api) = Foreign ftype api
foreignFor lang ftype Proxy req =
foreignFor lang ftype (Proxy :: Proxy sublayout) req
foreignFor lang ftype (Proxy :: Proxy api) req
instance HasForeign lang ftype sublayout =>
HasForeign lang ftype (WithNamedContext name context sublayout) where
instance HasForeign lang ftype api =>
HasForeign lang ftype (WithNamedContext name context api) where
type Foreign ftype (WithNamedContext name context sublayout) = Foreign ftype sublayout
type Foreign ftype (WithNamedContext name context api) = Foreign ftype api
foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy sublayout)
foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)
instance HasForeign lang ftype sublayout
=> HasForeign lang ftype (HttpVersion :> sublayout) where
type Foreign ftype (HttpVersion :> sublayout) = Foreign ftype sublayout
instance HasForeign lang ftype api
=> HasForeign lang ftype (HttpVersion :> api) where
type Foreign ftype (HttpVersion :> api) = Foreign ftype api
foreignFor lang ftype Proxy req =
foreignFor lang ftype (Proxy :: Proxy sublayout) req
foreignFor lang ftype (Proxy :: Proxy api) req
-- | Utility class used by 'listFromAPI' which computes
-- the data needed to generate a function for each endpoint

12
servant-js/servant-js.cabal
View file

@ -1,5 +1,5 @@
name: servant-js
version: 0.6
version: 0.7.1
synopsis: Automatically derive javascript functions to query servant webservices.
description:
Automatically derive javascript functions to query servant webservices.
@ -19,7 +19,7 @@ copyright: 2015-2016 Servant Contributors
category: Web
build-type: Simple
cabal-version: >=1.10
homepage: http://haskell-servant.github.io/
homepage: http://haskell-servant.readthedocs.org/
Bug-reports: http://github.com/haskell-servant/servant/issues
extra-source-files:
include/*.h
@ -45,7 +45,7 @@ library
, base-compat >= 0.9
, charset >= 0.3
, lens >= 4
, servant-foreign == 0.6.*
, servant-foreign == 0.7.*
, text >= 1.2 && < 1.3
hs-source-dirs: src
@ -55,7 +55,7 @@ library
executable counter
main-is: counter.hs
ghc-options: -O2 -Wall
ghc-options: -Wall
hs-source-dirs: examples
if flag(example)
@ -67,8 +67,8 @@ executable counter
, aeson >= 0.7 && < 0.12
, filepath >= 1
, lens >= 4
, servant == 0.6.*
, servant-server == 0.6.*
, servant == 0.7.*
, servant-server == 0.7.*
, servant-js
, stm
, transformers

4
servant-js/src/Servant/JS.hs
View file

@ -123,12 +123,12 @@ import Servant.JS.Axios
import Servant.JS.Internal
import Servant.JS.JQuery
import Servant.JS.Vanilla
import Servant.Foreign (GenerateList(..), listFromAPI, NoTypes)
import Servant.Foreign (listFromAPI)
-- | Generate the data necessary to generate javascript code
-- for all the endpoints of an API, as ':<|>'-separated values
-- of type 'AjaxReq'.
javascript :: HasForeign NoTypes () layout => Proxy layout -> Foreign () layout
javascript :: HasForeign NoTypes () api => Proxy api -> Foreign () api
javascript p = foreignFor (Proxy :: Proxy NoTypes) (Proxy :: Proxy ()) p defReq
-- | Directly generate all the javascript functions for your API

3
servant-js/src/Servant/JS/Internal.hs
View file

@ -23,7 +23,6 @@ module Servant.JS.Internal
, HasForeignType(..)
, GenerateList(..)
, NoTypes
, HeaderArg
, ArgType(..)
, HeaderArg(..)
, QueryArg(..)
@ -47,7 +46,7 @@ module Servant.JS.Internal
, Header
) where
import Control.Lens hiding (List)
import Control.Lens ((^.))
import qualified Data.CharSet as Set
import qualified Data.CharSet.Unicode.Category as Set
import Data.Monoid

24
servant-js/test/Servant/JSSpec/CustomHeaders.hs
View file

@ -23,11 +23,11 @@ import Servant.JS.Internal
-- using -- Basic, Digest, whatever.
data Authorization (sym :: Symbol) a
instance (KnownSymbol sym, HasForeign lang () sublayout)
=> HasForeign lang () (Authorization sym a :> sublayout) where
type Foreign () (Authorization sym a :> sublayout) = Foreign () sublayout
instance (KnownSymbol sym, HasForeign lang () api)
=> HasForeign lang () (Authorization sym a :> api) where
type Foreign () (Authorization sym a :> api) = Foreign () api
foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy sublayout) $
foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy api) $
req & reqHeaders <>~
[ ReplaceHeaderArg (Arg "Authorization" ())
$ tokenType (pack . symbolVal $ (Proxy :: Proxy sym)) ]
@ -37,11 +37,11 @@ instance (KnownSymbol sym, HasForeign lang () sublayout)
-- | This is a combinator that fetches an X-MyLovelyHorse header.
data MyLovelyHorse a
instance (HasForeign lang () sublayout)
=> HasForeign lang () (MyLovelyHorse a :> sublayout) where
type Foreign () (MyLovelyHorse a :> sublayout) = Foreign () sublayout
instance (HasForeign lang () api)
=> HasForeign lang () (MyLovelyHorse a :> api) where
type Foreign () (MyLovelyHorse a :> api) = Foreign () api
foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy sublayout) $
foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy api) $
req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-MyLovelyHorse" ()) tpl ]
where
tpl = "I am good friends with {X-MyLovelyHorse}"
@ -49,11 +49,11 @@ instance (HasForeign lang () sublayout)
-- | This is a combinator that fetches an X-WhatsForDinner header.
data WhatsForDinner a
instance (HasForeign lang () sublayout)
=> HasForeign lang () (WhatsForDinner a :> sublayout) where
type Foreign () (WhatsForDinner a :> sublayout) = Foreign () sublayout
instance (HasForeign lang () api)
=> HasForeign lang () (WhatsForDinner a :> api) where
type Foreign () (WhatsForDinner a :> api) = Foreign () api
foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy sublayout) $
foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy api) $
req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-WhatsForDinner" ()) tpl ]
where
tpl = "I would like {X-WhatsForDinner} with a cherry on top."

30
servant-lucid/LICENSE
View file

@ -1,30 +0,0 @@
Copyright (c) 2015-2016, Servant Contributors
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Julian K. Arni nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

2
servant-lucid/Setup.hs
View file

@ -1,2 +0,0 @@
import Distribution.Simple
main = defaultMain

8
servant-lucid/include/overlapping-compat.h
View file

@ -1,8 +0,0 @@
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

33
servant-lucid/servant-lucid.cabal
View file

@ -1,33 +0,0 @@
-- Initial servant-lucid.cabal generated by cabal init. For further
-- documentation, see http://haskell.org/cabal/users-guide/
name: servant-lucid
version: 0.6
synopsis: Servant support for lucid
-- description:
homepage: http://haskell-servant.github.io/
license: BSD3
license-file: LICENSE
author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com
copyright: 2015-2016 Servant Contributors
category: Web
build-type: Simple
extra-source-files: include/*.h
cabal-version: >=1.10
bug-reports: http://github.com/haskell-servant/servant/issues
source-repository head
type: git
location: http://github.com/haskell-servant/servant.git
library
exposed-modules: Servant.HTML.Lucid
-- other-modules:
-- other-extensions:
build-depends: base >=4.7 && <5
, http-media
, lucid
, servant == 0.6.*
hs-source-dirs: src
default-language: Haskell2010
include-dirs: include

36
servant-lucid/src/Servant/HTML/Lucid.hs
View file

@ -1,36 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
#include "overlapping-compat.h"
-- | An @HTML@ empty data type with `MimeRender` instances for @lucid@'s
-- `ToHtml` class and `Html` datatype.
-- You should only need to import this module for it's instances and the
-- `HTML` datatype.:
--
-- >>> type Eg = Get '[HTML] a
--
-- Will then check that @a@ has a `ToHtml` instance, or is `Html`.
module Servant.HTML.Lucid where
import Data.Typeable (Typeable)
import Lucid (Html, ToHtml (..), renderBS)
import qualified Network.HTTP.Media as M
import Servant.API (Accept (..), MimeRender (..))
data HTML deriving Typeable
-- | @text/html;charset=utf-8@
instance Accept HTML where
contentType _ = "text" M.// "html" M./: ("charset", "utf-8")
instance OVERLAPPABLE_
ToHtml a => MimeRender HTML a where
mimeRender _ = renderBS . toHtml
instance OVERLAPPING_
MimeRender HTML (Html a) where
mimeRender _ = renderBS

3
servant-lucid/tinc.yaml
View file

@ -1,3 +0,0 @@
dependencies:
- name: servant
path: ../servant

3
servant-mock/example/main.hs
View file

@ -2,6 +2,9 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
import Data.Aeson
import GHC.Generics
import Network.Wai.Handler.Warp

17
servant-mock/servant-mock.cabal
View file

@ -1,5 +1,5 @@
name: servant-mock
version: 0.6
version: 0.7.1
synopsis: Derive a mock server for free from your servant API types
description:
Derive a mock server for free from your servant API types
@ -15,6 +15,10 @@ category: Web
build-type: Simple
extra-source-files: include/*.h
cabal-version: >=1.10
bug-reports: http://github.com/haskell-servant/servant/issues
source-repository head
type: git
location: http://github.com/haskell-servant/servant.git
flag example
description: Build the example too
@ -27,14 +31,15 @@ library
base >=4.7 && <5,
bytestring >= 0.10 && <0.11,
http-types >= 0.8 && <0.10,
servant >= 0.4,
servant-server >= 0.4,
transformers >= 0.3 && <0.5,
servant == 0.7.*,
servant-server == 0.7.*,
transformers >= 0.3 && <0.6,
QuickCheck >= 2.7 && <2.9,
wai >= 3.0 && <3.3
hs-source-dirs: src
default-language: Haskell2010
include-dirs: include
ghc-options: -Wall
executable mock-app
main-is: main.hs
@ -45,11 +50,11 @@ executable mock-app
buildable: True
else
buildable: False
ghc-options: -Wall
test-suite spec
type: exitcode-stdio-1.0
ghc-options:
-Wall -fno-warn-name-shadowing
ghc-options: -Wall
default-language: Haskell2010
hs-source-dirs: test
main-is: Spec.hs

10
servant-mock/src/Servant/Mock.hs
View file

@ -36,7 +36,7 @@
-- and call 'mock', which has the following type:
--
-- @
-- 'mock' :: 'HasMock' api => 'Proxy' api -> 'Server' api
-- 'mock' :: 'HasMock' api context => 'Proxy' api -> 'Proxy' context -> 'Server' api
-- @
--
-- What this says is, given some API type @api@ that it knows it can
@ -52,7 +52,7 @@
-- @
-- main :: IO ()
-- main = Network.Wai.Handler.Warp.run 8080 $
-- 'serve' myAPI ('mock' myAPI)
-- 'serve' myAPI ('mock' myAPI Proxy)
-- @
module Servant.Mock ( HasMock(..) ) where
@ -90,15 +90,15 @@ class HasServer api context => HasMock api context where
-- -- let's say we will start with the frontend,
-- -- and hence need a placeholder server
-- server :: Server API
-- server = mock api
-- server = mock api Proxy
-- @
--
-- What happens here is that @'Server' API@
-- actually "means" 2 request handlers, of the following types:
--
-- @
-- getUser :: ExceptT ServantErr IO User
-- getBook :: ExceptT ServantErr IO Book
-- getUser :: Handler User
-- getBook :: Handler Book
-- @
--
-- So under the hood, 'mock' uses the 'IO' bit to generate

30
servant-server/CHANGELOG.md
View file

@ -1,3 +1,33 @@
0.7.1
------
* Remove module `Servant.Server.Internal.Enter` (https://github.com/haskell-servant/servant/pull/478)
* Support GHC 8.0
0.7
---
* The `Router` type has been changed. Static router tables should now
be properly shared between requests, drastically increasing the
number of situations where servers will be able to route requests
efficiently. Functions `layout` and `layoutWithContext` have been
added to visualize the router layout for debugging purposes. Test
cases for expected router layouts have been added.
* If an endpoint is discovered to have a non-matching "accept header",
this is now a recoverable rather than a fatal failure, allowing
different endpoints for the same route, but with different content
types to be specified modularly.
* Export `throwError` from module `Servant`
* Add `Handler` type synonym
0.6.1
-----
* If servers use the `BasicAuth` combinator and receive requests with missing or
invalid credentials, the resulting error responses (401 and 403) could be
overwritten by subsequent alternative routes. Now `BasicAuth` uses `FailFatal`
and the error responses can't be overwritten anymore.
0.6
---

3
servant-server/README.md
View file

@ -6,5 +6,4 @@ This library lets you *implement* an HTTP server with handlers for each endpoint
## Getting started
We've written a [tutorial](http://haskell-servant.github.io/tutorial/) guide that introduces the core types and features of servant. After this article, you should be able to write your first servant webservices, learning the rest from the haddocks' examples.
We've written a [tutorial](http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html) guide that introduces the core types and features of servant. After this article, you should be able to write your first servant webservices, learning the rest from the haddocks' examples.

2
servant-server/example/greet.hs
View file

@ -44,7 +44,7 @@ testApi = Proxy
-- There's one handler per endpoint, which, just like in the type
-- that represents the API, are glued together using :<|>.
--
-- Each handler runs in the 'ExceptT ServantErr IO' monad.
-- Each handler runs in the 'Handler' monad.
server :: Server TestApi
server = helloH :<|> postGreetH :<|> deleteGreetH

29
servant-server/servant-server.cabal
View file

@ -1,17 +1,17 @@
name: servant-server
version: 0.6
version: 0.7.1
synopsis: A family of combinators for defining webservices APIs and serving them
description:
A family of combinators for defining webservices APIs and serving them
.
You can learn about the basics in the <http://haskell-servant.github.io/tutorial tutorial>.
You can learn about the basics in the <http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html tutorial>.
.
<https://github.com/haskell-servant/servant/blob/master/servant-server/example/greet.hs Here>
is a runnable example, with comments, that defines a dummy API and implements
a webserver that serves this API, using this package.
.
<https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md CHANGELOG>
homepage: http://haskell-servant.github.io/
homepage: http://haskell-servant.readthedocs.org/
Bug-reports: http://github.com/haskell-servant/servant/issues
license: BSD3
license-file: LICENSE
@ -40,7 +40,6 @@ library
Servant.Server.Internal
Servant.Server.Internal.BasicAuth
Servant.Server.Internal.Context
Servant.Server.Internal.Enter
Servant.Server.Internal.Router
Servant.Server.Internal.RoutingApplication
Servant.Server.Internal.ServantErr
@ -57,25 +56,26 @@ library
, http-types >= 0.8 && < 0.10
, network-uri >= 2.6 && < 2.7
, mtl >= 2 && < 3
, mmorph >= 1
, network >= 2.6 && < 2.7
, safe >= 0.3 && < 0.4
, servant == 0.6.*
, servant == 0.7.*
, split >= 0.2 && < 0.3
, string-conversions >= 0.3 && < 0.5
, system-filepath >= 0.4 && < 0.5
, filepath >= 1
, text >= 1.2 && < 1.3
, transformers >= 0.3 && < 0.5
, transformers >= 0.3 && < 0.6
, transformers-compat>= 0.4
, wai >= 3.0 && < 3.3
, wai-app-static >= 3.0 && < 3.2
, wai-app-static >= 3.1 && < 3.2
, warp >= 3.0 && < 3.3
, word8 == 0.1.*
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall
if impl(ghc >= 8.0)
ghc-options: -Wno-redundant-constraints
include-dirs: include
executable greet
@ -94,23 +94,24 @@ executable greet
test-suite spec
type: exitcode-stdio-1.0
ghc-options:
-Wall -fno-warn-name-shadowing -fno-warn-missing-signatures
ghc-options: -Wall
default-language: Haskell2010
hs-source-dirs: test
main-is: Spec.hs
other-modules:
Servant.Server.ErrorSpec
Servant.Server.Internal.ContextSpec
Servant.Server.Internal.EnterSpec
Servant.ServerSpec
Servant.Server.RouterSpec
Servant.Server.StreamingSpec
Servant.Server.UsingContextSpec
Servant.Server.UsingContextSpec.TestCombinators
Servant.ServerSpec
Servant.Utils.StaticFilesSpec
build-depends:
base == 4.*
, base-compat
, aeson
, base64-bytestring
, bytestring
, bytestring-conversion
, directory
@ -125,7 +126,7 @@ test-suite spec
, servant
, servant-server
, string-conversions
, should-not-typecheck == 2.*
, should-not-typecheck == 2.1.*
, temporary
, text
, transformers
@ -146,5 +147,5 @@ test-suite doctests
main-is: test/Doctests.hs
buildable: True
default-language: Haskell2010
ghc-options: -threaded
ghc-options: -Wall -threaded
include-dirs: include

2
servant-server/src/Servant.hs
View file

@ -10,8 +10,10 @@ module Servant (
module Servant.Utils.StaticFiles,
-- | Useful re-exports
Proxy(..),
throwError
) where
import Control.Monad.Error.Class (throwError)
import Data.Proxy
import Servant.API
import Servant.Server

82
servant-server/src/Servant/Server.hs
View file

@ -17,6 +17,11 @@ module Servant.Server
, -- * Handlers for all standard combinators
HasServer(..)
, Server
, Handler
-- * Debugging the server layout
, layout
, layoutWithContext
-- * Enter
-- $enterDoc
@ -90,12 +95,16 @@ module Servant.Server
, err504
, err505
-- * Re-exports
, Application
) where
import Data.Proxy (Proxy)
import Data.Text (Text)
import Network.Wai (Application)
import Servant.Server.Internal
import Servant.Server.Internal.Enter
import Servant.Utils.Enter
-- * Implementing Servers
@ -121,16 +130,73 @@ import Servant.Server.Internal.Enter
-- > main :: IO ()
-- > main = Network.Wai.Handler.Warp.run 8080 app
--
serve :: (HasServer layout '[]) => Proxy layout -> Server layout -> Application
serve :: (HasServer api '[]) => Proxy api -> Server api -> Application
serve p = serveWithContext p EmptyContext
serveWithContext :: (HasServer layout context)
=> Proxy layout -> Context context -> Server layout -> Application
serveWithContext p context server = toApplication (runRouter (route p context d))
where
d = Delayed r r r r (\ _ _ _ -> Route server)
r = return (Route ())
serveWithContext :: (HasServer api context)
=> Proxy api -> Context context -> Server api -> Application
serveWithContext p context server =
toApplication (runRouter (route p context (emptyDelayed (Route server))))
-- | The function 'layout' produces a textual description of the internal
-- router layout for debugging purposes. Note that the router layout is
-- determined just by the API, not by the handlers.
--
-- Example:
--
-- For the following API
--
-- > type API =
-- > "a" :> "d" :> Get '[JSON] ()
-- > :<|> "b" :> Capture "x" Int :> Get '[JSON] Bool
-- > :<|> "c" :> Put '[JSON] Bool
-- > :<|> "a" :> "e" :> Get '[JSON] Int
-- > :<|> "b" :> Capture "x" Int :> Put '[JSON] Bool
-- > :<|> Raw
--
-- we get the following output:
--
-- > /
-- > ├─ a/
-- > │ ├─ d/
-- > │ │ └─•
-- > │ └─ e/
-- > │ └─•
-- > ├─ b/
-- > │ └─ <capture>/
-- > │ ├─•
-- > │ ┆
-- > │ └─•
-- > ├─ c/
-- > │ └─•
-- > ┆
-- > └─ <raw>
--
-- Explanation of symbols:
--
-- [@├@] Normal lines reflect static branching via a table.
--
-- [@a/@] Nodes reflect static path components.
--
-- [@─•@] Leaves reflect endpoints.
--
-- [@\<capture\>/@] This is a delayed capture of a path component.
--
-- [@\<raw\>@] This is a part of the API we do not know anything about.
--
-- [@┆@] Dashed lines suggest a dynamic choice between the part above
-- and below. If there is a success for fatal failure in the first part,
-- that one takes precedence. If both parts fail, the \"better\" error
-- code will be returned.
--
layout :: (HasServer api '[]) => Proxy api -> Text
layout p = layoutWithContext p EmptyContext
-- | Variant of 'layout' that takes an additional 'Context'.
layoutWithContext :: (HasServer api context)
=> Proxy api -> Context context -> Text
layoutWithContext p context =
routerLayout (route p context (emptyDelayed (FailFatal err501)))
-- Documentation

26
servant-server/src/Servant/Server/Experimental/Auth.hs
View file

@ -12,8 +12,8 @@
module Servant.Server.Experimental.Auth where
import Control.Monad.Trans.Except (ExceptT,
runExceptT)
import Control.Monad.Trans (liftIO)
import Control.Monad.Trans.Except (runExceptT)
import Data.Proxy (Proxy (Proxy))
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
@ -25,10 +25,11 @@ import Servant.Server.Internal (HasContextEntry,
HasServer, ServerT,
getContextEntry,
route)
import Servant.Server.Internal.Router (Router' (WithRequest))
import Servant.Server.Internal.RoutingApplication (RouteResult (FailFatal, Route),
addAuthCheck)
import Servant.Server.Internal.ServantErr (ServantErr)
import Servant.Server.Internal.RoutingApplication (addAuthCheck,
delayedFailFatal,
DelayedIO,
withRequest)
import Servant.Server.Internal.ServantErr (Handler)
-- * General Auth
@ -42,11 +43,11 @@ type family AuthServerData a :: *
--
-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
newtype AuthHandler r usr = AuthHandler
{ unAuthHandler :: r -> ExceptT ServantErr IO usr }
{ unAuthHandler :: r -> Handler usr }
deriving (Generic, Typeable)
-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
mkAuthHandler :: (r -> ExceptT ServantErr IO usr) -> AuthHandler r usr
mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr
mkAuthHandler = AuthHandler
-- | Known orphan instance.
@ -58,9 +59,10 @@ instance ( HasServer api context
type ServerT (AuthProtect tag :> api) m =
AuthServerData (AuthProtect tag) -> ServerT api m
route Proxy context subserver = WithRequest $ \ request ->
route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request)
route Proxy context subserver =
route (Proxy :: Proxy api) context (subserver `addAuthCheck` withRequest authCheck)
where
authHandler :: Request -> Handler (AuthServerData (AuthProtect tag))
authHandler = unAuthHandler (getContextEntry context)
authCheck = fmap (either FailFatal Route) . runExceptT . authHandler
authCheck :: Request -> DelayedIO (AuthServerData (AuthProtect tag))
authCheck = (>>= either delayedFailFatal return) . liftIO . runExceptT . authHandler

226
servant-server/src/Servant/Server/Internal.hs
View file

@ -22,15 +22,13 @@ module Servant.Server.Internal
, module Servant.Server.Internal.ServantErr
) where
import Control.Monad.Trans.Except (ExceptT)
import Control.Monad.Trans (liftIO)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC8
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as M
import Data.Maybe (fromMaybe, mapMaybe)
import Data.String (fromString)
import Data.String.Conversions (cs, (<>))
import Data.Text (Text)
import Data.Typeable
import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
symbolVal)
@ -38,7 +36,7 @@ import Network.HTTP.Types hiding (Header, ResponseHeaders)
import Network.Socket (SockAddr)
import Network.Wai (Application, Request, Response,
httpVersion, isSecure,
lazyRequestBody, pathInfo,
lazyRequestBody,
rawQueryString, remoteHost,
requestHeaders, requestMethod,
responseLBS, vault)
@ -70,12 +68,16 @@ import Servant.Server.Internal.RoutingApplication
import Servant.Server.Internal.ServantErr
class HasServer layout context where
type ServerT layout (m :: * -> *) :: *
class HasServer api context where
type ServerT api (m :: * -> *) :: *
route :: Proxy layout -> Context context -> Delayed (Server layout) -> Router
route ::
Proxy api
-> Context context
-> Delayed env (Server api)
-> Router env
type Server layout = ServerT layout (ExceptT ServantErr IO)
type Server api = ServerT api Handler
-- * Instances
@ -95,7 +97,7 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont
type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
route Proxy context server = choice (route pa context ((\ (a :<|> _) -> a) <$> server))
(route pb context ((\ (_ :<|> b) -> b) <$> server))
(route pb context ((\ (_ :<|> b) -> b) <$> server))
where pa = Proxy :: Proxy a
pb = Proxy :: Proxy b
@ -114,21 +116,21 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont
-- >
-- > server :: Server MyApi
-- > server = getBook
-- > where getBook :: Text -> ExceptT ServantErr IO Book
-- > where getBook :: Text -> Handler Book
-- > getBook isbn = ...
instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context)
=> HasServer (Capture capture a :> sublayout) context where
instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
=> HasServer (Capture capture a :> api) context where
type ServerT (Capture capture a :> sublayout) m =
a -> ServerT sublayout m
type ServerT (Capture capture a :> api) m =
a -> ServerT api m
route Proxy context d =
DynamicRouter $ \ first ->
route (Proxy :: Proxy sublayout)
CaptureRouter $
route (Proxy :: Proxy api)
context
(addCapture d $ case parseUrlPieceMaybe first :: Maybe a of
Nothing -> return $ Fail err400
Just v -> return $ Route v
(addCapture d $ \ txt -> case parseUrlPieceMaybe txt :: Maybe a of
Nothing -> delayedFail err400
Just v -> return v
)
allowedMethodHead :: Method -> Request -> Bool
@ -147,48 +149,51 @@ processMethodRouter handleA status method headers request = case handleA of
bdy = if allowedMethodHead method request then "" else body
hdrs = (hContentType, cs contentT) : (fromMaybe [] headers)
methodCheck :: Method -> Request -> IO (RouteResult ())
methodCheck :: Method -> Request -> DelayedIO ()
methodCheck method request
| allowedMethod method request = return $ Route ()
| otherwise = return $ Fail err405
| allowedMethod method request = return ()
| otherwise = delayedFail err405
acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> IO (RouteResult ())
-- This has switched between using 'Fail' and 'FailFatal' a number of
-- times. If the 'acceptCheck' is run after the body check (which would
-- be morally right), then we have to set this to 'FailFatal', because
-- the body check is not reversible, and therefore backtracking after the
-- body check is no longer an option. However, we now run the accept
-- check before the body check and can therefore afford to make it
-- recoverable.
acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO ()
acceptCheck proxy accH
| canHandleAcceptH proxy (AcceptHeader accH) = return $ Route ()
| otherwise = return $ FailFatal err406
| canHandleAcceptH proxy (AcceptHeader accH) = return ()
| otherwise = delayedFail err406
methodRouter :: (AllCTRender ctypes a)
=> Method -> Proxy ctypes -> Status
-> Delayed (ExceptT ServantErr IO a)
-> Router
methodRouter method proxy status action = LeafRouter route'
-> Delayed env (Handler a)
-> Router env
methodRouter method proxy status action = leafRouter route'
where
route' request respond
| pathIsEmpty request =
route' env request respond =
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
in runAction (action `addMethodCheck` methodCheck method request
`addAcceptCheck` acceptCheck proxy accH
) respond $ \ output -> do
) env request respond $ \ output -> do
let handleA = handleAcceptH proxy (AcceptHeader accH) output
processMethodRouter handleA status method Nothing request
| otherwise = respond $ Fail err404
methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)
=> Method -> Proxy ctypes -> Status
-> Delayed (ExceptT ServantErr IO (Headers h v))
-> Router
methodRouterHeaders method proxy status action = LeafRouter route'
-> Delayed env (Handler (Headers h v))
-> Router env
methodRouterHeaders method proxy status action = leafRouter route'
where
route' request respond
| pathIsEmpty request =
route' env request respond =
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
in runAction (action `addMethodCheck` methodCheck method request
`addAcceptCheck` acceptCheck proxy accH
) respond $ \ output -> do
) env request respond $ \ output -> do
let headers = getHeaders output
handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
processMethodRouter handleA status method (Just headers) request
| otherwise = respond $ Fail err404
instance OVERLAPPABLE_
( AllCTRender ctypes a, ReflectMethod method, KnownNat status
@ -229,17 +234,17 @@ instance OVERLAPPING_
-- >
-- > server :: Server MyApi
-- > server = viewReferer
-- > where viewReferer :: Referer -> ExceptT ServantErr IO referer
-- > where viewReferer :: Referer -> Handler referer
-- > viewReferer referer = return referer
instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)
=> HasServer (Header sym a :> sublayout) context where
instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
=> HasServer (Header sym a :> api) context where
type ServerT (Header sym a :> sublayout) m =
Maybe a -> ServerT sublayout m
type ServerT (Header sym a :> api) m =
Maybe a -> ServerT api m
route Proxy context subserver = WithRequest $ \ request ->
let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request)
in route (Proxy :: Proxy sublayout) context (passToServer subserver mheader)
route Proxy context subserver =
let mheader req = parseHeaderMaybe =<< lookup str (requestHeaders req)
in route (Proxy :: Proxy api) context (passToServer subserver mheader)
where str = fromString $ symbolVal (Proxy :: Proxy sym)
-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
@ -260,24 +265,24 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)
-- >
-- > server :: Server MyApi
-- > server = getBooksBy
-- > where getBooksBy :: Maybe Text -> ExceptT ServantErr IO [Book]
-- > where getBooksBy :: Maybe Text -> Handler [Book]
-- > getBooksBy Nothing = ...return all books...
-- > getBooksBy (Just author) = ...return books by the given author...
instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)
=> HasServer (QueryParam sym a :> sublayout) context where
instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
=> HasServer (QueryParam sym a :> api) context where
type ServerT (QueryParam sym a :> sublayout) m =
Maybe a -> ServerT sublayout m
type ServerT (QueryParam sym a :> api) m =
Maybe a -> ServerT api m
route Proxy context subserver = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request
param =
case lookup paramname querytext of
route Proxy context subserver =
let querytext r = parseQueryText $ rawQueryString r
param r =
case lookup paramname (querytext r) of
Nothing -> Nothing -- param absent from the query string
Just Nothing -> Nothing -- param present with no value -> Nothing
Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to
-- the right type
in route (Proxy :: Proxy sublayout) context (passToServer subserver param)
in route (Proxy :: Proxy api) context (passToServer subserver param)
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,
@ -297,22 +302,22 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)
-- >
-- > server :: Server MyApi
-- > server = getBooksBy
-- > where getBooksBy :: [Text] -> ExceptT ServantErr IO [Book]
-- > where getBooksBy :: [Text] -> Handler [Book]
-- > getBooksBy authors = ...return all books by these authors...
instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)
=> HasServer (QueryParams sym a :> sublayout) context where
instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
=> HasServer (QueryParams sym a :> api) context where
type ServerT (QueryParams sym a :> sublayout) m =
[a] -> ServerT sublayout m
type ServerT (QueryParams sym a :> api) m =
[a] -> ServerT api m
route Proxy context subserver = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request
route Proxy context subserver =
let querytext r = parseQueryText $ rawQueryString r
-- if sym is "foo", we look for query string parameters
-- named "foo" or "foo[]" and call parseQueryParam on the
-- corresponding values
parameters = filter looksLikeParam querytext
values = mapMaybe (convert . snd) parameters
in route (Proxy :: Proxy sublayout) context (passToServer subserver values)
parameters r = filter looksLikeParam (querytext r)
values r = mapMaybe (convert . snd) (parameters r)
in route (Proxy :: Proxy api) context (passToServer subserver values)
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
convert Nothing = Nothing
@ -328,21 +333,21 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)
-- >
-- > server :: Server MyApi
-- > server = getBooks
-- > where getBooks :: Bool -> ExceptT ServantErr IO [Book]
-- > where getBooks :: Bool -> Handler [Book]
-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...
instance (KnownSymbol sym, HasServer sublayout context)
=> HasServer (QueryFlag sym :> sublayout) context where
instance (KnownSymbol sym, HasServer api context)
=> HasServer (QueryFlag sym :> api) context where
type ServerT (QueryFlag sym :> sublayout) m =
Bool -> ServerT sublayout m
type ServerT (QueryFlag sym :> api) m =
Bool -> ServerT api m
route Proxy context subserver = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request
param = case lookup paramname querytext of
route Proxy context subserver =
let querytext r = parseQueryText $ rawQueryString r
param r = case lookup paramname (querytext r) of
Just Nothing -> True -- param is there, with no value
Just (Just v) -> examine v -- param with a value
Nothing -> False -- param not in the query string
in route (Proxy :: Proxy sublayout) context (passToServer subserver param)
in route (Proxy :: Proxy api) context (passToServer subserver param)
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
examine v | v == "true" || v == "1" || v == "" = True
| otherwise = False
@ -359,8 +364,8 @@ instance HasServer Raw context where
type ServerT Raw m = Application
route Proxy _ rawApplication = LeafRouter $ \ request respond -> do
r <- runDelayed rawApplication
route Proxy _ rawApplication = RawRouter $ \ env request respond -> do
r <- runDelayed rawApplication env request
case r of
Route app -> app request (respond . Route)
Fail a -> respond $ Fail a
@ -385,18 +390,18 @@ instance HasServer Raw context where
-- >
-- > server :: Server MyApi
-- > server = postBook
-- > where postBook :: Book -> ExceptT ServantErr IO Book
-- > where postBook :: Book -> Handler Book
-- > postBook book = ...insert into your db...
instance ( AllCTUnrender list a, HasServer sublayout context
) => HasServer (ReqBody list a :> sublayout) context where
instance ( AllCTUnrender list a, HasServer api context
) => HasServer (ReqBody list a :> api) context where
type ServerT (ReqBody list a :> sublayout) m =
a -> ServerT sublayout m
type ServerT (ReqBody list a :> api) m =
a -> ServerT api m
route Proxy context subserver = WithRequest $ \ request ->
route (Proxy :: Proxy sublayout) context (addBodyCheck subserver (bodyCheck request))
route Proxy context subserver =
route (Proxy :: Proxy api) context (addBodyCheck subserver bodyCheck)
where
bodyCheck request = do
bodyCheck = withRequest $ \ request -> do
-- See HTTP RFC 2616, section 7.2.1
-- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
-- See also "W3C Internet Media Type registration, consistency of use"
@ -404,48 +409,49 @@ instance ( AllCTUnrender list a, HasServer sublayout context
let contentTypeH = fromMaybe "application/octet-stream"
$ lookup hContentType $ requestHeaders request
mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
<$> lazyRequestBody request
<$> liftIO (lazyRequestBody request)
case mrqbody of
Nothing -> return $ FailFatal err415
Just (Left e) -> return $ FailFatal err400 { errBody = cs e }
Just (Right v) -> return $ Route v
Nothing -> delayedFailFatal err415
Just (Left e) -> delayedFailFatal err400 { errBody = cs e }
Just (Right v) -> return v
-- | Make sure the incoming request starts with @"/path"@, strip it and
-- pass the rest of the request path to @sublayout@.
instance (KnownSymbol path, HasServer sublayout context) => HasServer (path :> sublayout) context where
-- pass the rest of the request path to @api@.
instance (KnownSymbol path, HasServer api context) => HasServer (path :> api) context where
type ServerT (path :> sublayout) m = ServerT sublayout m
type ServerT (path :> api) m = ServerT api m
route Proxy context subserver = StaticRouter $
M.singleton (cs (symbolVal proxyPath))
(route (Proxy :: Proxy sublayout) context subserver)
route Proxy context subserver =
pathRouter
(cs (symbolVal proxyPath))
(route (Proxy :: Proxy api) context subserver)
where proxyPath = Proxy :: Proxy path
instance HasServer api context => HasServer (RemoteHost :> api) context where
type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m
route Proxy context subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) context (passToServer subserver $ remoteHost req)
route Proxy context subserver =
route (Proxy :: Proxy api) context (passToServer subserver remoteHost)
instance HasServer api context => HasServer (IsSecure :> api) context where
type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m
route Proxy context subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) context (passToServer subserver $ secure req)
route Proxy context subserver =
route (Proxy :: Proxy api) context (passToServer subserver secure)
where secure req = if isSecure req then Secure else NotSecure
instance HasServer api context => HasServer (Vault :> api) context where
type ServerT (Vault :> api) m = Vault -> ServerT api m
route Proxy context subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) context (passToServer subserver $ vault req)
route Proxy context subserver =
route (Proxy :: Proxy api) context (passToServer subserver vault)
instance HasServer api context => HasServer (HttpVersion :> api) context where
type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m
route Proxy context subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) context (passToServer subserver $ httpVersion req)
route Proxy context subserver =
route (Proxy :: Proxy api) context (passToServer subserver httpVersion)
-- | Basic Authentication
instance ( KnownSymbol realm
@ -456,21 +462,15 @@ instance ( KnownSymbol realm
type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m
route Proxy context subserver = WithRequest $ \ request ->
route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request)
route Proxy context subserver =
route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck)
where
realm = BC8.pack $ symbolVal (Proxy :: Proxy realm)
basicAuthContext = getContextEntry context
authCheck req = runBasicAuth req realm basicAuthContext
authCheck = withRequest $ \ req -> runBasicAuth req realm basicAuthContext
-- * helpers
pathIsEmpty :: Request -> Bool
pathIsEmpty = go . pathInfo
where go [] = True
go [""] = True
go _ = False
ct_wildcard :: B.ByteString
ct_wildcard = "*" <> "/" <> "*" -- Because CPP

23
servant-server/src/Servant/Server/Internal/BasicAuth.hs
View file

@ -1,11 +1,12 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Servant.Server.Internal.BasicAuth where
import Control.Monad (guard)
import Control.Monad.Trans (liftIO)
import qualified Data.ByteString as BS
import Data.ByteString.Base64 (decodeLenient)
import Data.Monoid ((<>))
@ -15,9 +16,9 @@ import GHC.Generics
import Network.HTTP.Types (Header)
import Network.Wai (Request, requestHeaders)
import Servant.API.BasicAuth (BasicAuthData(BasicAuthData))
import Servant.Server.Internal.RoutingApplication
import Servant.Server.Internal.ServantErr
import Servant.API.BasicAuth (BasicAuthData(BasicAuthData))
import Servant.Server.Internal.RoutingApplication
import Servant.Server.Internal.ServantErr
-- * Basic Auth
@ -57,13 +58,13 @@ decodeBAHdr req = do
-- | Run and check basic authentication, returning the appropriate http error per
-- the spec.
runBasicAuth :: Request -> BS.ByteString -> BasicAuthCheck usr -> IO (RouteResult usr)
runBasicAuth :: Request -> BS.ByteString -> BasicAuthCheck usr -> DelayedIO usr
runBasicAuth req realm (BasicAuthCheck ba) =
case decodeBAHdr req of
Nothing -> plzAuthenticate
Just e -> ba e >>= \res -> case res of
Just e -> liftIO (ba e) >>= \res -> case res of
BadPassword -> plzAuthenticate
NoSuchUser -> plzAuthenticate
Unauthorized -> return $ Fail err403
Authorized usr -> return $ Route usr
where plzAuthenticate = return $ Fail err401 { errHeaders = [mkBAChallengerHdr realm] }
Unauthorized -> delayedFailFatal err403
Authorized usr -> return usr
where plzAuthenticate = delayedFailFatal err401 { errHeaders = [mkBAChallengerHdr realm] }

4
servant-server/src/Servant/Server/Internal/Context.hs
View file

@ -18,7 +18,7 @@ import GHC.TypeLits
-- | 'Context's are used to pass values to combinators. (They are __not__ meant
-- to be used to pass parameters to your handlers, i.e. they should not replace
-- any custom 'Control.Monad.Trans.Reader.ReaderT'-monad-stack that you're using
-- with 'Servant.Server.Internal.Enter.enter'.) If you don't use combinators that
-- with 'Servant.Utils.Enter'.) If you don't use combinators that
-- require any context entries, you can just use 'Servant.Server.serve' as always.
--
-- If you are using combinators that require a non-empty 'Context' you have to
@ -59,7 +59,7 @@ instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where
--
-- >>> getContextEntry (True :. False :. EmptyContext) :: String
-- ...
-- No instance for (HasContextEntry '[] [Char])
-- ...No instance for (HasContextEntry '[] [Char])
-- ...
class HasContextEntry (context :: [*]) (val :: *) where
getContextEntry :: Context context -> val

231
servant-server/src/Servant/Server/Internal/Router.hs
View file

@ -1,89 +1,196 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
module Servant.Server.Internal.Router where
import Data.Map (Map)
import qualified Data.Map as M
import Data.Monoid
import Data.Text (Text)
import Network.Wai (Request, Response, pathInfo)
import qualified Data.Text as T
import Network.Wai (Response, pathInfo)
import Servant.Server.Internal.RoutingApplication
import Servant.Server.Internal.ServantErr
type Router = Router' RoutingApplication
type Router env = Router' env RoutingApplication
-- | Internal representation of a router.
data Router' a =
WithRequest (Request -> Router)
-- ^ current request is passed to the router
| StaticRouter (Map Text Router)
-- ^ first path component used for lookup and removed afterwards
| DynamicRouter (Text -> Router)
-- ^ first path component used for lookup and removed afterwards
| LeafRouter a
-- ^ to be used for routes that match an empty path
| Choice Router Router
--
-- The first argument describes an environment type that is
-- expected as extra input by the routers at the leaves. The
-- environment is filled while running the router, with path
-- components that can be used to process captures.
--
data Router' env a =
StaticRouter (Map Text (Router' env a)) [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 (Router' (Text, env) a)
-- ^ first path component is passed to the child router in its
-- environment and removed afterwards
| RawRouter (env -> a)
-- ^ to be used for routes we do not know anything about
| Choice (Router' env a) (Router' env a)
-- ^ left-biased choice between two routers
deriving Functor
-- | Apply a transformation to the response of a `Router`.
tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router -> Router
tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))
-- | Smart constructor for a single static path component.
pathRouter :: Text -> Router' env a -> Router' env a
pathRouter t r = StaticRouter (M.singleton t r) []
-- | Smart constructor for a leaf, i.e., a router that expects
-- the empty path.
--
leafRouter :: (env -> a) -> Router' env a
leafRouter l = StaticRouter M.empty [l]
-- | Smart constructor for the choice between routers.
-- We currently optimize the following cases:
--
-- * Two static routers can be joined by joining their maps.
-- * Two static routers can be joined by joining their maps
-- and concatenating their leaf-lists.
-- * Two dynamic routers can be joined by joining their codomains.
-- * Two 'WithRequest' routers can be joined by passing them
-- the same request and joining their codomains.
-- * A 'WithRequest' router can be joined with anything else by
-- passing the same request to both but ignoring it in the
-- component that does not need it.
-- * Choice nodes can be reordered.
--
choice :: Router -> Router -> Router
choice (StaticRouter table1) (StaticRouter table2) =
StaticRouter (M.unionWith choice table1 table2)
choice (DynamicRouter fun1) (DynamicRouter fun2) =
DynamicRouter (\ first -> choice (fun1 first) (fun2 first))
choice (WithRequest router1) (WithRequest router2) =
WithRequest (\ request -> choice (router1 request) (router2 request))
choice (WithRequest router1) router2 =
WithRequest (\ request -> choice (router1 request) router2)
choice router1 (WithRequest router2) =
WithRequest (\ request -> choice router1 (router2 request))
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 router1) (CaptureRouter router2) =
CaptureRouter (choice router1 router2)
choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3
choice router1 router2 = Choice router1 router2
-- | Interpret a router as an application.
runRouter :: Router -> RoutingApplication
runRouter (WithRequest router) request respond =
runRouter (router request) request respond
runRouter (StaticRouter table) request respond =
case pathInfo request of
first : rest
| Just router <- M.lookup first table
-> let request' = request { pathInfo = rest }
in runRouter router request' respond
_ -> respond $ Fail err404
runRouter (DynamicRouter fun) request respond =
case pathInfo request of
first : rest
-> let request' = request { pathInfo = rest }
in runRouter (fun first) request' respond
_ -> respond $ Fail err404
runRouter (LeafRouter app) request respond = app request respond
runRouter (Choice r1 r2) request respond =
runRouter r1 request $ \ mResponse1 -> case mResponse1 of
Fail _ -> runRouter r2 request $ \ mResponse2 ->
respond (highestPri mResponse1 mResponse2)
_ -> respond mResponse1
where
highestPri (Fail e1) (Fail e2) =
if worseHTTPCode (errHTTPCode e1) (errHTTPCode e2)
then Fail e2
else Fail e1
highestPri (Fail _) y = y
highestPri x _ = x
-- | Datatype used for representing and debugging the
-- structure of a router. Abstracts from the handlers
-- at the leaves.
--
-- Two 'Router's can be structurally compared by computing
-- their 'RouterStructure' using 'routerStructure' and
-- then testing for equality, see 'sameStructure'.
--
data RouterStructure =
StaticRouterStructure (Map Text RouterStructure) Int
| CaptureRouterStructure RouterStructure
| RawRouterStructure
| ChoiceStructure RouterStructure RouterStructure
deriving (Eq, Show)
-- | Compute the structure of a router.
--
-- Assumes that the request or text being passed
-- in 'WithRequest' or 'CaptureRouter' does not
-- affect the structure of the underlying tree.
--
routerStructure :: Router' env a -> RouterStructure
routerStructure (StaticRouter m ls) =
StaticRouterStructure (fmap routerStructure m) (length ls)
routerStructure (CaptureRouter router) =
CaptureRouterStructure $
routerStructure router
routerStructure (RawRouter _) =
RawRouterStructure
routerStructure (Choice r1 r2) =
ChoiceStructure
(routerStructure r1)
(routerStructure r2)
-- | Compare the structure of two routers.
--
sameStructure :: Router' env a -> Router' env b -> Bool
sameStructure r1 r2 =
routerStructure r1 == routerStructure r2
-- | Provide a textual representation of the
-- structure of a router.
--
routerLayout :: Router' env a -> Text
routerLayout router =
T.unlines (["/"] ++ mkRouterLayout False (routerStructure router))
where
mkRouterLayout :: Bool -> RouterStructure -> [Text]
mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n
mkRouterLayout c (CaptureRouterStructure r) = mkSubTree c "<capture>" (mkRouterLayout False r)
mkRouterLayout c RawRouterStructure =
if c then ["├─ <raw>"] else ["└─ <raw>"]
mkRouterLayout c (ChoiceStructure r1 r2) =
mkRouterLayout True r1 ++ ["┆"] ++ mkRouterLayout c r2
mkSubTrees :: Bool -> [(Text, RouterStructure)] -> Int -> [Text]
mkSubTrees _ [] 0 = []
mkSubTrees c [] n =
concat (replicate (n - 1) (mkLeaf True) ++ [mkLeaf c])
mkSubTrees c [(t, r)] 0 =
mkSubTree c t (mkRouterLayout False r)
mkSubTrees c ((t, r) : trs) n =
mkSubTree True t (mkRouterLayout False r) ++ mkSubTrees c trs n
mkLeaf :: Bool -> [Text]
mkLeaf True = ["├─•","┆"]
mkLeaf False = ["└─•"]
mkSubTree :: Bool -> Text -> [Text] -> [Text]
mkSubTree True path children = ("├─ " <> path <> "/") : map ("│ " <>) children
mkSubTree False path children = ("└─ " <> path <> "/") : map (" " <>) children
-- | Apply a transformation to the response of a `Router`.
tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router env -> Router env
tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))
-- | Interpret a router as an application.
runRouter :: Router () -> RoutingApplication
runRouter r = runRouterEnv r ()
runRouterEnv :: Router env -> env -> RoutingApplication
runRouterEnv router env request respond =
case router of
StaticRouter table ls ->
case pathInfo request of
[] -> runChoice ls env request respond
-- This case is to handle trailing slashes.
[""] -> runChoice ls env request respond
first : rest | Just router' <- M.lookup first table
-> let request' = request { pathInfo = rest }
in runRouterEnv router' env request' respond
_ -> respond $ Fail err404
CaptureRouter router' ->
case pathInfo request of
[] -> respond $ Fail err404
-- This case is to handle trailing slashes.
[""] -> respond $ Fail err404
first : rest
-> let request' = request { pathInfo = rest }
in runRouterEnv router' (first, env) request' respond
RawRouter app ->
app env request respond
Choice r1 r2 ->
runChoice [runRouterEnv r1, runRouterEnv r2] env request respond
-- | Try a list of routing applications in order.
-- We stop as soon as one fails fatally or succeeds.
-- If all fail normally, we pick the "best" error.
--
runChoice :: [env -> RoutingApplication] -> env -> RoutingApplication
runChoice ls =
case ls of
[] -> \ _ _ respond -> respond (Fail err404)
[r] -> r
(r : rs) ->
\ env request respond ->
r env request $ \ response1 ->
case response1 of
Fail _ -> runChoice rs env request $ \ response2 ->
respond $ highestPri response1 response2
_ -> respond response1
where
highestPri (Fail e1) (Fail e2) =
if worseHTTPCode (errHTTPCode e1) (errHTTPCode e2)
then Fail e2
else Fail e1
highestPri (Fail _) y = y
highestPri x _ = x
-- Priority on HTTP codes.
--

263
servant-server/src/Servant/Server/Internal/RoutingApplication.hs
View file

@ -8,7 +8,10 @@
{-# LANGUAGE StandaloneDeriving #-}
module Servant.Server.Internal.RoutingApplication where
import Control.Monad.Trans.Except (ExceptT, runExceptT)
import Control.Monad (ap, liftM)
import Control.Monad.Trans (MonadIO(..))
import Control.Monad.Trans.Except (runExceptT)
import Data.Text (Text)
import Network.Wai (Application, Request,
Response, ResponseReceived)
import Prelude ()
@ -35,31 +38,6 @@ toApplication ra request respond = ra request routingRespond
routingRespond (FailFatal err) = respond $ responseServantErr err
routingRespond (Route v) = respond v
-- We currently mix up the order in which we perform checks
-- and the priority with which errors are reported.
--
-- For example, we perform Capture checks prior to method checks,
-- and therefore get 404 before 405.
--
-- However, we also perform body checks prior to method checks
-- now, and therefore get 415 before 405, which is wrong.
--
-- If we delay Captures, but perform method checks eagerly, we
-- end up potentially preferring 405 over 404, which is also bad.
--
-- So in principle, we'd like:
--
-- static routes (can cause 404)
-- delayed captures (can cause 404)
-- methods (can cause 405)
-- authentication and authorization (can cause 401, 403)
-- delayed body (can cause 415, 400)
-- accept header (can cause 406)
--
-- According to the HTTP decision diagram, the priority order
-- between HTTP status codes is as follows:
--
-- | A 'Delayed' is a representation of a handler with scheduled
-- delayed checks that can trigger errors.
--
@ -120,113 +98,139 @@ toApplication ra request respond = ra request routingRespond
-- The accept header check can be performed as the final
-- computation in this block. It can cause a 406.
--
data Delayed c where
Delayed :: { capturesD :: IO (RouteResult captures)
, methodD :: IO (RouteResult ())
, authD :: IO (RouteResult auth)
, bodyD :: IO (RouteResult body)
, serverD :: (captures -> auth -> body -> RouteResult c)
} -> Delayed c
data Delayed env c where
Delayed :: { capturesD :: env -> DelayedIO captures
, methodD :: DelayedIO ()
, authD :: DelayedIO auth
, bodyD :: DelayedIO body
, serverD :: captures -> auth -> body -> Request -> RouteResult c
} -> Delayed env c
instance Functor Delayed where
fmap f Delayed{..}
= Delayed { capturesD = capturesD
, methodD = methodD
, authD = authD
, bodyD = bodyD
, serverD = (fmap.fmap.fmap.fmap) f serverD
} -- Note [Existential Record Update]
instance Functor (Delayed env) where
fmap f Delayed{..} =
Delayed
{ serverD = \ c a b req -> f <$> serverD c a b req
, ..
} -- Note [Existential Record Update]
-- | Computations used in a 'Delayed' can depend on the
-- incoming 'Request', may perform 'IO, and result in a
-- 'RouteResult, meaning they can either suceed, fail
-- (with the possibility to recover), or fail fatally.
--
newtype DelayedIO a = DelayedIO { runDelayedIO :: Request -> IO (RouteResult a) }
instance Functor DelayedIO where
fmap = liftM
instance Applicative DelayedIO where
pure = return
(<*>) = ap
instance Monad DelayedIO where
return x = DelayedIO (const $ return (Route x))
DelayedIO m >>= f =
DelayedIO $ \ req -> do
r <- m req
case r of
Fail e -> return $ Fail e
FailFatal e -> return $ FailFatal e
Route a -> runDelayedIO (f a) req
instance MonadIO DelayedIO where
liftIO m = DelayedIO (const $ Route <$> m)
-- | A 'Delayed' without any stored checks.
emptyDelayed :: RouteResult a -> Delayed env a
emptyDelayed result =
Delayed (const r) r r r (\ _ _ _ _ -> result)
where
r = return ()
-- | Fail with the option to recover.
delayedFail :: ServantErr -> DelayedIO a
delayedFail err = DelayedIO (const $ return $ Fail err)
-- | Fail fatally, i.e., without any option to recover.
delayedFailFatal :: ServantErr -> DelayedIO a
delayedFailFatal err = DelayedIO (const $ return $ FailFatal err)
-- | Gain access to the incoming request.
withRequest :: (Request -> DelayedIO a) -> DelayedIO a
withRequest f = DelayedIO (\ req -> runDelayedIO (f req) req)
-- | Add a capture to the end of the capture block.
addCapture :: Delayed (a -> b)
-> IO (RouteResult a)
-> Delayed b
addCapture Delayed{..} new
= Delayed { capturesD = combineRouteResults (,) capturesD new
, methodD = methodD
, authD = authD
, bodyD = bodyD
, serverD = \ (x, v) y z -> ($ v) <$> serverD x y z
} -- Note [Existential Record Update]
addCapture :: Delayed env (a -> b)
-> (Text -> DelayedIO a)
-> Delayed (Text, env) b
addCapture Delayed{..} new =
Delayed
{ capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt
, serverD = \ (x, v) a b req -> ($ v) <$> serverD x a b req
, ..
} -- Note [Existential Record Update]
-- | Add a method check to the end of the method block.
addMethodCheck :: Delayed a
-> IO (RouteResult ())
-> Delayed a
addMethodCheck Delayed{..} new
= Delayed { capturesD = capturesD
, methodD = combineRouteResults const methodD new
, authD = authD
, bodyD = bodyD
, serverD = serverD
} -- Note [Existential Record Update]
addMethodCheck :: Delayed env a
-> DelayedIO ()
-> Delayed env a
addMethodCheck Delayed{..} new =
Delayed
{ methodD = methodD <* new
, ..
} -- Note [Existential Record Update]
-- | Add an auth check to the end of the auth block.
addAuthCheck :: Delayed (a -> b)
-> IO (RouteResult a)
-> Delayed b
addAuthCheck Delayed{..} new
= Delayed { capturesD = capturesD
, methodD = methodD
, authD = combineRouteResults (,) authD new
, bodyD = bodyD
, serverD = \ x (y, v) z -> ($ v) <$> serverD x y z
} -- Note [Existential Record Update]
addAuthCheck :: Delayed env (a -> b)
-> DelayedIO a
-> Delayed env b
addAuthCheck Delayed{..} new =
Delayed
{ authD = (,) <$> authD <*> new
, serverD = \ c (y, v) b req -> ($ v) <$> serverD c y b req
, ..
} -- Note [Existential Record Update]
-- | Add a body check to the end of the body block.
addBodyCheck :: Delayed (a -> b)
-> IO (RouteResult a)
-> Delayed b
addBodyCheck Delayed{..} new
= Delayed { capturesD = capturesD
, methodD = methodD
, authD = authD
, bodyD = combineRouteResults (,) bodyD new
, serverD = \ x y (z, v) -> ($ v) <$> serverD x y z
} -- Note [Existential Record Update]
addBodyCheck :: Delayed env (a -> b)
-> DelayedIO a
-> Delayed env b
addBodyCheck Delayed{..} new =
Delayed
{ bodyD = (,) <$> bodyD <*> new
, serverD = \ c a (z, v) req -> ($ v) <$> serverD c a z req
, ..
} -- Note [Existential Record Update]
-- | Add an accept header check to the end of the body block.
-- The accept header check should occur after the body check,
-- but this will be the case, because the accept header check
-- is only scheduled by the method combinators.
addAcceptCheck :: Delayed a
-> IO (RouteResult ())
-> Delayed a
addAcceptCheck Delayed{..} new
= Delayed { capturesD = capturesD
, methodD = methodD
, authD = authD
, bodyD = combineRouteResults const bodyD new
, serverD = serverD
} -- Note [Existential Record Update]
-- | Add an accept header check to the beginning of the body
-- block. There is a tradeoff here. In principle, we'd like
-- to take a bad body (400) response take precedence over a
-- failed accept check (406). BUT to allow streaming the body,
-- we cannot run the body check and then still backtrack.
-- We therefore do the accept check before the body check,
-- when we can still backtrack. There are other solutions to
-- this, but they'd be more complicated (such as delaying the
-- body check further so that it can still be run in a situation
-- where we'd otherwise report 406).
addAcceptCheck :: Delayed env a
-> DelayedIO ()
-> Delayed env a
addAcceptCheck Delayed{..} new =
Delayed
{ bodyD = new *> bodyD
, ..
} -- Note [Existential Record Update]
-- | Many combinators extract information that is passed to
-- the handler without the possibility of failure. In such a
-- case, 'passToServer' can be used.
passToServer :: Delayed (a -> b) -> a -> Delayed b
passToServer d x = ($ x) <$> d
-- | The combination 'IO . RouteResult' is a monad, but we
-- don't explicitly wrap it in a newtype in order to make it
-- an instance. This is the '>>=' of that monad.
--
-- We stop on the first error.
bindRouteResults :: IO (RouteResult a) -> (a -> IO (RouteResult b)) -> IO (RouteResult b)
bindRouteResults m f = do
r <- m
case r of
Fail e -> return $ Fail e
FailFatal e -> return $ FailFatal e
Route a -> f a
-- | Common special case of 'bindRouteResults', corresponding
-- to 'liftM2'.
combineRouteResults :: (a -> b -> c) -> IO (RouteResult a) -> IO (RouteResult b) -> IO (RouteResult c)
combineRouteResults f m1 m2 =
m1 `bindRouteResults` \ a ->
m2 `bindRouteResults` \ b ->
return (Route (f a b))
passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b
passToServer Delayed{..} x =
Delayed
{ serverD = \ c a b req -> ($ x req) <$> serverD c a b req
, ..
} -- Note [Existential Record Update]
-- | Run a delayed server. Performs all scheduled operations
-- in order, and passes the results from the capture and body
@ -234,24 +238,29 @@ combineRouteResults f m1 m2 =
--
-- This should only be called once per request; otherwise the guarantees about
-- effect and HTTP error ordering break down.
runDelayed :: Delayed a
runDelayed :: Delayed env a
-> env
-> Request
-> IO (RouteResult a)
runDelayed Delayed{..} =
capturesD `bindRouteResults` \ c ->
methodD `bindRouteResults` \ _ ->
authD `bindRouteResults` \ a ->
bodyD `bindRouteResults` \ b ->
return (serverD c a b)
runDelayed Delayed{..} env = runDelayedIO $ do
c <- capturesD env
methodD
a <- authD
b <- bodyD
DelayedIO (\ req -> return $ serverD c a b req)
-- | Runs a delayed server and the resulting action.
-- Takes a continuation that lets us send a response.
-- Also takes a continuation for how to turn the
-- result of the delayed server into a response.
runAction :: Delayed (ExceptT ServantErr IO a)
runAction :: Delayed env (Handler a)
-> env
-> Request
-> (RouteResult Response -> IO r)
-> (a -> RouteResult Response)
-> IO r
runAction action respond k = runDelayed action >>= go >>= respond
runAction action env req respond k =
runDelayed action env req >>= go >>= respond
where
go (Fail e) = return $ Fail e
go (FailFatal e) = return $ FailFatal e

123
servant-server/src/Servant/Server/Internal/ServantErr.hs
View file

@ -4,6 +4,7 @@
module Servant.Server.Internal.ServantErr where
import Control.Exception (Exception)
import Control.Monad.Trans.Except (ExceptT)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as LBS
import Data.Typeable (Typeable)
@ -18,6 +19,8 @@ data ServantErr = ServantErr { errHTTPCode :: Int
instance Exception ServantErr
type Handler = ExceptT ServantErr IO
responseServantErr :: ServantErr -> Response
responseServantErr ServantErr{..} = responseLBS status errHeaders errBody
where
@ -27,8 +30,8 @@ responseServantErr ServantErr{..} = responseLBS status errHeaders errBody
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr $ err300 { errBody = "I can't choose." }
-- > failingHandler :: Handler ()
-- > failingHandler = throwError $ err300 { errBody = "I can't choose." }
--
err300 :: ServantErr
err300 = ServantErr { errHTTPCode = 300
@ -41,8 +44,8 @@ err300 = ServantErr { errHTTPCode = 300
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr err301
-- > failingHandler :: Handler ()
-- > failingHandler = throwError err301
--
err301 :: ServantErr
err301 = ServantErr { errHTTPCode = 301
@ -55,8 +58,8 @@ err301 = ServantErr { errHTTPCode = 301
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr err302
-- > failingHandler :: Handler ()
-- > failingHandler = throwError err302
--
err302 :: ServantErr
err302 = ServantErr { errHTTPCode = 302
@ -69,8 +72,8 @@ err302 = ServantErr { errHTTPCode = 302
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr err303
-- > failingHandler :: Handler ()
-- > failingHandler = throwError err303
--
err303 :: ServantErr
err303 = ServantErr { errHTTPCode = 303
@ -83,8 +86,8 @@ err303 = ServantErr { errHTTPCode = 303
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr err304
-- > failingHandler :: Handler ()
-- > failingHandler = throwError err304
--
err304 :: ServantErr
err304 = ServantErr { errHTTPCode = 304
@ -97,8 +100,8 @@ err304 = ServantErr { errHTTPCode = 304
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr err305
-- > failingHandler :: Handler ()
-- > failingHandler = throwError err305
--
err305 :: ServantErr
err305 = ServantErr { errHTTPCode = 305
@ -111,8 +114,8 @@ err305 = ServantErr { errHTTPCode = 305
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr err307
-- > failingHandler :: Handler ()
-- > failingHandler = throwError err307
--
err307 :: ServantErr
err307 = ServantErr { errHTTPCode = 307
@ -125,8 +128,8 @@ err307 = ServantErr { errHTTPCode = 307
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr $ err400 { errBody = "Your request makes no sense to me." }
-- > failingHandler :: Handler ()
-- > failingHandler = throwError $ err400 { errBody = "Your request makes no sense to me." }
--
err400 :: ServantErr
err400 = ServantErr { errHTTPCode = 400
@ -139,8 +142,8 @@ err400 = ServantErr { errHTTPCode = 400
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr $ err401 { errBody = "Your credentials are invalid." }
-- > failingHandler :: Handler ()
-- > failingHandler = throwError $ err401 { errBody = "Your credentials are invalid." }
--
err401 :: ServantErr
err401 = ServantErr { errHTTPCode = 401
@ -153,8 +156,8 @@ err401 = ServantErr { errHTTPCode = 401
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr $ err402 { errBody = "You have 0 credits. Please give me $$$." }
-- > failingHandler :: Handler ()
-- > failingHandler = throwError $ err402 { errBody = "You have 0 credits. Please give me $$$." }
--
err402 :: ServantErr
err402 = ServantErr { errHTTPCode = 402
@ -167,8 +170,8 @@ err402 = ServantErr { errHTTPCode = 402
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr $ err403 { errBody = "Please login first." }
-- > failingHandler :: Handler ()
-- > failingHandler = throwError $ err403 { errBody = "Please login first." }
--
err403 :: ServantErr
err403 = ServantErr { errHTTPCode = 403
@ -181,8 +184,8 @@ err403 = ServantErr { errHTTPCode = 403
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr $ err404 { errBody = "(╯°□°）╯︵ ┻━┻)." }
-- > failingHandler :: Handler ()
-- > failingHandler = throwError $ err404 { errBody = "(╯°□°）╯︵ ┻━┻)." }
--
err404 :: ServantErr
err404 = ServantErr { errHTTPCode = 404
@ -195,8 +198,8 @@ err404 = ServantErr { errHTTPCode = 404
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr $ err405 { errBody = "Your account privileges does not allow for this. Please pay $$$." }
-- > failingHandler :: Handler ()
-- > failingHandler = throwError $ err405 { errBody = "Your account privileges does not allow for this. Please pay $$$." }
--
err405 :: ServantErr
err405 = ServantErr { errHTTPCode = 405
@ -209,8 +212,8 @@ err405 = ServantErr { errHTTPCode = 405
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr err406
-- > failingHandler :: Handler ()
-- > failingHandler = throwError err406
--
err406 :: ServantErr
err406 = ServantErr { errHTTPCode = 406
@ -223,8 +226,8 @@ err406 = ServantErr { errHTTPCode = 406
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr err407
-- > failingHandler :: Handler ()
-- > failingHandler = throwError err407
--
err407 :: ServantErr
err407 = ServantErr { errHTTPCode = 407
@ -237,8 +240,8 @@ err407 = ServantErr { errHTTPCode = 407
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr $ err409 { errBody = "Transaction conflicts with 59879cb56c7c159231eeacdd503d755f7e835f74" }
-- > failingHandler :: Handler ()
-- > failingHandler = throwError $ err409 { errBody = "Transaction conflicts with 59879cb56c7c159231eeacdd503d755f7e835f74" }
--
err409 :: ServantErr
err409 = ServantErr { errHTTPCode = 409
@ -251,8 +254,8 @@ err409 = ServantErr { errHTTPCode = 409
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr $ err410 { errBody = "I know it was here at some point, but.. I blame bad luck." }
-- > failingHandler :: Handler ()
-- > failingHandler = throwError $ err410 { errBody = "I know it was here at some point, but.. I blame bad luck." }
--
err410 :: ServantErr
err410 = ServantErr { errHTTPCode = 410
@ -265,8 +268,8 @@ err410 = ServantErr { errHTTPCode = 410
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr err411
-- > failingHandler :: Handler ()
-- > failingHandler = throwError err411
--
err411 :: ServantErr
err411 = ServantErr { errHTTPCode = 411
@ -279,8 +282,8 @@ err411 = ServantErr { errHTTPCode = 411
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr $ err412 { errBody = "Precondition fail: x < 42 && y > 57" }
-- > failingHandler :: Handler ()
-- > failingHandler = throwError $ err412 { errBody = "Precondition fail: x < 42 && y > 57" }
--
err412 :: ServantErr
err412 = ServantErr { errHTTPCode = 412
@ -293,8 +296,8 @@ err412 = ServantErr { errHTTPCode = 412
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr $ err413 { errBody = "Request exceeded 64k." }
-- > failingHandler :: Handler ()
-- > failingHandler = throwError $ err413 { errBody = "Request exceeded 64k." }
--
err413 :: ServantErr
err413 = ServantErr { errHTTPCode = 413
@ -307,8 +310,8 @@ err413 = ServantErr { errHTTPCode = 413
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr $ err414 { errBody = "Maximum length is 64." }
-- > failingHandler :: Handler ()
-- > failingHandler = throwError $ err414 { errBody = "Maximum length is 64." }
--
err414 :: ServantErr
err414 = ServantErr { errHTTPCode = 414
@ -321,8 +324,8 @@ err414 = ServantErr { errHTTPCode = 414
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr $ err415 { errBody = "Supported media types: gif, png" }
-- > failingHandler :: Handler ()
-- > failingHandler = throwError $ err415 { errBody = "Supported media types: gif, png" }
--
err415 :: ServantErr
err415 = ServantErr { errHTTPCode = 415
@ -335,8 +338,8 @@ err415 = ServantErr { errHTTPCode = 415
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr $ err416 { errBody = "Valid range is [0, 424242]." }
-- > failingHandler :: Handler ()
-- > failingHandler = throwError $ err416 { errBody = "Valid range is [0, 424242]." }
--
err416 :: ServantErr
err416 = ServantErr { errHTTPCode = 416
@ -349,8 +352,8 @@ err416 = ServantErr { errHTTPCode = 416
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr $ err417 { errBody = "I found a quux in the request. This isn't going to work." }
-- > failingHandler :: Handler ()
-- > failingHandler = throwError $ err417 { errBody = "I found a quux in the request. This isn't going to work." }
--
err417 :: ServantErr
err417 = ServantErr { errHTTPCode = 417
@ -363,8 +366,8 @@ err417 = ServantErr { errHTTPCode = 417
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr $ err500 { errBody = "Exception in module A.B.C:55. Have a great day!" }
-- > failingHandler :: Handler ()
-- > failingHandler = throwError $ err500 { errBody = "Exception in module A.B.C:55. Have a great day!" }
--
err500 :: ServantErr
err500 = ServantErr { errHTTPCode = 500
@ -377,8 +380,8 @@ err500 = ServantErr { errHTTPCode = 500
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr $ err501 { errBody = "/v1/foo is not supported with quux in the request." }
-- > failingHandler :: Handler ()
-- > failingHandler = throwError $ err501 { errBody = "/v1/foo is not supported with quux in the request." }
--
err501 :: ServantErr
err501 = ServantErr { errHTTPCode = 501
@ -391,8 +394,8 @@ err501 = ServantErr { errHTTPCode = 501
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr $ err502 { errBody = "Tried gateway foo, bar, and baz. None responded." }
-- > failingHandler :: Handler ()
-- > failingHandler = throwError $ err502 { errBody = "Tried gateway foo, bar, and baz. None responded." }
--
err502 :: ServantErr
err502 = ServantErr { errHTTPCode = 502
@ -405,8 +408,8 @@ err502 = ServantErr { errHTTPCode = 502
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr $ err503 { errBody = "We're rewriting in PHP." }
-- > failingHandler :: Handler ()
-- > failingHandler = throwError $ err503 { errBody = "We're rewriting in PHP." }
--
err503 :: ServantErr
err503 = ServantErr { errHTTPCode = 503
@ -419,8 +422,8 @@ err503 = ServantErr { errHTTPCode = 503
--
-- Example:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr $ err504 { errBody = "Backend foobar did not respond in 5 seconds." }
-- > failingHandler :: Handler ()
-- > failingHandler = throwError $ err504 { errBody = "Backend foobar did not respond in 5 seconds." }
--
err504 :: ServantErr
err504 = ServantErr { errHTTPCode = 504
@ -433,8 +436,8 @@ err504 = ServantErr { errHTTPCode = 504
--
-- Example usage:
--
-- > failingHandler :: ExceptT ServantErr IO ()
-- > failingHandler = throwErr $ err505 { errBody = "I support HTTP/4.0 only." }
-- > failingHandler :: Handler ()
-- > failingHandler = throwError $ err505 { errBody = "I support HTTP/4.0 only." }
--
err505 :: ServantErr
err505 = ServantErr { errHTTPCode = 505

7
servant-server/test/Servant/Server/Internal/EnterSpec.hs → servant-server/test/Servant/ArbitraryMonadServerSpec.hs
View file

@ -1,11 +1,10 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
module Servant.Server.Internal.EnterSpec where
module Servant.ArbitraryMonadServerSpec where
import qualified Control.Category as C
import Control.Monad.Reader
import Control.Monad.Trans.Except
import Data.Proxy
import Servant.API
import Servant.Server
@ -15,7 +14,7 @@ import Test.Hspec.Wai (get, matchStatus, post,
shouldRespondWith, with)
spec :: Spec
spec = describe "module Servant.Server.Enter" $ do
spec = describe "Arbitrary monad server" $ do
enterSpec
type ReaderAPI = "int" :> Get '[JSON] Int
@ -34,7 +33,7 @@ combinedAPI = Proxy
readerServer' :: ServerT ReaderAPI (Reader String)
readerServer' = return 1797 :<|> ask
fReader :: Reader String :~> ExceptT ServantErr IO
fReader :: Reader String :~> Handler
fReader = generalizeNat C.. (runReaderTNat "hi")
readerServer :: Server ReaderAPI

31
servant-server/test/Servant/Server/ErrorSpec.hs
View file

@ -53,6 +53,23 @@ errorOrderApi = Proxy
errorOrderServer :: Server ErrorOrderApi
errorOrderServer = \_ _ _ -> throwE err402
-- On error priorities:
--
-- We originally had
--
-- 404, 405, 401, 415, 400, 406, 402
--
-- but we changed this to
--
-- 404, 405, 401, 406, 415, 400, 402
--
-- for servant-0.7.
--
-- This change is due to the body check being irreversible (to support
-- streaming). Any check done after the body check has to be made fatal,
-- breaking modularity. We've therefore moved the accept check before
-- the body check, to allow it being recoverable and modular, and this
-- goes along with promoting the error priority of 406.
errorOrderSpec :: Spec
errorOrderSpec =
describe "HTTP error order" $
@ -86,18 +103,18 @@ errorOrderSpec =
request goodMethod goodUrl [badAuth, badContentType, badAccept] badBody
`shouldRespondWith` 401
it "has 415 as its fourth highest priority error" $ do
it "has 406 as its fourth highest priority error" $ do
request goodMethod goodUrl [goodAuth, badContentType, badAccept] badBody
`shouldRespondWith` 406
it "has 415 as its fifth highest priority error" $ do
request goodMethod goodUrl [goodAuth, badContentType, goodAccept] badBody
`shouldRespondWith` 415
it "has 400 as its fifth highest priority error" $ do
request goodMethod goodUrl [goodAuth, goodContentType, badAccept] badBody
it "has 400 as its sixth highest priority error" $ do
request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] badBody
`shouldRespondWith` 400
it "has 406 as its sixth highest priority error" $ do
request goodMethod goodUrl [goodAuth, goodContentType, badAccept] goodBody
`shouldRespondWith` 406
it "has handler-level errors as last priority" $ do
request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] goodBody
`shouldRespondWith` 402

9
servant-server/test/Servant/Server/Internal/ContextSpec.hs
View file

@ -1,9 +1,9 @@
{-# LANGUAGE DataKinds #-}
{-# OPTIONS_GHC -fdefer-type-errors #-}
{-# OPTIONS_GHC -fdefer-type-errors -Wwarn #-}
module Servant.Server.Internal.ContextSpec (spec) where
import Data.Proxy (Proxy (..))
import Test.Hspec (Spec, describe, it, shouldBe, pending, context)
import Test.Hspec (Spec, describe, it, shouldBe, context)
import Test.ShouldNotTypecheck (shouldNotTypecheck)
import Servant.API
@ -26,16 +26,17 @@ spec = do
shouldNotTypecheck x
context "Show instance" $ do
let cxt = 'a' :. True :. EmptyContext
it "has a Show instance" $ do
let cxt = 'a' :. True :. EmptyContext
show cxt `shouldBe` "'a' :. True :. EmptyContext"
context "bracketing" $ do
it "works" $ do
let cxt = 'a' :. True :. EmptyContext
show (Just cxt) `shouldBe` "Just ('a' :. True :. EmptyContext)"
it "works with operators" $ do
let cxt = (1 :. 'a' :. EmptyContext) :<|> ('b' :. True :. EmptyContext)
let cxt = ((1 :: Integer) :. 'a' :. EmptyContext) :<|> ('b' :. True :. EmptyContext)
show cxt `shouldBe` "(1 :. 'a' :. EmptyContext) :<|> ('b' :. True :. EmptyContext)"
describe "descendIntoNamedContext" $ do

294
servant-server/test/Servant/Server/RouterSpec.hs Normal file
View file

@ -0,0 +1,294 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
module Servant.Server.RouterSpec (spec) where
import Control.Monad (unless)
import Data.Proxy (Proxy(..))
import Data.Text (unpack)
import Network.HTTP.Types (Status (..))
import Network.Wai (responseBuilder)
import Network.Wai.Internal (Response (ResponseBuilder))
import Test.Hspec
import Test.Hspec.Wai (get, shouldRespondWith, with)
import Servant.API
import Servant.Server
import Servant.Server.Internal
spec :: Spec
spec = describe "Servant.Server.Internal.Router" $ do
routerSpec
distributivitySpec
routerSpec :: Spec
routerSpec = do
let app' :: Application
app' = toApplication $ runRouter router'
router', router :: Router ()
router' = tweakResponse (fmap twk) router
router = leafRouter $ \_ _ cont -> cont (Route $ responseBuilder (Status 201 "") [] "")
twk :: Response -> Response
twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b
twk b = b
describe "tweakResponse" . with (return app') $ do
it "calls f on route result" $ do
get "" `shouldRespondWith` 202
distributivitySpec :: Spec
distributivitySpec =
describe "choice" $ do
it "distributes endpoints through static paths" $ do
endpoint `shouldHaveSameStructureAs` endpointRef
it "distributes nested routes through static paths" $ do
static `shouldHaveSameStructureAs` staticRef
it "distributes nested routes through dynamic paths" $ do
dynamic `shouldHaveSameStructureAs` dynamicRef
it "properly reorders permuted static paths" $ do
permute `shouldHaveSameStructureAs` permuteRef
it "properly reorders permuted static paths in the presence of Raw in end" $ do
permuteRawEnd `shouldHaveSameStructureAs` permuteRawEndRef
it "properly reorders permuted static paths in the presence of Raw in beginning" $ do
permuteRawBegin `shouldHaveSameStructureAs` permuteRawBeginRef
it "properly reorders permuted static paths in the presence of Raw in middle" $ do
permuteRawMiddle `shouldHaveSameStructureAs` permuteRawMiddleRef
it "properly reorders permuted static paths in the presence of a root endpoint in end" $ do
permuteEndEnd `shouldHaveSameStructureAs` permuteEndRef
it "properly reorders permuted static paths in the presence of a root endpoint in beginning" $ do
permuteEndBegin `shouldHaveSameStructureAs` permuteEndRef
it "properly reorders permuted static paths in the presence of a root endpoint in middle" $ do
permuteEndMiddle `shouldHaveSameStructureAs` permuteEndRef
it "properly handles mixing static paths at different levels" $ do
level `shouldHaveSameStructureAs` levelRef
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))
makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router ()
makeTrivialRouter p =
route p EmptyContext (emptyDelayed (FailFatal err501))
type End = Get '[JSON] ()
-- The latter version looks more efficient,
-- but the former should be compiled to the
-- same layout:
type Endpoint = "a" :> End :<|> "a" :> End
type EndpointRef = "a" :> (End :<|> End)
endpoint :: Proxy Endpoint
endpoint = Proxy
endpointRef :: Proxy EndpointRef
endpointRef = Proxy
-- Again, the latter version looks more efficient,
-- but the former should be compiled to the same
-- layout:
type Static = "a" :> "b" :> End :<|> "a" :> "c" :> End
type StaticRef = "a" :> ("b" :> End :<|> "c" :> End)
static :: Proxy Static
static = Proxy
staticRef :: Proxy StaticRef
staticRef = Proxy
-- Even for dynamic path components, we expect the
-- router to simplify the layout, because captures
-- are delayed and only actually performed once
-- reaching an endpoint. So the former version and
-- the latter should be compiled to the same router
-- structure:
type Dynamic =
"a" :> Capture "foo" Int :> "b" :> End
:<|> "a" :> Capture "bar" Bool :> "c" :> End
:<|> "a" :> Capture "baz" Char :> "d" :> End
type DynamicRef =
"a" :> Capture "anything" () :>
("b" :> End :<|> "c" :> End :<|> "d" :> End)
dynamic :: Proxy Dynamic
dynamic = Proxy
dynamicRef :: Proxy DynamicRef
dynamicRef = Proxy
-- A more complicated example of static route reordering.
-- All the permuted paths should be correctly grouped,
-- so both 'Permute' and 'PermuteRef' should compile to
-- the same layout:
type Permute =
"a" :> "b" :> "c" :> End
:<|> "b" :> "a" :> "c" :> End
:<|> "a" :> "c" :> "b" :> End
:<|> "c" :> "a" :> "b" :> End
:<|> "b" :> "c" :> "a" :> End
:<|> "c" :> "b" :> "a" :> End
type PermuteRef =
"a" :> ( "b" :> "c" :> End
:<|> "c" :> "b" :> End
)
:<|> "b" :> ( "a" :> "c" :> End
:<|> "c" :> "a" :> End
)
:<|> "c" :> ( "a" :> "b" :> End
:<|> "b" :> "a" :> End
)
permute :: Proxy Permute
permute = Proxy
permuteRef :: Proxy PermuteRef
permuteRef = Proxy
-- Adding a 'Raw' in one of the ends should have minimal
-- effect on the grouping.
type PermuteRawEnd =
"a" :> "b" :> "c" :> End
:<|> "b" :> "a" :> "c" :> End
:<|> "a" :> "c" :> "b" :> End
:<|> "c" :> "a" :> "b" :> End
:<|> "b" :> "c" :> "a" :> End
:<|> "c" :> "b" :> "a" :> End
:<|> Raw
type PermuteRawEndRef = PermuteRef :<|> Raw
type PermuteRawBegin =
Raw
:<|> "a" :> "b" :> "c" :> End
:<|> "b" :> "a" :> "c" :> End
:<|> "a" :> "c" :> "b" :> End
:<|> "c" :> "a" :> "b" :> End
:<|> "b" :> "c" :> "a" :> End
:<|> "c" :> "b" :> "a" :> End
type PermuteRawBeginRef = Raw :<|> PermuteRef
permuteRawBegin :: Proxy PermuteRawBegin
permuteRawBegin = Proxy
permuteRawBeginRef :: Proxy PermuteRawBeginRef
permuteRawBeginRef = Proxy
permuteRawEnd :: Proxy PermuteRawEnd
permuteRawEnd = Proxy
permuteRawEndRef :: Proxy PermuteRawEndRef
permuteRawEndRef = Proxy
-- Adding a 'Raw' in the middle will disrupt grouping,
-- because we commute things past a 'Raw'. But the two
-- halves should still be grouped.
type PermuteRawMiddle =
"a" :> "b" :> "c" :> End
:<|> "b" :> "a" :> "c" :> End
:<|> "a" :> "c" :> "b" :> End
:<|> Raw
:<|> "c" :> "a" :> "b" :> End
:<|> "b" :> "c" :> "a" :> End
:<|> "c" :> "b" :> "a" :> End
type PermuteRawMiddleRef =
"a" :> ( "b" :> "c" :> End
:<|> "c" :> "b" :> End
)
:<|> "b" :> "a" :> "c" :> End
:<|> Raw
:<|> "b" :> "c" :> "a" :> End
:<|> "c" :> ( "a" :> "b" :> End
:<|> "b" :> "a" :> End
)
permuteRawMiddle :: Proxy PermuteRawMiddle
permuteRawMiddle = Proxy
permuteRawMiddleRef :: Proxy PermuteRawMiddleRef
permuteRawMiddleRef = Proxy
-- Adding an endpoint at the top-level in various places
-- is also somewhat critical for grouping, but it should
-- not disrupt grouping at all, even if it is placed in
-- the middle.
type PermuteEndEnd =
"a" :> "b" :> "c" :> End
:<|> "b" :> "a" :> "c" :> End
:<|> "a" :> "c" :> "b" :> End
:<|> "c" :> "a" :> "b" :> End
:<|> "b" :> "c" :> "a" :> End
:<|> "c" :> "b" :> "a" :> End
:<|> End
type PermuteEndBegin =
End
:<|> "a" :> "b" :> "c" :> End
:<|> "b" :> "a" :> "c" :> End
:<|> "a" :> "c" :> "b" :> End
:<|> "c" :> "a" :> "b" :> End
:<|> "b" :> "c" :> "a" :> End
:<|> "c" :> "b" :> "a" :> End
type PermuteEndMiddle =
"a" :> "b" :> "c" :> End
:<|> "b" :> "a" :> "c" :> End
:<|> "a" :> "c" :> "b" :> End
:<|> End
:<|> "c" :> "a" :> "b" :> End
:<|> "b" :> "c" :> "a" :> End
:<|> "c" :> "b" :> "a" :> End
type PermuteEndRef = PermuteRef :<|> End
permuteEndEnd :: Proxy PermuteEndEnd
permuteEndEnd = Proxy
permuteEndBegin :: Proxy PermuteEndBegin
permuteEndBegin = Proxy
permuteEndMiddle :: Proxy PermuteEndMiddle
permuteEndMiddle = Proxy
permuteEndRef :: Proxy PermuteEndRef
permuteEndRef = Proxy
-- An API with routes on different nesting levels that
-- is composed out of different fragments should still
-- be reordered correctly.
type LevelFragment1 =
"a" :> "b" :> End
:<|> "a" :> End
type LevelFragment2 =
"b" :> End
:<|> "a" :> "c" :> End
:<|> End
type Level = LevelFragment1 :<|> LevelFragment2
type LevelRef =
"a" :> ("b" :> End :<|> "c" :> End :<|> End)
:<|> "b" :> End
:<|> End
level :: Proxy Level
level = Proxy
levelRef :: Proxy LevelRef
levelRef = Proxy

5
servant-server/test/Servant/Server/StreamingSpec.hs
View file

@ -9,9 +9,8 @@
module Servant.Server.StreamingSpec where
import Control.Concurrent
import Control.Exception
import Control.Exception hiding (Handler)
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Lazy as Lazy
import Network.HTTP.Types
@ -66,7 +65,7 @@ spec = do
-- - receives the first chunk
-- - notifies serverReceivedFirstChunk
-- - receives the rest of the request
let handler :: Lazy.ByteString -> ExceptT ServantErr IO NoContent
let handler :: Lazy.ByteString -> Handler NoContent
handler input = liftIO $ do
let prefix = Lazy.take 3 input
prefix `shouldBe` "foo"

3
servant-server/test/Servant/Server/UsingContextSpec.hs
View file

@ -5,7 +5,6 @@
module Servant.Server.UsingContextSpec where
import Control.Monad.Trans.Except
import Network.Wai
import Test.Hspec (Spec, describe, it)
import Test.Hspec.Wai
@ -25,7 +24,7 @@ spec = do
type OneEntryAPI =
ExtractFromContext :> Get '[JSON] String
testServer :: String -> ExceptT ServantErr IO String
testServer :: String -> Handler String
testServer s = return s
oneEntryApp :: Application

5
servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs
View file

@ -20,7 +20,6 @@ module Servant.Server.UsingContextSpec.TestCombinators where
import GHC.TypeLits
import Servant
import Servant.Server.Internal.RoutingApplication
data ExtractFromContext
@ -31,12 +30,12 @@ instance (HasContextEntry context String, HasServer subApi context) =>
String -> ServerT subApi m
route Proxy context delayed =
route subProxy context (fmap (inject context) delayed :: Delayed (Server subApi))
route subProxy context (fmap inject delayed)
where
subProxy :: Proxy subApi
subProxy = Proxy
inject context f = f (getContextEntry context)
inject f = f (getContextEntry context)
data InjectIntoContext

123
servant-server/test/Servant/ServerSpec.hs
View file

@ -13,14 +13,13 @@
module Servant.ServerSpec where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad (forM_, when, unless)
import Control.Monad.Trans.Except (ExceptT, throwE)
import Control.Monad.Trans.Except (throwE)
import Data.Aeson (FromJSON, ToJSON, decode', encode)
import qualified Data.ByteString.Base64 as Base64
import Data.ByteString.Conversion ()
import Data.Char (toUpper)
import Data.Monoid
import Data.Proxy (Proxy (Proxy))
import Data.String (fromString)
import Data.String.Conversions (cs)
@ -30,11 +29,11 @@ import Network.HTTP.Types (Status (..), hAccept, hContentType,
methodDelete, methodGet,
methodHead, methodPatch,
methodPost, methodPut, ok200,
imATeaPot418,
parseQuery)
import Network.Wai (Application, Request, requestHeaders, pathInfo,
queryString, rawQueryString,
responseBuilder, responseLBS)
import Network.Wai.Internal (Response (ResponseBuilder))
responseLBS)
import Network.Wai.Test (defaultRequest, request,
runSession, simpleBody,
simpleHeaders, simpleStatus)
@ -49,8 +48,9 @@ import Servant.API ((:<|>) (..), (:>), AuthProtect,
Raw, RemoteHost, ReqBody,
StdMethod (..), Verb, addHeader)
import Servant.API.Internal.Test.ComprehensiveAPI
import Servant.Server (ServantErr (..), Server, err401, err404,
serve, serveWithContext, Context((:.), EmptyContext))
import Servant.Server (Server, Handler, err401, err403,
err404, serve, serveWithContext,
Context((:.), EmptyContext))
import Test.Hspec (Spec, context, describe, it,
shouldBe, shouldContain)
import qualified Test.Hspec.Wai as THW
@ -63,11 +63,6 @@ import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthChec
import Servant.Server.Experimental.Auth
(AuthHandler, AuthServerData,
mkAuthHandler)
import Servant.Server.Internal.RoutingApplication
(toApplication, RouteResult(..))
import Servant.Server.Internal.Router
(tweakResponse, runRouter,
Router, Router'(LeafRouter))
import Servant.Server.Internal.Context
(NamedContext(..))
@ -91,7 +86,6 @@ spec = do
rawSpec
alternativeSpec
responseHeadersSpec
routerSpec
miscCombinatorSpec
basicAuthSpec
genAuthSpec
@ -105,6 +99,9 @@ type VerbApi method status
:<|> "noContent" :> Verb method status '[JSON] NoContent
:<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person)
:<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent)
:<|> "accept" :> ( Verb method status '[JSON] Person
:<|> Verb method status '[PlainText] String
)
verbSpec :: Spec
verbSpec = describe "Servant.API.Verb" $ do
@ -113,6 +110,7 @@ verbSpec = describe "Servant.API.Verb" $ do
:<|> return NoContent
:<|> return (addHeader 5 alice)
:<|> return (addHeader 10 NoContent)
:<|> (return alice :<|> return "B")
get200 = Proxy :: Proxy (VerbApi 'GET 200)
post210 = Proxy :: Proxy (VerbApi 'POST 210)
put203 = Proxy :: Proxy (VerbApi 'PUT 203)
@ -167,6 +165,12 @@ verbSpec = describe "Servant.API.Verb" $ do
[(hAccept, "application/json")] ""
liftIO $ statusCode (simpleStatus response) `shouldBe` status
unless (status `elem` [214, 215] || method == methodHead) $
it "allows modular specification of supported content types" $ do
response <- THW.request method "/accept" [(hAccept, "text/plain")] ""
liftIO $ statusCode (simpleStatus response) `shouldBe` status
liftIO $ simpleBody response `shouldBe` "B"
it "sets the Content-Type header" $ do
response <- THW.request method "" [] ""
liftIO $ simpleHeaders response `shouldContain`
@ -187,7 +191,7 @@ verbSpec = describe "Servant.API.Verb" $ do
type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal
captureApi :: Proxy CaptureApi
captureApi = Proxy
captureServer :: Integer -> ExceptT ServantErr IO Animal
captureServer :: Integer -> Handler Animal
captureServer legs = case legs of
4 -> return jerry
2 -> return tweety
@ -343,11 +347,11 @@ headerApi = Proxy
headerSpec :: Spec
headerSpec = describe "Servant.API.Header" $ do
let expectsInt :: Maybe Int -> ExceptT ServantErr IO ()
let expectsInt :: Maybe Int -> Handler ()
expectsInt (Just x) = when (x /= 5) $ error "Expected 5"
expectsInt Nothing = error "Expected an int"
let expectsString :: Maybe String -> ExceptT ServantErr IO ()
let expectsString :: Maybe String -> Handler ()
expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you"
expectsString Nothing = error "Expected a string"
@ -479,28 +483,6 @@ responseHeadersSpec = describe "ResponseHeaders" $ do
THW.request method "" [(hAccept, "crazy/mime")] ""
`shouldRespondWith` 406
-- }}}
------------------------------------------------------------------------------
-- * routerSpec {{{
------------------------------------------------------------------------------
routerSpec :: Spec
routerSpec = do
describe "Servant.Server.Internal.Router" $ do
let app' :: Application
app' = toApplication $ runRouter router'
router', router :: Router
router' = tweakResponse (twk <$>) router
router = LeafRouter $ \_ cont -> cont (Route $ responseBuilder (Status 201 "") [] "")
twk :: Response -> Response
twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b
twk b = b
describe "tweakResponse" . with (return app') $ do
it "calls f on route result" $ do
get "" `shouldRespondWith` 202
-- }}}
------------------------------------------------------------------------------
-- * miscCombinatorSpec {{{
@ -542,20 +524,24 @@ miscCombinatorSpec = with (return $ serve miscApi miscServ) $
-- * Basic Authentication {{{
------------------------------------------------------------------------------
type BasicAuthAPI = BasicAuth "foo" () :> "basic" :> Get '[JSON] Animal
type BasicAuthAPI =
BasicAuth "foo" () :> "basic" :> Get '[JSON] Animal
:<|> Raw
basicAuthApi :: Proxy BasicAuthAPI
basicAuthApi = Proxy
basicAuthServer :: Server BasicAuthAPI
basicAuthServer = const (return jerry)
basicAuthServer =
const (return jerry) :<|>
(\ _ respond -> respond $ responseLBS imATeaPot418 [] "")
basicAuthContext :: Context '[ BasicAuthCheck () ]
basicAuthContext =
let basicHandler = BasicAuthCheck $ (\(BasicAuthData usr pass) ->
let basicHandler = BasicAuthCheck $ \(BasicAuthData usr pass) ->
if usr == "servant" && pass == "server"
then return (Authorized ())
else return Unauthorized
)
then return (Authorized ())
else return Unauthorized
in basicHandler :. EmptyContext
basicAuthSpec :: Spec
@ -564,10 +550,21 @@ basicAuthSpec = do
with (return (serveWithContext basicAuthApi basicAuthContext basicAuthServer)) $ do
context "Basic Authentication" $ do
it "returns with 401 with bad password" $ do
let basicAuthHeaders user password =
[("Authorization", "Basic " <> Base64.encode (user <> ":" <> password))]
it "returns 401 when no credentials given" $ do
get "/basic" `shouldRespondWith` 401
it "returns 403 when invalid credentials given" $ do
THW.request methodGet "/basic" (basicAuthHeaders "servant" "wrong") ""
`shouldRespondWith` 403
it "returns 200 with the right password" $ do
THW.request methodGet "/basic" [("Authorization","Basic c2VydmFudDpzZXJ2ZXI=")] "" `shouldRespondWith` 200
THW.request methodGet "/basic" (basicAuthHeaders "servant" "server") ""
`shouldRespondWith` 200
it "plays nice with subsequent Raw endpoints" $ do
get "/foo" `shouldRespondWith` 418
-- }}}
------------------------------------------------------------------------------
@ -575,33 +572,43 @@ basicAuthSpec = do
------------------------------------------------------------------------------
type GenAuthAPI = AuthProtect "auth" :> "auth" :> Get '[JSON] Animal
authApi :: Proxy GenAuthAPI
authApi = Proxy
authServer :: Server GenAuthAPI
authServer = const (return tweety)
:<|> Raw
genAuthApi :: Proxy GenAuthAPI
genAuthApi = Proxy
genAuthServer :: Server GenAuthAPI
genAuthServer = const (return tweety)
:<|> (\ _ respond -> respond $ responseLBS imATeaPot418 [] "")
type instance AuthServerData (AuthProtect "auth") = ()
genAuthContext :: Context '[ AuthHandler Request () ]
genAuthContext :: Context '[AuthHandler Request ()]
genAuthContext =
let authHandler = (\req ->
if elem ("Auth", "secret") (requestHeaders req)
then return ()
else throwE err401
)
let authHandler = \req -> case lookup "Auth" (requestHeaders req) of
Just "secret" -> return ()
Just _ -> throwE err403
Nothing -> throwE err401
in mkAuthHandler authHandler :. EmptyContext
genAuthSpec :: Spec
genAuthSpec = do
describe "Servant.API.Auth" $ do
with (return (serveWithContext authApi genAuthContext authServer)) $ do
with (return (serveWithContext genAuthApi genAuthContext genAuthServer)) $ do
context "Custom Auth Protection" $ do
it "returns 401 when missing headers" $ do
get "/auth" `shouldRespondWith` 401
it "returns 403 on wrong passwords" $ do
THW.request methodGet "/auth" [("Auth","wrong")] "" `shouldRespondWith` 403
it "returns 200 with the right header" $ do
THW.request methodGet "/auth" [("Auth","secret")] "" `shouldRespondWith` 200
it "plays nice with subsequent Raw endpoints" $ do
get "/foo" `shouldRespondWith` 418
-- }}}
------------------------------------------------------------------------------
-- * Test data types {{{

8
servant/CHANGELOG.md
View file

@ -1,5 +1,11 @@
0.7.1
-----
* Add module `Servant.Utils.Enter` (https://github.com/haskell-servant/servant/pull/478)
* Allow to set the same header multiple times in responses.
0.5
----
---
* Add `WithNamedConfig` combinator.
* Add `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators

23
servant/servant.cabal
View file

@ -1,13 +1,13 @@
name: servant
version: 0.6
version: 0.7.1
synopsis: A family of combinators for defining webservices APIs
description:
A family of combinators for defining webservices APIs and serving them
.
You can learn about the basics in the <http://haskell-servant.github.io/tutorial tutorial>.
You can learn about the basics in the <http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html tutorial>.
.
<https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md CHANGELOG>
homepage: http://haskell-servant.github.io/
homepage: http://haskell-servant.readthedocs.org/
Bug-reports: http://github.com/haskell-servant/servant/issues
license: BSD3
license-file: LICENSE
@ -16,9 +16,11 @@ maintainer: haskell-servant-maintainers@googlegroups.com
copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors
category: Web
build-type: Simple
extra-source-files: include/*.h
cabal-version: >=1.10
tested-with: GHC >= 7.8
extra-source-files:
include/*.h
CHANGELOG.md
source-repository head
type: git
location: http://github.com/haskell-servant/servant.git
@ -45,8 +47,9 @@ library
Servant.API.Verbs
Servant.API.WithNamedContext
Servant.Utils.Links
Servant.Utils.Enter
build-depends:
base >= 4.7 && < 4.9
base >= 4.7 && < 4.10
, base-compat >= 0.9
, aeson >= 0.7
, attoparsec >= 0.12
@ -56,6 +59,8 @@ library
, http-api-data >= 0.1 && < 0.3
, http-media >= 0.4 && < 0.7
, http-types >= 0.8 && < 0.10
, mtl >= 2 && < 3
, mmorph >= 1
, text >= 1 && < 2
, string-conversions >= 0.3 && < 0.5
, network-uri >= 2.6
@ -83,12 +88,13 @@ library
, TypeSynonymInstances
, UndecidableInstances
ghc-options: -Wall
if impl(ghc >= 8.0)
ghc-options: -Wno-redundant-constraints
include-dirs: include
test-suite spec
type: exitcode-stdio-1.0
ghc-options:
-Wall -fno-warn-name-shadowing -fno-warn-missing-signatures
ghc-options: -Wall
default-language: Haskell2010
hs-source-dirs: test
main-is: Spec.hs
@ -98,6 +104,7 @@ test-suite spec
Servant.Utils.LinksSpec
build-depends:
base == 4.*
, base-compat
, aeson
, attoparsec
, bytestring
@ -120,5 +127,5 @@ test-suite doctests
main-is: test/Doctests.hs
buildable: True
default-language: Haskell2010
ghc-options: -threaded
ghc-options: -Wall -threaded
include-dirs: include

2
servant/src/Servant/API/Alternative.hs
View file

@ -1,9 +1,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE DeriveFoldable #-}
#endif
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_HADDOCK not-home #-}

7
servant/src/Servant/API/BasicAuth.hs
View file

@ -1,12 +1,13 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
module Servant.API.BasicAuth where
import Data.ByteString (ByteString)
import Data.Typeable (Typeable)
import GHC.TypeLits (Symbol)
import GHC.TypeLits (Symbol)
-- | Combinator for <https://tools.ietf.org/html/rfc2617#section-2 Basic Access Authentication>.

4
servant/src/Servant/API/ContentTypes.hs
View file

@ -154,7 +154,7 @@ newtype AcceptHeader = AcceptHeader BS.ByteString
-- > instance Accept MyContentType where
-- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8")
-- >
-- > instance Show a => MimeRender MyContentType where
-- > instance Show a => MimeRender MyContentType a where
-- > mimeRender _ val = pack ("This is MINE! " ++ show val)
-- >
-- > type MyAPI = "path" :> Get '[MyContentType] Int
@ -169,7 +169,7 @@ class (AllMime list) => AllCTRender (list :: [*]) a where
handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
instance OVERLAPPABLE_
(AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where
(Accept ct, AllMime cts, AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where
handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
where pctyps = Proxy :: Proxy (ct ': cts)
amrs = allMimeRender pctyps val

5
servant/src/Servant/API/Experimental/Auth.hs
View file

@ -1,7 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
module Servant.API.Experimental.Auth where
import Data.Typeable (Typeable)
@ -11,4 +11,3 @@ import Data.Typeable (Typeable)
--
-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE.
data AuthProtect (tag :: k) deriving (Typeable)

6
servant/src/Servant/API/Header.hs
View file

@ -3,7 +3,9 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE PolyKinds #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Header where
module Servant.API.Header (
Header(..),
) where
import Data.ByteString (ByteString)
import Data.Typeable (Typeable)
@ -25,5 +27,3 @@ data Header (sym :: Symbol) a = Header a
-- >>> import Servant.API
-- >>> import Data.Aeson
-- >>> import Data.Text
-- >>> data Book
-- >>> instance ToJSON Book where { toJSON = undefined }

16
servant/src/Servant/API/ResponseHeaders.hs
View file

@ -68,8 +68,7 @@ class BuildHeadersTo hs where
instance OVERLAPPING_ BuildHeadersTo '[] where
buildHeadersTo _ = HNil
instance OVERLAPPABLE_ ( FromByteString v, BuildHeadersTo xs, KnownSymbol h
, Contains h xs ~ 'False)
instance OVERLAPPABLE_ ( FromByteString v, BuildHeadersTo xs, KnownSymbol h )
=> BuildHeadersTo ((Header h v) ': xs) where
buildHeadersTo headers =
let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
@ -89,7 +88,7 @@ class GetHeaders ls where
instance OVERLAPPING_ GetHeaders (HList '[]) where
getHeaders _ = []
instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs))
instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs) )
=> GetHeaders (HList (Header h x ': xs)) where
getHeaders hdrs = case hdrs of
Header val `HCons` rest -> (headerName , toByteString' val):getHeaders rest
@ -100,7 +99,7 @@ instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs))
instance OVERLAPPING_ GetHeaders (Headers '[] a) where
getHeaders _ = []
instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToByteString v)
instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToByteString v )
=> GetHeaders (Headers (Header h v ': rest) a) where
getHeaders hs = getHeaders $ getHeadersHList hs
@ -112,20 +111,15 @@ class AddHeader h v orig new
addHeader :: v -> orig -> new -- ^ N.B.: The same header can't be added multiple times
instance OVERLAPPING_ ( KnownSymbol h, ToByteString v, Contains h (fst ': rest) ~ 'False)
instance OVERLAPPING_ ( KnownSymbol h, ToByteString v )
=> AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where
addHeader a (Headers resp heads) = Headers resp (HCons (Header a) heads)
instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString v
, new ~ (Headers '[Header h v] a))
, new ~ (Headers '[Header h v] a) )
=> AddHeader h v a new where
addHeader a resp = Headers resp (HCons (Header a) HNil)
type family Contains x xs where
Contains x ((Header x a) ': xs) = 'True
Contains x ((Header y a) ': xs) = Contains x xs
Contains x '[] = 'False
-- $setup
-- >>> import Servant.API
-- >>> import Data.Aeson

4
servant/src/Servant/API/Vault.hs
View file

@ -9,8 +9,8 @@ import Data.Vault.Lazy (Vault)
--
-- | Use 'Vault' in your API types to provide access to the 'Vault'
-- of the request, which is a location shared by middlewares and applications
-- to store arbitrary data. See 'Vault' for more details on how to actually
-- use the vault in your handlers
-- to store arbitrary data. See <https://hackage.haskell.org/package/vault vault>
-- for more details on how to actually use the vault in your handlers
--
-- Example:
--

13
servant/src/Servant/API/Verbs.hs
View file

@ -14,7 +14,9 @@ import GHC.Generics (Generic)
import GHC.TypeLits (Nat)
import Network.HTTP.Types.Method (Method, StdMethod (..),
methodDelete, methodGet, methodHead,
methodPatch, methodPost, methodPut)
methodPatch, methodPost, methodPut,
methodTrace, methodConnect,
methodOptions)
-- | @Verb@ is a general type for representing HTTP verbs (a.k.a. methods). For
-- convenience, type synonyms for each verb with a 200 response code are
@ -167,3 +169,12 @@ instance ReflectMethod 'PATCH where
instance ReflectMethod 'HEAD where
reflectMethod _ = methodHead
instance ReflectMethod 'OPTIONS where
reflectMethod _ = methodOptions
instance ReflectMethod 'TRACE where
reflectMethod _ = methodTrace
instance ReflectMethod 'CONNECT where
reflectMethod _ = methodConnect

5
servant-server/src/Servant/Server/Internal/Enter.hs → servant/src/Servant/Utils/Enter.hs
View file

@ -8,12 +8,9 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Servant.Server.Internal.Enter where
module Servant.Utils.Enter where
import qualified Control.Category as C
#if MIN_VERSION_mtl(2,2,1)
import Control.Monad.Except
#endif
import Control.Monad.Identity
import Control.Monad.Morph
import Control.Monad.Reader

20
servant/src/Servant/Utils/Links.hs
View file

@ -72,14 +72,8 @@
-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] ())
-- >>> safeLink api bad_link
-- ...
-- Could not deduce (Or
-- (IsElem' (Verb 'DELETE 200 '[JSON] ()) (Verb 'GET 200 '[JSON] Int))
-- (IsElem'
-- ("hello" :> Delete '[JSON] ())
-- ("bye" :> (QueryParam "name" String :> Delete '[JSON] ()))))
-- arising from a use of ‘safeLink’
-- In the expression: safeLink api bad_link
-- In an equation for ‘it’: it = safeLink api bad_link
-- ...Could not deduce...
-- ...
--
-- This error is essentially saying that the type family couldn't find
-- bad_link under api after trying the open (but empty) type family
@ -112,10 +106,12 @@ import Prelude ()
import Prelude.Compat
import Web.HttpApiData
import Servant.API.BasicAuth ( BasicAuth )
import Servant.API.Capture ( Capture )
import Servant.API.ReqBody ( ReqBody )
import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag )
import Servant.API.Header ( Header )
import Servant.API.RemoteHost ( RemoteHost )
import Servant.API.Verbs ( Verb )
import Servant.API.Sub ( type (:>) )
import Servant.API.Raw ( Raw )
@ -292,6 +288,14 @@ instance HasLink sub => HasLink (Header sym a :> sub) where
type MkLink (Header sym a :> sub) = MkLink sub
toLink _ = toLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (RemoteHost :> sub) where
type MkLink (RemoteHost :> sub) = MkLink sub
toLink _ = toLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (BasicAuth realm a :> sub) where
type MkLink (BasicAuth realm a :> sub) = MkLink sub
toLink _ = toLink (Proxy :: Proxy sub)
-- Verb (terminal) instances
instance HasLink (Verb m s ct a) where
type MkLink (Verb m s ct a) = URI

10
servant/test/Servant/API/ContentTypesSpec.hs
View file

@ -3,14 +3,14 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE PolyKinds #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Servant.API.ContentTypesSpec where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
import Data.Monoid
#endif
import Prelude ()
import Prelude.Compat
import Control.Arrow
import Data.Aeson
import Data.ByteString.Char8 (ByteString, append, pack)
@ -28,7 +28,7 @@ import GHC.Generics
import Network.URL (exportParams, importParams)
import Test.Hspec
import Test.QuickCheck
import Test.QuickCheck.Instances ()
import "quickcheck-instances" Test.QuickCheck.Instances ()
import Servant.API.ContentTypes

10
servant/test/Servant/Utils/LinksSpec.hs
View file

@ -67,27 +67,27 @@ spec = describe "Servant.Utils.Links" $ do
--
-- >>> apiLink (Proxy :: Proxy WrongPath)
-- ...
-- Could not deduce ...
-- ...Could not deduce...
-- ...
--
-- >>> apiLink (Proxy :: Proxy WrongReturnType)
-- ...
-- Could not deduce ...
-- ...Could not deduce...
-- ...
--
-- >>> apiLink (Proxy :: Proxy WrongContentType)
-- ...
-- Could not deduce ...
-- ...Could not deduce...
-- ...
--
-- >>> apiLink (Proxy :: Proxy WrongMethod)
-- ...
-- Could not deduce ...
-- ...Could not deduce...
-- ...
--
-- >>> apiLink (Proxy :: Proxy NotALink)
-- ...
-- Could not deduce ...
-- ...Could not deduce...
-- ...
--
-- sanity check

5
sources.txt
View file

@ -1,10 +1,7 @@
servant
servant-cassava
servant-server
servant-client
servant-docs
servant-foreign
servant-js
servant-server
servant-blaze
servant-lucid
servant-mock

32
stack-ghc-7.8.4.yaml
View file

@ -1,28 +1,28 @@
flags: {}
packages:
- servant/
- servant-blaze/
- servant-cassava/
- servant-client/
- servant-docs/
- servant-examples/
- servant-foreign/
- servant-js/
- servant-lucid/
- servant-mock/
- servant-server/
extra-deps:
- base-compat-0.9.0
- hspec-2.2.0
- hspec-core-2.2.0
- hspec-discover-2.2.0
- hspec-expectations-0.7.2
- doctest-0.10.1
- engine-io-1.2.10
- engine-io-wai-1.0.3
- socket-io-1.3.3
- stm-delay-0.1.1.1
- base-compat-0.9.1
- control-monad-omega-0.3.1
- http-api-data-0.1.1.1
- should-not-typecheck-2.0.1
- cryptonite-0.6
- doctest-0.11.0
- hspec-2.2.3
- hspec-core-2.2.3
- hspec-discover-2.2.3
- hspec-expectations-0.7.2
- http-api-data-0.2.2
- primitive-0.6.1.0
- servant-0.7.1
- servant-client-0.7.1
- servant-docs-0.7.1
- servant-server-0.7.1
- should-not-typecheck-2.1.0
- time-locale-compat-0.1.1.1
- wai-app-static-3.1.5
resolver: lts-2.22

11
stack-ghc-8.0.1.yaml Normal file
View file

@ -0,0 +1,11 @@
resolver: nightly-2016-05-27
packages:
- servant/
- servant-client/
- servant-docs/
- servant-foreign/
- servant-js/
- servant-mock/
- servant-server/
extra-deps: []
flags: {}

16
stack.yaml
View file

@ -1,24 +1,12 @@
flags:
servant-js:
example: false
flags: {}
packages:
- servant/
- servant-blaze/
- servant-cassava/
- servant-client/
- servant-docs/
- servant-foreign/
- servant-js/
- servant-lucid/
- servant-mock/
- servant-server/
- doc/tutorial
extra-deps:
- base-compat-0.9.0
- engine-io-wai-1.0.2
- control-monad-omega-0.3.1
- should-not-typecheck-2.0.1
- markdown-unlit-0.4.0
- aeson-0.11.0.0
- fail-4.9.0.0
resolver: nightly-2016-03-17
resolver: lts-6.0

2
travis.sh
View file

@ -6,7 +6,7 @@ for package in $(cat sources.txt) doc/tutorial ; do
echo testing $package
pushd $package
tinc
cabal configure --enable-tests --disable-optimization
cabal configure --enable-tests --disable-optimization --ghc-options='-Werror'
cabal build
cabal test
popd