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 language: c
env: env:
- GHCVER=7.8.4 - GHCVER=7.8.4 CABALVER=1.22
- GHCVER=7.10.2 - GHCVER=7.10.3 CABALVER=1.22
- GHCVER=8.0.1 CABALVER=1.24
addons: addons:
apt: apt:
@ -12,13 +13,15 @@ addons:
- hvr-ghc - hvr-ghc
packages: packages:
- ghc-7.8.4 - ghc-7.8.4
- ghc-7.10.2 - ghc-7.10.3
- ghc-8.0.1
- cabal-install-1.22 - cabal-install-1.22
- cabal-install-1.24
- libgmp-dev - libgmp-dev
install: install:
- (mkdir -p $HOME/.local/bin && cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc) - (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 - ghc --version
- cabal --version - cabal --version
- travis_retry cabal update - travis_retry cabal update

3
README.md
View file

@ -4,11 +4,12 @@
## Getting Started ## 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 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' to write your first servant webservices, learning the rest from the haddocks'
examples. examples.
The central documentation can be found [here](http://haskell-servant.readthedocs.org/).
Other blog posts, videos and slides can be found on the Other blog posts, videos and slides can be found on the
[website](http://haskell-servant.github.io/). [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 introduction.rst
tutorial/index.rst tutorial/index.rst
examples.md
links.rst 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: 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 2. The datatype returned by the server after authentication is verified. This
is usually a `User` or `Customer` type datatype. 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 module Authentication where
import Control.Monad.Trans.Except (ExceptT, throwE)
import Data.Aeson (ToJSON) import Data.Aeson (ToJSON)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Map (Map, fromList) import Data.Map (Map, fromList)
@ -59,13 +58,14 @@ import Servant.API ((:<|>) ((:<|>)), (:>), BasicAuth,
Get, JSON) Get, JSON)
import Servant.API.BasicAuth (BasicAuthData (BasicAuthData)) import Servant.API.BasicAuth (BasicAuthData (BasicAuthData))
import Servant.API.Experimental.Auth (AuthProtect) import Servant.API.Experimental.Auth (AuthProtect)
import Servant (throwError)
import Servant.Server (BasicAuthCheck (BasicAuthCheck), import Servant.Server (BasicAuthCheck (BasicAuthCheck),
BasicAuthResult( Authorized BasicAuthResult( Authorized
, Unauthorized , Unauthorized
), ),
Context ((:.), EmptyContext), Context ((:.), EmptyContext),
err401, err403, errBody, Server, err401, err403, errBody, Server,
ServantErr, serveWithContext) serveWithContext, Handler)
import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData,
mkAuthHandler) mkAuthHandler)
import Servant.Server.Experimental.Auth() 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 the request path). Now consider an API resource protected by basic
authentication. Once the required `WWW-Authenticate` header is checked, we need 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 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 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 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 engineered around the idea that each combinator can extract information from
only the request. We cannot extract the function 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 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 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 `serve` function, and that data is propagated to the functions that handle each
combinator. Using `Context`, we can supply a function of type 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` handler. This will allow the handler to check authentication and return a `User`
to downstream handlers if successful. 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: different function to better capture the semantics of basic authentication:
``` haskell ignore ``` haskell ignore
@ -246,7 +246,7 @@ your feedback!
### What is Generalized Authentication? ### What is Generalized Authentication?
**TL;DR**: you throw a tagged `AuthProtect` combinator in front of the endpoints **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 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 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 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. -- | A method that, when given a password, will return a Account.
-- This is our bespoke (and bad) authentication logic. -- 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 lookupAccount key = case Map.lookup key database of
Nothing -> throwE (err403 { errBody = "Invalid Cookie" }) Nothing -> throwError (err403 { errBody = "Invalid Cookie" })
Just usr -> return usr Just usr -> return usr
``` ```
For generalized authentication, servant exposes the `AuthHandler` type, 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` create a value of type `AuthHandler Request Account` using the above `lookupAccount`
method: method:
```haskell ```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`. -- we look for a Cookie and pass the value of the cookie to `lookupAccount`.
authHandler :: AuthHandler Request Account authHandler :: AuthHandler Request Account
authHandler = authHandler =
let handler req = case lookup "servant-auth-cookie" (requestHeaders req) of 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 Just authCookieKey -> lookupAccount authCookieKey
in mkAuthHandler handler in mkAuthHandler handler
``` ```
@ -379,7 +379,7 @@ forward:
2. choose a application-specific data type used by your server when 2. choose a application-specific data type used by your server when
authentication is successful (in our case this was `User`). authentication is successful (in our case this was `User`).
3. Create a value of `AuthHandler Request User` which encapsulates the 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. will be executed everytime a request matches a protected route.
4. Provide an instance of the `AuthServerData` type family, specifying your 4. Provide an instance of the `AuthServerData` type family, specifying your
application-specific data type returned when authentication is successful (in 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 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 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 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 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 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 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: we have a monad, let's just `return` our list:
``` haskell ``` haskell
@ -269,15 +269,15 @@ server3 = position
:<|> hello :<|> hello
:<|> marketing :<|> marketing
where position :: Int -> Int -> ExceptT ServantErr IO Position where position :: Int -> Int -> Handler Position
position x y = return (Position x y) 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 hello mname = return . HelloMessage $ case mname of
Nothing -> "Hello, anonymous coward" Nothing -> "Hello, anonymous coward"
Just n -> "Hello, " ++ n Just n -> "Hello, " ++ n
marketing :: ClientInfo -> ExceptT ServantErr IO Email marketing :: ClientInfo -> Handler Email
marketing clientinfo = return (emailForClient clientinfo) 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**: 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`. > - `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. > - `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`. > - `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 # 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 At the heart of the handlers is the monad they run in, namely `ExceptT ServantErr IO`
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`.
([haddock documentation for `ExceptT`](http://hackage.haskell.org/package/mtl-2.2.1/docs/Control-Monad-Except.html#t:ExceptT)).
One might wonder: why this monad? The answer is that it is the One might wonder: why this monad? The answer is that it is the
simplest monad with the following properties: 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)) 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 equivalent to a computation of type `IO (Either ServantErr a)`, that is, an IO
action that either returns an error or a result. 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: use record update syntax:
``` haskell ``` haskell
failingHandler :: ExceptT ServantErr IO () failingHandler :: Handler ()
failingHandler = throwError myerr failingHandler = throwError myerr
where myerr :: ServantErr where myerr :: ServantErr
@ -810,7 +809,7 @@ type UserAPI3 = -- view the user with given userid, in JSON
Capture "userid" Int :> Get '[JSON] User Capture "userid" Int :> Get '[JSON] User
:<|> -- delete the user with given userid. empty response :<|> -- 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`: We can instead factor out the `userid`:
@ -818,7 +817,7 @@ We can instead factor out the `userid`:
``` haskell ``` haskell
type UserAPI4 = Capture "userid" Int :> type UserAPI4 = Capture "userid" Int :>
( Get '[JSON] User ( 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`: corresponding `Server`:
``` haskell ignore ``` haskell ignore
Server UserAPI3 = (Int -> ExceptT ServantErr IO User) Server UserAPI3 = (Int -> Handler User)
:<|> (Int -> ExceptT ServantErr IO ()) :<|> (Int -> Handler NoContent)
Server UserAPI4 = Int -> ( ExceptT ServantErr IO User Server UserAPI4 = Int -> ( Handler User
:<|> ExceptT ServantErr IO () :<|> Handler NoContent
) )
``` ```
@ -842,10 +841,10 @@ computations in `ExceptT`, with no arguments. In other words:
server8 :: Server UserAPI3 server8 :: Server UserAPI3
server8 = getUser :<|> deleteUser server8 = getUser :<|> deleteUser
where getUser :: Int -> ExceptT ServantErr IO User where getUser :: Int -> Handler User
getUser _userid = error "..." getUser _userid = error "..."
deleteUser :: Int -> ExceptT ServantErr IO () deleteUser :: Int -> Handler NoContent
deleteUser _userid = error "..." deleteUser _userid = error "..."
-- notice how getUser and deleteUser -- notice how getUser and deleteUser
@ -854,10 +853,10 @@ server8 = getUser :<|> deleteUser
server9 :: Server UserAPI4 server9 :: Server UserAPI4
server9 userid = getUser userid :<|> deleteUser userid server9 userid = getUser userid :<|> deleteUser userid
where getUser :: Int -> ExceptT ServantErr IO User where getUser :: Int -> Handler User
getUser = error "..." getUser = error "..."
deleteUser :: Int -> ExceptT ServantErr IO () deleteUser :: Int -> Handler NoContent
deleteUser = error "..." deleteUser = error "..."
``` ```
@ -876,13 +875,13 @@ type API1 = "users" :>
-- we factor out the Request Body -- we factor out the Request Body
type API2 = ReqBody '[JSON] User :> type API2 = ReqBody '[JSON] User :>
( Get '[JSON] User -- just display the same user back, don't register it ( 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 -- we factor out a Header
type API3 = Header "Authorization" Token :> type API3 = Header "Authorization" Token :>
( Get '[JSON] SecretData -- get some secret data, if authorized ( 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 newtype Token = Token ByteString
@ -895,44 +894,44 @@ API type only at the end.
``` haskell ``` haskell
type UsersAPI = type UsersAPI =
Get '[JSON] [User] -- list users Get '[JSON] [User] -- list users
:<|> ReqBody '[JSON] User :> Post '[] () -- add a user :<|> ReqBody '[JSON] User :> PostNoContent '[JSON] NoContent -- add a user
:<|> Capture "userid" Int :> :<|> Capture "userid" Int :>
( Get '[JSON] User -- view a user ( Get '[JSON] User -- view a user
:<|> ReqBody '[JSON] User :> Put '[] () -- update a user :<|> ReqBody '[JSON] User :> PutNoContent '[JSON] NoContent -- update a user
:<|> Delete '[] () -- delete a user :<|> DeleteNoContent '[JSON] NoContent -- delete a user
) )
usersServer :: Server UsersAPI usersServer :: Server UsersAPI
usersServer = getUsers :<|> newUser :<|> userOperations usersServer = getUsers :<|> newUser :<|> userOperations
where getUsers :: ExceptT ServantErr IO [User] where getUsers :: Handler [User]
getUsers = error "..." getUsers = error "..."
newUser :: User -> ExceptT ServantErr IO () newUser :: User -> Handler NoContent
newUser = error "..." newUser = error "..."
userOperations userid = userOperations userid =
viewUser userid :<|> updateUser userid :<|> deleteUser userid viewUser userid :<|> updateUser userid :<|> deleteUser userid
where where
viewUser :: Int -> ExceptT ServantErr IO User viewUser :: Int -> Handler User
viewUser = error "..." viewUser = error "..."
updateUser :: Int -> User -> ExceptT ServantErr IO () updateUser :: Int -> User -> Handler NoContent
updateUser = error "..." updateUser = error "..."
deleteUser :: Int -> ExceptT ServantErr IO () deleteUser :: Int -> Handler NoContent
deleteUser = error "..." deleteUser = error "..."
``` ```
``` haskell ``` haskell
type ProductsAPI = type ProductsAPI =
Get '[JSON] [Product] -- list products Get '[JSON] [Product] -- list products
:<|> ReqBody '[JSON] Product :> Post '[] () -- add a product :<|> ReqBody '[JSON] Product :> PostNoContent '[JSON] NoContent -- add a product
:<|> Capture "productid" Int :> :<|> Capture "productid" Int :>
( Get '[JSON] Product -- view a product ( Get '[JSON] Product -- view a product
:<|> ReqBody '[JSON] Product :> Put '[] () -- update a product :<|> ReqBody '[JSON] Product :> PutNoContent '[JSON] NoContent -- update a product
:<|> Delete '[] () -- delete a product :<|> DeleteNoContent '[JSON] NoContent -- delete a product
) )
data Product = Product { productId :: Int } data Product = Product { productId :: Int }
@ -940,23 +939,23 @@ data Product = Product { productId :: Int }
productsServer :: Server ProductsAPI productsServer :: Server ProductsAPI
productsServer = getProducts :<|> newProduct :<|> productOperations productsServer = getProducts :<|> newProduct :<|> productOperations
where getProducts :: ExceptT ServantErr IO [Product] where getProducts :: Handler [Product]
getProducts = error "..." getProducts = error "..."
newProduct :: Product -> ExceptT ServantErr IO () newProduct :: Product -> Handler NoContent
newProduct = error "..." newProduct = error "..."
productOperations productid = productOperations productid =
viewProduct productid :<|> updateProduct productid :<|> deleteProduct productid viewProduct productid :<|> updateProduct productid :<|> deleteProduct productid
where where
viewProduct :: Int -> ExceptT ServantErr IO Product viewProduct :: Int -> Handler Product
viewProduct = error "..." viewProduct = error "..."
updateProduct :: Int -> Product -> ExceptT ServantErr IO () updateProduct :: Int -> Product -> Handler NoContent
updateProduct = error "..." updateProduct = error "..."
deleteProduct :: Int -> ExceptT ServantErr IO () deleteProduct :: Int -> Handler NoContent
deleteProduct = error "..." deleteProduct = error "..."
``` ```
@ -976,20 +975,20 @@ abstract that away:
-- indexed by values of type 'i' -- indexed by values of type 'i'
type APIFor a i = type APIFor a i =
Get '[JSON] [a] -- list 'a's 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 :> :<|> Capture "id" i :>
( Get '[JSON] a -- view an 'a' given its "identifier" of type 'i' ( Get '[JSON] a -- view an 'a' given its "identifier" of type 'i'
:<|> ReqBody '[JSON] a :> Put '[] () -- update an 'a' :<|> ReqBody '[JSON] a :> PutNoContent '[JSON] NoContent -- update an 'a'
:<|> Delete '[] () -- delete an 'a' :<|> DeleteNoContent '[JSON] NoContent -- delete an 'a'
) )
-- Build the appropriate 'Server' -- Build the appropriate 'Server'
-- given the handlers of the right type. -- given the handlers of the right type.
serverFor :: ExceptT ServantErr IO [a] -- handler for listing of 'a's serverFor :: Handler [a] -- handler for listing of 'a's
-> (a -> ExceptT ServantErr IO ()) -- handler for adding an 'a' -> (a -> Handler NoContent) -- handler for adding an 'a'
-> (i -> ExceptT ServantErr IO a) -- handler for viewing an 'a' given its identifier of type 'i' -> (i -> Handler a) -- handler for viewing an 'a' given its identifier of type 'i'
-> (i -> a -> ExceptT ServantErr IO ()) -- updating an 'a' with given id -> (i -> a -> Handler NoContent) -- updating an 'a' with given id
-> (i -> ExceptT ServantErr IO ()) -- deleting an 'a' given its id -> (i -> Handler NoContent) -- deleting an 'a' given its id
-> Server (APIFor a i) -> Server (APIFor a i)
serverFor = error "..." serverFor = error "..."
-- implementation left as an exercise. contact us on IRC -- implementation left as an exercise. contact us on IRC
@ -998,12 +997,11 @@ serverFor = error "..."
## Using another monad for your handlers ## Using another monad for your handlers
Remember how `Server` turns combinators for HTTP methods into `ExceptT Remember how `Server` turns combinators for HTTP methods into `Handler`? Well, actually, there's more to that. `Server` is actually a
ServantErr IO`? Well, actually, there's more to that. `Server` is actually a
simple type synonym. simple type synonym.
``` haskell ignore ``` 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 `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.) (`Nat` comes from "natural transformation", in case you're wondering.)
So if you want to write handlers using another monad/type than `ExceptT So if you want to write handlers using another monad/type than `Handler`, say the `Reader String` monad, the first thing you have to
ServantErr IO`, say the `Reader String` monad, the first thing you have to
prepare is a function: prepare is a function:
``` haskell ignore ``` haskell ignore
readerToHandler :: Reader String :~> ExceptT ServantErr IO readerToHandler :: Reader String :~> Handler
``` ```
Let's start with `readerToHandler'`. We obviously have to run the `Reader` 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. that function with the `Nat` constructor to make it have the fancier type.
``` haskell ``` 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' r = return (runReader r "hi")
readerToHandler :: Reader String :~> ExceptT ServantErr IO readerToHandler :: Reader String :~> Handler
readerToHandler = Nat readerToHandler' readerToHandler = Nat readerToHandler'
``` ```
@ -1077,8 +1074,7 @@ readerServerT = a :<|> b
``` ```
We unfortunately can't use `readerServerT` as an argument of `serve`, because We unfortunately can't use `readerServerT` as an argument of `serve`, because
`serve` wants a `Server ReaderAPI`, i.e., with handlers running in `ExceptT `serve` wants a `Server ReaderAPI`, i.e., with handlers running in `Handler`. But there's a simple solution to this.
ServantErr IO`. But there's a simple solution to this.
### Enter `enter` ### Enter `enter`

10
doc/tutorial/index.rst
View file

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

22
doc/tutorial/tutorial.cabal
View file

@ -1,7 +1,7 @@
name: tutorial name: tutorial
version: 0.6 version: 0.7.1
synopsis: The servant tutorial synopsis: The servant tutorial
homepage: http://haskell-servant.github.io/ homepage: http://haskell-servant.readthedocs.org/
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
author: Servant Contributors author: Servant Contributors
@ -25,11 +25,11 @@ library
, directory , directory
, blaze-markup , blaze-markup
, containers , containers
, servant == 0.6.* , servant == 0.7.*
, servant-server == 0.6.* , servant-server == 0.7.*
, servant-client == 0.6.* , servant-client == 0.7.*
, servant-docs == 0.6.* , servant-docs == 0.7.*
, servant-js == 0.6.* , servant-js == 0.7.*
, warp , warp
, http-media , http-media
, lucid , lucid
@ -46,15 +46,11 @@ library
, markdown-unlit >= 0.4 , markdown-unlit >= 0.4
, http-client , http-client
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall -Werror -pgmL markdown-unlit ghc-options: -Wall -pgmL markdown-unlit
-- to silence aeson-0.10 warnings:
ghc-options: -fno-warn-missing-methods
ghc-options: -fno-warn-name-shadowing
test-suite spec test-suite spec
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
ghc-options: ghc-options: -Wall
-Wall -fno-warn-name-shadowing -fno-warn-missing-signatures
default-language: Haskell2010 default-language: Haskell2010
hs-source-dirs: test hs-source-dirs: test
main-is: Spec.hs 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 main = do
sources <- words <$> readFile "sources.txt" sources <- words <$> readFile "sources.txt"
forM_ sources $ \ source -> do 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 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 MyApi
myApi = Proxy myApi = Proxy
getAllBooks :: ExceptT String IO [Book] getAllBooks :: Manager -> BaseUrl -> ExceptT String IO [Book]
postNewBook :: Book -> 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. -- 'client' allows you to produce operations to query an API from a client.
(getAllBooks :<|> postNewBook) = client myApi host (getAllBooks :<|> postNewBook) = client myApi
where host = BaseUrl Http "localhost" 8080
``` ```

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

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

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

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

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

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

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

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

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

@ -1,5 +1,5 @@
name: servant-docs name: servant-docs
version: 0.6 version: 0.7.1
synopsis: generate API docs for your servant webservice synopsis: generate API docs for your servant webservice
description: description:
Library for generating API docs from a servant API definition. Library for generating API docs from a servant API definition.
@ -16,7 +16,7 @@ category: Web
build-type: Simple build-type: Simple
cabal-version: >=1.10 cabal-version: >=1.10
tested-with: GHC >= 7.8 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 Bug-reports: http://github.com/haskell-servant/servant/issues
extra-source-files: extra-source-files:
include/*.h include/*.h
@ -42,7 +42,7 @@ library
, http-media >= 0.6 , http-media >= 0.6
, http-types >= 0.7 , http-types >= 0.7
, lens , lens
, servant == 0.6.* , servant == 0.7.*
, string-conversions , string-conversions
, text , text
, unordered-containers , unordered-containers
@ -50,6 +50,8 @@ library
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall
if impl(ghc >= 8.0)
ghc-options: -Wno-redundant-constraints
include-dirs: include include-dirs: include
executable greet-docs executable greet-docs
@ -82,4 +84,3 @@ test-suite spec
, servant-docs , servant-docs
, string-conversions , string-conversions
default-language: Haskell2010 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. -- These are intended to be built using extraInfo.
-- Multiple ExtraInfo may be combined with the monoid instance. -- 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 instance Monoid (ExtraInfo a) where
mempty = ExtraInfo mempty mempty = ExtraInfo mempty
ExtraInfo a `mappend` ExtraInfo b = ExtraInfo a `mappend` ExtraInfo b =
@ -300,11 +300,11 @@ makeLenses ''Action
-- default way to create documentation. -- default way to create documentation.
-- --
-- prop> docs == docsWithOptions defaultDocOptions -- prop> docs == docsWithOptions defaultDocOptions
docs :: HasDocs layout => Proxy layout -> API docs :: HasDocs api => Proxy api -> API
docs p = docsWithOptions p defaultDocOptions docs p = docsWithOptions p defaultDocOptions
-- | Generate the docs for a given API that implements 'HasDocs'. -- | 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) docsWithOptions p = docsFor p (defEndpoint, defAction)
-- | Closed type family, check if endpoint is exactly within API. -- | 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 :> sa) (e :> sb) = IsIn sa sb
IsIn e e = () 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 -- The safety here is to ensure that you only add custom documentation to an
-- endpoint that actually exists within your API. -- endpoint that actually exists within your API.
@ -329,8 +329,8 @@ type family IsIn (endpoint :: *) (api :: *) :: Constraint where
-- > , DocNote "Second secton" ["And some more"] -- > , DocNote "Second secton" ["And some more"]
-- > ] -- > ]
extraInfo :: (IsIn endpoint layout, HasLink endpoint, HasDocs endpoint) extraInfo :: (IsIn endpoint api, HasLink endpoint, HasDocs endpoint)
=> Proxy endpoint -> Action -> ExtraInfo layout => Proxy endpoint -> Action -> ExtraInfo api
extraInfo p action = extraInfo p action =
let api = docsFor p (defEndpoint, defAction) defaultDocOptions let api = docsFor p (defEndpoint, defAction) defaultDocOptions
-- Assume one endpoint, HasLink constraint means that we should only ever -- Assume one endpoint, HasLink constraint means that we should only ever
@ -349,7 +349,7 @@ extraInfo p action =
-- 'extraInfo'. -- 'extraInfo'.
-- --
-- If you only want to add an introduction, use 'docsWithIntros'. -- 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 = docsWith opts intros (ExtraInfo endpoints) p =
docsWithOptions p opts docsWithOptions p opts
& apiIntros <>~ intros & 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 -- | Generate the docs for a given API that implements 'HasDocs' with with any
-- number of introduction(s) -- number of introduction(s)
docsWithIntros :: HasDocs layout => [DocIntro] -> Proxy layout -> API docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API
docsWithIntros intros = docsWith defaultDocOptions intros mempty docsWithIntros intros = docsWith defaultDocOptions intros mempty
-- | The class that abstracts away the impact of API combinators -- | The class that abstracts away the impact of API combinators
-- on documentation generation. -- on documentation generation.
class HasDocs layout where class HasDocs api where
docsFor :: Proxy layout -> (Endpoint, Action) -> DocOptions -> API docsFor :: Proxy api -> (Endpoint, Action) -> DocOptions -> API
-- | The class that lets us display a sample input or output in the supported -- | The class that lets us display a sample input or output in the supported
-- content-types when generating documentation for endpoints that either: -- 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 -- | The generated docs for @a ':<|>' b@ just appends the docs
-- for @a@ with the docs for @b@. -- for @a@ with the docs for @b@.
instance OVERLAPPABLE_ instance OVERLAPPABLE_
(HasDocs layout1, HasDocs layout2) (HasDocs a, HasDocs b)
=> HasDocs (layout1 :<|> layout2) where => HasDocs (a :<|> b) where
docsFor Proxy (ep, action) = docsFor p1 (ep, action) <> docsFor p2 (ep, action) docsFor Proxy (ep, action) = docsFor p1 (ep, action) <> docsFor p2 (ep, action)
where p1 :: Proxy layout1 where p1 :: Proxy a
p1 = Proxy p1 = Proxy
p2 :: Proxy layout2 p2 :: Proxy b
p2 = Proxy p2 = Proxy
-- | @"books" :> 'Capture' "isbn" Text@ will appear as -- | @"books" :> 'Capture' "isbn" Text@ will appear as
-- @/books/:isbn@ in the docs. -- @/books/:isbn@ in the docs.
instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout) instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)
=> HasDocs (Capture sym a :> sublayout) where => HasDocs (Capture sym a :> api) where
docsFor Proxy (endpoint, action) = 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) captureP = Proxy :: Proxy (Capture sym a)
action' = over captures (|> toCapture captureP) action action' = over captures (|> toCapture captureP) action
@ -736,43 +736,43 @@ instance OVERLAPPING_
status = fromInteger $ natVal (Proxy :: Proxy status) status = fromInteger $ natVal (Proxy :: Proxy status)
p = Proxy :: Proxy a p = Proxy :: Proxy a
instance (KnownSymbol sym, HasDocs sublayout) instance (KnownSymbol sym, HasDocs api)
=> HasDocs (Header sym a :> sublayout) where => HasDocs (Header sym a :> api) where
docsFor Proxy (endpoint, action) = 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 action' = over headers (|> headername) action
headername = T.pack $ symbolVal (Proxy :: Proxy sym) headername = T.pack $ symbolVal (Proxy :: Proxy sym)
instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout) instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs api)
=> HasDocs (QueryParam sym a :> sublayout) where => HasDocs (QueryParam sym a :> api) where
docsFor Proxy (endpoint, action) = 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) paramP = Proxy :: Proxy (QueryParam sym a)
action' = over params (|> toParam paramP) action action' = over params (|> toParam paramP) action
instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs sublayout) instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs api)
=> HasDocs (QueryParams sym a :> sublayout) where => HasDocs (QueryParams sym a :> api) where
docsFor Proxy (endpoint, action) = 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) paramP = Proxy :: Proxy (QueryParams sym a)
action' = over params (|> toParam paramP) action action' = over params (|> toParam paramP) action
instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs sublayout) instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs api)
=> HasDocs (QueryFlag sym :> sublayout) where => HasDocs (QueryFlag sym :> api) where
docsFor Proxy (endpoint, action) = 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) paramP = Proxy :: Proxy (QueryFlag sym)
action' = over params (|> toParam paramP) action 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 -- example data. However, there's no reason to believe that the instances of
-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that -- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
-- both are even defined) for any particular type. -- both are even defined) for any particular type.
instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs sublayout) instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api)
=> HasDocs (ReqBody (ct ': cts) a :> sublayout) where => HasDocs (ReqBody (ct ': cts) a :> api) where
docsFor Proxy (endpoint, action) = 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 action' = action & rqbody .~ sampleByteString t p
& rqtypes .~ allMime t & rqtypes .~ allMime t
t = Proxy :: Proxy (ct ': cts) t = Proxy :: Proxy (ct ': cts)
p = Proxy :: Proxy a 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 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] endpoint' = endpoint & path <>~ [symbolVal pa]
pa = Proxy :: Proxy path pa = Proxy :: Proxy path
instance HasDocs sublayout => HasDocs (RemoteHost :> sublayout) where instance HasDocs api => HasDocs (RemoteHost :> api) where
docsFor Proxy ep = 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 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 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 ep =
docsFor (Proxy :: Proxy sublayout) ep docsFor (Proxy :: Proxy api) ep
instance HasDocs sublayout => HasDocs (WithNamedContext name context sublayout) where instance HasDocs api => HasDocs (WithNamedContext name context api) where
docsFor Proxy = docsFor (Proxy :: Proxy sublayout) 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 (endpoint, action) =
docsFor (Proxy :: Proxy sublayout) (endpoint, action') docsFor (Proxy :: Proxy api) (endpoint, action')
where where
authProxy = Proxy :: Proxy (BasicAuth realm usr) authProxy = Proxy :: Proxy (BasicAuth realm usr)
action' = over authInfo (|> toAuthInfo authProxy) action 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)) -- 'docs' ('pretty' ('Proxy' :: 'Proxy' MyAPI))
-- @ -- @
pretty :: Proxy layout -> Proxy (Pretty layout) pretty :: Proxy api -> Proxy (Pretty api)
pretty Proxy = Proxy pretty Proxy = Proxy
-- | Replace all JSON content types with PrettyJSON. -- | Replace all JSON content types with PrettyJSON.
-- Kind-polymorphic so it can operate on kinds @*@ and @[*]@. -- 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 (x :> y) = Pretty x :> Pretty y Pretty (x :> y) = Pretty x :> Pretty y
Pretty (Get cs r) = Get (Pretty cs) r 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 0.5
----- -----
* Use the `text` package instead of `String`. * Use the `text` package instead of `String`.

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

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

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

@ -7,7 +7,8 @@
-- arbitrary programming languages. -- arbitrary programming languages.
module Servant.Foreign.Internal where module Servant.Foreign.Internal where
import Control.Lens hiding (cons, List) import Control.Lens (makePrisms, makeLenses, Getter, (&), (<>~), (%~),
(.~))
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
import Data.Monoid import Data.Monoid
#endif #endif
@ -183,9 +184,9 @@ data NoTypes
instance HasForeignType NoTypes () ftype where instance HasForeignType NoTypes () ftype where
typeFor _ _ _ = () typeFor _ _ _ = ()
class HasForeign lang ftype (layout :: *) where class HasForeign lang ftype (api :: *) where
type Foreign ftype layout :: * type Foreign ftype api :: *
foreignFor :: Proxy lang -> Proxy ftype -> Proxy layout -> Req ftype -> Foreign ftype layout foreignFor :: Proxy lang -> Proxy ftype -> Proxy api -> Req ftype -> Foreign ftype api
instance (HasForeign lang ftype a, HasForeign lang ftype b) instance (HasForeign lang ftype a, HasForeign lang ftype b)
=> HasForeign lang ftype (a :<|> b) where => 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 a) req
:<|> foreignFor lang ftype (Proxy :: Proxy b) req :<|> foreignFor lang ftype (Proxy :: Proxy b) req
instance (KnownSymbol sym, HasForeignType lang ftype t, HasForeign lang ftype sublayout) instance (KnownSymbol sym, HasForeignType lang ftype t, HasForeign lang ftype api)
=> HasForeign lang ftype (Capture sym t :> sublayout) where => HasForeign lang ftype (Capture sym t :> api) where
type Foreign ftype (Capture sym a :> sublayout) = Foreign ftype sublayout type Foreign ftype (Capture sym a :> api) = Foreign ftype api
foreignFor lang Proxy Proxy req = foreignFor lang Proxy Proxy req =
foreignFor lang Proxy (Proxy :: Proxy sublayout) $ foreignFor lang Proxy (Proxy :: Proxy api) $
req & reqUrl . path <>~ [Segment (Cap arg)] req & reqUrl . path <>~ [Segment (Cap arg)]
& reqFuncName . _FunctionName %~ (++ ["by", str]) & reqFuncName . _FunctionName %~ (++ ["by", str])
where where
@ -223,9 +224,9 @@ instance (Elem JSON list, HasForeignType lang ftype a, ReflectMethod method)
method = reflectMethod (Proxy :: Proxy method) method = reflectMethod (Proxy :: Proxy method)
methodLC = toLower $ decodeUtf8 method methodLC = toLower $ decodeUtf8 method
instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype sublayout) instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype api)
=> HasForeign lang ftype (Header sym a :> sublayout) where => HasForeign lang ftype (Header sym a :> api) where
type Foreign ftype (Header sym a :> sublayout) = Foreign ftype sublayout type Foreign ftype (Header sym a :> api) = Foreign ftype api
foreignFor lang Proxy Proxy req = foreignFor lang Proxy Proxy req =
foreignFor lang Proxy subP $ req & reqHeaders <>~ [HeaderArg arg] 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 arg = Arg
{ _argName = PathSegment hname { _argName = PathSegment hname
, _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a) } , _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) instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype api)
=> HasForeign lang ftype (QueryParam sym a :> sublayout) where => HasForeign lang ftype (QueryParam sym a :> api) where
type Foreign ftype (QueryParam sym a :> sublayout) = Foreign ftype sublayout type Foreign ftype (QueryParam sym a :> api) = Foreign ftype api
foreignFor lang Proxy Proxy req = 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] req & reqUrl.queryStr <>~ [QueryArg arg Normal]
where where
str = pack . symbolVal $ (Proxy :: Proxy sym) 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) } , _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a) }
instance instance
(KnownSymbol sym, HasForeignType lang ftype [a], HasForeign lang ftype sublayout) (KnownSymbol sym, HasForeignType lang ftype [a], HasForeign lang ftype api)
=> HasForeign lang ftype (QueryParams sym a :> sublayout) where => HasForeign lang ftype (QueryParams sym a :> api) where
type Foreign ftype (QueryParams sym a :> sublayout) = Foreign ftype sublayout type Foreign ftype (QueryParams sym a :> api) = Foreign ftype api
foreignFor lang Proxy Proxy req = 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] req & reqUrl.queryStr <>~ [QueryArg arg List]
where where
str = pack . symbolVal $ (Proxy :: Proxy sym) str = pack . symbolVal $ (Proxy :: Proxy sym)
@ -263,12 +264,12 @@ instance
, _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy [a]) } , _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy [a]) }
instance instance
(KnownSymbol sym, HasForeignType lang ftype Bool, HasForeign lang ftype sublayout) (KnownSymbol sym, HasForeignType lang ftype Bool, HasForeign lang ftype api)
=> HasForeign lang ftype (QueryFlag sym :> sublayout) where => HasForeign lang ftype (QueryFlag sym :> api) where
type Foreign ftype (QueryFlag sym :> sublayout) = Foreign ftype sublayout type Foreign ftype (QueryFlag sym :> api) = Foreign ftype api
foreignFor lang ftype Proxy req = foreignFor lang ftype Proxy req =
foreignFor lang ftype (Proxy :: Proxy sublayout) $ foreignFor lang ftype (Proxy :: Proxy api) $
req & reqUrl.queryStr <>~ [QueryArg arg Flag] req & reqUrl.queryStr <>~ [QueryArg arg Flag]
where where
str = pack . symbolVal $ (Proxy :: Proxy sym) str = pack . symbolVal $ (Proxy :: Proxy sym)
@ -283,20 +284,20 @@ instance HasForeign lang ftype Raw where
req & reqFuncName . _FunctionName %~ ((toLower $ decodeUtf8 method) :) req & reqFuncName . _FunctionName %~ ((toLower $ decodeUtf8 method) :)
& reqMethod .~ method & reqMethod .~ method
instance (Elem JSON list, HasForeignType lang ftype a, HasForeign lang ftype sublayout) instance (Elem JSON list, HasForeignType lang ftype a, HasForeign lang ftype api)
=> HasForeign lang ftype (ReqBody list a :> sublayout) where => HasForeign lang ftype (ReqBody list a :> api) where
type Foreign ftype (ReqBody list a :> sublayout) = Foreign ftype sublayout type Foreign ftype (ReqBody list a :> api) = Foreign ftype api
foreignFor lang ftype Proxy req = 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)) req & reqBody .~ (Just $ typeFor lang ftype (Proxy :: Proxy a))
instance (KnownSymbol path, HasForeign lang ftype sublayout) instance (KnownSymbol path, HasForeign lang ftype api)
=> HasForeign lang ftype (path :> sublayout) where => HasForeign lang ftype (path :> api) where
type Foreign ftype (path :> sublayout) = Foreign ftype sublayout type Foreign ftype (path :> api) = Foreign ftype api
foreignFor lang ftype Proxy req = foreignFor lang ftype Proxy req =
foreignFor lang ftype (Proxy :: Proxy sublayout) $ foreignFor lang ftype (Proxy :: Proxy api) $
req & reqUrl . path <>~ [Segment (Static (PathSegment str))] req & reqUrl . path <>~ [Segment (Static (PathSegment str))]
& reqFuncName . _FunctionName %~ (++ [str]) & reqFuncName . _FunctionName %~ (++ [str])
where where
@ -304,39 +305,39 @@ instance (KnownSymbol path, HasForeign lang ftype sublayout)
Data.Text.map (\c -> if c == '.' then '_' else c) Data.Text.map (\c -> if c == '.' then '_' else c)
. pack . symbolVal $ (Proxy :: Proxy path) . pack . symbolVal $ (Proxy :: Proxy path)
instance HasForeign lang ftype sublayout instance HasForeign lang ftype api
=> HasForeign lang ftype (RemoteHost :> sublayout) where => HasForeign lang ftype (RemoteHost :> api) where
type Foreign ftype (RemoteHost :> sublayout) = Foreign ftype sublayout type Foreign ftype (RemoteHost :> api) = Foreign ftype api
foreignFor lang ftype Proxy req = foreignFor lang ftype Proxy req =
foreignFor lang ftype (Proxy :: Proxy sublayout) req foreignFor lang ftype (Proxy :: Proxy api) req
instance HasForeign lang ftype sublayout instance HasForeign lang ftype api
=> HasForeign lang ftype (IsSecure :> sublayout) where => HasForeign lang ftype (IsSecure :> api) where
type Foreign ftype (IsSecure :> sublayout) = Foreign ftype sublayout type Foreign ftype (IsSecure :> api) = Foreign ftype api
foreignFor lang ftype Proxy req = 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 instance HasForeign lang ftype api => HasForeign lang ftype (Vault :> api) where
type Foreign ftype (Vault :> sublayout) = Foreign ftype sublayout type Foreign ftype (Vault :> api) = Foreign ftype api
foreignFor lang ftype Proxy req = foreignFor lang ftype Proxy req =
foreignFor lang ftype (Proxy :: Proxy sublayout) req foreignFor lang ftype (Proxy :: Proxy api) req
instance HasForeign lang ftype sublayout => instance HasForeign lang ftype api =>
HasForeign lang ftype (WithNamedContext name context sublayout) where 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 instance HasForeign lang ftype api
=> HasForeign lang ftype (HttpVersion :> sublayout) where => HasForeign lang ftype (HttpVersion :> api) where
type Foreign ftype (HttpVersion :> sublayout) = Foreign ftype sublayout type Foreign ftype (HttpVersion :> api) = Foreign ftype api
foreignFor lang ftype Proxy req = 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 -- | Utility class used by 'listFromAPI' which computes
-- the data needed to generate a function for each endpoint -- 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 name: servant-js
version: 0.6 version: 0.7.1
synopsis: Automatically derive javascript functions to query servant webservices. synopsis: Automatically derive javascript functions to query servant webservices.
description: description:
Automatically derive javascript functions to query servant webservices. Automatically derive javascript functions to query servant webservices.
@ -19,7 +19,7 @@ copyright: 2015-2016 Servant Contributors
category: Web category: Web
build-type: Simple build-type: Simple
cabal-version: >=1.10 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 Bug-reports: http://github.com/haskell-servant/servant/issues
extra-source-files: extra-source-files:
include/*.h include/*.h
@ -45,7 +45,7 @@ library
, base-compat >= 0.9 , base-compat >= 0.9
, charset >= 0.3 , charset >= 0.3
, lens >= 4 , lens >= 4
, servant-foreign == 0.6.* , servant-foreign == 0.7.*
, text >= 1.2 && < 1.3 , text >= 1.2 && < 1.3
hs-source-dirs: src hs-source-dirs: src
@ -55,7 +55,7 @@ library
executable counter executable counter
main-is: counter.hs main-is: counter.hs
ghc-options: -O2 -Wall ghc-options: -Wall
hs-source-dirs: examples hs-source-dirs: examples
if flag(example) if flag(example)
@ -67,8 +67,8 @@ executable counter
, aeson >= 0.7 && < 0.12 , aeson >= 0.7 && < 0.12
, filepath >= 1 , filepath >= 1
, lens >= 4 , lens >= 4
, servant == 0.6.* , servant == 0.7.*
, servant-server == 0.6.* , servant-server == 0.7.*
, servant-js , servant-js
, stm , stm
, transformers , 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.Internal
import Servant.JS.JQuery import Servant.JS.JQuery
import Servant.JS.Vanilla import Servant.JS.Vanilla
import Servant.Foreign (GenerateList(..), listFromAPI, NoTypes) import Servant.Foreign (listFromAPI)
-- | Generate the data necessary to generate javascript code -- | Generate the data necessary to generate javascript code
-- for all the endpoints of an API, as ':<|>'-separated values -- for all the endpoints of an API, as ':<|>'-separated values
-- of type 'AjaxReq'. -- 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 javascript p = foreignFor (Proxy :: Proxy NoTypes) (Proxy :: Proxy ()) p defReq
-- | Directly generate all the javascript functions for your API -- | 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(..) , HasForeignType(..)
, GenerateList(..) , GenerateList(..)
, NoTypes , NoTypes
, HeaderArg
, ArgType(..) , ArgType(..)
, HeaderArg(..) , HeaderArg(..)
, QueryArg(..) , QueryArg(..)
@ -47,7 +46,7 @@ module Servant.JS.Internal
, Header , Header
) where ) where
import Control.Lens hiding (List) import Control.Lens ((^.))
import qualified Data.CharSet as Set import qualified Data.CharSet as Set
import qualified Data.CharSet.Unicode.Category as Set import qualified Data.CharSet.Unicode.Category as Set
import Data.Monoid 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. -- using -- Basic, Digest, whatever.
data Authorization (sym :: Symbol) a data Authorization (sym :: Symbol) a
instance (KnownSymbol sym, HasForeign lang () sublayout) instance (KnownSymbol sym, HasForeign lang () api)
=> HasForeign lang () (Authorization sym a :> sublayout) where => HasForeign lang () (Authorization sym a :> api) where
type Foreign () (Authorization sym a :> sublayout) = Foreign () sublayout 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 <>~ req & reqHeaders <>~
[ ReplaceHeaderArg (Arg "Authorization" ()) [ ReplaceHeaderArg (Arg "Authorization" ())
$ tokenType (pack . symbolVal $ (Proxy :: Proxy sym)) ] $ 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. -- | This is a combinator that fetches an X-MyLovelyHorse header.
data MyLovelyHorse a data MyLovelyHorse a
instance (HasForeign lang () sublayout) instance (HasForeign lang () api)
=> HasForeign lang () (MyLovelyHorse a :> sublayout) where => HasForeign lang () (MyLovelyHorse a :> api) where
type Foreign () (MyLovelyHorse a :> sublayout) = Foreign () sublayout 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 ] req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-MyLovelyHorse" ()) tpl ]
where where
tpl = "I am good friends with {X-MyLovelyHorse}" 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. -- | This is a combinator that fetches an X-WhatsForDinner header.
data WhatsForDinner a data WhatsForDinner a
instance (HasForeign lang () sublayout) instance (HasForeign lang () api)
=> HasForeign lang () (WhatsForDinner a :> sublayout) where => HasForeign lang () (WhatsForDinner a :> api) where
type Foreign () (WhatsForDinner a :> sublayout) = Foreign () sublayout 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 ] req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-WhatsForDinner" ()) tpl ]
where where
tpl = "I would like {X-WhatsForDinner} with a cherry on top." 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 DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
import Data.Aeson import Data.Aeson
import GHC.Generics import GHC.Generics
import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp

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

@ -1,5 +1,5 @@
name: servant-mock name: servant-mock
version: 0.6 version: 0.7.1
synopsis: Derive a mock server for free from your servant API types synopsis: Derive a mock server for free from your servant API types
description: description:
Derive a mock server for free from your servant API types Derive a mock server for free from your servant API types
@ -15,6 +15,10 @@ category: Web
build-type: Simple build-type: Simple
extra-source-files: include/*.h extra-source-files: include/*.h
cabal-version: >=1.10 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 flag example
description: Build the example too description: Build the example too
@ -27,14 +31,15 @@ library
base >=4.7 && <5, base >=4.7 && <5,
bytestring >= 0.10 && <0.11, bytestring >= 0.10 && <0.11,
http-types >= 0.8 && <0.10, http-types >= 0.8 && <0.10,
servant >= 0.4, servant == 0.7.*,
servant-server >= 0.4, servant-server == 0.7.*,
transformers >= 0.3 && <0.5, transformers >= 0.3 && <0.6,
QuickCheck >= 2.7 && <2.9, QuickCheck >= 2.7 && <2.9,
wai >= 3.0 && <3.3 wai >= 3.0 && <3.3
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
include-dirs: include include-dirs: include
ghc-options: -Wall
executable mock-app executable mock-app
main-is: main.hs main-is: main.hs
@ -45,11 +50,11 @@ executable mock-app
buildable: True buildable: True
else else
buildable: False buildable: False
ghc-options: -Wall
test-suite spec test-suite spec
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
ghc-options: ghc-options: -Wall
-Wall -fno-warn-name-shadowing
default-language: Haskell2010 default-language: Haskell2010
hs-source-dirs: test hs-source-dirs: test
main-is: Spec.hs 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: -- 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 -- What this says is, given some API type @api@ that it knows it can
@ -52,7 +52,7 @@
-- @ -- @
-- main :: IO () -- main :: IO ()
-- main = Network.Wai.Handler.Warp.run 8080 $ -- main = Network.Wai.Handler.Warp.run 8080 $
-- 'serve' myAPI ('mock' myAPI) -- 'serve' myAPI ('mock' myAPI Proxy)
-- @ -- @
module Servant.Mock ( HasMock(..) ) where 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, -- -- let's say we will start with the frontend,
-- -- and hence need a placeholder server -- -- and hence need a placeholder server
-- server :: Server API -- server :: Server API
-- server = mock api -- server = mock api Proxy
-- @ -- @
-- --
-- What happens here is that @'Server' API@ -- What happens here is that @'Server' API@
-- actually "means" 2 request handlers, of the following types: -- actually "means" 2 request handlers, of the following types:
-- --
-- @ -- @
-- getUser :: ExceptT ServantErr IO User -- getUser :: Handler User
-- getBook :: ExceptT ServantErr IO Book -- getBook :: Handler Book
-- @ -- @
-- --
-- So under the hood, 'mock' uses the 'IO' bit to generate -- 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 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 ## 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 -- There's one handler per endpoint, which, just like in the type
-- that represents the API, are glued together using :<|>. -- 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 :: Server TestApi
server = helloH :<|> postGreetH :<|> deleteGreetH server = helloH :<|> postGreetH :<|> deleteGreetH

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

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

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

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

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

@ -17,6 +17,11 @@ module Servant.Server
, -- * Handlers for all standard combinators , -- * Handlers for all standard combinators
HasServer(..) HasServer(..)
, Server , Server
, Handler
-- * Debugging the server layout
, layout
, layoutWithContext
-- * Enter -- * Enter
-- $enterDoc -- $enterDoc
@ -90,12 +95,16 @@ module Servant.Server
, err504 , err504
, err505 , err505
-- * Re-exports
, Application
) where ) where
import Data.Proxy (Proxy) import Data.Proxy (Proxy)
import Data.Text (Text)
import Network.Wai (Application) import Network.Wai (Application)
import Servant.Server.Internal import Servant.Server.Internal
import Servant.Server.Internal.Enter import Servant.Utils.Enter
-- * Implementing Servers -- * Implementing Servers
@ -121,16 +130,73 @@ import Servant.Server.Internal.Enter
-- > main :: IO () -- > main :: IO ()
-- > main = Network.Wai.Handler.Warp.run 8080 app -- > 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 serve p = serveWithContext p EmptyContext
serveWithContext :: (HasServer layout context) serveWithContext :: (HasServer api context)
=> Proxy layout -> Context context -> Server layout -> Application => Proxy api -> Context context -> Server api -> Application
serveWithContext p context server = toApplication (runRouter (route p context d)) serveWithContext p context server =
where toApplication (runRouter (route p context (emptyDelayed (Route server))))
d = Delayed r r r r (\ _ _ _ -> Route server)
r = return (Route ())
-- | 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 -- Documentation

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

@ -12,8 +12,8 @@
module Servant.Server.Experimental.Auth where module Servant.Server.Experimental.Auth where
import Control.Monad.Trans.Except (ExceptT, import Control.Monad.Trans (liftIO)
runExceptT) import Control.Monad.Trans.Except (runExceptT)
import Data.Proxy (Proxy (Proxy)) import Data.Proxy (Proxy (Proxy))
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import GHC.Generics (Generic) import GHC.Generics (Generic)
@ -25,10 +25,11 @@ import Servant.Server.Internal (HasContextEntry,
HasServer, ServerT, HasServer, ServerT,
getContextEntry, getContextEntry,
route) route)
import Servant.Server.Internal.Router (Router' (WithRequest)) import Servant.Server.Internal.RoutingApplication (addAuthCheck,
import Servant.Server.Internal.RoutingApplication (RouteResult (FailFatal, Route), delayedFailFatal,
addAuthCheck) DelayedIO,
import Servant.Server.Internal.ServantErr (ServantErr) withRequest)
import Servant.Server.Internal.ServantErr (Handler)
-- * General Auth -- * General Auth
@ -42,11 +43,11 @@ type family AuthServerData a :: *
-- --
-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
newtype AuthHandler r usr = AuthHandler newtype AuthHandler r usr = AuthHandler
{ unAuthHandler :: r -> ExceptT ServantErr IO usr } { unAuthHandler :: r -> Handler usr }
deriving (Generic, Typeable) deriving (Generic, Typeable)
-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE -- | 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 mkAuthHandler = AuthHandler
-- | Known orphan instance. -- | Known orphan instance.
@ -58,9 +59,10 @@ instance ( HasServer api context
type ServerT (AuthProtect tag :> api) m = type ServerT (AuthProtect tag :> api) m =
AuthServerData (AuthProtect tag) -> ServerT api m AuthServerData (AuthProtect tag) -> ServerT api m
route Proxy context subserver = WithRequest $ \ request -> route Proxy context subserver =
route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request) route (Proxy :: Proxy api) context (subserver `addAuthCheck` withRequest authCheck)
where where
authHandler :: Request -> Handler (AuthServerData (AuthProtect tag))
authHandler = unAuthHandler (getContextEntry context) 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 , module Servant.Server.Internal.ServantErr
) where ) where
import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans (liftIO)
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Char8 as BC8
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as M
import Data.Maybe (fromMaybe, mapMaybe) import Data.Maybe (fromMaybe, mapMaybe)
import Data.String (fromString) import Data.String (fromString)
import Data.String.Conversions (cs, (<>)) import Data.String.Conversions (cs, (<>))
import Data.Text (Text)
import Data.Typeable import Data.Typeable
import GHC.TypeLits (KnownNat, KnownSymbol, natVal, import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
symbolVal) symbolVal)
@ -38,7 +36,7 @@ import Network.HTTP.Types hiding (Header, ResponseHeaders)
import Network.Socket (SockAddr) import Network.Socket (SockAddr)
import Network.Wai (Application, Request, Response, import Network.Wai (Application, Request, Response,
httpVersion, isSecure, httpVersion, isSecure,
lazyRequestBody, pathInfo, lazyRequestBody,
rawQueryString, remoteHost, rawQueryString, remoteHost,
requestHeaders, requestMethod, requestHeaders, requestMethod,
responseLBS, vault) responseLBS, vault)
@ -70,12 +68,16 @@ import Servant.Server.Internal.RoutingApplication
import Servant.Server.Internal.ServantErr import Servant.Server.Internal.ServantErr
class HasServer layout context where class HasServer api context where
type ServerT layout (m :: * -> *) :: * 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 -- * 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 type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
route Proxy context server = choice (route pa context ((\ (a :<|> _) -> a) <$> server)) 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 where pa = Proxy :: Proxy a
pb = Proxy :: Proxy b pb = Proxy :: Proxy b
@ -114,21 +116,21 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = getBook -- > server = getBook
-- > where getBook :: Text -> ExceptT ServantErr IO Book -- > where getBook :: Text -> Handler Book
-- > getBook isbn = ... -- > getBook isbn = ...
instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context) instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
=> HasServer (Capture capture a :> sublayout) context where => HasServer (Capture capture a :> api) context where
type ServerT (Capture capture a :> sublayout) m = type ServerT (Capture capture a :> api) m =
a -> ServerT sublayout m a -> ServerT api m
route Proxy context d = route Proxy context d =
DynamicRouter $ \ first -> CaptureRouter $
route (Proxy :: Proxy sublayout) route (Proxy :: Proxy api)
context context
(addCapture d $ case parseUrlPieceMaybe first :: Maybe a of (addCapture d $ \ txt -> case parseUrlPieceMaybe txt :: Maybe a of
Nothing -> return $ Fail err400 Nothing -> delayedFail err400
Just v -> return $ Route v Just v -> return v
) )
allowedMethodHead :: Method -> Request -> Bool 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 bdy = if allowedMethodHead method request then "" else body
hdrs = (hContentType, cs contentT) : (fromMaybe [] headers) hdrs = (hContentType, cs contentT) : (fromMaybe [] headers)
methodCheck :: Method -> Request -> IO (RouteResult ()) methodCheck :: Method -> Request -> DelayedIO ()
methodCheck method request methodCheck method request
| allowedMethod method request = return $ Route () | allowedMethod method request = return ()
| otherwise = return $ Fail err405 | 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 acceptCheck proxy accH
| canHandleAcceptH proxy (AcceptHeader accH) = return $ Route () | canHandleAcceptH proxy (AcceptHeader accH) = return ()
| otherwise = return $ FailFatal err406 | otherwise = delayedFail err406
methodRouter :: (AllCTRender ctypes a) methodRouter :: (AllCTRender ctypes a)
=> Method -> Proxy ctypes -> Status => Method -> Proxy ctypes -> Status
-> Delayed (ExceptT ServantErr IO a) -> Delayed env (Handler a)
-> Router -> Router env
methodRouter method proxy status action = LeafRouter route' methodRouter method proxy status action = leafRouter route'
where where
route' request respond route' env request respond =
| pathIsEmpty request =
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
in runAction (action `addMethodCheck` methodCheck method request in runAction (action `addMethodCheck` methodCheck method request
`addAcceptCheck` acceptCheck proxy accH `addAcceptCheck` acceptCheck proxy accH
) respond $ \ output -> do ) env request respond $ \ output -> do
let handleA = handleAcceptH proxy (AcceptHeader accH) output let handleA = handleAcceptH proxy (AcceptHeader accH) output
processMethodRouter handleA status method Nothing request processMethodRouter handleA status method Nothing request
| otherwise = respond $ Fail err404
methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v) methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)
=> Method -> Proxy ctypes -> Status => Method -> Proxy ctypes -> Status
-> Delayed (ExceptT ServantErr IO (Headers h v)) -> Delayed env (Handler (Headers h v))
-> Router -> Router env
methodRouterHeaders method proxy status action = LeafRouter route' methodRouterHeaders method proxy status action = leafRouter route'
where where
route' request respond route' env request respond =
| pathIsEmpty request =
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
in runAction (action `addMethodCheck` methodCheck method request in runAction (action `addMethodCheck` methodCheck method request
`addAcceptCheck` acceptCheck proxy accH `addAcceptCheck` acceptCheck proxy accH
) respond $ \ output -> do ) env request respond $ \ output -> do
let headers = getHeaders output let headers = getHeaders output
handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output) handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
processMethodRouter handleA status method (Just headers) request processMethodRouter handleA status method (Just headers) request
| otherwise = respond $ Fail err404
instance OVERLAPPABLE_ instance OVERLAPPABLE_
( AllCTRender ctypes a, ReflectMethod method, KnownNat status ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
@ -229,17 +234,17 @@ instance OVERLAPPING_
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = viewReferer -- > server = viewReferer
-- > where viewReferer :: Referer -> ExceptT ServantErr IO referer -- > where viewReferer :: Referer -> Handler referer
-- > viewReferer referer = return referer -- > viewReferer referer = return referer
instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
=> HasServer (Header sym a :> sublayout) context where => HasServer (Header sym a :> api) context where
type ServerT (Header sym a :> sublayout) m = type ServerT (Header sym a :> api) m =
Maybe a -> ServerT sublayout m Maybe a -> ServerT api m
route Proxy context subserver = WithRequest $ \ request -> route Proxy context subserver =
let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request) let mheader req = parseHeaderMaybe =<< lookup str (requestHeaders req)
in route (Proxy :: Proxy sublayout) context (passToServer subserver mheader) in route (Proxy :: Proxy api) context (passToServer subserver mheader)
where str = fromString $ symbolVal (Proxy :: Proxy sym) where str = fromString $ symbolVal (Proxy :: Proxy sym)
-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, -- | 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 :: Server MyApi
-- > server = getBooksBy -- > server = getBooksBy
-- > where getBooksBy :: Maybe Text -> ExceptT ServantErr IO [Book] -- > where getBooksBy :: Maybe Text -> Handler [Book]
-- > getBooksBy Nothing = ...return all books... -- > getBooksBy Nothing = ...return all books...
-- > getBooksBy (Just author) = ...return books by the given author... -- > getBooksBy (Just author) = ...return books by the given author...
instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
=> HasServer (QueryParam sym a :> sublayout) context where => HasServer (QueryParam sym a :> api) context where
type ServerT (QueryParam sym a :> sublayout) m = type ServerT (QueryParam sym a :> api) m =
Maybe a -> ServerT sublayout m Maybe a -> ServerT api m
route Proxy context subserver = WithRequest $ \ request -> route Proxy context subserver =
let querytext = parseQueryText $ rawQueryString request let querytext r = parseQueryText $ rawQueryString r
param = param r =
case lookup paramname querytext of case lookup paramname (querytext r) of
Nothing -> Nothing -- param absent from the query string Nothing -> Nothing -- param absent from the query string
Just Nothing -> Nothing -- param present with no value -> Nothing Just Nothing -> Nothing -- param present with no value -> Nothing
Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to
-- the right type -- 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) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API, -- | 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 :: Server MyApi
-- > server = getBooksBy -- > server = getBooksBy
-- > where getBooksBy :: [Text] -> ExceptT ServantErr IO [Book] -- > where getBooksBy :: [Text] -> Handler [Book]
-- > getBooksBy authors = ...return all books by these authors... -- > getBooksBy authors = ...return all books by these authors...
instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
=> HasServer (QueryParams sym a :> sublayout) context where => HasServer (QueryParams sym a :> api) context where
type ServerT (QueryParams sym a :> sublayout) m = type ServerT (QueryParams sym a :> api) m =
[a] -> ServerT sublayout m [a] -> ServerT api m
route Proxy context subserver = WithRequest $ \ request -> route Proxy context subserver =
let querytext = parseQueryText $ rawQueryString request let querytext r = parseQueryText $ rawQueryString r
-- if sym is "foo", we look for query string parameters -- if sym is "foo", we look for query string parameters
-- named "foo" or "foo[]" and call parseQueryParam on the -- named "foo" or "foo[]" and call parseQueryParam on the
-- corresponding values -- corresponding values
parameters = filter looksLikeParam querytext parameters r = filter looksLikeParam (querytext r)
values = mapMaybe (convert . snd) parameters values r = mapMaybe (convert . snd) (parameters r)
in route (Proxy :: Proxy sublayout) context (passToServer subserver values) in route (Proxy :: Proxy api) context (passToServer subserver values)
where paramname = cs $ symbolVal (Proxy :: Proxy sym) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
convert Nothing = Nothing convert Nothing = Nothing
@ -328,21 +333,21 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = getBooks -- > 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... -- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...
instance (KnownSymbol sym, HasServer sublayout context) instance (KnownSymbol sym, HasServer api context)
=> HasServer (QueryFlag sym :> sublayout) context where => HasServer (QueryFlag sym :> api) context where
type ServerT (QueryFlag sym :> sublayout) m = type ServerT (QueryFlag sym :> api) m =
Bool -> ServerT sublayout m Bool -> ServerT api m
route Proxy context subserver = WithRequest $ \ request -> route Proxy context subserver =
let querytext = parseQueryText $ rawQueryString request let querytext r = parseQueryText $ rawQueryString r
param = case lookup paramname querytext of param r = case lookup paramname (querytext r) of
Just Nothing -> True -- param is there, with no value Just Nothing -> True -- param is there, with no value
Just (Just v) -> examine v -- param with a value Just (Just v) -> examine v -- param with a value
Nothing -> False -- param not in the query string 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) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
examine v | v == "true" || v == "1" || v == "" = True examine v | v == "true" || v == "1" || v == "" = True
| otherwise = False | otherwise = False
@ -359,8 +364,8 @@ instance HasServer Raw context where
type ServerT Raw m = Application type ServerT Raw m = Application
route Proxy _ rawApplication = LeafRouter $ \ request respond -> do route Proxy _ rawApplication = RawRouter $ \ env request respond -> do
r <- runDelayed rawApplication r <- runDelayed rawApplication env request
case r of case r of
Route app -> app request (respond . Route) Route app -> app request (respond . Route)
Fail a -> respond $ Fail a Fail a -> respond $ Fail a
@ -385,18 +390,18 @@ instance HasServer Raw context where
-- > -- >
-- > server :: Server MyApi -- > server :: Server MyApi
-- > server = postBook -- > server = postBook
-- > where postBook :: Book -> ExceptT ServantErr IO Book -- > where postBook :: Book -> Handler Book
-- > postBook book = ...insert into your db... -- > postBook book = ...insert into your db...
instance ( AllCTUnrender list a, HasServer sublayout context instance ( AllCTUnrender list a, HasServer api context
) => HasServer (ReqBody list a :> sublayout) context where ) => HasServer (ReqBody list a :> api) context where
type ServerT (ReqBody list a :> sublayout) m = type ServerT (ReqBody list a :> api) m =
a -> ServerT sublayout m a -> ServerT api m
route Proxy context subserver = WithRequest $ \ request -> route Proxy context subserver =
route (Proxy :: Proxy sublayout) context (addBodyCheck subserver (bodyCheck request)) route (Proxy :: Proxy api) context (addBodyCheck subserver bodyCheck)
where where
bodyCheck request = do bodyCheck = withRequest $ \ request -> do
-- See HTTP RFC 2616, section 7.2.1 -- See HTTP RFC 2616, section 7.2.1
-- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1 -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
-- See also "W3C Internet Media Type registration, consistency of use" -- 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" let contentTypeH = fromMaybe "application/octet-stream"
$ lookup hContentType $ requestHeaders request $ lookup hContentType $ requestHeaders request
mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH) mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
<$> lazyRequestBody request <$> liftIO (lazyRequestBody request)
case mrqbody of case mrqbody of
Nothing -> return $ FailFatal err415 Nothing -> delayedFailFatal err415
Just (Left e) -> return $ FailFatal err400 { errBody = cs e } Just (Left e) -> delayedFailFatal err400 { errBody = cs e }
Just (Right v) -> return $ Route v Just (Right v) -> return v
-- | Make sure the incoming request starts with @"/path"@, strip it and -- | Make sure the incoming request starts with @"/path"@, strip it and
-- pass the rest of the request path to @sublayout@. -- pass the rest of the request path to @api@.
instance (KnownSymbol path, HasServer sublayout context) => HasServer (path :> sublayout) context where 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 $ route Proxy context subserver =
M.singleton (cs (symbolVal proxyPath)) pathRouter
(route (Proxy :: Proxy sublayout) context subserver) (cs (symbolVal proxyPath))
(route (Proxy :: Proxy api) context subserver)
where proxyPath = Proxy :: Proxy path where proxyPath = Proxy :: Proxy path
instance HasServer api context => HasServer (RemoteHost :> api) context where instance HasServer api context => HasServer (RemoteHost :> api) context where
type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m
route Proxy context subserver = WithRequest $ \req -> route Proxy context subserver =
route (Proxy :: Proxy api) context (passToServer subserver $ remoteHost req) route (Proxy :: Proxy api) context (passToServer subserver remoteHost)
instance HasServer api context => HasServer (IsSecure :> api) context where instance HasServer api context => HasServer (IsSecure :> api) context where
type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m
route Proxy context subserver = WithRequest $ \req -> route Proxy context subserver =
route (Proxy :: Proxy api) context (passToServer subserver $ secure req) route (Proxy :: Proxy api) context (passToServer subserver secure)
where secure req = if isSecure req then Secure else NotSecure where secure req = if isSecure req then Secure else NotSecure
instance HasServer api context => HasServer (Vault :> api) context where instance HasServer api context => HasServer (Vault :> api) context where
type ServerT (Vault :> api) m = Vault -> ServerT api m type ServerT (Vault :> api) m = Vault -> ServerT api m
route Proxy context subserver = WithRequest $ \req -> route Proxy context subserver =
route (Proxy :: Proxy api) context (passToServer subserver $ vault req) route (Proxy :: Proxy api) context (passToServer subserver vault)
instance HasServer api context => HasServer (HttpVersion :> api) context where instance HasServer api context => HasServer (HttpVersion :> api) context where
type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m
route Proxy context subserver = WithRequest $ \req -> route Proxy context subserver =
route (Proxy :: Proxy api) context (passToServer subserver $ httpVersion req) route (Proxy :: Proxy api) context (passToServer subserver httpVersion)
-- | Basic Authentication -- | Basic Authentication
instance ( KnownSymbol realm instance ( KnownSymbol realm
@ -456,21 +462,15 @@ instance ( KnownSymbol realm
type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m
route Proxy context subserver = WithRequest $ \ request -> route Proxy context subserver =
route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request) route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck)
where where
realm = BC8.pack $ symbolVal (Proxy :: Proxy realm) realm = BC8.pack $ symbolVal (Proxy :: Proxy realm)
basicAuthContext = getContextEntry context basicAuthContext = getContextEntry context
authCheck req = runBasicAuth req realm basicAuthContext authCheck = withRequest $ \ req -> runBasicAuth req realm basicAuthContext
-- * helpers -- * helpers
pathIsEmpty :: Request -> Bool
pathIsEmpty = go . pathInfo
where go [] = True
go [""] = True
go _ = False
ct_wildcard :: B.ByteString ct_wildcard :: B.ByteString
ct_wildcard = "*" <> "/" <> "*" -- Because CPP 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 DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Servant.Server.Internal.BasicAuth where module Servant.Server.Internal.BasicAuth where
import Control.Monad (guard) import Control.Monad (guard)
import Control.Monad.Trans (liftIO)
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.ByteString.Base64 (decodeLenient) import Data.ByteString.Base64 (decodeLenient)
import Data.Monoid ((<>)) import Data.Monoid ((<>))
@ -15,9 +16,9 @@ import GHC.Generics
import Network.HTTP.Types (Header) import Network.HTTP.Types (Header)
import Network.Wai (Request, requestHeaders) import Network.Wai (Request, requestHeaders)
import Servant.API.BasicAuth (BasicAuthData(BasicAuthData)) import Servant.API.BasicAuth (BasicAuthData(BasicAuthData))
import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.RoutingApplication
import Servant.Server.Internal.ServantErr import Servant.Server.Internal.ServantErr
-- * Basic Auth -- * Basic Auth
@ -57,13 +58,13 @@ decodeBAHdr req = do
-- | Run and check basic authentication, returning the appropriate http error per -- | Run and check basic authentication, returning the appropriate http error per
-- the spec. -- the spec.
runBasicAuth :: Request -> BS.ByteString -> BasicAuthCheck usr -> IO (RouteResult usr) runBasicAuth :: Request -> BS.ByteString -> BasicAuthCheck usr -> DelayedIO usr
runBasicAuth req realm (BasicAuthCheck ba) = runBasicAuth req realm (BasicAuthCheck ba) =
case decodeBAHdr req of case decodeBAHdr req of
Nothing -> plzAuthenticate Nothing -> plzAuthenticate
Just e -> ba e >>= \res -> case res of Just e -> liftIO (ba e) >>= \res -> case res of
BadPassword -> plzAuthenticate BadPassword -> plzAuthenticate
NoSuchUser -> plzAuthenticate NoSuchUser -> plzAuthenticate
Unauthorized -> return $ Fail err403 Unauthorized -> delayedFailFatal err403
Authorized usr -> return $ Route usr Authorized usr -> return usr
where plzAuthenticate = return $ Fail err401 { errHeaders = [mkBAChallengerHdr realm] } 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 -- | '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 -- 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 -- 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. -- 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 -- 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 -- >>> getContextEntry (True :. False :. EmptyContext) :: String
-- ... -- ...
-- No instance for (HasContextEntry '[] [Char]) -- ...No instance for (HasContextEntry '[] [Char])
-- ... -- ...
class HasContextEntry (context :: [*]) (val :: *) where class HasContextEntry (context :: [*]) (val :: *) where
getContextEntry :: Context context -> val getContextEntry :: Context context -> val

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

@ -1,89 +1,196 @@
{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
module Servant.Server.Internal.Router where module Servant.Server.Internal.Router where
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as M import qualified Data.Map as M
import Data.Monoid
import Data.Text (Text) 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.RoutingApplication
import Servant.Server.Internal.ServantErr import Servant.Server.Internal.ServantErr
type Router = Router' RoutingApplication type Router env = Router' env RoutingApplication
-- | Internal representation of a router. -- | Internal representation of a router.
data Router' a = --
WithRequest (Request -> Router) -- The first argument describes an environment type that is
-- ^ current request is passed to the router -- expected as extra input by the routers at the leaves. The
| StaticRouter (Map Text Router) -- environment is filled while running the router, with path
-- ^ first path component used for lookup and removed afterwards -- components that can be used to process captures.
| DynamicRouter (Text -> Router) --
-- ^ first path component used for lookup and removed afterwards data Router' env a =
| LeafRouter a StaticRouter (Map Text (Router' env a)) [env -> a]
-- ^ to be used for routes that match an empty path -- ^ the map contains routers for subpaths (first path component used
| Choice Router Router -- 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 -- ^ left-biased choice between two routers
deriving Functor deriving Functor
-- | Apply a transformation to the response of a `Router`. -- | Smart constructor for a single static path component.
tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router -> Router pathRouter :: Text -> Router' env a -> Router' env a
tweakResponse f = fmap (\a -> \req cont -> a req (cont . f)) 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. -- | Smart constructor for the choice between routers.
-- We currently optimize the following cases: -- 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 dynamic routers can be joined by joining their codomains.
-- * Two 'WithRequest' routers can be joined by passing them -- * Choice nodes can be reordered.
-- 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 :: Router -> Router -> Router choice :: Router' env a -> Router' env a -> Router' env a
choice (StaticRouter table1) (StaticRouter table2) = choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =
StaticRouter (M.unionWith choice table1 table2) StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)
choice (DynamicRouter fun1) (DynamicRouter fun2) = choice (CaptureRouter router1) (CaptureRouter router2) =
DynamicRouter (\ first -> choice (fun1 first) (fun2 first)) CaptureRouter (choice router1 router2)
choice (WithRequest router1) (WithRequest router2) = choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3
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 router1 router2 = Choice router1 router2 choice router1 router2 = Choice router1 router2
-- | Interpret a router as an application. -- | Datatype used for representing and debugging the
runRouter :: Router -> RoutingApplication -- structure of a router. Abstracts from the handlers
runRouter (WithRequest router) request respond = -- at the leaves.
runRouter (router request) request respond --
runRouter (StaticRouter table) request respond = -- Two 'Router's can be structurally compared by computing
case pathInfo request of -- their 'RouterStructure' using 'routerStructure' and
first : rest -- then testing for equality, see 'sameStructure'.
| Just router <- M.lookup first table --
-> let request' = request { pathInfo = rest } data RouterStructure =
in runRouter router request' respond StaticRouterStructure (Map Text RouterStructure) Int
_ -> respond $ Fail err404 | CaptureRouterStructure RouterStructure
runRouter (DynamicRouter fun) request respond = | RawRouterStructure
case pathInfo request of | ChoiceStructure RouterStructure RouterStructure
first : rest deriving (Eq, Show)
-> 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
-- | 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. -- Priority on HTTP codes.
-- --

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

@ -8,7 +8,10 @@
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
module Servant.Server.Internal.RoutingApplication where 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, import Network.Wai (Application, Request,
Response, ResponseReceived) Response, ResponseReceived)
import Prelude () import Prelude ()
@ -35,31 +38,6 @@ toApplication ra request respond = ra request routingRespond
routingRespond (FailFatal err) = respond $ responseServantErr err routingRespond (FailFatal err) = respond $ responseServantErr err
routingRespond (Route v) = respond v 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 -- | A 'Delayed' is a representation of a handler with scheduled
-- delayed checks that can trigger errors. -- 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 -- The accept header check can be performed as the final
-- computation in this block. It can cause a 406. -- computation in this block. It can cause a 406.
-- --
data Delayed c where data Delayed env c where
Delayed :: { capturesD :: IO (RouteResult captures) Delayed :: { capturesD :: env -> DelayedIO captures
, methodD :: IO (RouteResult ()) , methodD :: DelayedIO ()
, authD :: IO (RouteResult auth) , authD :: DelayedIO auth
, bodyD :: IO (RouteResult body) , bodyD :: DelayedIO body
, serverD :: (captures -> auth -> body -> RouteResult c) , serverD :: captures -> auth -> body -> Request -> RouteResult c
} -> Delayed c } -> Delayed env c
instance Functor Delayed where instance Functor (Delayed env) where
fmap f Delayed{..} fmap f Delayed{..} =
= Delayed { capturesD = capturesD Delayed
, methodD = methodD { serverD = \ c a b req -> f <$> serverD c a b req
, authD = authD , ..
, bodyD = bodyD } -- Note [Existential Record Update]
, serverD = (fmap.fmap.fmap.fmap) f serverD
} -- 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. -- | Add a capture to the end of the capture block.
addCapture :: Delayed (a -> b) addCapture :: Delayed env (a -> b)
-> IO (RouteResult a) -> (Text -> DelayedIO a)
-> Delayed b -> Delayed (Text, env) b
addCapture Delayed{..} new addCapture Delayed{..} new =
= Delayed { capturesD = combineRouteResults (,) capturesD new Delayed
, methodD = methodD { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt
, authD = authD , serverD = \ (x, v) a b req -> ($ v) <$> serverD x a b req
, bodyD = bodyD , ..
, serverD = \ (x, v) y z -> ($ v) <$> serverD x y z } -- Note [Existential Record Update]
} -- Note [Existential Record Update]
-- | Add a method check to the end of the method block. -- | Add a method check to the end of the method block.
addMethodCheck :: Delayed a addMethodCheck :: Delayed env a
-> IO (RouteResult ()) -> DelayedIO ()
-> Delayed a -> Delayed env a
addMethodCheck Delayed{..} new addMethodCheck Delayed{..} new =
= Delayed { capturesD = capturesD Delayed
, methodD = combineRouteResults const methodD new { methodD = methodD <* new
, authD = authD , ..
, bodyD = bodyD } -- Note [Existential Record Update]
, serverD = serverD
} -- Note [Existential Record Update]
-- | Add an auth check to the end of the auth block. -- | Add an auth check to the end of the auth block.
addAuthCheck :: Delayed (a -> b) addAuthCheck :: Delayed env (a -> b)
-> IO (RouteResult a) -> DelayedIO a
-> Delayed b -> Delayed env b
addAuthCheck Delayed{..} new addAuthCheck Delayed{..} new =
= Delayed { capturesD = capturesD Delayed
, methodD = methodD { authD = (,) <$> authD <*> new
, authD = combineRouteResults (,) authD new , serverD = \ c (y, v) b req -> ($ v) <$> serverD c y b req
, bodyD = bodyD , ..
, serverD = \ x (y, v) z -> ($ v) <$> serverD x y z } -- Note [Existential Record Update]
} -- Note [Existential Record Update]
-- | Add a body check to the end of the body block. -- | Add a body check to the end of the body block.
addBodyCheck :: Delayed (a -> b) addBodyCheck :: Delayed env (a -> b)
-> IO (RouteResult a) -> DelayedIO a
-> Delayed b -> Delayed env b
addBodyCheck Delayed{..} new addBodyCheck Delayed{..} new =
= Delayed { capturesD = capturesD Delayed
, methodD = methodD { bodyD = (,) <$> bodyD <*> new
, authD = authD , serverD = \ c a (z, v) req -> ($ v) <$> serverD c a z req
, bodyD = combineRouteResults (,) bodyD new , ..
, serverD = \ x y (z, v) -> ($ v) <$> serverD x y z } -- Note [Existential Record Update]
} -- Note [Existential Record Update]
-- | Add an accept header check to the end of the body block. -- | Add an accept header check to the beginning of the body
-- The accept header check should occur after the body check, -- block. There is a tradeoff here. In principle, we'd like
-- but this will be the case, because the accept header check -- to take a bad body (400) response take precedence over a
-- is only scheduled by the method combinators. -- failed accept check (406). BUT to allow streaming the body,
addAcceptCheck :: Delayed a -- we cannot run the body check and then still backtrack.
-> IO (RouteResult ()) -- We therefore do the accept check before the body check,
-> Delayed a -- when we can still backtrack. There are other solutions to
addAcceptCheck Delayed{..} new -- this, but they'd be more complicated (such as delaying the
= Delayed { capturesD = capturesD -- body check further so that it can still be run in a situation
, methodD = methodD -- where we'd otherwise report 406).
, authD = authD addAcceptCheck :: Delayed env a
, bodyD = combineRouteResults const bodyD new -> DelayedIO ()
, serverD = serverD -> Delayed env a
} -- Note [Existential Record Update] addAcceptCheck Delayed{..} new =
Delayed
{ bodyD = new *> bodyD
, ..
} -- Note [Existential Record Update]
-- | Many combinators extract information that is passed to -- | Many combinators extract information that is passed to
-- the handler without the possibility of failure. In such a -- the handler without the possibility of failure. In such a
-- case, 'passToServer' can be used. -- case, 'passToServer' can be used.
passToServer :: Delayed (a -> b) -> a -> Delayed b passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b
passToServer d x = ($ x) <$> d passToServer Delayed{..} x =
Delayed
-- | The combination 'IO . RouteResult' is a monad, but we { serverD = \ c a b req -> ($ x req) <$> serverD c a b req
-- don't explicitly wrap it in a newtype in order to make it , ..
-- an instance. This is the '>>=' of that monad. } -- Note [Existential Record Update]
--
-- 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))
-- | Run a delayed server. Performs all scheduled operations -- | Run a delayed server. Performs all scheduled operations
-- in order, and passes the results from the capture and body -- 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 -- This should only be called once per request; otherwise the guarantees about
-- effect and HTTP error ordering break down. -- effect and HTTP error ordering break down.
runDelayed :: Delayed a runDelayed :: Delayed env a
-> env
-> Request
-> IO (RouteResult a) -> IO (RouteResult a)
runDelayed Delayed{..} = runDelayed Delayed{..} env = runDelayedIO $ do
capturesD `bindRouteResults` \ c -> c <- capturesD env
methodD `bindRouteResults` \ _ -> methodD
authD `bindRouteResults` \ a -> a <- authD
bodyD `bindRouteResults` \ b -> b <- bodyD
return (serverD c a b) DelayedIO (\ req -> return $ serverD c a b req)
-- | Runs a delayed server and the resulting action. -- | Runs a delayed server and the resulting action.
-- Takes a continuation that lets us send a response. -- Takes a continuation that lets us send a response.
-- Also takes a continuation for how to turn the -- Also takes a continuation for how to turn the
-- result of the delayed server into a response. -- 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) -> (RouteResult Response -> IO r)
-> (a -> RouteResult Response) -> (a -> RouteResult Response)
-> IO r -> IO r
runAction action respond k = runDelayed action >>= go >>= respond runAction action env req respond k =
runDelayed action env req >>= go >>= respond
where where
go (Fail e) = return $ Fail e go (Fail e) = return $ Fail e
go (FailFatal e) = return $ FailFatal 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 module Servant.Server.Internal.ServantErr where
import Control.Exception (Exception) import Control.Exception (Exception)
import Control.Monad.Trans.Except (ExceptT)
import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy as LBS
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
@ -18,6 +19,8 @@ data ServantErr = ServantErr { errHTTPCode :: Int
instance Exception ServantErr instance Exception ServantErr
type Handler = ExceptT ServantErr IO
responseServantErr :: ServantErr -> Response responseServantErr :: ServantErr -> Response
responseServantErr ServantErr{..} = responseLBS status errHeaders errBody responseServantErr ServantErr{..} = responseLBS status errHeaders errBody
where where
@ -27,8 +30,8 @@ responseServantErr ServantErr{..} = responseLBS status errHeaders errBody
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr $ err300 { errBody = "I can't choose." } -- > failingHandler = throwError $ err300 { errBody = "I can't choose." }
-- --
err300 :: ServantErr err300 :: ServantErr
err300 = ServantErr { errHTTPCode = 300 err300 = ServantErr { errHTTPCode = 300
@ -41,8 +44,8 @@ err300 = ServantErr { errHTTPCode = 300
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr err301 -- > failingHandler = throwError err301
-- --
err301 :: ServantErr err301 :: ServantErr
err301 = ServantErr { errHTTPCode = 301 err301 = ServantErr { errHTTPCode = 301
@ -55,8 +58,8 @@ err301 = ServantErr { errHTTPCode = 301
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr err302 -- > failingHandler = throwError err302
-- --
err302 :: ServantErr err302 :: ServantErr
err302 = ServantErr { errHTTPCode = 302 err302 = ServantErr { errHTTPCode = 302
@ -69,8 +72,8 @@ err302 = ServantErr { errHTTPCode = 302
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr err303 -- > failingHandler = throwError err303
-- --
err303 :: ServantErr err303 :: ServantErr
err303 = ServantErr { errHTTPCode = 303 err303 = ServantErr { errHTTPCode = 303
@ -83,8 +86,8 @@ err303 = ServantErr { errHTTPCode = 303
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr err304 -- > failingHandler = throwError err304
-- --
err304 :: ServantErr err304 :: ServantErr
err304 = ServantErr { errHTTPCode = 304 err304 = ServantErr { errHTTPCode = 304
@ -97,8 +100,8 @@ err304 = ServantErr { errHTTPCode = 304
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr err305 -- > failingHandler = throwError err305
-- --
err305 :: ServantErr err305 :: ServantErr
err305 = ServantErr { errHTTPCode = 305 err305 = ServantErr { errHTTPCode = 305
@ -111,8 +114,8 @@ err305 = ServantErr { errHTTPCode = 305
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr err307 -- > failingHandler = throwError err307
-- --
err307 :: ServantErr err307 :: ServantErr
err307 = ServantErr { errHTTPCode = 307 err307 = ServantErr { errHTTPCode = 307
@ -125,8 +128,8 @@ err307 = ServantErr { errHTTPCode = 307
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr $ err400 { errBody = "Your request makes no sense to me." } -- > failingHandler = throwError $ err400 { errBody = "Your request makes no sense to me." }
-- --
err400 :: ServantErr err400 :: ServantErr
err400 = ServantErr { errHTTPCode = 400 err400 = ServantErr { errHTTPCode = 400
@ -139,8 +142,8 @@ err400 = ServantErr { errHTTPCode = 400
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr $ err401 { errBody = "Your credentials are invalid." } -- > failingHandler = throwError $ err401 { errBody = "Your credentials are invalid." }
-- --
err401 :: ServantErr err401 :: ServantErr
err401 = ServantErr { errHTTPCode = 401 err401 = ServantErr { errHTTPCode = 401
@ -153,8 +156,8 @@ err401 = ServantErr { errHTTPCode = 401
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr $ err402 { errBody = "You have 0 credits. Please give me $$$." } -- > failingHandler = throwError $ err402 { errBody = "You have 0 credits. Please give me $$$." }
-- --
err402 :: ServantErr err402 :: ServantErr
err402 = ServantErr { errHTTPCode = 402 err402 = ServantErr { errHTTPCode = 402
@ -167,8 +170,8 @@ err402 = ServantErr { errHTTPCode = 402
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr $ err403 { errBody = "Please login first." } -- > failingHandler = throwError $ err403 { errBody = "Please login first." }
-- --
err403 :: ServantErr err403 :: ServantErr
err403 = ServantErr { errHTTPCode = 403 err403 = ServantErr { errHTTPCode = 403
@ -181,8 +184,8 @@ err403 = ServantErr { errHTTPCode = 403
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr $ err404 { errBody = "(╯°□°）╯︵ ┻━┻)." } -- > failingHandler = throwError $ err404 { errBody = "(╯°□°）╯︵ ┻━┻)." }
-- --
err404 :: ServantErr err404 :: ServantErr
err404 = ServantErr { errHTTPCode = 404 err404 = ServantErr { errHTTPCode = 404
@ -195,8 +198,8 @@ err404 = ServantErr { errHTTPCode = 404
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr $ err405 { errBody = "Your account privileges does not allow for this. Please pay $$$." } -- > failingHandler = throwError $ err405 { errBody = "Your account privileges does not allow for this. Please pay $$$." }
-- --
err405 :: ServantErr err405 :: ServantErr
err405 = ServantErr { errHTTPCode = 405 err405 = ServantErr { errHTTPCode = 405
@ -209,8 +212,8 @@ err405 = ServantErr { errHTTPCode = 405
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr err406 -- > failingHandler = throwError err406
-- --
err406 :: ServantErr err406 :: ServantErr
err406 = ServantErr { errHTTPCode = 406 err406 = ServantErr { errHTTPCode = 406
@ -223,8 +226,8 @@ err406 = ServantErr { errHTTPCode = 406
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr err407 -- > failingHandler = throwError err407
-- --
err407 :: ServantErr err407 :: ServantErr
err407 = ServantErr { errHTTPCode = 407 err407 = ServantErr { errHTTPCode = 407
@ -237,8 +240,8 @@ err407 = ServantErr { errHTTPCode = 407
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr $ err409 { errBody = "Transaction conflicts with 59879cb56c7c159231eeacdd503d755f7e835f74" } -- > failingHandler = throwError $ err409 { errBody = "Transaction conflicts with 59879cb56c7c159231eeacdd503d755f7e835f74" }
-- --
err409 :: ServantErr err409 :: ServantErr
err409 = ServantErr { errHTTPCode = 409 err409 = ServantErr { errHTTPCode = 409
@ -251,8 +254,8 @@ err409 = ServantErr { errHTTPCode = 409
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr $ err410 { errBody = "I know it was here at some point, but.. I blame bad luck." } -- > failingHandler = throwError $ err410 { errBody = "I know it was here at some point, but.. I blame bad luck." }
-- --
err410 :: ServantErr err410 :: ServantErr
err410 = ServantErr { errHTTPCode = 410 err410 = ServantErr { errHTTPCode = 410
@ -265,8 +268,8 @@ err410 = ServantErr { errHTTPCode = 410
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr err411 -- > failingHandler = throwError err411
-- --
err411 :: ServantErr err411 :: ServantErr
err411 = ServantErr { errHTTPCode = 411 err411 = ServantErr { errHTTPCode = 411
@ -279,8 +282,8 @@ err411 = ServantErr { errHTTPCode = 411
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr $ err412 { errBody = "Precondition fail: x < 42 && y > 57" } -- > failingHandler = throwError $ err412 { errBody = "Precondition fail: x < 42 && y > 57" }
-- --
err412 :: ServantErr err412 :: ServantErr
err412 = ServantErr { errHTTPCode = 412 err412 = ServantErr { errHTTPCode = 412
@ -293,8 +296,8 @@ err412 = ServantErr { errHTTPCode = 412
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr $ err413 { errBody = "Request exceeded 64k." } -- > failingHandler = throwError $ err413 { errBody = "Request exceeded 64k." }
-- --
err413 :: ServantErr err413 :: ServantErr
err413 = ServantErr { errHTTPCode = 413 err413 = ServantErr { errHTTPCode = 413
@ -307,8 +310,8 @@ err413 = ServantErr { errHTTPCode = 413
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr $ err414 { errBody = "Maximum length is 64." } -- > failingHandler = throwError $ err414 { errBody = "Maximum length is 64." }
-- --
err414 :: ServantErr err414 :: ServantErr
err414 = ServantErr { errHTTPCode = 414 err414 = ServantErr { errHTTPCode = 414
@ -321,8 +324,8 @@ err414 = ServantErr { errHTTPCode = 414
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr $ err415 { errBody = "Supported media types: gif, png" } -- > failingHandler = throwError $ err415 { errBody = "Supported media types: gif, png" }
-- --
err415 :: ServantErr err415 :: ServantErr
err415 = ServantErr { errHTTPCode = 415 err415 = ServantErr { errHTTPCode = 415
@ -335,8 +338,8 @@ err415 = ServantErr { errHTTPCode = 415
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr $ err416 { errBody = "Valid range is [0, 424242]." } -- > failingHandler = throwError $ err416 { errBody = "Valid range is [0, 424242]." }
-- --
err416 :: ServantErr err416 :: ServantErr
err416 = ServantErr { errHTTPCode = 416 err416 = ServantErr { errHTTPCode = 416
@ -349,8 +352,8 @@ err416 = ServantErr { errHTTPCode = 416
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr $ err417 { errBody = "I found a quux in the request. This isn't going to work." } -- > failingHandler = throwError $ err417 { errBody = "I found a quux in the request. This isn't going to work." }
-- --
err417 :: ServantErr err417 :: ServantErr
err417 = ServantErr { errHTTPCode = 417 err417 = ServantErr { errHTTPCode = 417
@ -363,8 +366,8 @@ err417 = ServantErr { errHTTPCode = 417
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr $ err500 { errBody = "Exception in module A.B.C:55. Have a great day!" } -- > failingHandler = throwError $ err500 { errBody = "Exception in module A.B.C:55. Have a great day!" }
-- --
err500 :: ServantErr err500 :: ServantErr
err500 = ServantErr { errHTTPCode = 500 err500 = ServantErr { errHTTPCode = 500
@ -377,8 +380,8 @@ err500 = ServantErr { errHTTPCode = 500
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr $ err501 { errBody = "/v1/foo is not supported with quux in the request." } -- > failingHandler = throwError $ err501 { errBody = "/v1/foo is not supported with quux in the request." }
-- --
err501 :: ServantErr err501 :: ServantErr
err501 = ServantErr { errHTTPCode = 501 err501 = ServantErr { errHTTPCode = 501
@ -391,8 +394,8 @@ err501 = ServantErr { errHTTPCode = 501
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr $ err502 { errBody = "Tried gateway foo, bar, and baz. None responded." } -- > failingHandler = throwError $ err502 { errBody = "Tried gateway foo, bar, and baz. None responded." }
-- --
err502 :: ServantErr err502 :: ServantErr
err502 = ServantErr { errHTTPCode = 502 err502 = ServantErr { errHTTPCode = 502
@ -405,8 +408,8 @@ err502 = ServantErr { errHTTPCode = 502
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr $ err503 { errBody = "We're rewriting in PHP." } -- > failingHandler = throwError $ err503 { errBody = "We're rewriting in PHP." }
-- --
err503 :: ServantErr err503 :: ServantErr
err503 = ServantErr { errHTTPCode = 503 err503 = ServantErr { errHTTPCode = 503
@ -419,8 +422,8 @@ err503 = ServantErr { errHTTPCode = 503
-- --
-- Example: -- Example:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr $ err504 { errBody = "Backend foobar did not respond in 5 seconds." } -- > failingHandler = throwError $ err504 { errBody = "Backend foobar did not respond in 5 seconds." }
-- --
err504 :: ServantErr err504 :: ServantErr
err504 = ServantErr { errHTTPCode = 504 err504 = ServantErr { errHTTPCode = 504
@ -433,8 +436,8 @@ err504 = ServantErr { errHTTPCode = 504
-- --
-- Example usage: -- Example usage:
-- --
-- > failingHandler :: ExceptT ServantErr IO () -- > failingHandler :: Handler ()
-- > failingHandler = throwErr $ err505 { errBody = "I support HTTP/4.0 only." } -- > failingHandler = throwError $ err505 { errBody = "I support HTTP/4.0 only." }
-- --
err505 :: ServantErr err505 :: ServantErr
err505 = ServantErr { errHTTPCode = 505 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 DataKinds #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
module Servant.Server.Internal.EnterSpec where module Servant.ArbitraryMonadServerSpec where
import qualified Control.Category as C import qualified Control.Category as C
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.Trans.Except
import Data.Proxy import Data.Proxy
import Servant.API import Servant.API
import Servant.Server import Servant.Server
@ -15,7 +14,7 @@ import Test.Hspec.Wai (get, matchStatus, post,
shouldRespondWith, with) shouldRespondWith, with)
spec :: Spec spec :: Spec
spec = describe "module Servant.Server.Enter" $ do spec = describe "Arbitrary monad server" $ do
enterSpec enterSpec
type ReaderAPI = "int" :> Get '[JSON] Int type ReaderAPI = "int" :> Get '[JSON] Int
@ -34,7 +33,7 @@ combinedAPI = Proxy
readerServer' :: ServerT ReaderAPI (Reader String) readerServer' :: ServerT ReaderAPI (Reader String)
readerServer' = return 1797 :<|> ask readerServer' = return 1797 :<|> ask
fReader :: Reader String :~> ExceptT ServantErr IO fReader :: Reader String :~> Handler
fReader = generalizeNat C.. (runReaderTNat "hi") fReader = generalizeNat C.. (runReaderTNat "hi")
readerServer :: Server ReaderAPI readerServer :: Server ReaderAPI

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

@ -53,6 +53,23 @@ errorOrderApi = Proxy
errorOrderServer :: Server ErrorOrderApi errorOrderServer :: Server ErrorOrderApi
errorOrderServer = \_ _ _ -> throwE err402 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 :: Spec
errorOrderSpec = errorOrderSpec =
describe "HTTP error order" $ describe "HTTP error order" $
@ -86,18 +103,18 @@ errorOrderSpec =
request goodMethod goodUrl [badAuth, badContentType, badAccept] badBody request goodMethod goodUrl [badAuth, badContentType, badAccept] badBody
`shouldRespondWith` 401 `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 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 `shouldRespondWith` 415
it "has 400 as its fifth highest priority error" $ do it "has 400 as its sixth highest priority error" $ do
request goodMethod goodUrl [goodAuth, goodContentType, badAccept] badBody request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] badBody
`shouldRespondWith` 400 `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 it "has handler-level errors as last priority" $ do
request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] goodBody request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] goodBody
`shouldRespondWith` 402 `shouldRespondWith` 402

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

@ -1,9 +1,9 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# OPTIONS_GHC -fdefer-type-errors #-} {-# OPTIONS_GHC -fdefer-type-errors -Wwarn #-}
module Servant.Server.Internal.ContextSpec (spec) where module Servant.Server.Internal.ContextSpec (spec) where
import Data.Proxy (Proxy (..)) 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 Test.ShouldNotTypecheck (shouldNotTypecheck)
import Servant.API import Servant.API
@ -26,16 +26,17 @@ spec = do
shouldNotTypecheck x shouldNotTypecheck x
context "Show instance" $ do context "Show instance" $ do
let cxt = 'a' :. True :. EmptyContext
it "has a Show instance" $ do it "has a Show instance" $ do
let cxt = 'a' :. True :. EmptyContext
show cxt `shouldBe` "'a' :. True :. EmptyContext" show cxt `shouldBe` "'a' :. True :. EmptyContext"
context "bracketing" $ do context "bracketing" $ do
it "works" $ do it "works" $ do
let cxt = 'a' :. True :. EmptyContext
show (Just cxt) `shouldBe` "Just ('a' :. True :. EmptyContext)" show (Just cxt) `shouldBe` "Just ('a' :. True :. EmptyContext)"
it "works with operators" $ do 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)" show cxt `shouldBe` "(1 :. 'a' :. EmptyContext) :<|> ('b' :. True :. EmptyContext)"
describe "descendIntoNamedContext" $ do 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 module Servant.Server.StreamingSpec where
import Control.Concurrent import Control.Concurrent
import Control.Exception import Control.Exception hiding (Handler)
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import qualified Data.ByteString as Strict import qualified Data.ByteString as Strict
import qualified Data.ByteString.Lazy as Lazy import qualified Data.ByteString.Lazy as Lazy
import Network.HTTP.Types import Network.HTTP.Types
@ -66,7 +65,7 @@ spec = do
-- - receives the first chunk -- - receives the first chunk
-- - notifies serverReceivedFirstChunk -- - notifies serverReceivedFirstChunk
-- - receives the rest of the request -- - receives the rest of the request
let handler :: Lazy.ByteString -> ExceptT ServantErr IO NoContent let handler :: Lazy.ByteString -> Handler NoContent
handler input = liftIO $ do handler input = liftIO $ do
let prefix = Lazy.take 3 input let prefix = Lazy.take 3 input
prefix `shouldBe` "foo" prefix `shouldBe` "foo"

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

@ -5,7 +5,6 @@
module Servant.Server.UsingContextSpec where module Servant.Server.UsingContextSpec where
import Control.Monad.Trans.Except
import Network.Wai import Network.Wai
import Test.Hspec (Spec, describe, it) import Test.Hspec (Spec, describe, it)
import Test.Hspec.Wai import Test.Hspec.Wai
@ -25,7 +24,7 @@ spec = do
type OneEntryAPI = type OneEntryAPI =
ExtractFromContext :> Get '[JSON] String ExtractFromContext :> Get '[JSON] String
testServer :: String -> ExceptT ServantErr IO String testServer :: String -> Handler String
testServer s = return s testServer s = return s
oneEntryApp :: Application 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 GHC.TypeLits
import Servant import Servant
import Servant.Server.Internal.RoutingApplication
data ExtractFromContext data ExtractFromContext
@ -31,12 +30,12 @@ instance (HasContextEntry context String, HasServer subApi context) =>
String -> ServerT subApi m String -> ServerT subApi m
route Proxy context delayed = route Proxy context delayed =
route subProxy context (fmap (inject context) delayed :: Delayed (Server subApi)) route subProxy context (fmap inject delayed)
where where
subProxy :: Proxy subApi subProxy :: Proxy subApi
subProxy = Proxy subProxy = Proxy
inject context f = f (getContextEntry context) inject f = f (getContextEntry context)
data InjectIntoContext data InjectIntoContext

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

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

23
servant/servant.cabal
View file

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

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

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

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

@ -1,12 +1,13 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-} {-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
module Servant.API.BasicAuth where module Servant.API.BasicAuth where
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Typeable (Typeable) 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>. -- | 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 -- > instance Accept MyContentType where
-- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8") -- > 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) -- > mimeRender _ val = pack ("This is MINE! " ++ show val)
-- > -- >
-- > type MyAPI = "path" :> Get '[MyContentType] Int -- > 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) handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
instance OVERLAPPABLE_ 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 handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
where pctyps = Proxy :: Proxy (ct ': cts) where pctyps = Proxy :: Proxy (ct ': cts)
amrs = allMimeRender pctyps val amrs = allMimeRender pctyps val

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

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

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

@ -3,7 +3,9 @@
{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# OPTIONS_HADDOCK not-home #-} {-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Header where module Servant.API.Header (
Header(..),
) where
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
@ -25,5 +27,3 @@ data Header (sym :: Symbol) a = Header a
-- >>> import Servant.API -- >>> import Servant.API
-- >>> import Data.Aeson -- >>> import Data.Aeson
-- >>> import Data.Text -- >>> 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 instance OVERLAPPING_ BuildHeadersTo '[] where
buildHeadersTo _ = HNil buildHeadersTo _ = HNil
instance OVERLAPPABLE_ ( FromByteString v, BuildHeadersTo xs, KnownSymbol h instance OVERLAPPABLE_ ( FromByteString v, BuildHeadersTo xs, KnownSymbol h )
, Contains h xs ~ 'False)
=> BuildHeadersTo ((Header h v) ': xs) where => BuildHeadersTo ((Header h v) ': xs) where
buildHeadersTo headers = buildHeadersTo headers =
let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h) let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
@ -89,7 +88,7 @@ class GetHeaders ls where
instance OVERLAPPING_ GetHeaders (HList '[]) where instance OVERLAPPING_ GetHeaders (HList '[]) where
getHeaders _ = [] 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 (HList (Header h x ': xs)) where
getHeaders hdrs = case hdrs of getHeaders hdrs = case hdrs of
Header val `HCons` rest -> (headerName , toByteString' val):getHeaders rest 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 instance OVERLAPPING_ GetHeaders (Headers '[] a) where
getHeaders _ = [] 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 (Headers (Header h v ': rest) a) where
getHeaders hs = getHeaders $ getHeadersHList hs 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 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 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) addHeader a (Headers resp heads) = Headers resp (HCons (Header a) heads)
instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString v 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 h v a new where
addHeader a resp = Headers resp (HCons (Header a) HNil) 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 -- $setup
-- >>> import Servant.API -- >>> import Servant.API
-- >>> import Data.Aeson -- >>> 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' -- | Use 'Vault' in your API types to provide access to the 'Vault'
-- of the request, which is a location shared by middlewares and applications -- 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 -- to store arbitrary data. See <https://hackage.haskell.org/package/vault vault>
-- use the vault in your handlers -- for more details on how to actually use the vault in your handlers
-- --
-- Example: -- Example:
-- --

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

@ -14,7 +14,9 @@ import GHC.Generics (Generic)
import GHC.TypeLits (Nat) import GHC.TypeLits (Nat)
import Network.HTTP.Types.Method (Method, StdMethod (..), import Network.HTTP.Types.Method (Method, StdMethod (..),
methodDelete, methodGet, methodHead, 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 -- | @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 -- convenience, type synonyms for each verb with a 200 response code are
@ -167,3 +169,12 @@ instance ReflectMethod 'PATCH where
instance ReflectMethod 'HEAD where instance ReflectMethod 'HEAD where
reflectMethod _ = methodHead 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 TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
module Servant.Server.Internal.Enter where module Servant.Utils.Enter where
import qualified Control.Category as C 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.Identity
import Control.Monad.Morph import Control.Monad.Morph
import Control.Monad.Reader 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] ()) -- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] ())
-- >>> safeLink api bad_link -- >>> safeLink api bad_link
-- ... -- ...
-- Could not deduce (Or -- ...Could not deduce...
-- (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
-- --
-- This error is essentially saying that the type family couldn't find -- This error is essentially saying that the type family couldn't find
-- bad_link under api after trying the open (but empty) type family -- bad_link under api after trying the open (but empty) type family
@ -112,10 +106,12 @@ import Prelude ()
import Prelude.Compat import Prelude.Compat
import Web.HttpApiData import Web.HttpApiData
import Servant.API.BasicAuth ( BasicAuth )
import Servant.API.Capture ( Capture ) import Servant.API.Capture ( Capture )
import Servant.API.ReqBody ( ReqBody ) import Servant.API.ReqBody ( ReqBody )
import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag ) import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag )
import Servant.API.Header ( Header ) import Servant.API.Header ( Header )
import Servant.API.RemoteHost ( RemoteHost )
import Servant.API.Verbs ( Verb ) import Servant.API.Verbs ( Verb )
import Servant.API.Sub ( type (:>) ) import Servant.API.Sub ( type (:>) )
import Servant.API.Raw ( Raw ) 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 type MkLink (Header sym a :> sub) = MkLink sub
toLink _ = toLink (Proxy :: Proxy 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 -- Verb (terminal) instances
instance HasLink (Verb m s ct a) where instance HasLink (Verb m s ct a) where
type MkLink (Verb m s ct a) = URI type MkLink (Verb m s ct a) = URI

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

@ -3,14 +3,14 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Servant.API.ContentTypesSpec where module Servant.API.ContentTypesSpec where
#if !MIN_VERSION_base(4,8,0) import Prelude ()
import Control.Applicative import Prelude.Compat
import Data.Monoid
#endif
import Control.Arrow import Control.Arrow
import Data.Aeson import Data.Aeson
import Data.ByteString.Char8 (ByteString, append, pack) import Data.ByteString.Char8 (ByteString, append, pack)
@ -28,7 +28,7 @@ import GHC.Generics
import Network.URL (exportParams, importParams) import Network.URL (exportParams, importParams)
import Test.Hspec import Test.Hspec
import Test.QuickCheck import Test.QuickCheck
import Test.QuickCheck.Instances () import "quickcheck-instances" Test.QuickCheck.Instances ()
import Servant.API.ContentTypes 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) -- >>> apiLink (Proxy :: Proxy WrongPath)
-- ... -- ...
-- Could not deduce ... -- ...Could not deduce...
-- ... -- ...
-- --
-- >>> apiLink (Proxy :: Proxy WrongReturnType) -- >>> apiLink (Proxy :: Proxy WrongReturnType)
-- ... -- ...
-- Could not deduce ... -- ...Could not deduce...
-- ... -- ...
-- --
-- >>> apiLink (Proxy :: Proxy WrongContentType) -- >>> apiLink (Proxy :: Proxy WrongContentType)
-- ... -- ...
-- Could not deduce ... -- ...Could not deduce...
-- ... -- ...
-- --
-- >>> apiLink (Proxy :: Proxy WrongMethod) -- >>> apiLink (Proxy :: Proxy WrongMethod)
-- ... -- ...
-- Could not deduce ... -- ...Could not deduce...
-- ... -- ...
-- --
-- >>> apiLink (Proxy :: Proxy NotALink) -- >>> apiLink (Proxy :: Proxy NotALink)
-- ... -- ...
-- Could not deduce ... -- ...Could not deduce...
-- ... -- ...
-- --
-- sanity check -- sanity check

5
sources.txt
View file

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

32
stack-ghc-7.8.4.yaml
View file

@ -1,28 +1,28 @@
flags: {} flags: {}
packages: packages:
- servant/ - servant/
- servant-blaze/
- servant-cassava/
- servant-client/ - servant-client/
- servant-docs/ - servant-docs/
- servant-examples/
- servant-foreign/ - servant-foreign/
- servant-js/ - servant-js/
- servant-lucid/
- servant-mock/ - servant-mock/
- servant-server/ - servant-server/
extra-deps: extra-deps:
- base-compat-0.9.0 - base-compat-0.9.1
- 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
- control-monad-omega-0.3.1 - control-monad-omega-0.3.1
- http-api-data-0.1.1.1 - cryptonite-0.6
- should-not-typecheck-2.0.1 - 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 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: flags: {}
servant-js:
example: false
packages: packages:
- servant/ - servant/
- servant-blaze/
- servant-cassava/
- servant-client/ - servant-client/
- servant-docs/ - servant-docs/
- servant-foreign/ - servant-foreign/
- servant-js/ - servant-js/
- servant-lucid/
- servant-mock/ - servant-mock/
- servant-server/ - servant-server/
- doc/tutorial - doc/tutorial
extra-deps: extra-deps:
- base-compat-0.9.0 resolver: lts-6.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

2
travis.sh
View file

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