Merge remote-tracking branch 'origin/master' into client-ghcjs_update-stack-file
This commit is contained in:
commit
6c5afe8fb3
90 changed files with 1543 additions and 1305 deletions
11
.travis.yml
11
.travis.yml
|
@ -3,8 +3,9 @@ sudo: false
|
|||
language: c
|
||||
|
||||
env:
|
||||
- GHCVER=7.8.4
|
||||
- GHCVER=7.10.2
|
||||
- GHCVER=7.8.4 CABALVER=1.22
|
||||
- GHCVER=7.10.3 CABALVER=1.22
|
||||
- GHCVER=8.0.1 CABALVER=1.24
|
||||
|
||||
addons:
|
||||
apt:
|
||||
|
@ -12,13 +13,15 @@ addons:
|
|||
- hvr-ghc
|
||||
packages:
|
||||
- ghc-7.8.4
|
||||
- ghc-7.10.2
|
||||
- ghc-7.10.3
|
||||
- ghc-8.0.1
|
||||
- cabal-install-1.22
|
||||
- cabal-install-1.24
|
||||
- libgmp-dev
|
||||
|
||||
install:
|
||||
- (mkdir -p $HOME/.local/bin && cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc)
|
||||
- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.22/bin:$PATH
|
||||
- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
|
||||
- ghc --version
|
||||
- cabal --version
|
||||
- travis_retry cabal update
|
||||
|
|
|
@ -4,11 +4,12 @@
|
|||
|
||||
## Getting Started
|
||||
|
||||
We have a [tutorial](http://haskell-servant.github.io/tutorial) that
|
||||
We have a [tutorial](http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html) that
|
||||
introduces the core features of servant. After this article, you should be able
|
||||
to write your first servant webservices, learning the rest from the haddocks'
|
||||
examples.
|
||||
|
||||
The central documentation can be found [here](http://haskell-servant.readthedocs.org/).
|
||||
Other blog posts, videos and slides can be found on the
|
||||
[website](http://haskell-servant.github.io/).
|
||||
|
||||
|
|
37
doc/examples.md
Normal file
37
doc/examples.md
Normal 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.
|
|
@ -19,4 +19,5 @@ All in a type-safe manner.
|
|||
|
||||
introduction.rst
|
||||
tutorial/index.rst
|
||||
examples.md
|
||||
links.rst
|
||||
|
|
|
@ -297,7 +297,7 @@ Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication).
|
|||
|
||||
When protecting endpoints with basic authentication, we need to specify two items:
|
||||
|
||||
1. The **realm** of authentication as per the Basic Authentictaion spec.
|
||||
1. The **realm** of authentication as per the Basic Authentication spec.
|
||||
2. The datatype returned by the server after authentication is verified. This
|
||||
is usually a `User` or `Customer` type datatype.
|
||||
|
||||
|
|
|
@ -44,7 +44,6 @@ You can use this combinator to protect an API as follows:
|
|||
|
||||
module Authentication where
|
||||
|
||||
import Control.Monad.Trans.Except (ExceptT, throwE)
|
||||
import Data.Aeson (ToJSON)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Map (Map, fromList)
|
||||
|
@ -59,13 +58,14 @@ import Servant.API ((:<|>) ((:<|>)), (:>), BasicAuth,
|
|||
Get, JSON)
|
||||
import Servant.API.BasicAuth (BasicAuthData (BasicAuthData))
|
||||
import Servant.API.Experimental.Auth (AuthProtect)
|
||||
import Servant (throwError)
|
||||
import Servant.Server (BasicAuthCheck (BasicAuthCheck),
|
||||
BasicAuthResult( Authorized
|
||||
, Unauthorized
|
||||
),
|
||||
Context ((:.), EmptyContext),
|
||||
err401, err403, errBody, Server,
|
||||
ServantErr, serveWithContext)
|
||||
serveWithContext, Handler)
|
||||
import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData,
|
||||
mkAuthHandler)
|
||||
import Servant.Server.Experimental.Auth()
|
||||
|
@ -117,22 +117,22 @@ or dictated the structure of a response (e.g. a `Capture` param is pulled from
|
|||
the request path). Now consider an API resource protected by basic
|
||||
authentication. Once the required `WWW-Authenticate` header is checked, we need
|
||||
to verify the username and password. But how? One solution would be to force an
|
||||
API author to provide a function of type `BasicAuthData -> ExceptT ServantErr IO User`
|
||||
API author to provide a function of type `BasicAuthData -> Handler User`
|
||||
and servant should use this function to authenticate a request. Unfortunately
|
||||
this didn't work prior to `0.5` because all of servant's machinery was
|
||||
engineered around the idea that each combinator can extract information from
|
||||
only the request. We cannot extract the function
|
||||
`BasicAuthData -> ExceptT ServantErr IO User` from a request! Are we doomed?
|
||||
`BasicAuthData -> Handler User` from a request! Are we doomed?
|
||||
|
||||
Servant `0.5` introduced `Context` to handle this. The type machinery is beyond
|
||||
the scope of this tutorial, but the idea is simple: provide some data to the
|
||||
`serve` function, and that data is propagated to the functions that handle each
|
||||
combinator. Using `Context`, we can supply a function of type
|
||||
`BasicAuthData -> ExceptT ServantErr IO User` to the `BasicAuth` combinator
|
||||
`BasicAuthData -> Handler User` to the `BasicAuth` combinator
|
||||
handler. This will allow the handler to check authentication and return a `User`
|
||||
to downstream handlers if successful.
|
||||
|
||||
In practice we wrap `BasicAuthData -> ExceptT ServantErr IO` into a slightly
|
||||
In practice we wrap `BasicAuthData -> Handler` into a slightly
|
||||
different function to better capture the semantics of basic authentication:
|
||||
|
||||
``` haskell ignore
|
||||
|
@ -173,7 +173,7 @@ And now we create the `Context` used by servant to find `BasicAuthCheck`:
|
|||
```haskell
|
||||
-- | We need to supply our handlers with the right Context. In this case,
|
||||
-- Basic Authentication requires a Context Entry with the 'BasicAuthCheck' value
|
||||
-- tagged with "foo-tag" This context is then supplied to 'server' and threaded
|
||||
-- tagged with "foo-tag" This context is then supplied to 'server' and threaded
|
||||
-- to the BasicAuth HasServer handlers.
|
||||
basicAuthServerContext :: Context (BasicAuthCheck User ': '[])
|
||||
basicAuthServerContext = authCheck :. EmptyContext
|
||||
|
@ -246,7 +246,7 @@ your feedback!
|
|||
### What is Generalized Authentication?
|
||||
|
||||
**TL;DR**: you throw a tagged `AuthProtect` combinator in front of the endpoints
|
||||
you want protected and then supply a function `Request -> ExceptT IO ServantErr user`
|
||||
you want protected and then supply a function `Request -> Handler user`
|
||||
which we run anytime a request matches a protected endpoint. It precisely solves
|
||||
the "I just need to protect these endpoints with a function that does some
|
||||
complicated business logic" and nothing more. Behind the scenes we use a type
|
||||
|
@ -272,24 +272,24 @@ database = fromList [ ("key1", Account "Anne Briggs")
|
|||
|
||||
-- | A method that, when given a password, will return a Account.
|
||||
-- This is our bespoke (and bad) authentication logic.
|
||||
lookupAccount :: ByteString -> ExceptT ServantErr IO Account
|
||||
lookupAccount :: ByteString -> Handler Account
|
||||
lookupAccount key = case Map.lookup key database of
|
||||
Nothing -> throwE (err403 { errBody = "Invalid Cookie" })
|
||||
Nothing -> throwError (err403 { errBody = "Invalid Cookie" })
|
||||
Just usr -> return usr
|
||||
```
|
||||
|
||||
For generalized authentication, servant exposes the `AuthHandler` type,
|
||||
which is used to wrap the `Request -> ExceptT IO ServantErr user` logic. Let's
|
||||
which is used to wrap the `Request -> Handler user` logic. Let's
|
||||
create a value of type `AuthHandler Request Account` using the above `lookupAccount`
|
||||
method:
|
||||
|
||||
```haskell
|
||||
-- | The auth handler wraps a function from Request -> ExceptT ServantErr IO Account
|
||||
-- | The auth handler wraps a function from Request -> Handler Account
|
||||
-- we look for a Cookie and pass the value of the cookie to `lookupAccount`.
|
||||
authHandler :: AuthHandler Request Account
|
||||
authHandler =
|
||||
let handler req = case lookup "servant-auth-cookie" (requestHeaders req) of
|
||||
Nothing -> throwE (err401 { errBody = "Missing auth header" })
|
||||
Nothing -> throwError (err401 { errBody = "Missing auth header" })
|
||||
Just authCookieKey -> lookupAccount authCookieKey
|
||||
in mkAuthHandler handler
|
||||
```
|
||||
|
@ -329,7 +329,7 @@ We now construct the `Context` for our server, allowing us to instantiate a
|
|||
value of type `Server AuthGenAPI`, in addition to the server value:
|
||||
|
||||
```haskell
|
||||
-- | The context that will be made available to request handlers. We supply the
|
||||
-- | The context that will be made available to request handlers. We supply the
|
||||
-- "cookie-auth"-tagged request handler defined above, so that the 'HasServer' instance
|
||||
-- of 'AuthProtect' can extract the handler and run it on the request.
|
||||
genAuthServerContext :: Context (AuthHandler Request Account ': '[])
|
||||
|
@ -379,7 +379,7 @@ forward:
|
|||
2. choose a application-specific data type used by your server when
|
||||
authentication is successful (in our case this was `User`).
|
||||
3. Create a value of `AuthHandler Request User` which encapsulates the
|
||||
authentication logic (`Request -> ExceptT IO ServantErr User`). This function
|
||||
authentication logic (`Request -> Handler User`). This function
|
||||
will be executed everytime a request matches a protected route.
|
||||
4. Provide an instance of the `AuthServerData` type family, specifying your
|
||||
application-specific data type returned when authentication is successful (in
|
||||
|
|
|
@ -111,11 +111,11 @@ corresponding API type.
|
|||
The first thing to know about the `Server` type family is that behind the
|
||||
scenes it will drive the routing, letting you focus only on the business
|
||||
logic. The second thing to know is that for each endpoint, your handlers will
|
||||
by default run in the `ExceptT ServantErr IO` monad. This is overridable very
|
||||
by default run in the `Handler` monad. This is overridable very
|
||||
easily, as explained near the end of this guide. Third thing, the type of the
|
||||
value returned in that monad must be the same as the second argument of the
|
||||
HTTP method combinator used for the corresponding endpoint. In our case, it
|
||||
means we must provide a handler of type `ExceptT ServantErr IO [User]`. Well,
|
||||
means we must provide a handler of type `Handler [User]`. Well,
|
||||
we have a monad, let's just `return` our list:
|
||||
|
||||
``` haskell
|
||||
|
@ -269,15 +269,15 @@ server3 = position
|
|||
:<|> hello
|
||||
:<|> marketing
|
||||
|
||||
where position :: Int -> Int -> ExceptT ServantErr IO Position
|
||||
where position :: Int -> Int -> Handler Position
|
||||
position x y = return (Position x y)
|
||||
|
||||
hello :: Maybe String -> ExceptT ServantErr IO HelloMessage
|
||||
hello :: Maybe String -> Handler HelloMessage
|
||||
hello mname = return . HelloMessage $ case mname of
|
||||
Nothing -> "Hello, anonymous coward"
|
||||
Just n -> "Hello, " ++ n
|
||||
|
||||
marketing :: ClientInfo -> ExceptT ServantErr IO Email
|
||||
marketing :: ClientInfo -> Handler Email
|
||||
marketing clientinfo = return (emailForClient clientinfo)
|
||||
```
|
||||
|
||||
|
@ -307,7 +307,7 @@ $ curl -X POST -d '{"clientName":"Alp Mestanogullari", "clientEmail" : "alp@foo.
|
|||
|
||||
For reference, here's a list of some combinators from **servant**:
|
||||
|
||||
> - `Delete`, `Get`, `Patch`, `Post`, `Put`: these do not become arguments. They provide the return type of handlers, which usually is `ExceptT ServantErr IO <something>`.
|
||||
> - `Delete`, `Get`, `Patch`, `Post`, `Put`: these do not become arguments. They provide the return type of handlers, which usually is `Handler <something>`.
|
||||
> - `Capture "something" a` becomes an argument of type `a`.
|
||||
> - `QueryParam "something" a`, `Header "something" a` all become arguments of type `Maybe a`, because there might be no value at all specified by the client for these.
|
||||
> - `QueryFlag "something"` gets turned into an argument of type `Bool`.
|
||||
|
@ -601,11 +601,10 @@ $ curl -H 'Accept: text/html' http://localhost:8081/persons
|
|||
# or just point your browser to http://localhost:8081/persons
|
||||
```
|
||||
|
||||
## The `ExceptT ServantErr IO` monad
|
||||
## The `Handler` monad
|
||||
|
||||
At the heart of the handlers is the monad they run in, namely `ExceptT
|
||||
ServantErr IO`
|
||||
([haddock documentation for `ExceptT`](http://hackage.haskell.org/package/mtl-2.2.1/docs/Control-Monad-Except.html#t:ExceptT)).
|
||||
At the heart of the handlers is the monad they run in, namely `ExceptT ServantErr IO`
|
||||
([haddock documentation for `ExceptT`](http://hackage.haskell.org/package/mtl-2.2.1/docs/Control-Monad-Except.html#t:ExceptT)), which is aliased as `Handler`.
|
||||
One might wonder: why this monad? The answer is that it is the
|
||||
simplest monad with the following properties:
|
||||
|
||||
|
@ -621,7 +620,7 @@ Let's recall some definitions.
|
|||
newtype ExceptT e m a = ExceptT (m (Either e a))
|
||||
```
|
||||
|
||||
In short, this means that a handler of type `ExceptT ServantErr IO a` is simply
|
||||
In short, this means that a handler of type `Handler a` is simply
|
||||
equivalent to a computation of type `IO (Either ServantErr a)`, that is, an IO
|
||||
action that either returns an error or a result.
|
||||
|
||||
|
@ -688,7 +687,7 @@ module. If you want to use these values but add a body or some headers, just
|
|||
use record update syntax:
|
||||
|
||||
``` haskell
|
||||
failingHandler :: ExceptT ServantErr IO ()
|
||||
failingHandler :: Handler ()
|
||||
failingHandler = throwError myerr
|
||||
|
||||
where myerr :: ServantErr
|
||||
|
@ -810,7 +809,7 @@ type UserAPI3 = -- view the user with given userid, in JSON
|
|||
Capture "userid" Int :> Get '[JSON] User
|
||||
|
||||
:<|> -- delete the user with given userid. empty response
|
||||
Capture "userid" Int :> Delete '[] ()
|
||||
Capture "userid" Int :> DeleteNoContent '[JSON] NoContent
|
||||
```
|
||||
|
||||
We can instead factor out the `userid`:
|
||||
|
@ -818,7 +817,7 @@ We can instead factor out the `userid`:
|
|||
``` haskell
|
||||
type UserAPI4 = Capture "userid" Int :>
|
||||
( Get '[JSON] User
|
||||
:<|> Delete '[] ()
|
||||
:<|> DeleteNoContent '[JSON] NoContent
|
||||
)
|
||||
```
|
||||
|
||||
|
@ -826,11 +825,11 @@ However, you have to be aware that this has an effect on the type of the
|
|||
corresponding `Server`:
|
||||
|
||||
``` haskell ignore
|
||||
Server UserAPI3 = (Int -> ExceptT ServantErr IO User)
|
||||
:<|> (Int -> ExceptT ServantErr IO ())
|
||||
Server UserAPI3 = (Int -> Handler User)
|
||||
:<|> (Int -> Handler NoContent)
|
||||
|
||||
Server UserAPI4 = Int -> ( ExceptT ServantErr IO User
|
||||
:<|> ExceptT ServantErr IO ()
|
||||
Server UserAPI4 = Int -> ( Handler User
|
||||
:<|> Handler NoContent
|
||||
)
|
||||
```
|
||||
|
||||
|
@ -842,10 +841,10 @@ computations in `ExceptT`, with no arguments. In other words:
|
|||
server8 :: Server UserAPI3
|
||||
server8 = getUser :<|> deleteUser
|
||||
|
||||
where getUser :: Int -> ExceptT ServantErr IO User
|
||||
where getUser :: Int -> Handler User
|
||||
getUser _userid = error "..."
|
||||
|
||||
deleteUser :: Int -> ExceptT ServantErr IO ()
|
||||
deleteUser :: Int -> Handler NoContent
|
||||
deleteUser _userid = error "..."
|
||||
|
||||
-- notice how getUser and deleteUser
|
||||
|
@ -854,10 +853,10 @@ server8 = getUser :<|> deleteUser
|
|||
server9 :: Server UserAPI4
|
||||
server9 userid = getUser userid :<|> deleteUser userid
|
||||
|
||||
where getUser :: Int -> ExceptT ServantErr IO User
|
||||
where getUser :: Int -> Handler User
|
||||
getUser = error "..."
|
||||
|
||||
deleteUser :: Int -> ExceptT ServantErr IO ()
|
||||
deleteUser :: Int -> Handler NoContent
|
||||
deleteUser = error "..."
|
||||
```
|
||||
|
||||
|
@ -876,13 +875,13 @@ type API1 = "users" :>
|
|||
-- we factor out the Request Body
|
||||
type API2 = ReqBody '[JSON] User :>
|
||||
( Get '[JSON] User -- just display the same user back, don't register it
|
||||
:<|> Post '[JSON] () -- register the user. empty response
|
||||
:<|> PostNoContent '[JSON] NoContent -- register the user. empty response
|
||||
)
|
||||
|
||||
-- we factor out a Header
|
||||
type API3 = Header "Authorization" Token :>
|
||||
( Get '[JSON] SecretData -- get some secret data, if authorized
|
||||
:<|> ReqBody '[JSON] SecretData :> Post '[] () -- add some secret data, if authorized
|
||||
:<|> ReqBody '[JSON] SecretData :> PostNoContent '[JSON] NoContent -- add some secret data, if authorized
|
||||
)
|
||||
|
||||
newtype Token = Token ByteString
|
||||
|
@ -895,44 +894,44 @@ API type only at the end.
|
|||
``` haskell
|
||||
type UsersAPI =
|
||||
Get '[JSON] [User] -- list users
|
||||
:<|> ReqBody '[JSON] User :> Post '[] () -- add a user
|
||||
:<|> ReqBody '[JSON] User :> PostNoContent '[JSON] NoContent -- add a user
|
||||
:<|> Capture "userid" Int :>
|
||||
( Get '[JSON] User -- view a user
|
||||
:<|> ReqBody '[JSON] User :> Put '[] () -- update a user
|
||||
:<|> Delete '[] () -- delete a user
|
||||
:<|> ReqBody '[JSON] User :> PutNoContent '[JSON] NoContent -- update a user
|
||||
:<|> DeleteNoContent '[JSON] NoContent -- delete a user
|
||||
)
|
||||
|
||||
usersServer :: Server UsersAPI
|
||||
usersServer = getUsers :<|> newUser :<|> userOperations
|
||||
|
||||
where getUsers :: ExceptT ServantErr IO [User]
|
||||
where getUsers :: Handler [User]
|
||||
getUsers = error "..."
|
||||
|
||||
newUser :: User -> ExceptT ServantErr IO ()
|
||||
newUser :: User -> Handler NoContent
|
||||
newUser = error "..."
|
||||
|
||||
userOperations userid =
|
||||
viewUser userid :<|> updateUser userid :<|> deleteUser userid
|
||||
|
||||
where
|
||||
viewUser :: Int -> ExceptT ServantErr IO User
|
||||
viewUser :: Int -> Handler User
|
||||
viewUser = error "..."
|
||||
|
||||
updateUser :: Int -> User -> ExceptT ServantErr IO ()
|
||||
updateUser :: Int -> User -> Handler NoContent
|
||||
updateUser = error "..."
|
||||
|
||||
deleteUser :: Int -> ExceptT ServantErr IO ()
|
||||
deleteUser :: Int -> Handler NoContent
|
||||
deleteUser = error "..."
|
||||
```
|
||||
|
||||
``` haskell
|
||||
type ProductsAPI =
|
||||
Get '[JSON] [Product] -- list products
|
||||
:<|> ReqBody '[JSON] Product :> Post '[] () -- add a product
|
||||
:<|> ReqBody '[JSON] Product :> PostNoContent '[JSON] NoContent -- add a product
|
||||
:<|> Capture "productid" Int :>
|
||||
( Get '[JSON] Product -- view a product
|
||||
:<|> ReqBody '[JSON] Product :> Put '[] () -- update a product
|
||||
:<|> Delete '[] () -- delete a product
|
||||
:<|> ReqBody '[JSON] Product :> PutNoContent '[JSON] NoContent -- update a product
|
||||
:<|> DeleteNoContent '[JSON] NoContent -- delete a product
|
||||
)
|
||||
|
||||
data Product = Product { productId :: Int }
|
||||
|
@ -940,23 +939,23 @@ data Product = Product { productId :: Int }
|
|||
productsServer :: Server ProductsAPI
|
||||
productsServer = getProducts :<|> newProduct :<|> productOperations
|
||||
|
||||
where getProducts :: ExceptT ServantErr IO [Product]
|
||||
where getProducts :: Handler [Product]
|
||||
getProducts = error "..."
|
||||
|
||||
newProduct :: Product -> ExceptT ServantErr IO ()
|
||||
newProduct :: Product -> Handler NoContent
|
||||
newProduct = error "..."
|
||||
|
||||
productOperations productid =
|
||||
viewProduct productid :<|> updateProduct productid :<|> deleteProduct productid
|
||||
|
||||
where
|
||||
viewProduct :: Int -> ExceptT ServantErr IO Product
|
||||
viewProduct :: Int -> Handler Product
|
||||
viewProduct = error "..."
|
||||
|
||||
updateProduct :: Int -> Product -> ExceptT ServantErr IO ()
|
||||
updateProduct :: Int -> Product -> Handler NoContent
|
||||
updateProduct = error "..."
|
||||
|
||||
deleteProduct :: Int -> ExceptT ServantErr IO ()
|
||||
deleteProduct :: Int -> Handler NoContent
|
||||
deleteProduct = error "..."
|
||||
```
|
||||
|
||||
|
@ -976,20 +975,20 @@ abstract that away:
|
|||
-- indexed by values of type 'i'
|
||||
type APIFor a i =
|
||||
Get '[JSON] [a] -- list 'a's
|
||||
:<|> ReqBody '[JSON] a :> Post '[] () -- add an 'a'
|
||||
:<|> ReqBody '[JSON] a :> PostNoContent '[JSON] NoContent -- add an 'a'
|
||||
:<|> Capture "id" i :>
|
||||
( Get '[JSON] a -- view an 'a' given its "identifier" of type 'i'
|
||||
:<|> ReqBody '[JSON] a :> Put '[] () -- update an 'a'
|
||||
:<|> Delete '[] () -- delete an 'a'
|
||||
:<|> ReqBody '[JSON] a :> PutNoContent '[JSON] NoContent -- update an 'a'
|
||||
:<|> DeleteNoContent '[JSON] NoContent -- delete an 'a'
|
||||
)
|
||||
|
||||
-- Build the appropriate 'Server'
|
||||
-- given the handlers of the right type.
|
||||
serverFor :: ExceptT ServantErr IO [a] -- handler for listing of 'a's
|
||||
-> (a -> ExceptT ServantErr IO ()) -- handler for adding an 'a'
|
||||
-> (i -> ExceptT ServantErr IO a) -- handler for viewing an 'a' given its identifier of type 'i'
|
||||
-> (i -> a -> ExceptT ServantErr IO ()) -- updating an 'a' with given id
|
||||
-> (i -> ExceptT ServantErr IO ()) -- deleting an 'a' given its id
|
||||
serverFor :: Handler [a] -- handler for listing of 'a's
|
||||
-> (a -> Handler NoContent) -- handler for adding an 'a'
|
||||
-> (i -> Handler a) -- handler for viewing an 'a' given its identifier of type 'i'
|
||||
-> (i -> a -> Handler NoContent) -- updating an 'a' with given id
|
||||
-> (i -> Handler NoContent) -- deleting an 'a' given its id
|
||||
-> Server (APIFor a i)
|
||||
serverFor = error "..."
|
||||
-- implementation left as an exercise. contact us on IRC
|
||||
|
@ -998,12 +997,11 @@ serverFor = error "..."
|
|||
|
||||
## Using another monad for your handlers
|
||||
|
||||
Remember how `Server` turns combinators for HTTP methods into `ExceptT
|
||||
ServantErr IO`? Well, actually, there's more to that. `Server` is actually a
|
||||
Remember how `Server` turns combinators for HTTP methods into `Handler`? Well, actually, there's more to that. `Server` is actually a
|
||||
simple type synonym.
|
||||
|
||||
``` haskell ignore
|
||||
type Server api = ServerT api (ExceptT ServantErr IO)
|
||||
type Server api = ServerT api Handler
|
||||
```
|
||||
|
||||
`ServerT` is the actual type family that computes the required types for the
|
||||
|
@ -1036,12 +1034,11 @@ listToMaybeNat = Nat listToMaybe -- from Data.Maybe
|
|||
|
||||
(`Nat` comes from "natural transformation", in case you're wondering.)
|
||||
|
||||
So if you want to write handlers using another monad/type than `ExceptT
|
||||
ServantErr IO`, say the `Reader String` monad, the first thing you have to
|
||||
So if you want to write handlers using another monad/type than `Handler`, say the `Reader String` monad, the first thing you have to
|
||||
prepare is a function:
|
||||
|
||||
``` haskell ignore
|
||||
readerToHandler :: Reader String :~> ExceptT ServantErr IO
|
||||
readerToHandler :: Reader String :~> Handler
|
||||
```
|
||||
|
||||
Let's start with `readerToHandler'`. We obviously have to run the `Reader`
|
||||
|
@ -1050,10 +1047,10 @@ from that and can then just `return` it into `ExceptT`. We can then just wrap
|
|||
that function with the `Nat` constructor to make it have the fancier type.
|
||||
|
||||
``` haskell
|
||||
readerToHandler' :: forall a. Reader String a -> ExceptT ServantErr IO a
|
||||
readerToHandler' :: forall a. Reader String a -> Handler a
|
||||
readerToHandler' r = return (runReader r "hi")
|
||||
|
||||
readerToHandler :: Reader String :~> ExceptT ServantErr IO
|
||||
readerToHandler :: Reader String :~> Handler
|
||||
readerToHandler = Nat readerToHandler'
|
||||
```
|
||||
|
||||
|
@ -1077,8 +1074,7 @@ readerServerT = a :<|> b
|
|||
```
|
||||
|
||||
We unfortunately can't use `readerServerT` as an argument of `serve`, because
|
||||
`serve` wants a `Server ReaderAPI`, i.e., with handlers running in `ExceptT
|
||||
ServantErr IO`. But there's a simple solution to this.
|
||||
`serve` wants a `Server ReaderAPI`, i.e., with handlers running in `Handler`. But there's a simple solution to this.
|
||||
|
||||
### Enter `enter`
|
||||
|
||||
|
|
|
@ -3,14 +3,8 @@ Tutorial
|
|||
|
||||
This is an introductory tutorial to **servant**.
|
||||
|
||||
.. note::
|
||||
This tutorial is for the latest version of servant. The tutorial for
|
||||
servant-0.4 can be viewed
|
||||
`here <https://haskell-servant.github.io/tutorial/>`_.
|
||||
|
||||
(Any comments, issues or feedback about the tutorial can be handled
|
||||
through
|
||||
`servant's issue tracker <http://github.com/haskell-servant/servant/issues>`_.)
|
||||
(Any comments, issues or feedback about the tutorial can be submitted
|
||||
to `servant's issue tracker <http://github.com/haskell-servant/servant/issues>`_.)
|
||||
|
||||
|
||||
.. toctree::
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
name: tutorial
|
||||
version: 0.6
|
||||
version: 0.7.1
|
||||
synopsis: The servant tutorial
|
||||
homepage: http://haskell-servant.github.io/
|
||||
homepage: http://haskell-servant.readthedocs.org/
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Servant Contributors
|
||||
|
@ -25,11 +25,11 @@ library
|
|||
, directory
|
||||
, blaze-markup
|
||||
, containers
|
||||
, servant == 0.6.*
|
||||
, servant-server == 0.6.*
|
||||
, servant-client == 0.6.*
|
||||
, servant-docs == 0.6.*
|
||||
, servant-js == 0.6.*
|
||||
, servant == 0.7.*
|
||||
, servant-server == 0.7.*
|
||||
, servant-client == 0.7.*
|
||||
, servant-docs == 0.7.*
|
||||
, servant-js == 0.7.*
|
||||
, warp
|
||||
, http-media
|
||||
, lucid
|
||||
|
@ -46,15 +46,11 @@ library
|
|||
, markdown-unlit >= 0.4
|
||||
, http-client
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -Werror -pgmL markdown-unlit
|
||||
-- to silence aeson-0.10 warnings:
|
||||
ghc-options: -fno-warn-missing-methods
|
||||
ghc-options: -fno-warn-name-shadowing
|
||||
ghc-options: -Wall -pgmL markdown-unlit
|
||||
|
||||
test-suite spec
|
||||
type: exitcode-stdio-1.0
|
||||
ghc-options:
|
||||
-Wall -fno-warn-name-shadowing -fno-warn-missing-signatures
|
||||
ghc-options: -Wall
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
main-is: Spec.hs
|
||||
|
|
11
scripts/test-stack.sh
Executable file
11
scripts/test-stack.sh
Executable 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
|
|
@ -11,4 +11,4 @@ main :: IO ()
|
|||
main = do
|
||||
sources <- words <$> readFile "sources.txt"
|
||||
forM_ sources $ \ source -> do
|
||||
callCommand ("stack upload " ++ source)
|
||||
callCommand ("stack upload --no-signature " ++ source)
|
||||
|
|
|
@ -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.
|
|
@ -1,2 +0,0 @@
|
|||
import Distribution.Simple
|
||||
main = defaultMain
|
|
@ -1,8 +0,0 @@
|
|||
#if __GLASGOW_HASKELL__ >= 710
|
||||
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
|
||||
#define OVERLAPPING_ {-# OVERLAPPING #-}
|
||||
#else
|
||||
{-# LANGUAGE OverlappingInstances #-}
|
||||
#define OVERLAPPABLE_
|
||||
#define OVERLAPPING_
|
||||
#endif
|
|
@ -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
|
|
@ -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
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
dependencies:
|
||||
- name: servant
|
||||
path: ../servant
|
|
@ -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.
|
|
@ -1,2 +0,0 @@
|
|||
import Distribution.Simple
|
||||
main = defaultMain
|
|
@ -1,8 +0,0 @@
|
|||
#if __GLASGOW_HASKELL__ >= 710
|
||||
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
|
||||
#define OVERLAPPING_ {-# OVERLAPPING #-}
|
||||
#else
|
||||
{-# LANGUAGE OverlappingInstances #-}
|
||||
#define OVERLAPPABLE_
|
||||
#define OVERLAPPING_
|
||||
#endif
|
|
@ -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
|
|
@ -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
|
|
@ -1,3 +0,0 @@
|
|||
dependencies:
|
||||
- name: servant
|
||||
path: ../servant
|
|
@ -1,3 +1,9 @@
|
|||
0.7.1
|
||||
-----
|
||||
|
||||
* Support GHC 8.0
|
||||
* `ServantError` has an `Eq` instance now.
|
||||
|
||||
0.6
|
||||
---
|
||||
|
||||
|
|
|
@ -13,9 +13,8 @@ type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
|
|||
myApi :: Proxy MyApi
|
||||
myApi = Proxy
|
||||
|
||||
getAllBooks :: ExceptT String IO [Book]
|
||||
postNewBook :: Book -> ExceptT String IO Book
|
||||
getAllBooks :: Manager -> BaseUrl -> ExceptT String IO [Book]
|
||||
postNewBook :: Book -> Manager -> BaseUrl -> ExceptT String IO Book
|
||||
-- 'client' allows you to produce operations to query an API from a client.
|
||||
(getAllBooks :<|> postNewBook) = client myApi host
|
||||
where host = BaseUrl Http "localhost" 8080
|
||||
(getAllBooks :<|> postNewBook) = client myApi
|
||||
```
|
||||
|
|
|
@ -1,11 +1,11 @@
|
|||
name: servant-client
|
||||
version: 0.6
|
||||
version: 0.7.1
|
||||
synopsis: automatical derivation of querying functions for servant webservices
|
||||
description:
|
||||
This library lets you derive automatically Haskell functions that
|
||||
let you query each endpoint of a <http://hackage.haskell.org/package/servant servant> webservice.
|
||||
.
|
||||
See <http://haskell-servant.github.io/tutorial/client.html the client section of the tutorial>.
|
||||
See <http://haskell-servant.readthedocs.org/en/stable/tutorial/Client.html the client section of the tutorial>.
|
||||
.
|
||||
<https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG>
|
||||
license: BSD3
|
||||
|
@ -15,11 +15,14 @@ maintainer: haskell-servant-maintainers@googlegroups.com
|
|||
copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors
|
||||
category: Web
|
||||
build-type: Simple
|
||||
extra-source-files: include/*.h
|
||||
cabal-version: >=1.10
|
||||
tested-with: GHC >= 7.8
|
||||
homepage: http://haskell-servant.github.io/
|
||||
homepage: http://haskell-servant.readthedocs.org/
|
||||
Bug-reports: http://github.com/haskell-servant/servant/issues
|
||||
extra-source-files:
|
||||
include/*.h
|
||||
CHANGELOG.md
|
||||
README.md
|
||||
source-repository head
|
||||
type: git
|
||||
location: http://github.com/haskell-servant/servant.git
|
||||
|
@ -49,13 +52,13 @@ library
|
|||
, case-insensitive
|
||||
, exceptions
|
||||
, http-api-data >= 0.1 && < 0.3
|
||||
, http-client
|
||||
, http-client <0.5
|
||||
, http-client-tls
|
||||
, http-media
|
||||
, http-types
|
||||
, network-uri >= 2.6
|
||||
, safe
|
||||
, servant == 0.6.*
|
||||
, servant == 0.7.*
|
||||
, string-conversions
|
||||
, text
|
||||
, transformers
|
||||
|
@ -67,12 +70,13 @@ library
|
|||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall
|
||||
if impl(ghc >= 8.0)
|
||||
ghc-options: -Wno-redundant-constraints
|
||||
include-dirs: include
|
||||
|
||||
test-suite spec
|
||||
type: exitcode-stdio-1.0
|
||||
ghc-options:
|
||||
-Wall -fno-warn-name-shadowing -fno-warn-missing-signatures
|
||||
ghc-options: -Wall -fno-warn-name-shadowing
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test, src
|
||||
main-is: Spec.hs
|
||||
|
@ -92,6 +96,7 @@ test-suite spec
|
|||
Servant.Client.TestServer.GHC
|
||||
build-depends:
|
||||
base == 4.*
|
||||
, base-compat
|
||||
, transformers
|
||||
, transformers-compat
|
||||
, aeson
|
||||
|
@ -105,8 +110,8 @@ test-suite spec
|
|||
, HUnit
|
||||
, network >= 2.6
|
||||
, QuickCheck >= 2.7
|
||||
, servant == 0.6.*
|
||||
, servant-server == 0.6.*
|
||||
, servant == 0.7.*
|
||||
, servant-server == 0.7.*
|
||||
, text
|
||||
, wai
|
||||
, warp
|
||||
|
|
|
@ -19,6 +19,7 @@ module Servant.Client
|
|||
, AuthenticateReq(..)
|
||||
, client
|
||||
, HasClient(..)
|
||||
, ClientM
|
||||
, mkAuthenticateReq
|
||||
, ServantError(..)
|
||||
, module Servant.Common.BaseUrl
|
||||
|
@ -57,15 +58,15 @@ import Servant.Client.PerformRequest (ServantError(..))
|
|||
-- > getAllBooks :: Manager -> BaseUrl -> ClientM [Book]
|
||||
-- > postNewBook :: Book -> Manager -> BaseUrl -> ClientM Book
|
||||
-- > (getAllBooks :<|> postNewBook) = client myApi
|
||||
client :: HasClient layout => Proxy layout -> Client layout
|
||||
client :: HasClient api => Proxy api -> Client api
|
||||
client p = clientWithRoute p defReq
|
||||
|
||||
-- | This class lets us define how each API combinator
|
||||
-- influences the creation of an HTTP request. It's mostly
|
||||
-- an internal class, you can just use 'client'.
|
||||
class HasClient layout where
|
||||
type Client layout :: *
|
||||
clientWithRoute :: Proxy layout -> Req -> Client layout
|
||||
class HasClient api where
|
||||
type Client api :: *
|
||||
clientWithRoute :: Proxy api -> Req -> Client api
|
||||
|
||||
|
||||
-- | A client querying function for @a ':<|>' b@ will actually hand you
|
||||
|
@ -106,14 +107,14 @@ instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
|
|||
-- > getBook :: Text -> Manager -> BaseUrl -> ClientM Book
|
||||
-- > getBook = client myApi
|
||||
-- > -- then you can just use "getBook" to query that endpoint
|
||||
instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout)
|
||||
=> HasClient (Capture capture a :> sublayout) where
|
||||
instance (KnownSymbol capture, ToHttpApiData a, HasClient api)
|
||||
=> HasClient (Capture capture a :> api) where
|
||||
|
||||
type Client (Capture capture a :> sublayout) =
|
||||
a -> Client sublayout
|
||||
type Client (Capture capture a :> api) =
|
||||
a -> Client api
|
||||
|
||||
clientWithRoute Proxy req val =
|
||||
clientWithRoute (Proxy :: Proxy sublayout)
|
||||
clientWithRoute (Proxy :: Proxy api)
|
||||
(appendToPath p req)
|
||||
|
||||
where p = unpack (toUrlPiece val)
|
||||
|
@ -186,14 +187,14 @@ instance OVERLAPPING_
|
|||
-- > viewReferer = client myApi
|
||||
-- > -- then you can just use "viewRefer" to query that endpoint
|
||||
-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
|
||||
instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
|
||||
=> HasClient (Header sym a :> sublayout) where
|
||||
instance (KnownSymbol sym, ToHttpApiData a, HasClient api)
|
||||
=> HasClient (Header sym a :> api) where
|
||||
|
||||
type Client (Header sym a :> sublayout) =
|
||||
Maybe a -> Client sublayout
|
||||
type Client (Header sym a :> api) =
|
||||
Maybe a -> Client api
|
||||
|
||||
clientWithRoute Proxy req mval =
|
||||
clientWithRoute (Proxy :: Proxy sublayout)
|
||||
clientWithRoute (Proxy :: Proxy api)
|
||||
(maybe req
|
||||
(\value -> Servant.Common.Req.addHeader hname value req)
|
||||
mval
|
||||
|
@ -203,14 +204,14 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
|
|||
|
||||
-- | Using a 'HttpVersion' combinator in your API doesn't affect the client
|
||||
-- functions.
|
||||
instance HasClient sublayout
|
||||
=> HasClient (HttpVersion :> sublayout) where
|
||||
instance HasClient api
|
||||
=> HasClient (HttpVersion :> api) where
|
||||
|
||||
type Client (HttpVersion :> sublayout) =
|
||||
Client sublayout
|
||||
type Client (HttpVersion :> api) =
|
||||
Client api
|
||||
|
||||
clientWithRoute Proxy =
|
||||
clientWithRoute (Proxy :: Proxy sublayout)
|
||||
clientWithRoute (Proxy :: Proxy api)
|
||||
|
||||
-- | If you use a 'QueryParam' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take
|
||||
|
@ -237,15 +238,15 @@ instance HasClient sublayout
|
|||
-- > -- then you can just use "getBooksBy" to query that endpoint.
|
||||
-- > -- 'getBooksBy Nothing' for all books
|
||||
-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
|
||||
instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
|
||||
=> HasClient (QueryParam sym a :> sublayout) where
|
||||
instance (KnownSymbol sym, ToHttpApiData a, HasClient api)
|
||||
=> HasClient (QueryParam sym a :> api) where
|
||||
|
||||
type Client (QueryParam sym a :> sublayout) =
|
||||
Maybe a -> Client sublayout
|
||||
type Client (QueryParam sym a :> api) =
|
||||
Maybe a -> Client api
|
||||
|
||||
-- if mparam = Nothing, we don't add it to the query string
|
||||
clientWithRoute Proxy req mparam =
|
||||
clientWithRoute (Proxy :: Proxy sublayout)
|
||||
clientWithRoute (Proxy :: Proxy api)
|
||||
(maybe req
|
||||
(flip (appendToQueryString pname) req . Just)
|
||||
mparamText
|
||||
|
@ -282,14 +283,14 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
|
|||
-- > -- 'getBooksBy []' for all books
|
||||
-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
|
||||
-- > -- to get all books by Asimov and Heinlein
|
||||
instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
|
||||
=> HasClient (QueryParams sym a :> sublayout) where
|
||||
instance (KnownSymbol sym, ToHttpApiData a, HasClient api)
|
||||
=> HasClient (QueryParams sym a :> api) where
|
||||
|
||||
type Client (QueryParams sym a :> sublayout) =
|
||||
[a] -> Client sublayout
|
||||
type Client (QueryParams sym a :> api) =
|
||||
[a] -> Client api
|
||||
|
||||
clientWithRoute Proxy req paramlist =
|
||||
clientWithRoute (Proxy :: Proxy sublayout)
|
||||
clientWithRoute (Proxy :: Proxy api)
|
||||
(foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))
|
||||
req
|
||||
paramlist'
|
||||
|
@ -320,14 +321,14 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
|
|||
-- > -- then you can just use "getBooks" to query that endpoint.
|
||||
-- > -- 'getBooksBy False' for all books
|
||||
-- > -- 'getBooksBy True' to only get _already published_ books
|
||||
instance (KnownSymbol sym, HasClient sublayout)
|
||||
=> HasClient (QueryFlag sym :> sublayout) where
|
||||
instance (KnownSymbol sym, HasClient api)
|
||||
=> HasClient (QueryFlag sym :> api) where
|
||||
|
||||
type Client (QueryFlag sym :> sublayout) =
|
||||
Bool -> Client sublayout
|
||||
type Client (QueryFlag sym :> api) =
|
||||
Bool -> Client api
|
||||
|
||||
clientWithRoute Proxy req flag =
|
||||
clientWithRoute (Proxy :: Proxy sublayout)
|
||||
clientWithRoute (Proxy :: Proxy api)
|
||||
(if flag
|
||||
then appendToQueryString paramname Nothing req
|
||||
else req
|
||||
|
@ -364,14 +365,14 @@ instance HasClient Raw where
|
|||
-- > addBook :: Book -> Manager -> BaseUrl -> ClientM Book
|
||||
-- > addBook = client myApi
|
||||
-- > -- then you can just use "addBook" to query that endpoint
|
||||
instance (MimeRender ct a, HasClient sublayout)
|
||||
=> HasClient (ReqBody (ct ': cts) a :> sublayout) where
|
||||
instance (MimeRender ct a, HasClient api)
|
||||
=> HasClient (ReqBody (ct ': cts) a :> api) where
|
||||
|
||||
type Client (ReqBody (ct ': cts) a :> sublayout) =
|
||||
a -> Client sublayout
|
||||
type Client (ReqBody (ct ': cts) a :> api) =
|
||||
a -> Client api
|
||||
|
||||
clientWithRoute Proxy req body =
|
||||
clientWithRoute (Proxy :: Proxy sublayout)
|
||||
clientWithRoute (Proxy :: Proxy api)
|
||||
(let ctProxy = Proxy :: Proxy ct
|
||||
in setRQBody (mimeRender ctProxy body)
|
||||
(contentType ctProxy)
|
||||
|
@ -379,11 +380,11 @@ instance (MimeRender ct a, HasClient sublayout)
|
|||
)
|
||||
|
||||
-- | Make the querying function append @path@ to the request path.
|
||||
instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
|
||||
type Client (path :> sublayout) = Client sublayout
|
||||
instance (KnownSymbol path, HasClient api) => HasClient (path :> api) where
|
||||
type Client (path :> api) = Client api
|
||||
|
||||
clientWithRoute Proxy req =
|
||||
clientWithRoute (Proxy :: Proxy sublayout)
|
||||
clientWithRoute (Proxy :: Proxy api)
|
||||
(appendToPath p req)
|
||||
|
||||
where p = symbolVal (Proxy :: Proxy path)
|
||||
|
|
|
@ -32,4 +32,17 @@ data ServantError
|
|||
}
|
||||
deriving (Show, Typeable)
|
||||
|
||||
instance Eq ServantError where
|
||||
FailureResponse a b c == FailureResponse x y z =
|
||||
(a, b, c) == (x, y, z)
|
||||
DecodeFailure a b c == DecodeFailure x y z =
|
||||
(a, b, c) == (x, y, z)
|
||||
UnsupportedContentType a b == UnsupportedContentType x y =
|
||||
(a, b) == (x, y)
|
||||
InvalidContentTypeHeader a b == InvalidContentTypeHeader x y =
|
||||
(a, b) == (x, y)
|
||||
ConnectionError a == ConnectionError x =
|
||||
show a == show x
|
||||
_ == _ = False
|
||||
|
||||
instance Exception ServantError
|
||||
|
|
|
@ -2,6 +2,11 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
#if MIN_VERSION_base(4,9,0)
|
||||
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
||||
#endif
|
||||
|
||||
module Servant.Common.Req where
|
||||
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
|
@ -63,7 +68,7 @@ setRQBody b t req = req { reqBody = Just (b, t) }
|
|||
|
||||
reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
|
||||
reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
|
||||
setheaders . setAccept . setrqb . setQS <$> parseUrl url
|
||||
setheaders . setAccept . setrqb . setQS <$> parseUrlThrow url
|
||||
|
||||
where url = show $ nullURI { uriScheme = case reqScheme of
|
||||
Http -> "http:"
|
||||
|
@ -89,6 +94,9 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
|
|||
| not . null . reqAccept $ req] }
|
||||
toProperHeader (name, val) =
|
||||
(fromString name, encodeUtf8 val)
|
||||
#if !MIN_VERSION_http_client(0,4,30)
|
||||
parseUrlThrow = parseUrl
|
||||
#endif
|
||||
|
||||
|
||||
-- * performing requests
|
||||
|
|
|
@ -13,14 +13,18 @@
|
|||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
{-# OPTIONS_GHC -freduction-depth=100 #-}
|
||||
#else
|
||||
{-# OPTIONS_GHC -fcontext-stack=100 #-}
|
||||
#endif
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Servant.ClientSpec where
|
||||
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
import Control.Applicative ((<$>))
|
||||
#endif
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Control.Arrow (left)
|
||||
import Control.Monad.Trans.Except (runExceptT, throwE)
|
||||
import Data.Aeson
|
||||
|
@ -36,7 +40,7 @@ import Network.HTTP.Media
|
|||
import qualified Network.HTTP.Types as HTTP
|
||||
import Network.Wai (responseLBS)
|
||||
import qualified Network.Wai as Wai
|
||||
import System.Exit
|
||||
import System.Exit.Compat
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import Test.HUnit
|
||||
import Test.Hspec
|
||||
|
@ -432,7 +436,6 @@ failSpec = around (withTestServer "failServer") $ do
|
|||
InvalidContentTypeHeader "fooooo" _ -> return ()
|
||||
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
|
||||
|
||||
|
||||
-- * utils
|
||||
|
||||
pathGen :: Gen (NonEmptyList Char)
|
||||
|
|
|
@ -1,3 +1,13 @@
|
|||
0.7.1
|
||||
-----
|
||||
|
||||
* Support GHC 8.0
|
||||
|
||||
0.7
|
||||
---
|
||||
|
||||
* Use `throwError` instead of `throwE` in documentation
|
||||
|
||||
0.5
|
||||
----
|
||||
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
name: servant-docs
|
||||
version: 0.6
|
||||
version: 0.7.1
|
||||
synopsis: generate API docs for your servant webservice
|
||||
description:
|
||||
Library for generating API docs from a servant API definition.
|
||||
|
@ -16,7 +16,7 @@ category: Web
|
|||
build-type: Simple
|
||||
cabal-version: >=1.10
|
||||
tested-with: GHC >= 7.8
|
||||
homepage: http://haskell-servant.github.io/
|
||||
homepage: http://haskell-servant.readthedocs.org/
|
||||
Bug-reports: http://github.com/haskell-servant/servant/issues
|
||||
extra-source-files:
|
||||
include/*.h
|
||||
|
@ -42,7 +42,7 @@ library
|
|||
, http-media >= 0.6
|
||||
, http-types >= 0.7
|
||||
, lens
|
||||
, servant == 0.6.*
|
||||
, servant == 0.7.*
|
||||
, string-conversions
|
||||
, text
|
||||
, unordered-containers
|
||||
|
@ -50,6 +50,8 @@ library
|
|||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall
|
||||
if impl(ghc >= 8.0)
|
||||
ghc-options: -Wno-redundant-constraints
|
||||
include-dirs: include
|
||||
|
||||
executable greet-docs
|
||||
|
@ -82,4 +84,3 @@ test-suite spec
|
|||
, servant-docs
|
||||
, string-conversions
|
||||
default-language: Haskell2010
|
||||
|
||||
|
|
|
@ -163,7 +163,7 @@ data DocNote = DocNote
|
|||
--
|
||||
-- These are intended to be built using extraInfo.
|
||||
-- Multiple ExtraInfo may be combined with the monoid instance.
|
||||
newtype ExtraInfo layout = ExtraInfo (HashMap Endpoint Action)
|
||||
newtype ExtraInfo api = ExtraInfo (HashMap Endpoint Action)
|
||||
instance Monoid (ExtraInfo a) where
|
||||
mempty = ExtraInfo mempty
|
||||
ExtraInfo a `mappend` ExtraInfo b =
|
||||
|
@ -300,11 +300,11 @@ makeLenses ''Action
|
|||
-- default way to create documentation.
|
||||
--
|
||||
-- prop> docs == docsWithOptions defaultDocOptions
|
||||
docs :: HasDocs layout => Proxy layout -> API
|
||||
docs :: HasDocs api => Proxy api -> API
|
||||
docs p = docsWithOptions p defaultDocOptions
|
||||
|
||||
-- | Generate the docs for a given API that implements 'HasDocs'.
|
||||
docsWithOptions :: HasDocs layout => Proxy layout -> DocOptions -> API
|
||||
docsWithOptions :: HasDocs api => Proxy api -> DocOptions -> API
|
||||
docsWithOptions p = docsFor p (defEndpoint, defAction)
|
||||
|
||||
-- | Closed type family, check if endpoint is exactly within API.
|
||||
|
@ -316,7 +316,7 @@ type family IsIn (endpoint :: *) (api :: *) :: Constraint where
|
|||
IsIn (e :> sa) (e :> sb) = IsIn sa sb
|
||||
IsIn e e = ()
|
||||
|
||||
-- | Create an 'ExtraInfo' that is garunteed to be within the given API layout.
|
||||
-- | Create an 'ExtraInfo' that is guaranteed to be within the given API layout.
|
||||
--
|
||||
-- The safety here is to ensure that you only add custom documentation to an
|
||||
-- endpoint that actually exists within your API.
|
||||
|
@ -329,8 +329,8 @@ type family IsIn (endpoint :: *) (api :: *) :: Constraint where
|
|||
-- > , DocNote "Second secton" ["And some more"]
|
||||
-- > ]
|
||||
|
||||
extraInfo :: (IsIn endpoint layout, HasLink endpoint, HasDocs endpoint)
|
||||
=> Proxy endpoint -> Action -> ExtraInfo layout
|
||||
extraInfo :: (IsIn endpoint api, HasLink endpoint, HasDocs endpoint)
|
||||
=> Proxy endpoint -> Action -> ExtraInfo api
|
||||
extraInfo p action =
|
||||
let api = docsFor p (defEndpoint, defAction) defaultDocOptions
|
||||
-- Assume one endpoint, HasLink constraint means that we should only ever
|
||||
|
@ -349,7 +349,7 @@ extraInfo p action =
|
|||
-- 'extraInfo'.
|
||||
--
|
||||
-- If you only want to add an introduction, use 'docsWithIntros'.
|
||||
docsWith :: HasDocs layout => DocOptions -> [DocIntro] -> ExtraInfo layout -> Proxy layout -> API
|
||||
docsWith :: HasDocs api => DocOptions -> [DocIntro] -> ExtraInfo api -> Proxy api -> API
|
||||
docsWith opts intros (ExtraInfo endpoints) p =
|
||||
docsWithOptions p opts
|
||||
& apiIntros <>~ intros
|
||||
|
@ -358,13 +358,13 @@ docsWith opts intros (ExtraInfo endpoints) p =
|
|||
|
||||
-- | Generate the docs for a given API that implements 'HasDocs' with with any
|
||||
-- number of introduction(s)
|
||||
docsWithIntros :: HasDocs layout => [DocIntro] -> Proxy layout -> API
|
||||
docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API
|
||||
docsWithIntros intros = docsWith defaultDocOptions intros mempty
|
||||
|
||||
-- | The class that abstracts away the impact of API combinators
|
||||
-- on documentation generation.
|
||||
class HasDocs layout where
|
||||
docsFor :: Proxy layout -> (Endpoint, Action) -> DocOptions -> API
|
||||
class HasDocs api where
|
||||
docsFor :: Proxy api -> (Endpoint, Action) -> DocOptions -> API
|
||||
|
||||
-- | The class that lets us display a sample input or output in the supported
|
||||
-- content-types when generating documentation for endpoints that either:
|
||||
|
@ -675,26 +675,26 @@ markdown api = unlines $
|
|||
-- | The generated docs for @a ':<|>' b@ just appends the docs
|
||||
-- for @a@ with the docs for @b@.
|
||||
instance OVERLAPPABLE_
|
||||
(HasDocs layout1, HasDocs layout2)
|
||||
=> HasDocs (layout1 :<|> layout2) where
|
||||
(HasDocs a, HasDocs b)
|
||||
=> HasDocs (a :<|> b) where
|
||||
|
||||
docsFor Proxy (ep, action) = docsFor p1 (ep, action) <> docsFor p2 (ep, action)
|
||||
|
||||
where p1 :: Proxy layout1
|
||||
where p1 :: Proxy a
|
||||
p1 = Proxy
|
||||
|
||||
p2 :: Proxy layout2
|
||||
p2 :: Proxy b
|
||||
p2 = Proxy
|
||||
|
||||
-- | @"books" :> 'Capture' "isbn" Text@ will appear as
|
||||
-- @/books/:isbn@ in the docs.
|
||||
instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout)
|
||||
=> HasDocs (Capture sym a :> sublayout) where
|
||||
instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)
|
||||
=> HasDocs (Capture sym a :> api) where
|
||||
|
||||
docsFor Proxy (endpoint, action) =
|
||||
docsFor sublayoutP (endpoint', action')
|
||||
docsFor subApiP (endpoint', action')
|
||||
|
||||
where sublayoutP = Proxy :: Proxy sublayout
|
||||
where subApiP = Proxy :: Proxy api
|
||||
captureP = Proxy :: Proxy (Capture sym a)
|
||||
|
||||
action' = over captures (|> toCapture captureP) action
|
||||
|
@ -736,43 +736,43 @@ instance OVERLAPPING_
|
|||
status = fromInteger $ natVal (Proxy :: Proxy status)
|
||||
p = Proxy :: Proxy a
|
||||
|
||||
instance (KnownSymbol sym, HasDocs sublayout)
|
||||
=> HasDocs (Header sym a :> sublayout) where
|
||||
instance (KnownSymbol sym, HasDocs api)
|
||||
=> HasDocs (Header sym a :> api) where
|
||||
docsFor Proxy (endpoint, action) =
|
||||
docsFor sublayoutP (endpoint, action')
|
||||
docsFor subApiP (endpoint, action')
|
||||
|
||||
where sublayoutP = Proxy :: Proxy sublayout
|
||||
where subApiP = Proxy :: Proxy api
|
||||
action' = over headers (|> headername) action
|
||||
headername = T.pack $ symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
|
||||
=> HasDocs (QueryParam sym a :> sublayout) where
|
||||
instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs api)
|
||||
=> HasDocs (QueryParam sym a :> api) where
|
||||
|
||||
docsFor Proxy (endpoint, action) =
|
||||
docsFor sublayoutP (endpoint, action')
|
||||
docsFor subApiP (endpoint, action')
|
||||
|
||||
where sublayoutP = Proxy :: Proxy sublayout
|
||||
where subApiP = Proxy :: Proxy api
|
||||
paramP = Proxy :: Proxy (QueryParam sym a)
|
||||
action' = over params (|> toParam paramP) action
|
||||
|
||||
instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs sublayout)
|
||||
=> HasDocs (QueryParams sym a :> sublayout) where
|
||||
instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs api)
|
||||
=> HasDocs (QueryParams sym a :> api) where
|
||||
|
||||
docsFor Proxy (endpoint, action) =
|
||||
docsFor sublayoutP (endpoint, action')
|
||||
docsFor subApiP (endpoint, action')
|
||||
|
||||
where sublayoutP = Proxy :: Proxy sublayout
|
||||
where subApiP = Proxy :: Proxy api
|
||||
paramP = Proxy :: Proxy (QueryParams sym a)
|
||||
action' = over params (|> toParam paramP) action
|
||||
|
||||
|
||||
instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs sublayout)
|
||||
=> HasDocs (QueryFlag sym :> sublayout) where
|
||||
instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs api)
|
||||
=> HasDocs (QueryFlag sym :> api) where
|
||||
|
||||
docsFor Proxy (endpoint, action) =
|
||||
docsFor sublayoutP (endpoint, action')
|
||||
docsFor subApiP (endpoint, action')
|
||||
|
||||
where sublayoutP = Proxy :: Proxy sublayout
|
||||
where subApiP = Proxy :: Proxy api
|
||||
paramP = Proxy :: Proxy (QueryFlag sym)
|
||||
action' = over params (|> toParam paramP) action
|
||||
|
||||
|
@ -785,49 +785,49 @@ instance HasDocs Raw where
|
|||
-- example data. However, there's no reason to believe that the instances of
|
||||
-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
|
||||
-- both are even defined) for any particular type.
|
||||
instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs sublayout)
|
||||
=> HasDocs (ReqBody (ct ': cts) a :> sublayout) where
|
||||
instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api)
|
||||
=> HasDocs (ReqBody (ct ': cts) a :> api) where
|
||||
|
||||
docsFor Proxy (endpoint, action) =
|
||||
docsFor sublayoutP (endpoint, action')
|
||||
docsFor subApiP (endpoint, action')
|
||||
|
||||
where sublayoutP = Proxy :: Proxy sublayout
|
||||
where subApiP = Proxy :: Proxy api
|
||||
action' = action & rqbody .~ sampleByteString t p
|
||||
& rqtypes .~ allMime t
|
||||
t = Proxy :: Proxy (ct ': cts)
|
||||
p = Proxy :: Proxy a
|
||||
|
||||
instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where
|
||||
instance (KnownSymbol path, HasDocs api) => HasDocs (path :> api) where
|
||||
|
||||
docsFor Proxy (endpoint, action) =
|
||||
docsFor sublayoutP (endpoint', action)
|
||||
docsFor subApiP (endpoint', action)
|
||||
|
||||
where sublayoutP = Proxy :: Proxy sublayout
|
||||
where subApiP = Proxy :: Proxy api
|
||||
endpoint' = endpoint & path <>~ [symbolVal pa]
|
||||
pa = Proxy :: Proxy path
|
||||
|
||||
instance HasDocs sublayout => HasDocs (RemoteHost :> sublayout) where
|
||||
instance HasDocs api => HasDocs (RemoteHost :> api) where
|
||||
docsFor Proxy ep =
|
||||
docsFor (Proxy :: Proxy sublayout) ep
|
||||
docsFor (Proxy :: Proxy api) ep
|
||||
|
||||
instance HasDocs sublayout => HasDocs (IsSecure :> sublayout) where
|
||||
instance HasDocs api => HasDocs (IsSecure :> api) where
|
||||
docsFor Proxy ep =
|
||||
docsFor (Proxy :: Proxy sublayout) ep
|
||||
docsFor (Proxy :: Proxy api) ep
|
||||
|
||||
instance HasDocs sublayout => HasDocs (HttpVersion :> sublayout) where
|
||||
instance HasDocs api => HasDocs (HttpVersion :> api) where
|
||||
docsFor Proxy ep =
|
||||
docsFor (Proxy :: Proxy sublayout) ep
|
||||
docsFor (Proxy :: Proxy api) ep
|
||||
|
||||
instance HasDocs sublayout => HasDocs (Vault :> sublayout) where
|
||||
instance HasDocs api => HasDocs (Vault :> api) where
|
||||
docsFor Proxy ep =
|
||||
docsFor (Proxy :: Proxy sublayout) ep
|
||||
docsFor (Proxy :: Proxy api) ep
|
||||
|
||||
instance HasDocs sublayout => HasDocs (WithNamedContext name context sublayout) where
|
||||
docsFor Proxy = docsFor (Proxy :: Proxy sublayout)
|
||||
instance HasDocs api => HasDocs (WithNamedContext name context api) where
|
||||
docsFor Proxy = docsFor (Proxy :: Proxy api)
|
||||
|
||||
instance (ToAuthInfo (BasicAuth realm usr), HasDocs sublayout) => HasDocs (BasicAuth realm usr :> sublayout) where
|
||||
instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth realm usr :> api) where
|
||||
docsFor Proxy (endpoint, action) =
|
||||
docsFor (Proxy :: Proxy sublayout) (endpoint, action')
|
||||
docsFor (Proxy :: Proxy api) (endpoint, action')
|
||||
where
|
||||
authProxy = Proxy :: Proxy (BasicAuth realm usr)
|
||||
action' = over authInfo (|> toAuthInfo authProxy) action
|
||||
|
|
|
@ -29,12 +29,12 @@ instance ToJSON a => MimeRender PrettyJSON a where
|
|||
-- @
|
||||
-- 'docs' ('pretty' ('Proxy' :: 'Proxy' MyAPI))
|
||||
-- @
|
||||
pretty :: Proxy layout -> Proxy (Pretty layout)
|
||||
pretty :: Proxy api -> Proxy (Pretty api)
|
||||
pretty Proxy = Proxy
|
||||
|
||||
-- | Replace all JSON content types with PrettyJSON.
|
||||
-- Kind-polymorphic so it can operate on kinds @*@ and @[*]@.
|
||||
type family Pretty (layout :: k) :: k where
|
||||
type family Pretty (api :: k) :: k where
|
||||
Pretty (x :<|> y) = Pretty x :<|> Pretty y
|
||||
Pretty (x :> y) = Pretty x :> Pretty y
|
||||
Pretty (Get cs r) = Get (Pretty cs) r
|
||||
|
|
|
@ -1,3 +1,8 @@
|
|||
0.7.1
|
||||
-----
|
||||
|
||||
* Support GHC 8.0
|
||||
|
||||
0.5
|
||||
-----
|
||||
* Use the `text` package instead of `String`.
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
name: servant-foreign
|
||||
version: 0.6
|
||||
version: 0.7.1
|
||||
synopsis: Helpers for generating clients for servant APIs in any programming language
|
||||
description:
|
||||
Helper types and functions for generating client functions for servant APIs in any programming language
|
||||
|
@ -21,6 +21,7 @@ extra-source-files:
|
|||
include/*.h
|
||||
CHANGELOG.md
|
||||
README.md
|
||||
bug-reports: http://github.com/haskell-servant/servant/issues
|
||||
source-repository head
|
||||
type: git
|
||||
location: http://github.com/haskell-servant/servant.git
|
||||
|
@ -31,12 +32,14 @@ library
|
|||
, Servant.Foreign.Inflections
|
||||
build-depends: base == 4.*
|
||||
, lens == 4.*
|
||||
, servant == 0.6.*
|
||||
, servant == 0.7.*
|
||||
, text >= 1.2 && < 1.3
|
||||
, http-types
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall
|
||||
if impl(ghc >= 8.0)
|
||||
ghc-options: -Wno-redundant-constraints
|
||||
include-dirs: include
|
||||
default-extensions: CPP
|
||||
, ConstraintKinds
|
||||
|
|
|
@ -7,7 +7,8 @@
|
|||
-- arbitrary programming languages.
|
||||
module Servant.Foreign.Internal where
|
||||
|
||||
import Control.Lens hiding (cons, List)
|
||||
import Control.Lens (makePrisms, makeLenses, Getter, (&), (<>~), (%~),
|
||||
(.~))
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
import Data.Monoid
|
||||
#endif
|
||||
|
@ -183,9 +184,9 @@ data NoTypes
|
|||
instance HasForeignType NoTypes () ftype where
|
||||
typeFor _ _ _ = ()
|
||||
|
||||
class HasForeign lang ftype (layout :: *) where
|
||||
type Foreign ftype layout :: *
|
||||
foreignFor :: Proxy lang -> Proxy ftype -> Proxy layout -> Req ftype -> Foreign ftype layout
|
||||
class HasForeign lang ftype (api :: *) where
|
||||
type Foreign ftype api :: *
|
||||
foreignFor :: Proxy lang -> Proxy ftype -> Proxy api -> Req ftype -> Foreign ftype api
|
||||
|
||||
instance (HasForeign lang ftype a, HasForeign lang ftype b)
|
||||
=> HasForeign lang ftype (a :<|> b) where
|
||||
|
@ -195,12 +196,12 @@ instance (HasForeign lang ftype a, HasForeign lang ftype b)
|
|||
foreignFor lang ftype (Proxy :: Proxy a) req
|
||||
:<|> foreignFor lang ftype (Proxy :: Proxy b) req
|
||||
|
||||
instance (KnownSymbol sym, HasForeignType lang ftype t, HasForeign lang ftype sublayout)
|
||||
=> HasForeign lang ftype (Capture sym t :> sublayout) where
|
||||
type Foreign ftype (Capture sym a :> sublayout) = Foreign ftype sublayout
|
||||
instance (KnownSymbol sym, HasForeignType lang ftype t, HasForeign lang ftype api)
|
||||
=> HasForeign lang ftype (Capture sym t :> api) where
|
||||
type Foreign ftype (Capture sym a :> api) = Foreign ftype api
|
||||
|
||||
foreignFor lang Proxy Proxy req =
|
||||
foreignFor lang Proxy (Proxy :: Proxy sublayout) $
|
||||
foreignFor lang Proxy (Proxy :: Proxy api) $
|
||||
req & reqUrl . path <>~ [Segment (Cap arg)]
|
||||
& reqFuncName . _FunctionName %~ (++ ["by", str])
|
||||
where
|
||||
|
@ -223,9 +224,9 @@ instance (Elem JSON list, HasForeignType lang ftype a, ReflectMethod method)
|
|||
method = reflectMethod (Proxy :: Proxy method)
|
||||
methodLC = toLower $ decodeUtf8 method
|
||||
|
||||
instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype sublayout)
|
||||
=> HasForeign lang ftype (Header sym a :> sublayout) where
|
||||
type Foreign ftype (Header sym a :> sublayout) = Foreign ftype sublayout
|
||||
instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype api)
|
||||
=> HasForeign lang ftype (Header sym a :> api) where
|
||||
type Foreign ftype (Header sym a :> api) = Foreign ftype api
|
||||
|
||||
foreignFor lang Proxy Proxy req =
|
||||
foreignFor lang Proxy subP $ req & reqHeaders <>~ [HeaderArg arg]
|
||||
|
@ -234,14 +235,14 @@ instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype su
|
|||
arg = Arg
|
||||
{ _argName = PathSegment hname
|
||||
, _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a) }
|
||||
subP = Proxy :: Proxy sublayout
|
||||
subP = Proxy :: Proxy api
|
||||
|
||||
instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype sublayout)
|
||||
=> HasForeign lang ftype (QueryParam sym a :> sublayout) where
|
||||
type Foreign ftype (QueryParam sym a :> sublayout) = Foreign ftype sublayout
|
||||
instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype api)
|
||||
=> HasForeign lang ftype (QueryParam sym a :> api) where
|
||||
type Foreign ftype (QueryParam sym a :> api) = Foreign ftype api
|
||||
|
||||
foreignFor lang Proxy Proxy req =
|
||||
foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy sublayout) $
|
||||
foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy api) $
|
||||
req & reqUrl.queryStr <>~ [QueryArg arg Normal]
|
||||
where
|
||||
str = pack . symbolVal $ (Proxy :: Proxy sym)
|
||||
|
@ -250,11 +251,11 @@ instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype su
|
|||
, _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a) }
|
||||
|
||||
instance
|
||||
(KnownSymbol sym, HasForeignType lang ftype [a], HasForeign lang ftype sublayout)
|
||||
=> HasForeign lang ftype (QueryParams sym a :> sublayout) where
|
||||
type Foreign ftype (QueryParams sym a :> sublayout) = Foreign ftype sublayout
|
||||
(KnownSymbol sym, HasForeignType lang ftype [a], HasForeign lang ftype api)
|
||||
=> HasForeign lang ftype (QueryParams sym a :> api) where
|
||||
type Foreign ftype (QueryParams sym a :> api) = Foreign ftype api
|
||||
foreignFor lang Proxy Proxy req =
|
||||
foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy sublayout) $
|
||||
foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy api) $
|
||||
req & reqUrl.queryStr <>~ [QueryArg arg List]
|
||||
where
|
||||
str = pack . symbolVal $ (Proxy :: Proxy sym)
|
||||
|
@ -263,12 +264,12 @@ instance
|
|||
, _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy [a]) }
|
||||
|
||||
instance
|
||||
(KnownSymbol sym, HasForeignType lang ftype Bool, HasForeign lang ftype sublayout)
|
||||
=> HasForeign lang ftype (QueryFlag sym :> sublayout) where
|
||||
type Foreign ftype (QueryFlag sym :> sublayout) = Foreign ftype sublayout
|
||||
(KnownSymbol sym, HasForeignType lang ftype Bool, HasForeign lang ftype api)
|
||||
=> HasForeign lang ftype (QueryFlag sym :> api) where
|
||||
type Foreign ftype (QueryFlag sym :> api) = Foreign ftype api
|
||||
|
||||
foreignFor lang ftype Proxy req =
|
||||
foreignFor lang ftype (Proxy :: Proxy sublayout) $
|
||||
foreignFor lang ftype (Proxy :: Proxy api) $
|
||||
req & reqUrl.queryStr <>~ [QueryArg arg Flag]
|
||||
where
|
||||
str = pack . symbolVal $ (Proxy :: Proxy sym)
|
||||
|
@ -283,20 +284,20 @@ instance HasForeign lang ftype Raw where
|
|||
req & reqFuncName . _FunctionName %~ ((toLower $ decodeUtf8 method) :)
|
||||
& reqMethod .~ method
|
||||
|
||||
instance (Elem JSON list, HasForeignType lang ftype a, HasForeign lang ftype sublayout)
|
||||
=> HasForeign lang ftype (ReqBody list a :> sublayout) where
|
||||
type Foreign ftype (ReqBody list a :> sublayout) = Foreign ftype sublayout
|
||||
instance (Elem JSON list, HasForeignType lang ftype a, HasForeign lang ftype api)
|
||||
=> HasForeign lang ftype (ReqBody list a :> api) where
|
||||
type Foreign ftype (ReqBody list a :> api) = Foreign ftype api
|
||||
|
||||
foreignFor lang ftype Proxy req =
|
||||
foreignFor lang ftype (Proxy :: Proxy sublayout) $
|
||||
foreignFor lang ftype (Proxy :: Proxy api) $
|
||||
req & reqBody .~ (Just $ typeFor lang ftype (Proxy :: Proxy a))
|
||||
|
||||
instance (KnownSymbol path, HasForeign lang ftype sublayout)
|
||||
=> HasForeign lang ftype (path :> sublayout) where
|
||||
type Foreign ftype (path :> sublayout) = Foreign ftype sublayout
|
||||
instance (KnownSymbol path, HasForeign lang ftype api)
|
||||
=> HasForeign lang ftype (path :> api) where
|
||||
type Foreign ftype (path :> api) = Foreign ftype api
|
||||
|
||||
foreignFor lang ftype Proxy req =
|
||||
foreignFor lang ftype (Proxy :: Proxy sublayout) $
|
||||
foreignFor lang ftype (Proxy :: Proxy api) $
|
||||
req & reqUrl . path <>~ [Segment (Static (PathSegment str))]
|
||||
& reqFuncName . _FunctionName %~ (++ [str])
|
||||
where
|
||||
|
@ -304,39 +305,39 @@ instance (KnownSymbol path, HasForeign lang ftype sublayout)
|
|||
Data.Text.map (\c -> if c == '.' then '_' else c)
|
||||
. pack . symbolVal $ (Proxy :: Proxy path)
|
||||
|
||||
instance HasForeign lang ftype sublayout
|
||||
=> HasForeign lang ftype (RemoteHost :> sublayout) where
|
||||
type Foreign ftype (RemoteHost :> sublayout) = Foreign ftype sublayout
|
||||
instance HasForeign lang ftype api
|
||||
=> HasForeign lang ftype (RemoteHost :> api) where
|
||||
type Foreign ftype (RemoteHost :> api) = Foreign ftype api
|
||||
|
||||
foreignFor lang ftype Proxy req =
|
||||
foreignFor lang ftype (Proxy :: Proxy sublayout) req
|
||||
foreignFor lang ftype (Proxy :: Proxy api) req
|
||||
|
||||
instance HasForeign lang ftype sublayout
|
||||
=> HasForeign lang ftype (IsSecure :> sublayout) where
|
||||
type Foreign ftype (IsSecure :> sublayout) = Foreign ftype sublayout
|
||||
instance HasForeign lang ftype api
|
||||
=> HasForeign lang ftype (IsSecure :> api) where
|
||||
type Foreign ftype (IsSecure :> api) = Foreign ftype api
|
||||
|
||||
foreignFor lang ftype Proxy req =
|
||||
foreignFor lang ftype (Proxy :: Proxy sublayout) req
|
||||
foreignFor lang ftype (Proxy :: Proxy api) req
|
||||
|
||||
instance HasForeign lang ftype sublayout => HasForeign lang ftype (Vault :> sublayout) where
|
||||
type Foreign ftype (Vault :> sublayout) = Foreign ftype sublayout
|
||||
instance HasForeign lang ftype api => HasForeign lang ftype (Vault :> api) where
|
||||
type Foreign ftype (Vault :> api) = Foreign ftype api
|
||||
|
||||
foreignFor lang ftype Proxy req =
|
||||
foreignFor lang ftype (Proxy :: Proxy sublayout) req
|
||||
foreignFor lang ftype (Proxy :: Proxy api) req
|
||||
|
||||
instance HasForeign lang ftype sublayout =>
|
||||
HasForeign lang ftype (WithNamedContext name context sublayout) where
|
||||
instance HasForeign lang ftype api =>
|
||||
HasForeign lang ftype (WithNamedContext name context api) where
|
||||
|
||||
type Foreign ftype (WithNamedContext name context sublayout) = Foreign ftype sublayout
|
||||
type Foreign ftype (WithNamedContext name context api) = Foreign ftype api
|
||||
|
||||
foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy sublayout)
|
||||
foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)
|
||||
|
||||
instance HasForeign lang ftype sublayout
|
||||
=> HasForeign lang ftype (HttpVersion :> sublayout) where
|
||||
type Foreign ftype (HttpVersion :> sublayout) = Foreign ftype sublayout
|
||||
instance HasForeign lang ftype api
|
||||
=> HasForeign lang ftype (HttpVersion :> api) where
|
||||
type Foreign ftype (HttpVersion :> api) = Foreign ftype api
|
||||
|
||||
foreignFor lang ftype Proxy req =
|
||||
foreignFor lang ftype (Proxy :: Proxy sublayout) req
|
||||
foreignFor lang ftype (Proxy :: Proxy api) req
|
||||
|
||||
-- | Utility class used by 'listFromAPI' which computes
|
||||
-- the data needed to generate a function for each endpoint
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
name: servant-js
|
||||
version: 0.6
|
||||
version: 0.7.1
|
||||
synopsis: Automatically derive javascript functions to query servant webservices.
|
||||
description:
|
||||
Automatically derive javascript functions to query servant webservices.
|
||||
|
@ -19,7 +19,7 @@ copyright: 2015-2016 Servant Contributors
|
|||
category: Web
|
||||
build-type: Simple
|
||||
cabal-version: >=1.10
|
||||
homepage: http://haskell-servant.github.io/
|
||||
homepage: http://haskell-servant.readthedocs.org/
|
||||
Bug-reports: http://github.com/haskell-servant/servant/issues
|
||||
extra-source-files:
|
||||
include/*.h
|
||||
|
@ -45,7 +45,7 @@ library
|
|||
, base-compat >= 0.9
|
||||
, charset >= 0.3
|
||||
, lens >= 4
|
||||
, servant-foreign == 0.6.*
|
||||
, servant-foreign == 0.7.*
|
||||
, text >= 1.2 && < 1.3
|
||||
|
||||
hs-source-dirs: src
|
||||
|
@ -55,7 +55,7 @@ library
|
|||
|
||||
executable counter
|
||||
main-is: counter.hs
|
||||
ghc-options: -O2 -Wall
|
||||
ghc-options: -Wall
|
||||
hs-source-dirs: examples
|
||||
|
||||
if flag(example)
|
||||
|
@ -67,8 +67,8 @@ executable counter
|
|||
, aeson >= 0.7 && < 0.12
|
||||
, filepath >= 1
|
||||
, lens >= 4
|
||||
, servant == 0.6.*
|
||||
, servant-server == 0.6.*
|
||||
, servant == 0.7.*
|
||||
, servant-server == 0.7.*
|
||||
, servant-js
|
||||
, stm
|
||||
, transformers
|
||||
|
|
|
@ -123,12 +123,12 @@ import Servant.JS.Axios
|
|||
import Servant.JS.Internal
|
||||
import Servant.JS.JQuery
|
||||
import Servant.JS.Vanilla
|
||||
import Servant.Foreign (GenerateList(..), listFromAPI, NoTypes)
|
||||
import Servant.Foreign (listFromAPI)
|
||||
|
||||
-- | Generate the data necessary to generate javascript code
|
||||
-- for all the endpoints of an API, as ':<|>'-separated values
|
||||
-- of type 'AjaxReq'.
|
||||
javascript :: HasForeign NoTypes () layout => Proxy layout -> Foreign () layout
|
||||
javascript :: HasForeign NoTypes () api => Proxy api -> Foreign () api
|
||||
javascript p = foreignFor (Proxy :: Proxy NoTypes) (Proxy :: Proxy ()) p defReq
|
||||
|
||||
-- | Directly generate all the javascript functions for your API
|
||||
|
|
|
@ -23,7 +23,6 @@ module Servant.JS.Internal
|
|||
, HasForeignType(..)
|
||||
, GenerateList(..)
|
||||
, NoTypes
|
||||
, HeaderArg
|
||||
, ArgType(..)
|
||||
, HeaderArg(..)
|
||||
, QueryArg(..)
|
||||
|
@ -47,7 +46,7 @@ module Servant.JS.Internal
|
|||
, Header
|
||||
) where
|
||||
|
||||
import Control.Lens hiding (List)
|
||||
import Control.Lens ((^.))
|
||||
import qualified Data.CharSet as Set
|
||||
import qualified Data.CharSet.Unicode.Category as Set
|
||||
import Data.Monoid
|
||||
|
|
|
@ -23,11 +23,11 @@ import Servant.JS.Internal
|
|||
-- using -- Basic, Digest, whatever.
|
||||
data Authorization (sym :: Symbol) a
|
||||
|
||||
instance (KnownSymbol sym, HasForeign lang () sublayout)
|
||||
=> HasForeign lang () (Authorization sym a :> sublayout) where
|
||||
type Foreign () (Authorization sym a :> sublayout) = Foreign () sublayout
|
||||
instance (KnownSymbol sym, HasForeign lang () api)
|
||||
=> HasForeign lang () (Authorization sym a :> api) where
|
||||
type Foreign () (Authorization sym a :> api) = Foreign () api
|
||||
|
||||
foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy sublayout) $
|
||||
foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy api) $
|
||||
req & reqHeaders <>~
|
||||
[ ReplaceHeaderArg (Arg "Authorization" ())
|
||||
$ tokenType (pack . symbolVal $ (Proxy :: Proxy sym)) ]
|
||||
|
@ -37,11 +37,11 @@ instance (KnownSymbol sym, HasForeign lang () sublayout)
|
|||
-- | This is a combinator that fetches an X-MyLovelyHorse header.
|
||||
data MyLovelyHorse a
|
||||
|
||||
instance (HasForeign lang () sublayout)
|
||||
=> HasForeign lang () (MyLovelyHorse a :> sublayout) where
|
||||
type Foreign () (MyLovelyHorse a :> sublayout) = Foreign () sublayout
|
||||
instance (HasForeign lang () api)
|
||||
=> HasForeign lang () (MyLovelyHorse a :> api) where
|
||||
type Foreign () (MyLovelyHorse a :> api) = Foreign () api
|
||||
|
||||
foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy sublayout) $
|
||||
foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy api) $
|
||||
req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-MyLovelyHorse" ()) tpl ]
|
||||
where
|
||||
tpl = "I am good friends with {X-MyLovelyHorse}"
|
||||
|
@ -49,11 +49,11 @@ instance (HasForeign lang () sublayout)
|
|||
-- | This is a combinator that fetches an X-WhatsForDinner header.
|
||||
data WhatsForDinner a
|
||||
|
||||
instance (HasForeign lang () sublayout)
|
||||
=> HasForeign lang () (WhatsForDinner a :> sublayout) where
|
||||
type Foreign () (WhatsForDinner a :> sublayout) = Foreign () sublayout
|
||||
instance (HasForeign lang () api)
|
||||
=> HasForeign lang () (WhatsForDinner a :> api) where
|
||||
type Foreign () (WhatsForDinner a :> api) = Foreign () api
|
||||
|
||||
foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy sublayout) $
|
||||
foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy api) $
|
||||
req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-WhatsForDinner" ()) tpl ]
|
||||
where
|
||||
tpl = "I would like {X-WhatsForDinner} with a cherry on top."
|
||||
|
|
|
@ -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.
|
|
@ -1,2 +0,0 @@
|
|||
import Distribution.Simple
|
||||
main = defaultMain
|
|
@ -1,8 +0,0 @@
|
|||
#if __GLASGOW_HASKELL__ >= 710
|
||||
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
|
||||
#define OVERLAPPING_ {-# OVERLAPPING #-}
|
||||
#else
|
||||
{-# LANGUAGE OverlappingInstances #-}
|
||||
#define OVERLAPPABLE_
|
||||
#define OVERLAPPING_
|
||||
#endif
|
|
@ -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
|
|
@ -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
|
|
@ -1,3 +0,0 @@
|
|||
dependencies:
|
||||
- name: servant
|
||||
path: ../servant
|
|
@ -2,6 +2,9 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
|
||||
|
||||
import Data.Aeson
|
||||
import GHC.Generics
|
||||
import Network.Wai.Handler.Warp
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
name: servant-mock
|
||||
version: 0.6
|
||||
version: 0.7.1
|
||||
synopsis: Derive a mock server for free from your servant API types
|
||||
description:
|
||||
Derive a mock server for free from your servant API types
|
||||
|
@ -15,6 +15,10 @@ category: Web
|
|||
build-type: Simple
|
||||
extra-source-files: include/*.h
|
||||
cabal-version: >=1.10
|
||||
bug-reports: http://github.com/haskell-servant/servant/issues
|
||||
source-repository head
|
||||
type: git
|
||||
location: http://github.com/haskell-servant/servant.git
|
||||
|
||||
flag example
|
||||
description: Build the example too
|
||||
|
@ -27,14 +31,15 @@ library
|
|||
base >=4.7 && <5,
|
||||
bytestring >= 0.10 && <0.11,
|
||||
http-types >= 0.8 && <0.10,
|
||||
servant >= 0.4,
|
||||
servant-server >= 0.4,
|
||||
transformers >= 0.3 && <0.5,
|
||||
servant == 0.7.*,
|
||||
servant-server == 0.7.*,
|
||||
transformers >= 0.3 && <0.6,
|
||||
QuickCheck >= 2.7 && <2.9,
|
||||
wai >= 3.0 && <3.3
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
include-dirs: include
|
||||
ghc-options: -Wall
|
||||
|
||||
executable mock-app
|
||||
main-is: main.hs
|
||||
|
@ -45,11 +50,11 @@ executable mock-app
|
|||
buildable: True
|
||||
else
|
||||
buildable: False
|
||||
ghc-options: -Wall
|
||||
|
||||
test-suite spec
|
||||
type: exitcode-stdio-1.0
|
||||
ghc-options:
|
||||
-Wall -fno-warn-name-shadowing
|
||||
ghc-options: -Wall
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
main-is: Spec.hs
|
||||
|
|
|
@ -36,7 +36,7 @@
|
|||
-- and call 'mock', which has the following type:
|
||||
--
|
||||
-- @
|
||||
-- 'mock' :: 'HasMock' api => 'Proxy' api -> 'Server' api
|
||||
-- 'mock' :: 'HasMock' api context => 'Proxy' api -> 'Proxy' context -> 'Server' api
|
||||
-- @
|
||||
--
|
||||
-- What this says is, given some API type @api@ that it knows it can
|
||||
|
@ -52,7 +52,7 @@
|
|||
-- @
|
||||
-- main :: IO ()
|
||||
-- main = Network.Wai.Handler.Warp.run 8080 $
|
||||
-- 'serve' myAPI ('mock' myAPI)
|
||||
-- 'serve' myAPI ('mock' myAPI Proxy)
|
||||
-- @
|
||||
module Servant.Mock ( HasMock(..) ) where
|
||||
|
||||
|
@ -90,15 +90,15 @@ class HasServer api context => HasMock api context where
|
|||
-- -- let's say we will start with the frontend,
|
||||
-- -- and hence need a placeholder server
|
||||
-- server :: Server API
|
||||
-- server = mock api
|
||||
-- server = mock api Proxy
|
||||
-- @
|
||||
--
|
||||
-- What happens here is that @'Server' API@
|
||||
-- actually "means" 2 request handlers, of the following types:
|
||||
--
|
||||
-- @
|
||||
-- getUser :: ExceptT ServantErr IO User
|
||||
-- getBook :: ExceptT ServantErr IO Book
|
||||
-- getUser :: Handler User
|
||||
-- getBook :: Handler Book
|
||||
-- @
|
||||
--
|
||||
-- So under the hood, 'mock' uses the 'IO' bit to generate
|
||||
|
|
|
@ -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
|
||||
---
|
||||
|
||||
|
|
|
@ -6,5 +6,4 @@ This library lets you *implement* an HTTP server with handlers for each endpoint
|
|||
|
||||
## Getting started
|
||||
|
||||
We've written a [tutorial](http://haskell-servant.github.io/tutorial/) guide that introduces the core types and features of servant. After this article, you should be able to write your first servant webservices, learning the rest from the haddocks' examples.
|
||||
|
||||
We've written a [tutorial](http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html) guide that introduces the core types and features of servant. After this article, you should be able to write your first servant webservices, learning the rest from the haddocks' examples.
|
||||
|
|
|
@ -44,7 +44,7 @@ testApi = Proxy
|
|||
-- There's one handler per endpoint, which, just like in the type
|
||||
-- that represents the API, are glued together using :<|>.
|
||||
--
|
||||
-- Each handler runs in the 'ExceptT ServantErr IO' monad.
|
||||
-- Each handler runs in the 'Handler' monad.
|
||||
server :: Server TestApi
|
||||
server = helloH :<|> postGreetH :<|> deleteGreetH
|
||||
|
||||
|
|
|
@ -1,17 +1,17 @@
|
|||
name: servant-server
|
||||
version: 0.6
|
||||
version: 0.7.1
|
||||
synopsis: A family of combinators for defining webservices APIs and serving them
|
||||
description:
|
||||
A family of combinators for defining webservices APIs and serving them
|
||||
.
|
||||
You can learn about the basics in the <http://haskell-servant.github.io/tutorial tutorial>.
|
||||
You can learn about the basics in the <http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html tutorial>.
|
||||
.
|
||||
<https://github.com/haskell-servant/servant/blob/master/servant-server/example/greet.hs Here>
|
||||
is a runnable example, with comments, that defines a dummy API and implements
|
||||
a webserver that serves this API, using this package.
|
||||
.
|
||||
<https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md CHANGELOG>
|
||||
homepage: http://haskell-servant.github.io/
|
||||
homepage: http://haskell-servant.readthedocs.org/
|
||||
Bug-reports: http://github.com/haskell-servant/servant/issues
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
|
@ -40,7 +40,6 @@ library
|
|||
Servant.Server.Internal
|
||||
Servant.Server.Internal.BasicAuth
|
||||
Servant.Server.Internal.Context
|
||||
Servant.Server.Internal.Enter
|
||||
Servant.Server.Internal.Router
|
||||
Servant.Server.Internal.RoutingApplication
|
||||
Servant.Server.Internal.ServantErr
|
||||
|
@ -57,25 +56,26 @@ library
|
|||
, http-types >= 0.8 && < 0.10
|
||||
, network-uri >= 2.6 && < 2.7
|
||||
, mtl >= 2 && < 3
|
||||
, mmorph >= 1
|
||||
, network >= 2.6 && < 2.7
|
||||
, safe >= 0.3 && < 0.4
|
||||
, servant == 0.6.*
|
||||
, servant == 0.7.*
|
||||
, split >= 0.2 && < 0.3
|
||||
, string-conversions >= 0.3 && < 0.5
|
||||
, system-filepath >= 0.4 && < 0.5
|
||||
, filepath >= 1
|
||||
, text >= 1.2 && < 1.3
|
||||
, transformers >= 0.3 && < 0.5
|
||||
, transformers >= 0.3 && < 0.6
|
||||
, transformers-compat>= 0.4
|
||||
, wai >= 3.0 && < 3.3
|
||||
, wai-app-static >= 3.0 && < 3.2
|
||||
, wai-app-static >= 3.1 && < 3.2
|
||||
, warp >= 3.0 && < 3.3
|
||||
, word8 == 0.1.*
|
||||
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall
|
||||
if impl(ghc >= 8.0)
|
||||
ghc-options: -Wno-redundant-constraints
|
||||
include-dirs: include
|
||||
|
||||
executable greet
|
||||
|
@ -94,23 +94,24 @@ executable greet
|
|||
|
||||
test-suite spec
|
||||
type: exitcode-stdio-1.0
|
||||
ghc-options:
|
||||
-Wall -fno-warn-name-shadowing -fno-warn-missing-signatures
|
||||
ghc-options: -Wall
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
main-is: Spec.hs
|
||||
other-modules:
|
||||
Servant.Server.ErrorSpec
|
||||
Servant.Server.Internal.ContextSpec
|
||||
Servant.Server.Internal.EnterSpec
|
||||
Servant.ServerSpec
|
||||
Servant.Server.RouterSpec
|
||||
Servant.Server.StreamingSpec
|
||||
Servant.Server.UsingContextSpec
|
||||
Servant.Server.UsingContextSpec.TestCombinators
|
||||
Servant.ServerSpec
|
||||
Servant.Utils.StaticFilesSpec
|
||||
build-depends:
|
||||
base == 4.*
|
||||
, base-compat
|
||||
, aeson
|
||||
, base64-bytestring
|
||||
, bytestring
|
||||
, bytestring-conversion
|
||||
, directory
|
||||
|
@ -125,7 +126,7 @@ test-suite spec
|
|||
, servant
|
||||
, servant-server
|
||||
, string-conversions
|
||||
, should-not-typecheck == 2.*
|
||||
, should-not-typecheck == 2.1.*
|
||||
, temporary
|
||||
, text
|
||||
, transformers
|
||||
|
@ -146,5 +147,5 @@ test-suite doctests
|
|||
main-is: test/Doctests.hs
|
||||
buildable: True
|
||||
default-language: Haskell2010
|
||||
ghc-options: -threaded
|
||||
ghc-options: -Wall -threaded
|
||||
include-dirs: include
|
||||
|
|
|
@ -10,8 +10,10 @@ module Servant (
|
|||
module Servant.Utils.StaticFiles,
|
||||
-- | Useful re-exports
|
||||
Proxy(..),
|
||||
throwError
|
||||
) where
|
||||
|
||||
import Control.Monad.Error.Class (throwError)
|
||||
import Data.Proxy
|
||||
import Servant.API
|
||||
import Servant.Server
|
||||
|
|
|
@ -17,6 +17,11 @@ module Servant.Server
|
|||
, -- * Handlers for all standard combinators
|
||||
HasServer(..)
|
||||
, Server
|
||||
, Handler
|
||||
|
||||
-- * Debugging the server layout
|
||||
, layout
|
||||
, layoutWithContext
|
||||
|
||||
-- * Enter
|
||||
-- $enterDoc
|
||||
|
@ -90,12 +95,16 @@ module Servant.Server
|
|||
, err504
|
||||
, err505
|
||||
|
||||
-- * Re-exports
|
||||
, Application
|
||||
|
||||
) where
|
||||
|
||||
import Data.Proxy (Proxy)
|
||||
import Data.Text (Text)
|
||||
import Network.Wai (Application)
|
||||
import Servant.Server.Internal
|
||||
import Servant.Server.Internal.Enter
|
||||
import Servant.Utils.Enter
|
||||
|
||||
|
||||
-- * Implementing Servers
|
||||
|
@ -121,16 +130,73 @@ import Servant.Server.Internal.Enter
|
|||
-- > main :: IO ()
|
||||
-- > main = Network.Wai.Handler.Warp.run 8080 app
|
||||
--
|
||||
serve :: (HasServer layout '[]) => Proxy layout -> Server layout -> Application
|
||||
serve :: (HasServer api '[]) => Proxy api -> Server api -> Application
|
||||
serve p = serveWithContext p EmptyContext
|
||||
|
||||
serveWithContext :: (HasServer layout context)
|
||||
=> Proxy layout -> Context context -> Server layout -> Application
|
||||
serveWithContext p context server = toApplication (runRouter (route p context d))
|
||||
where
|
||||
d = Delayed r r r r (\ _ _ _ -> Route server)
|
||||
r = return (Route ())
|
||||
serveWithContext :: (HasServer api context)
|
||||
=> Proxy api -> Context context -> Server api -> Application
|
||||
serveWithContext p context server =
|
||||
toApplication (runRouter (route p context (emptyDelayed (Route server))))
|
||||
|
||||
-- | The function 'layout' produces a textual description of the internal
|
||||
-- router layout for debugging purposes. Note that the router layout is
|
||||
-- determined just by the API, not by the handlers.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- For the following API
|
||||
--
|
||||
-- > type API =
|
||||
-- > "a" :> "d" :> Get '[JSON] ()
|
||||
-- > :<|> "b" :> Capture "x" Int :> Get '[JSON] Bool
|
||||
-- > :<|> "c" :> Put '[JSON] Bool
|
||||
-- > :<|> "a" :> "e" :> Get '[JSON] Int
|
||||
-- > :<|> "b" :> Capture "x" Int :> Put '[JSON] Bool
|
||||
-- > :<|> Raw
|
||||
--
|
||||
-- we get the following output:
|
||||
--
|
||||
-- > /
|
||||
-- > ├─ a/
|
||||
-- > │ ├─ d/
|
||||
-- > │ │ └─•
|
||||
-- > │ └─ e/
|
||||
-- > │ └─•
|
||||
-- > ├─ b/
|
||||
-- > │ └─ <capture>/
|
||||
-- > │ ├─•
|
||||
-- > │ ┆
|
||||
-- > │ └─•
|
||||
-- > ├─ c/
|
||||
-- > │ └─•
|
||||
-- > ┆
|
||||
-- > └─ <raw>
|
||||
--
|
||||
-- Explanation of symbols:
|
||||
--
|
||||
-- [@├@] Normal lines reflect static branching via a table.
|
||||
--
|
||||
-- [@a/@] Nodes reflect static path components.
|
||||
--
|
||||
-- [@─•@] Leaves reflect endpoints.
|
||||
--
|
||||
-- [@\<capture\>/@] This is a delayed capture of a path component.
|
||||
--
|
||||
-- [@\<raw\>@] This is a part of the API we do not know anything about.
|
||||
--
|
||||
-- [@┆@] Dashed lines suggest a dynamic choice between the part above
|
||||
-- and below. If there is a success for fatal failure in the first part,
|
||||
-- that one takes precedence. If both parts fail, the \"better\" error
|
||||
-- code will be returned.
|
||||
--
|
||||
layout :: (HasServer api '[]) => Proxy api -> Text
|
||||
layout p = layoutWithContext p EmptyContext
|
||||
|
||||
-- | Variant of 'layout' that takes an additional 'Context'.
|
||||
layoutWithContext :: (HasServer api context)
|
||||
=> Proxy api -> Context context -> Text
|
||||
layoutWithContext p context =
|
||||
routerLayout (route p context (emptyDelayed (FailFatal err501)))
|
||||
|
||||
-- Documentation
|
||||
|
||||
|
|
|
@ -12,8 +12,8 @@
|
|||
|
||||
module Servant.Server.Experimental.Auth where
|
||||
|
||||
import Control.Monad.Trans.Except (ExceptT,
|
||||
runExceptT)
|
||||
import Control.Monad.Trans (liftIO)
|
||||
import Control.Monad.Trans.Except (runExceptT)
|
||||
import Data.Proxy (Proxy (Proxy))
|
||||
import Data.Typeable (Typeable)
|
||||
import GHC.Generics (Generic)
|
||||
|
@ -25,10 +25,11 @@ import Servant.Server.Internal (HasContextEntry,
|
|||
HasServer, ServerT,
|
||||
getContextEntry,
|
||||
route)
|
||||
import Servant.Server.Internal.Router (Router' (WithRequest))
|
||||
import Servant.Server.Internal.RoutingApplication (RouteResult (FailFatal, Route),
|
||||
addAuthCheck)
|
||||
import Servant.Server.Internal.ServantErr (ServantErr)
|
||||
import Servant.Server.Internal.RoutingApplication (addAuthCheck,
|
||||
delayedFailFatal,
|
||||
DelayedIO,
|
||||
withRequest)
|
||||
import Servant.Server.Internal.ServantErr (Handler)
|
||||
|
||||
-- * General Auth
|
||||
|
||||
|
@ -42,11 +43,11 @@ type family AuthServerData a :: *
|
|||
--
|
||||
-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
|
||||
newtype AuthHandler r usr = AuthHandler
|
||||
{ unAuthHandler :: r -> ExceptT ServantErr IO usr }
|
||||
{ unAuthHandler :: r -> Handler usr }
|
||||
deriving (Generic, Typeable)
|
||||
|
||||
-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
|
||||
mkAuthHandler :: (r -> ExceptT ServantErr IO usr) -> AuthHandler r usr
|
||||
mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr
|
||||
mkAuthHandler = AuthHandler
|
||||
|
||||
-- | Known orphan instance.
|
||||
|
@ -58,9 +59,10 @@ instance ( HasServer api context
|
|||
type ServerT (AuthProtect tag :> api) m =
|
||||
AuthServerData (AuthProtect tag) -> ServerT api m
|
||||
|
||||
route Proxy context subserver = WithRequest $ \ request ->
|
||||
route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request)
|
||||
route Proxy context subserver =
|
||||
route (Proxy :: Proxy api) context (subserver `addAuthCheck` withRequest authCheck)
|
||||
where
|
||||
authHandler :: Request -> Handler (AuthServerData (AuthProtect tag))
|
||||
authHandler = unAuthHandler (getContextEntry context)
|
||||
authCheck = fmap (either FailFatal Route) . runExceptT . authHandler
|
||||
|
||||
authCheck :: Request -> DelayedIO (AuthServerData (AuthProtect tag))
|
||||
authCheck = (>>= either delayedFailFatal return) . liftIO . runExceptT . authHandler
|
||||
|
|
|
@ -22,15 +22,13 @@ module Servant.Server.Internal
|
|||
, module Servant.Server.Internal.ServantErr
|
||||
) where
|
||||
|
||||
import Control.Monad.Trans.Except (ExceptT)
|
||||
import Control.Monad.Trans (liftIO)
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Char8 as BC8
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (fromMaybe, mapMaybe)
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions (cs, (<>))
|
||||
import Data.Text (Text)
|
||||
import Data.Typeable
|
||||
import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
|
||||
symbolVal)
|
||||
|
@ -38,7 +36,7 @@ import Network.HTTP.Types hiding (Header, ResponseHeaders)
|
|||
import Network.Socket (SockAddr)
|
||||
import Network.Wai (Application, Request, Response,
|
||||
httpVersion, isSecure,
|
||||
lazyRequestBody, pathInfo,
|
||||
lazyRequestBody,
|
||||
rawQueryString, remoteHost,
|
||||
requestHeaders, requestMethod,
|
||||
responseLBS, vault)
|
||||
|
@ -70,12 +68,16 @@ import Servant.Server.Internal.RoutingApplication
|
|||
import Servant.Server.Internal.ServantErr
|
||||
|
||||
|
||||
class HasServer layout context where
|
||||
type ServerT layout (m :: * -> *) :: *
|
||||
class HasServer api context where
|
||||
type ServerT api (m :: * -> *) :: *
|
||||
|
||||
route :: Proxy layout -> Context context -> Delayed (Server layout) -> Router
|
||||
route ::
|
||||
Proxy api
|
||||
-> Context context
|
||||
-> Delayed env (Server api)
|
||||
-> Router env
|
||||
|
||||
type Server layout = ServerT layout (ExceptT ServantErr IO)
|
||||
type Server api = ServerT api Handler
|
||||
|
||||
-- * Instances
|
||||
|
||||
|
@ -95,7 +97,7 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont
|
|||
type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
|
||||
|
||||
route Proxy context server = choice (route pa context ((\ (a :<|> _) -> a) <$> server))
|
||||
(route pb context ((\ (_ :<|> b) -> b) <$> server))
|
||||
(route pb context ((\ (_ :<|> b) -> b) <$> server))
|
||||
where pa = Proxy :: Proxy a
|
||||
pb = Proxy :: Proxy b
|
||||
|
||||
|
@ -114,21 +116,21 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont
|
|||
-- >
|
||||
-- > server :: Server MyApi
|
||||
-- > server = getBook
|
||||
-- > where getBook :: Text -> ExceptT ServantErr IO Book
|
||||
-- > where getBook :: Text -> Handler Book
|
||||
-- > getBook isbn = ...
|
||||
instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context)
|
||||
=> HasServer (Capture capture a :> sublayout) context where
|
||||
instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
|
||||
=> HasServer (Capture capture a :> api) context where
|
||||
|
||||
type ServerT (Capture capture a :> sublayout) m =
|
||||
a -> ServerT sublayout m
|
||||
type ServerT (Capture capture a :> api) m =
|
||||
a -> ServerT api m
|
||||
|
||||
route Proxy context d =
|
||||
DynamicRouter $ \ first ->
|
||||
route (Proxy :: Proxy sublayout)
|
||||
CaptureRouter $
|
||||
route (Proxy :: Proxy api)
|
||||
context
|
||||
(addCapture d $ case parseUrlPieceMaybe first :: Maybe a of
|
||||
Nothing -> return $ Fail err400
|
||||
Just v -> return $ Route v
|
||||
(addCapture d $ \ txt -> case parseUrlPieceMaybe txt :: Maybe a of
|
||||
Nothing -> delayedFail err400
|
||||
Just v -> return v
|
||||
)
|
||||
|
||||
allowedMethodHead :: Method -> Request -> Bool
|
||||
|
@ -147,48 +149,51 @@ processMethodRouter handleA status method headers request = case handleA of
|
|||
bdy = if allowedMethodHead method request then "" else body
|
||||
hdrs = (hContentType, cs contentT) : (fromMaybe [] headers)
|
||||
|
||||
methodCheck :: Method -> Request -> IO (RouteResult ())
|
||||
methodCheck :: Method -> Request -> DelayedIO ()
|
||||
methodCheck method request
|
||||
| allowedMethod method request = return $ Route ()
|
||||
| otherwise = return $ Fail err405
|
||||
| allowedMethod method request = return ()
|
||||
| otherwise = delayedFail err405
|
||||
|
||||
acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> IO (RouteResult ())
|
||||
-- This has switched between using 'Fail' and 'FailFatal' a number of
|
||||
-- times. If the 'acceptCheck' is run after the body check (which would
|
||||
-- be morally right), then we have to set this to 'FailFatal', because
|
||||
-- the body check is not reversible, and therefore backtracking after the
|
||||
-- body check is no longer an option. However, we now run the accept
|
||||
-- check before the body check and can therefore afford to make it
|
||||
-- recoverable.
|
||||
acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO ()
|
||||
acceptCheck proxy accH
|
||||
| canHandleAcceptH proxy (AcceptHeader accH) = return $ Route ()
|
||||
| otherwise = return $ FailFatal err406
|
||||
| canHandleAcceptH proxy (AcceptHeader accH) = return ()
|
||||
| otherwise = delayedFail err406
|
||||
|
||||
methodRouter :: (AllCTRender ctypes a)
|
||||
=> Method -> Proxy ctypes -> Status
|
||||
-> Delayed (ExceptT ServantErr IO a)
|
||||
-> Router
|
||||
methodRouter method proxy status action = LeafRouter route'
|
||||
-> Delayed env (Handler a)
|
||||
-> Router env
|
||||
methodRouter method proxy status action = leafRouter route'
|
||||
where
|
||||
route' request respond
|
||||
| pathIsEmpty request =
|
||||
route' env request respond =
|
||||
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
||||
in runAction (action `addMethodCheck` methodCheck method request
|
||||
`addAcceptCheck` acceptCheck proxy accH
|
||||
) respond $ \ output -> do
|
||||
) env request respond $ \ output -> do
|
||||
let handleA = handleAcceptH proxy (AcceptHeader accH) output
|
||||
processMethodRouter handleA status method Nothing request
|
||||
| otherwise = respond $ Fail err404
|
||||
|
||||
methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)
|
||||
=> Method -> Proxy ctypes -> Status
|
||||
-> Delayed (ExceptT ServantErr IO (Headers h v))
|
||||
-> Router
|
||||
methodRouterHeaders method proxy status action = LeafRouter route'
|
||||
-> Delayed env (Handler (Headers h v))
|
||||
-> Router env
|
||||
methodRouterHeaders method proxy status action = leafRouter route'
|
||||
where
|
||||
route' request respond
|
||||
| pathIsEmpty request =
|
||||
route' env request respond =
|
||||
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
||||
in runAction (action `addMethodCheck` methodCheck method request
|
||||
`addAcceptCheck` acceptCheck proxy accH
|
||||
) respond $ \ output -> do
|
||||
) env request respond $ \ output -> do
|
||||
let headers = getHeaders output
|
||||
handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
|
||||
processMethodRouter handleA status method (Just headers) request
|
||||
| otherwise = respond $ Fail err404
|
||||
|
||||
instance OVERLAPPABLE_
|
||||
( AllCTRender ctypes a, ReflectMethod method, KnownNat status
|
||||
|
@ -229,17 +234,17 @@ instance OVERLAPPING_
|
|||
-- >
|
||||
-- > server :: Server MyApi
|
||||
-- > server = viewReferer
|
||||
-- > where viewReferer :: Referer -> ExceptT ServantErr IO referer
|
||||
-- > where viewReferer :: Referer -> Handler referer
|
||||
-- > viewReferer referer = return referer
|
||||
instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)
|
||||
=> HasServer (Header sym a :> sublayout) context where
|
||||
instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
|
||||
=> HasServer (Header sym a :> api) context where
|
||||
|
||||
type ServerT (Header sym a :> sublayout) m =
|
||||
Maybe a -> ServerT sublayout m
|
||||
type ServerT (Header sym a :> api) m =
|
||||
Maybe a -> ServerT api m
|
||||
|
||||
route Proxy context subserver = WithRequest $ \ request ->
|
||||
let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request)
|
||||
in route (Proxy :: Proxy sublayout) context (passToServer subserver mheader)
|
||||
route Proxy context subserver =
|
||||
let mheader req = parseHeaderMaybe =<< lookup str (requestHeaders req)
|
||||
in route (Proxy :: Proxy api) context (passToServer subserver mheader)
|
||||
where str = fromString $ symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
|
||||
|
@ -260,24 +265,24 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)
|
|||
-- >
|
||||
-- > server :: Server MyApi
|
||||
-- > server = getBooksBy
|
||||
-- > where getBooksBy :: Maybe Text -> ExceptT ServantErr IO [Book]
|
||||
-- > where getBooksBy :: Maybe Text -> Handler [Book]
|
||||
-- > getBooksBy Nothing = ...return all books...
|
||||
-- > getBooksBy (Just author) = ...return books by the given author...
|
||||
instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)
|
||||
=> HasServer (QueryParam sym a :> sublayout) context where
|
||||
instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
|
||||
=> HasServer (QueryParam sym a :> api) context where
|
||||
|
||||
type ServerT (QueryParam sym a :> sublayout) m =
|
||||
Maybe a -> ServerT sublayout m
|
||||
type ServerT (QueryParam sym a :> api) m =
|
||||
Maybe a -> ServerT api m
|
||||
|
||||
route Proxy context subserver = WithRequest $ \ request ->
|
||||
let querytext = parseQueryText $ rawQueryString request
|
||||
param =
|
||||
case lookup paramname querytext of
|
||||
route Proxy context subserver =
|
||||
let querytext r = parseQueryText $ rawQueryString r
|
||||
param r =
|
||||
case lookup paramname (querytext r) of
|
||||
Nothing -> Nothing -- param absent from the query string
|
||||
Just Nothing -> Nothing -- param present with no value -> Nothing
|
||||
Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to
|
||||
-- the right type
|
||||
in route (Proxy :: Proxy sublayout) context (passToServer subserver param)
|
||||
in route (Proxy :: Proxy api) context (passToServer subserver param)
|
||||
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,
|
||||
|
@ -297,22 +302,22 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)
|
|||
-- >
|
||||
-- > server :: Server MyApi
|
||||
-- > server = getBooksBy
|
||||
-- > where getBooksBy :: [Text] -> ExceptT ServantErr IO [Book]
|
||||
-- > where getBooksBy :: [Text] -> Handler [Book]
|
||||
-- > getBooksBy authors = ...return all books by these authors...
|
||||
instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)
|
||||
=> HasServer (QueryParams sym a :> sublayout) context where
|
||||
instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
|
||||
=> HasServer (QueryParams sym a :> api) context where
|
||||
|
||||
type ServerT (QueryParams sym a :> sublayout) m =
|
||||
[a] -> ServerT sublayout m
|
||||
type ServerT (QueryParams sym a :> api) m =
|
||||
[a] -> ServerT api m
|
||||
|
||||
route Proxy context subserver = WithRequest $ \ request ->
|
||||
let querytext = parseQueryText $ rawQueryString request
|
||||
route Proxy context subserver =
|
||||
let querytext r = parseQueryText $ rawQueryString r
|
||||
-- if sym is "foo", we look for query string parameters
|
||||
-- named "foo" or "foo[]" and call parseQueryParam on the
|
||||
-- corresponding values
|
||||
parameters = filter looksLikeParam querytext
|
||||
values = mapMaybe (convert . snd) parameters
|
||||
in route (Proxy :: Proxy sublayout) context (passToServer subserver values)
|
||||
parameters r = filter looksLikeParam (querytext r)
|
||||
values r = mapMaybe (convert . snd) (parameters r)
|
||||
in route (Proxy :: Proxy api) context (passToServer subserver values)
|
||||
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||
looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
|
||||
convert Nothing = Nothing
|
||||
|
@ -328,21 +333,21 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)
|
|||
-- >
|
||||
-- > server :: Server MyApi
|
||||
-- > server = getBooks
|
||||
-- > where getBooks :: Bool -> ExceptT ServantErr IO [Book]
|
||||
-- > where getBooks :: Bool -> Handler [Book]
|
||||
-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...
|
||||
instance (KnownSymbol sym, HasServer sublayout context)
|
||||
=> HasServer (QueryFlag sym :> sublayout) context where
|
||||
instance (KnownSymbol sym, HasServer api context)
|
||||
=> HasServer (QueryFlag sym :> api) context where
|
||||
|
||||
type ServerT (QueryFlag sym :> sublayout) m =
|
||||
Bool -> ServerT sublayout m
|
||||
type ServerT (QueryFlag sym :> api) m =
|
||||
Bool -> ServerT api m
|
||||
|
||||
route Proxy context subserver = WithRequest $ \ request ->
|
||||
let querytext = parseQueryText $ rawQueryString request
|
||||
param = case lookup paramname querytext of
|
||||
route Proxy context subserver =
|
||||
let querytext r = parseQueryText $ rawQueryString r
|
||||
param r = case lookup paramname (querytext r) of
|
||||
Just Nothing -> True -- param is there, with no value
|
||||
Just (Just v) -> examine v -- param with a value
|
||||
Nothing -> False -- param not in the query string
|
||||
in route (Proxy :: Proxy sublayout) context (passToServer subserver param)
|
||||
in route (Proxy :: Proxy api) context (passToServer subserver param)
|
||||
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||
examine v | v == "true" || v == "1" || v == "" = True
|
||||
| otherwise = False
|
||||
|
@ -359,8 +364,8 @@ instance HasServer Raw context where
|
|||
|
||||
type ServerT Raw m = Application
|
||||
|
||||
route Proxy _ rawApplication = LeafRouter $ \ request respond -> do
|
||||
r <- runDelayed rawApplication
|
||||
route Proxy _ rawApplication = RawRouter $ \ env request respond -> do
|
||||
r <- runDelayed rawApplication env request
|
||||
case r of
|
||||
Route app -> app request (respond . Route)
|
||||
Fail a -> respond $ Fail a
|
||||
|
@ -385,18 +390,18 @@ instance HasServer Raw context where
|
|||
-- >
|
||||
-- > server :: Server MyApi
|
||||
-- > server = postBook
|
||||
-- > where postBook :: Book -> ExceptT ServantErr IO Book
|
||||
-- > where postBook :: Book -> Handler Book
|
||||
-- > postBook book = ...insert into your db...
|
||||
instance ( AllCTUnrender list a, HasServer sublayout context
|
||||
) => HasServer (ReqBody list a :> sublayout) context where
|
||||
instance ( AllCTUnrender list a, HasServer api context
|
||||
) => HasServer (ReqBody list a :> api) context where
|
||||
|
||||
type ServerT (ReqBody list a :> sublayout) m =
|
||||
a -> ServerT sublayout m
|
||||
type ServerT (ReqBody list a :> api) m =
|
||||
a -> ServerT api m
|
||||
|
||||
route Proxy context subserver = WithRequest $ \ request ->
|
||||
route (Proxy :: Proxy sublayout) context (addBodyCheck subserver (bodyCheck request))
|
||||
route Proxy context subserver =
|
||||
route (Proxy :: Proxy api) context (addBodyCheck subserver bodyCheck)
|
||||
where
|
||||
bodyCheck request = do
|
||||
bodyCheck = withRequest $ \ request -> do
|
||||
-- See HTTP RFC 2616, section 7.2.1
|
||||
-- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
|
||||
-- See also "W3C Internet Media Type registration, consistency of use"
|
||||
|
@ -404,48 +409,49 @@ instance ( AllCTUnrender list a, HasServer sublayout context
|
|||
let contentTypeH = fromMaybe "application/octet-stream"
|
||||
$ lookup hContentType $ requestHeaders request
|
||||
mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
|
||||
<$> lazyRequestBody request
|
||||
<$> liftIO (lazyRequestBody request)
|
||||
case mrqbody of
|
||||
Nothing -> return $ FailFatal err415
|
||||
Just (Left e) -> return $ FailFatal err400 { errBody = cs e }
|
||||
Just (Right v) -> return $ Route v
|
||||
Nothing -> delayedFailFatal err415
|
||||
Just (Left e) -> delayedFailFatal err400 { errBody = cs e }
|
||||
Just (Right v) -> return v
|
||||
|
||||
-- | Make sure the incoming request starts with @"/path"@, strip it and
|
||||
-- pass the rest of the request path to @sublayout@.
|
||||
instance (KnownSymbol path, HasServer sublayout context) => HasServer (path :> sublayout) context where
|
||||
-- pass the rest of the request path to @api@.
|
||||
instance (KnownSymbol path, HasServer api context) => HasServer (path :> api) context where
|
||||
|
||||
type ServerT (path :> sublayout) m = ServerT sublayout m
|
||||
type ServerT (path :> api) m = ServerT api m
|
||||
|
||||
route Proxy context subserver = StaticRouter $
|
||||
M.singleton (cs (symbolVal proxyPath))
|
||||
(route (Proxy :: Proxy sublayout) context subserver)
|
||||
route Proxy context subserver =
|
||||
pathRouter
|
||||
(cs (symbolVal proxyPath))
|
||||
(route (Proxy :: Proxy api) context subserver)
|
||||
where proxyPath = Proxy :: Proxy path
|
||||
|
||||
instance HasServer api context => HasServer (RemoteHost :> api) context where
|
||||
type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m
|
||||
|
||||
route Proxy context subserver = WithRequest $ \req ->
|
||||
route (Proxy :: Proxy api) context (passToServer subserver $ remoteHost req)
|
||||
route Proxy context subserver =
|
||||
route (Proxy :: Proxy api) context (passToServer subserver remoteHost)
|
||||
|
||||
instance HasServer api context => HasServer (IsSecure :> api) context where
|
||||
type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m
|
||||
|
||||
route Proxy context subserver = WithRequest $ \req ->
|
||||
route (Proxy :: Proxy api) context (passToServer subserver $ secure req)
|
||||
route Proxy context subserver =
|
||||
route (Proxy :: Proxy api) context (passToServer subserver secure)
|
||||
|
||||
where secure req = if isSecure req then Secure else NotSecure
|
||||
|
||||
instance HasServer api context => HasServer (Vault :> api) context where
|
||||
type ServerT (Vault :> api) m = Vault -> ServerT api m
|
||||
|
||||
route Proxy context subserver = WithRequest $ \req ->
|
||||
route (Proxy :: Proxy api) context (passToServer subserver $ vault req)
|
||||
route Proxy context subserver =
|
||||
route (Proxy :: Proxy api) context (passToServer subserver vault)
|
||||
|
||||
instance HasServer api context => HasServer (HttpVersion :> api) context where
|
||||
type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m
|
||||
|
||||
route Proxy context subserver = WithRequest $ \req ->
|
||||
route (Proxy :: Proxy api) context (passToServer subserver $ httpVersion req)
|
||||
route Proxy context subserver =
|
||||
route (Proxy :: Proxy api) context (passToServer subserver httpVersion)
|
||||
|
||||
-- | Basic Authentication
|
||||
instance ( KnownSymbol realm
|
||||
|
@ -456,21 +462,15 @@ instance ( KnownSymbol realm
|
|||
|
||||
type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m
|
||||
|
||||
route Proxy context subserver = WithRequest $ \ request ->
|
||||
route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request)
|
||||
route Proxy context subserver =
|
||||
route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck)
|
||||
where
|
||||
realm = BC8.pack $ symbolVal (Proxy :: Proxy realm)
|
||||
basicAuthContext = getContextEntry context
|
||||
authCheck req = runBasicAuth req realm basicAuthContext
|
||||
authCheck = withRequest $ \ req -> runBasicAuth req realm basicAuthContext
|
||||
|
||||
-- * helpers
|
||||
|
||||
pathIsEmpty :: Request -> Bool
|
||||
pathIsEmpty = go . pathInfo
|
||||
where go [] = True
|
||||
go [""] = True
|
||||
go _ = False
|
||||
|
||||
ct_wildcard :: B.ByteString
|
||||
ct_wildcard = "*" <> "/" <> "*" -- Because CPP
|
||||
|
||||
|
|
|
@ -1,11 +1,12 @@
|
|||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Servant.Server.Internal.BasicAuth where
|
||||
|
||||
import Control.Monad (guard)
|
||||
import Control.Monad.Trans (liftIO)
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.ByteString.Base64 (decodeLenient)
|
||||
import Data.Monoid ((<>))
|
||||
|
@ -15,9 +16,9 @@ import GHC.Generics
|
|||
import Network.HTTP.Types (Header)
|
||||
import Network.Wai (Request, requestHeaders)
|
||||
|
||||
import Servant.API.BasicAuth (BasicAuthData(BasicAuthData))
|
||||
import Servant.Server.Internal.RoutingApplication
|
||||
import Servant.Server.Internal.ServantErr
|
||||
import Servant.API.BasicAuth (BasicAuthData(BasicAuthData))
|
||||
import Servant.Server.Internal.RoutingApplication
|
||||
import Servant.Server.Internal.ServantErr
|
||||
|
||||
-- * Basic Auth
|
||||
|
||||
|
@ -57,13 +58,13 @@ decodeBAHdr req = do
|
|||
|
||||
-- | Run and check basic authentication, returning the appropriate http error per
|
||||
-- the spec.
|
||||
runBasicAuth :: Request -> BS.ByteString -> BasicAuthCheck usr -> IO (RouteResult usr)
|
||||
runBasicAuth :: Request -> BS.ByteString -> BasicAuthCheck usr -> DelayedIO usr
|
||||
runBasicAuth req realm (BasicAuthCheck ba) =
|
||||
case decodeBAHdr req of
|
||||
Nothing -> plzAuthenticate
|
||||
Just e -> ba e >>= \res -> case res of
|
||||
Just e -> liftIO (ba e) >>= \res -> case res of
|
||||
BadPassword -> plzAuthenticate
|
||||
NoSuchUser -> plzAuthenticate
|
||||
Unauthorized -> return $ Fail err403
|
||||
Authorized usr -> return $ Route usr
|
||||
where plzAuthenticate = return $ Fail err401 { errHeaders = [mkBAChallengerHdr realm] }
|
||||
Unauthorized -> delayedFailFatal err403
|
||||
Authorized usr -> return usr
|
||||
where plzAuthenticate = delayedFailFatal err401 { errHeaders = [mkBAChallengerHdr realm] }
|
||||
|
|
|
@ -18,7 +18,7 @@ import GHC.TypeLits
|
|||
-- | 'Context's are used to pass values to combinators. (They are __not__ meant
|
||||
-- to be used to pass parameters to your handlers, i.e. they should not replace
|
||||
-- any custom 'Control.Monad.Trans.Reader.ReaderT'-monad-stack that you're using
|
||||
-- with 'Servant.Server.Internal.Enter.enter'.) If you don't use combinators that
|
||||
-- with 'Servant.Utils.Enter'.) If you don't use combinators that
|
||||
-- require any context entries, you can just use 'Servant.Server.serve' as always.
|
||||
--
|
||||
-- If you are using combinators that require a non-empty 'Context' you have to
|
||||
|
@ -59,7 +59,7 @@ instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where
|
|||
--
|
||||
-- >>> getContextEntry (True :. False :. EmptyContext) :: String
|
||||
-- ...
|
||||
-- No instance for (HasContextEntry '[] [Char])
|
||||
-- ...No instance for (HasContextEntry '[] [Char])
|
||||
-- ...
|
||||
class HasContextEntry (context :: [*]) (val :: *) where
|
||||
getContextEntry :: Context context -> val
|
||||
|
|
|
@ -1,89 +1,196 @@
|
|||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Servant.Server.Internal.Router where
|
||||
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
import Data.Monoid
|
||||
import Data.Text (Text)
|
||||
import Network.Wai (Request, Response, pathInfo)
|
||||
import qualified Data.Text as T
|
||||
import Network.Wai (Response, pathInfo)
|
||||
import Servant.Server.Internal.RoutingApplication
|
||||
import Servant.Server.Internal.ServantErr
|
||||
|
||||
type Router = Router' RoutingApplication
|
||||
type Router env = Router' env RoutingApplication
|
||||
|
||||
-- | Internal representation of a router.
|
||||
data Router' a =
|
||||
WithRequest (Request -> Router)
|
||||
-- ^ current request is passed to the router
|
||||
| StaticRouter (Map Text Router)
|
||||
-- ^ first path component used for lookup and removed afterwards
|
||||
| DynamicRouter (Text -> Router)
|
||||
-- ^ first path component used for lookup and removed afterwards
|
||||
| LeafRouter a
|
||||
-- ^ to be used for routes that match an empty path
|
||||
| Choice Router Router
|
||||
--
|
||||
-- The first argument describes an environment type that is
|
||||
-- expected as extra input by the routers at the leaves. The
|
||||
-- environment is filled while running the router, with path
|
||||
-- components that can be used to process captures.
|
||||
--
|
||||
data Router' env a =
|
||||
StaticRouter (Map Text (Router' env a)) [env -> a]
|
||||
-- ^ the map contains routers for subpaths (first path component used
|
||||
-- for lookup and removed afterwards), the list contains handlers
|
||||
-- for the empty path, to be tried in order
|
||||
| CaptureRouter (Router' (Text, env) a)
|
||||
-- ^ first path component is passed to the child router in its
|
||||
-- environment and removed afterwards
|
||||
| RawRouter (env -> a)
|
||||
-- ^ to be used for routes we do not know anything about
|
||||
| Choice (Router' env a) (Router' env a)
|
||||
-- ^ left-biased choice between two routers
|
||||
deriving Functor
|
||||
|
||||
-- | Apply a transformation to the response of a `Router`.
|
||||
tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router -> Router
|
||||
tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))
|
||||
-- | Smart constructor for a single static path component.
|
||||
pathRouter :: Text -> Router' env a -> Router' env a
|
||||
pathRouter t r = StaticRouter (M.singleton t r) []
|
||||
|
||||
-- | Smart constructor for a leaf, i.e., a router that expects
|
||||
-- the empty path.
|
||||
--
|
||||
leafRouter :: (env -> a) -> Router' env a
|
||||
leafRouter l = StaticRouter M.empty [l]
|
||||
|
||||
-- | Smart constructor for the choice between routers.
|
||||
-- We currently optimize the following cases:
|
||||
--
|
||||
-- * Two static routers can be joined by joining their maps.
|
||||
-- * Two static routers can be joined by joining their maps
|
||||
-- and concatenating their leaf-lists.
|
||||
-- * Two dynamic routers can be joined by joining their codomains.
|
||||
-- * Two 'WithRequest' routers can be joined by passing them
|
||||
-- the same request and joining their codomains.
|
||||
-- * A 'WithRequest' router can be joined with anything else by
|
||||
-- passing the same request to both but ignoring it in the
|
||||
-- component that does not need it.
|
||||
-- * Choice nodes can be reordered.
|
||||
--
|
||||
choice :: Router -> Router -> Router
|
||||
choice (StaticRouter table1) (StaticRouter table2) =
|
||||
StaticRouter (M.unionWith choice table1 table2)
|
||||
choice (DynamicRouter fun1) (DynamicRouter fun2) =
|
||||
DynamicRouter (\ first -> choice (fun1 first) (fun2 first))
|
||||
choice (WithRequest router1) (WithRequest router2) =
|
||||
WithRequest (\ request -> choice (router1 request) (router2 request))
|
||||
choice (WithRequest router1) router2 =
|
||||
WithRequest (\ request -> choice (router1 request) router2)
|
||||
choice router1 (WithRequest router2) =
|
||||
WithRequest (\ request -> choice router1 (router2 request))
|
||||
choice :: Router' env a -> Router' env a -> Router' env a
|
||||
choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =
|
||||
StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)
|
||||
choice (CaptureRouter router1) (CaptureRouter router2) =
|
||||
CaptureRouter (choice router1 router2)
|
||||
choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3
|
||||
choice router1 router2 = Choice router1 router2
|
||||
|
||||
-- | Interpret a router as an application.
|
||||
runRouter :: Router -> RoutingApplication
|
||||
runRouter (WithRequest router) request respond =
|
||||
runRouter (router request) request respond
|
||||
runRouter (StaticRouter table) request respond =
|
||||
case pathInfo request of
|
||||
first : rest
|
||||
| Just router <- M.lookup first table
|
||||
-> let request' = request { pathInfo = rest }
|
||||
in runRouter router request' respond
|
||||
_ -> respond $ Fail err404
|
||||
runRouter (DynamicRouter fun) request respond =
|
||||
case pathInfo request of
|
||||
first : rest
|
||||
-> let request' = request { pathInfo = rest }
|
||||
in runRouter (fun first) request' respond
|
||||
_ -> respond $ Fail err404
|
||||
runRouter (LeafRouter app) request respond = app request respond
|
||||
runRouter (Choice r1 r2) request respond =
|
||||
runRouter r1 request $ \ mResponse1 -> case mResponse1 of
|
||||
Fail _ -> runRouter r2 request $ \ mResponse2 ->
|
||||
respond (highestPri mResponse1 mResponse2)
|
||||
_ -> respond mResponse1
|
||||
where
|
||||
highestPri (Fail e1) (Fail e2) =
|
||||
if worseHTTPCode (errHTTPCode e1) (errHTTPCode e2)
|
||||
then Fail e2
|
||||
else Fail e1
|
||||
highestPri (Fail _) y = y
|
||||
highestPri x _ = x
|
||||
-- | Datatype used for representing and debugging the
|
||||
-- structure of a router. Abstracts from the handlers
|
||||
-- at the leaves.
|
||||
--
|
||||
-- Two 'Router's can be structurally compared by computing
|
||||
-- their 'RouterStructure' using 'routerStructure' and
|
||||
-- then testing for equality, see 'sameStructure'.
|
||||
--
|
||||
data RouterStructure =
|
||||
StaticRouterStructure (Map Text RouterStructure) Int
|
||||
| CaptureRouterStructure RouterStructure
|
||||
| RawRouterStructure
|
||||
| ChoiceStructure RouterStructure RouterStructure
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Compute the structure of a router.
|
||||
--
|
||||
-- Assumes that the request or text being passed
|
||||
-- in 'WithRequest' or 'CaptureRouter' does not
|
||||
-- affect the structure of the underlying tree.
|
||||
--
|
||||
routerStructure :: Router' env a -> RouterStructure
|
||||
routerStructure (StaticRouter m ls) =
|
||||
StaticRouterStructure (fmap routerStructure m) (length ls)
|
||||
routerStructure (CaptureRouter router) =
|
||||
CaptureRouterStructure $
|
||||
routerStructure router
|
||||
routerStructure (RawRouter _) =
|
||||
RawRouterStructure
|
||||
routerStructure (Choice r1 r2) =
|
||||
ChoiceStructure
|
||||
(routerStructure r1)
|
||||
(routerStructure r2)
|
||||
|
||||
-- | Compare the structure of two routers.
|
||||
--
|
||||
sameStructure :: Router' env a -> Router' env b -> Bool
|
||||
sameStructure r1 r2 =
|
||||
routerStructure r1 == routerStructure r2
|
||||
|
||||
-- | Provide a textual representation of the
|
||||
-- structure of a router.
|
||||
--
|
||||
routerLayout :: Router' env a -> Text
|
||||
routerLayout router =
|
||||
T.unlines (["/"] ++ mkRouterLayout False (routerStructure router))
|
||||
where
|
||||
mkRouterLayout :: Bool -> RouterStructure -> [Text]
|
||||
mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n
|
||||
mkRouterLayout c (CaptureRouterStructure r) = mkSubTree c "<capture>" (mkRouterLayout False r)
|
||||
mkRouterLayout c RawRouterStructure =
|
||||
if c then ["├─ <raw>"] else ["└─ <raw>"]
|
||||
mkRouterLayout c (ChoiceStructure r1 r2) =
|
||||
mkRouterLayout True r1 ++ ["┆"] ++ mkRouterLayout c r2
|
||||
|
||||
mkSubTrees :: Bool -> [(Text, RouterStructure)] -> Int -> [Text]
|
||||
mkSubTrees _ [] 0 = []
|
||||
mkSubTrees c [] n =
|
||||
concat (replicate (n - 1) (mkLeaf True) ++ [mkLeaf c])
|
||||
mkSubTrees c [(t, r)] 0 =
|
||||
mkSubTree c t (mkRouterLayout False r)
|
||||
mkSubTrees c ((t, r) : trs) n =
|
||||
mkSubTree True t (mkRouterLayout False r) ++ mkSubTrees c trs n
|
||||
|
||||
mkLeaf :: Bool -> [Text]
|
||||
mkLeaf True = ["├─•","┆"]
|
||||
mkLeaf False = ["└─•"]
|
||||
|
||||
mkSubTree :: Bool -> Text -> [Text] -> [Text]
|
||||
mkSubTree True path children = ("├─ " <> path <> "/") : map ("│ " <>) children
|
||||
mkSubTree False path children = ("└─ " <> path <> "/") : map (" " <>) children
|
||||
|
||||
-- | Apply a transformation to the response of a `Router`.
|
||||
tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router env -> Router env
|
||||
tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))
|
||||
|
||||
-- | Interpret a router as an application.
|
||||
runRouter :: Router () -> RoutingApplication
|
||||
runRouter r = runRouterEnv r ()
|
||||
|
||||
runRouterEnv :: Router env -> env -> RoutingApplication
|
||||
runRouterEnv router env request respond =
|
||||
case router of
|
||||
StaticRouter table ls ->
|
||||
case pathInfo request of
|
||||
[] -> runChoice ls env request respond
|
||||
-- This case is to handle trailing slashes.
|
||||
[""] -> runChoice ls env request respond
|
||||
first : rest | Just router' <- M.lookup first table
|
||||
-> let request' = request { pathInfo = rest }
|
||||
in runRouterEnv router' env request' respond
|
||||
_ -> respond $ Fail err404
|
||||
CaptureRouter router' ->
|
||||
case pathInfo request of
|
||||
[] -> respond $ Fail err404
|
||||
-- This case is to handle trailing slashes.
|
||||
[""] -> respond $ Fail err404
|
||||
first : rest
|
||||
-> let request' = request { pathInfo = rest }
|
||||
in runRouterEnv router' (first, env) request' respond
|
||||
RawRouter app ->
|
||||
app env request respond
|
||||
Choice r1 r2 ->
|
||||
runChoice [runRouterEnv r1, runRouterEnv r2] env request respond
|
||||
|
||||
-- | Try a list of routing applications in order.
|
||||
-- We stop as soon as one fails fatally or succeeds.
|
||||
-- If all fail normally, we pick the "best" error.
|
||||
--
|
||||
runChoice :: [env -> RoutingApplication] -> env -> RoutingApplication
|
||||
runChoice ls =
|
||||
case ls of
|
||||
[] -> \ _ _ respond -> respond (Fail err404)
|
||||
[r] -> r
|
||||
(r : rs) ->
|
||||
\ env request respond ->
|
||||
r env request $ \ response1 ->
|
||||
case response1 of
|
||||
Fail _ -> runChoice rs env request $ \ response2 ->
|
||||
respond $ highestPri response1 response2
|
||||
_ -> respond response1
|
||||
where
|
||||
highestPri (Fail e1) (Fail e2) =
|
||||
if worseHTTPCode (errHTTPCode e1) (errHTTPCode e2)
|
||||
then Fail e2
|
||||
else Fail e1
|
||||
highestPri (Fail _) y = y
|
||||
highestPri x _ = x
|
||||
|
||||
-- Priority on HTTP codes.
|
||||
--
|
||||
|
|
|
@ -8,7 +8,10 @@
|
|||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
module Servant.Server.Internal.RoutingApplication where
|
||||
|
||||
import Control.Monad.Trans.Except (ExceptT, runExceptT)
|
||||
import Control.Monad (ap, liftM)
|
||||
import Control.Monad.Trans (MonadIO(..))
|
||||
import Control.Monad.Trans.Except (runExceptT)
|
||||
import Data.Text (Text)
|
||||
import Network.Wai (Application, Request,
|
||||
Response, ResponseReceived)
|
||||
import Prelude ()
|
||||
|
@ -35,31 +38,6 @@ toApplication ra request respond = ra request routingRespond
|
|||
routingRespond (FailFatal err) = respond $ responseServantErr err
|
||||
routingRespond (Route v) = respond v
|
||||
|
||||
-- We currently mix up the order in which we perform checks
|
||||
-- and the priority with which errors are reported.
|
||||
--
|
||||
-- For example, we perform Capture checks prior to method checks,
|
||||
-- and therefore get 404 before 405.
|
||||
--
|
||||
-- However, we also perform body checks prior to method checks
|
||||
-- now, and therefore get 415 before 405, which is wrong.
|
||||
--
|
||||
-- If we delay Captures, but perform method checks eagerly, we
|
||||
-- end up potentially preferring 405 over 404, which is also bad.
|
||||
--
|
||||
-- So in principle, we'd like:
|
||||
--
|
||||
-- static routes (can cause 404)
|
||||
-- delayed captures (can cause 404)
|
||||
-- methods (can cause 405)
|
||||
-- authentication and authorization (can cause 401, 403)
|
||||
-- delayed body (can cause 415, 400)
|
||||
-- accept header (can cause 406)
|
||||
--
|
||||
-- According to the HTTP decision diagram, the priority order
|
||||
-- between HTTP status codes is as follows:
|
||||
--
|
||||
|
||||
-- | A 'Delayed' is a representation of a handler with scheduled
|
||||
-- delayed checks that can trigger errors.
|
||||
--
|
||||
|
@ -120,113 +98,139 @@ toApplication ra request respond = ra request routingRespond
|
|||
-- The accept header check can be performed as the final
|
||||
-- computation in this block. It can cause a 406.
|
||||
--
|
||||
data Delayed c where
|
||||
Delayed :: { capturesD :: IO (RouteResult captures)
|
||||
, methodD :: IO (RouteResult ())
|
||||
, authD :: IO (RouteResult auth)
|
||||
, bodyD :: IO (RouteResult body)
|
||||
, serverD :: (captures -> auth -> body -> RouteResult c)
|
||||
} -> Delayed c
|
||||
data Delayed env c where
|
||||
Delayed :: { capturesD :: env -> DelayedIO captures
|
||||
, methodD :: DelayedIO ()
|
||||
, authD :: DelayedIO auth
|
||||
, bodyD :: DelayedIO body
|
||||
, serverD :: captures -> auth -> body -> Request -> RouteResult c
|
||||
} -> Delayed env c
|
||||
|
||||
instance Functor Delayed where
|
||||
fmap f Delayed{..}
|
||||
= Delayed { capturesD = capturesD
|
||||
, methodD = methodD
|
||||
, authD = authD
|
||||
, bodyD = bodyD
|
||||
, serverD = (fmap.fmap.fmap.fmap) f serverD
|
||||
} -- Note [Existential Record Update]
|
||||
instance Functor (Delayed env) where
|
||||
fmap f Delayed{..} =
|
||||
Delayed
|
||||
{ serverD = \ c a b req -> f <$> serverD c a b req
|
||||
, ..
|
||||
} -- Note [Existential Record Update]
|
||||
|
||||
-- | Computations used in a 'Delayed' can depend on the
|
||||
-- incoming 'Request', may perform 'IO, and result in a
|
||||
-- 'RouteResult, meaning they can either suceed, fail
|
||||
-- (with the possibility to recover), or fail fatally.
|
||||
--
|
||||
newtype DelayedIO a = DelayedIO { runDelayedIO :: Request -> IO (RouteResult a) }
|
||||
|
||||
instance Functor DelayedIO where
|
||||
fmap = liftM
|
||||
|
||||
instance Applicative DelayedIO where
|
||||
pure = return
|
||||
(<*>) = ap
|
||||
|
||||
instance Monad DelayedIO where
|
||||
return x = DelayedIO (const $ return (Route x))
|
||||
DelayedIO m >>= f =
|
||||
DelayedIO $ \ req -> do
|
||||
r <- m req
|
||||
case r of
|
||||
Fail e -> return $ Fail e
|
||||
FailFatal e -> return $ FailFatal e
|
||||
Route a -> runDelayedIO (f a) req
|
||||
|
||||
instance MonadIO DelayedIO where
|
||||
liftIO m = DelayedIO (const $ Route <$> m)
|
||||
|
||||
-- | A 'Delayed' without any stored checks.
|
||||
emptyDelayed :: RouteResult a -> Delayed env a
|
||||
emptyDelayed result =
|
||||
Delayed (const r) r r r (\ _ _ _ _ -> result)
|
||||
where
|
||||
r = return ()
|
||||
|
||||
-- | Fail with the option to recover.
|
||||
delayedFail :: ServantErr -> DelayedIO a
|
||||
delayedFail err = DelayedIO (const $ return $ Fail err)
|
||||
|
||||
-- | Fail fatally, i.e., without any option to recover.
|
||||
delayedFailFatal :: ServantErr -> DelayedIO a
|
||||
delayedFailFatal err = DelayedIO (const $ return $ FailFatal err)
|
||||
|
||||
-- | Gain access to the incoming request.
|
||||
withRequest :: (Request -> DelayedIO a) -> DelayedIO a
|
||||
withRequest f = DelayedIO (\ req -> runDelayedIO (f req) req)
|
||||
|
||||
-- | Add a capture to the end of the capture block.
|
||||
addCapture :: Delayed (a -> b)
|
||||
-> IO (RouteResult a)
|
||||
-> Delayed b
|
||||
addCapture Delayed{..} new
|
||||
= Delayed { capturesD = combineRouteResults (,) capturesD new
|
||||
, methodD = methodD
|
||||
, authD = authD
|
||||
, bodyD = bodyD
|
||||
, serverD = \ (x, v) y z -> ($ v) <$> serverD x y z
|
||||
} -- Note [Existential Record Update]
|
||||
addCapture :: Delayed env (a -> b)
|
||||
-> (Text -> DelayedIO a)
|
||||
-> Delayed (Text, env) b
|
||||
addCapture Delayed{..} new =
|
||||
Delayed
|
||||
{ capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt
|
||||
, serverD = \ (x, v) a b req -> ($ v) <$> serverD x a b req
|
||||
, ..
|
||||
} -- Note [Existential Record Update]
|
||||
|
||||
-- | Add a method check to the end of the method block.
|
||||
addMethodCheck :: Delayed a
|
||||
-> IO (RouteResult ())
|
||||
-> Delayed a
|
||||
addMethodCheck Delayed{..} new
|
||||
= Delayed { capturesD = capturesD
|
||||
, methodD = combineRouteResults const methodD new
|
||||
, authD = authD
|
||||
, bodyD = bodyD
|
||||
, serverD = serverD
|
||||
} -- Note [Existential Record Update]
|
||||
addMethodCheck :: Delayed env a
|
||||
-> DelayedIO ()
|
||||
-> Delayed env a
|
||||
addMethodCheck Delayed{..} new =
|
||||
Delayed
|
||||
{ methodD = methodD <* new
|
||||
, ..
|
||||
} -- Note [Existential Record Update]
|
||||
|
||||
-- | Add an auth check to the end of the auth block.
|
||||
addAuthCheck :: Delayed (a -> b)
|
||||
-> IO (RouteResult a)
|
||||
-> Delayed b
|
||||
addAuthCheck Delayed{..} new
|
||||
= Delayed { capturesD = capturesD
|
||||
, methodD = methodD
|
||||
, authD = combineRouteResults (,) authD new
|
||||
, bodyD = bodyD
|
||||
, serverD = \ x (y, v) z -> ($ v) <$> serverD x y z
|
||||
} -- Note [Existential Record Update]
|
||||
addAuthCheck :: Delayed env (a -> b)
|
||||
-> DelayedIO a
|
||||
-> Delayed env b
|
||||
addAuthCheck Delayed{..} new =
|
||||
Delayed
|
||||
{ authD = (,) <$> authD <*> new
|
||||
, serverD = \ c (y, v) b req -> ($ v) <$> serverD c y b req
|
||||
, ..
|
||||
} -- Note [Existential Record Update]
|
||||
|
||||
-- | Add a body check to the end of the body block.
|
||||
addBodyCheck :: Delayed (a -> b)
|
||||
-> IO (RouteResult a)
|
||||
-> Delayed b
|
||||
addBodyCheck Delayed{..} new
|
||||
= Delayed { capturesD = capturesD
|
||||
, methodD = methodD
|
||||
, authD = authD
|
||||
, bodyD = combineRouteResults (,) bodyD new
|
||||
, serverD = \ x y (z, v) -> ($ v) <$> serverD x y z
|
||||
} -- Note [Existential Record Update]
|
||||
addBodyCheck :: Delayed env (a -> b)
|
||||
-> DelayedIO a
|
||||
-> Delayed env b
|
||||
addBodyCheck Delayed{..} new =
|
||||
Delayed
|
||||
{ bodyD = (,) <$> bodyD <*> new
|
||||
, serverD = \ c a (z, v) req -> ($ v) <$> serverD c a z req
|
||||
, ..
|
||||
} -- Note [Existential Record Update]
|
||||
|
||||
|
||||
-- | Add an accept header check to the end of the body block.
|
||||
-- The accept header check should occur after the body check,
|
||||
-- but this will be the case, because the accept header check
|
||||
-- is only scheduled by the method combinators.
|
||||
addAcceptCheck :: Delayed a
|
||||
-> IO (RouteResult ())
|
||||
-> Delayed a
|
||||
addAcceptCheck Delayed{..} new
|
||||
= Delayed { capturesD = capturesD
|
||||
, methodD = methodD
|
||||
, authD = authD
|
||||
, bodyD = combineRouteResults const bodyD new
|
||||
, serverD = serverD
|
||||
} -- Note [Existential Record Update]
|
||||
-- | Add an accept header check to the beginning of the body
|
||||
-- block. There is a tradeoff here. In principle, we'd like
|
||||
-- to take a bad body (400) response take precedence over a
|
||||
-- failed accept check (406). BUT to allow streaming the body,
|
||||
-- we cannot run the body check and then still backtrack.
|
||||
-- We therefore do the accept check before the body check,
|
||||
-- when we can still backtrack. There are other solutions to
|
||||
-- this, but they'd be more complicated (such as delaying the
|
||||
-- body check further so that it can still be run in a situation
|
||||
-- where we'd otherwise report 406).
|
||||
addAcceptCheck :: Delayed env a
|
||||
-> DelayedIO ()
|
||||
-> Delayed env a
|
||||
addAcceptCheck Delayed{..} new =
|
||||
Delayed
|
||||
{ bodyD = new *> bodyD
|
||||
, ..
|
||||
} -- Note [Existential Record Update]
|
||||
|
||||
-- | Many combinators extract information that is passed to
|
||||
-- the handler without the possibility of failure. In such a
|
||||
-- case, 'passToServer' can be used.
|
||||
passToServer :: Delayed (a -> b) -> a -> Delayed b
|
||||
passToServer d x = ($ x) <$> d
|
||||
|
||||
-- | The combination 'IO . RouteResult' is a monad, but we
|
||||
-- don't explicitly wrap it in a newtype in order to make it
|
||||
-- an instance. This is the '>>=' of that monad.
|
||||
--
|
||||
-- We stop on the first error.
|
||||
bindRouteResults :: IO (RouteResult a) -> (a -> IO (RouteResult b)) -> IO (RouteResult b)
|
||||
bindRouteResults m f = do
|
||||
r <- m
|
||||
case r of
|
||||
Fail e -> return $ Fail e
|
||||
FailFatal e -> return $ FailFatal e
|
||||
Route a -> f a
|
||||
|
||||
-- | Common special case of 'bindRouteResults', corresponding
|
||||
-- to 'liftM2'.
|
||||
combineRouteResults :: (a -> b -> c) -> IO (RouteResult a) -> IO (RouteResult b) -> IO (RouteResult c)
|
||||
combineRouteResults f m1 m2 =
|
||||
m1 `bindRouteResults` \ a ->
|
||||
m2 `bindRouteResults` \ b ->
|
||||
return (Route (f a b))
|
||||
passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b
|
||||
passToServer Delayed{..} x =
|
||||
Delayed
|
||||
{ serverD = \ c a b req -> ($ x req) <$> serverD c a b req
|
||||
, ..
|
||||
} -- Note [Existential Record Update]
|
||||
|
||||
-- | Run a delayed server. Performs all scheduled operations
|
||||
-- in order, and passes the results from the capture and body
|
||||
|
@ -234,24 +238,29 @@ combineRouteResults f m1 m2 =
|
|||
--
|
||||
-- This should only be called once per request; otherwise the guarantees about
|
||||
-- effect and HTTP error ordering break down.
|
||||
runDelayed :: Delayed a
|
||||
runDelayed :: Delayed env a
|
||||
-> env
|
||||
-> Request
|
||||
-> IO (RouteResult a)
|
||||
runDelayed Delayed{..} =
|
||||
capturesD `bindRouteResults` \ c ->
|
||||
methodD `bindRouteResults` \ _ ->
|
||||
authD `bindRouteResults` \ a ->
|
||||
bodyD `bindRouteResults` \ b ->
|
||||
return (serverD c a b)
|
||||
runDelayed Delayed{..} env = runDelayedIO $ do
|
||||
c <- capturesD env
|
||||
methodD
|
||||
a <- authD
|
||||
b <- bodyD
|
||||
DelayedIO (\ req -> return $ serverD c a b req)
|
||||
|
||||
-- | Runs a delayed server and the resulting action.
|
||||
-- Takes a continuation that lets us send a response.
|
||||
-- Also takes a continuation for how to turn the
|
||||
-- result of the delayed server into a response.
|
||||
runAction :: Delayed (ExceptT ServantErr IO a)
|
||||
runAction :: Delayed env (Handler a)
|
||||
-> env
|
||||
-> Request
|
||||
-> (RouteResult Response -> IO r)
|
||||
-> (a -> RouteResult Response)
|
||||
-> IO r
|
||||
runAction action respond k = runDelayed action >>= go >>= respond
|
||||
runAction action env req respond k =
|
||||
runDelayed action env req >>= go >>= respond
|
||||
where
|
||||
go (Fail e) = return $ Fail e
|
||||
go (FailFatal e) = return $ FailFatal e
|
||||
|
|
|
@ -4,6 +4,7 @@
|
|||
module Servant.Server.Internal.ServantErr where
|
||||
|
||||
import Control.Exception (Exception)
|
||||
import Control.Monad.Trans.Except (ExceptT)
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Data.Typeable (Typeable)
|
||||
|
@ -18,6 +19,8 @@ data ServantErr = ServantErr { errHTTPCode :: Int
|
|||
|
||||
instance Exception ServantErr
|
||||
|
||||
type Handler = ExceptT ServantErr IO
|
||||
|
||||
responseServantErr :: ServantErr -> Response
|
||||
responseServantErr ServantErr{..} = responseLBS status errHeaders errBody
|
||||
where
|
||||
|
@ -27,8 +30,8 @@ responseServantErr ServantErr{..} = responseLBS status errHeaders errBody
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr $ err300 { errBody = "I can't choose." }
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError $ err300 { errBody = "I can't choose." }
|
||||
--
|
||||
err300 :: ServantErr
|
||||
err300 = ServantErr { errHTTPCode = 300
|
||||
|
@ -41,8 +44,8 @@ err300 = ServantErr { errHTTPCode = 300
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr err301
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError err301
|
||||
--
|
||||
err301 :: ServantErr
|
||||
err301 = ServantErr { errHTTPCode = 301
|
||||
|
@ -55,8 +58,8 @@ err301 = ServantErr { errHTTPCode = 301
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr err302
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError err302
|
||||
--
|
||||
err302 :: ServantErr
|
||||
err302 = ServantErr { errHTTPCode = 302
|
||||
|
@ -69,8 +72,8 @@ err302 = ServantErr { errHTTPCode = 302
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr err303
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError err303
|
||||
--
|
||||
err303 :: ServantErr
|
||||
err303 = ServantErr { errHTTPCode = 303
|
||||
|
@ -83,8 +86,8 @@ err303 = ServantErr { errHTTPCode = 303
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr err304
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError err304
|
||||
--
|
||||
err304 :: ServantErr
|
||||
err304 = ServantErr { errHTTPCode = 304
|
||||
|
@ -97,8 +100,8 @@ err304 = ServantErr { errHTTPCode = 304
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr err305
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError err305
|
||||
--
|
||||
err305 :: ServantErr
|
||||
err305 = ServantErr { errHTTPCode = 305
|
||||
|
@ -111,8 +114,8 @@ err305 = ServantErr { errHTTPCode = 305
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr err307
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError err307
|
||||
--
|
||||
err307 :: ServantErr
|
||||
err307 = ServantErr { errHTTPCode = 307
|
||||
|
@ -125,8 +128,8 @@ err307 = ServantErr { errHTTPCode = 307
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr $ err400 { errBody = "Your request makes no sense to me." }
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError $ err400 { errBody = "Your request makes no sense to me." }
|
||||
--
|
||||
err400 :: ServantErr
|
||||
err400 = ServantErr { errHTTPCode = 400
|
||||
|
@ -139,8 +142,8 @@ err400 = ServantErr { errHTTPCode = 400
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr $ err401 { errBody = "Your credentials are invalid." }
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError $ err401 { errBody = "Your credentials are invalid." }
|
||||
--
|
||||
err401 :: ServantErr
|
||||
err401 = ServantErr { errHTTPCode = 401
|
||||
|
@ -153,8 +156,8 @@ err401 = ServantErr { errHTTPCode = 401
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr $ err402 { errBody = "You have 0 credits. Please give me $$$." }
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError $ err402 { errBody = "You have 0 credits. Please give me $$$." }
|
||||
--
|
||||
err402 :: ServantErr
|
||||
err402 = ServantErr { errHTTPCode = 402
|
||||
|
@ -167,8 +170,8 @@ err402 = ServantErr { errHTTPCode = 402
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr $ err403 { errBody = "Please login first." }
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError $ err403 { errBody = "Please login first." }
|
||||
--
|
||||
err403 :: ServantErr
|
||||
err403 = ServantErr { errHTTPCode = 403
|
||||
|
@ -181,8 +184,8 @@ err403 = ServantErr { errHTTPCode = 403
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr $ err404 { errBody = "(╯°□°)╯︵ ┻━┻)." }
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError $ err404 { errBody = "(╯°□°)╯︵ ┻━┻)." }
|
||||
--
|
||||
err404 :: ServantErr
|
||||
err404 = ServantErr { errHTTPCode = 404
|
||||
|
@ -195,8 +198,8 @@ err404 = ServantErr { errHTTPCode = 404
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr $ err405 { errBody = "Your account privileges does not allow for this. Please pay $$$." }
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError $ err405 { errBody = "Your account privileges does not allow for this. Please pay $$$." }
|
||||
--
|
||||
err405 :: ServantErr
|
||||
err405 = ServantErr { errHTTPCode = 405
|
||||
|
@ -209,8 +212,8 @@ err405 = ServantErr { errHTTPCode = 405
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr err406
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError err406
|
||||
--
|
||||
err406 :: ServantErr
|
||||
err406 = ServantErr { errHTTPCode = 406
|
||||
|
@ -223,8 +226,8 @@ err406 = ServantErr { errHTTPCode = 406
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr err407
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError err407
|
||||
--
|
||||
err407 :: ServantErr
|
||||
err407 = ServantErr { errHTTPCode = 407
|
||||
|
@ -237,8 +240,8 @@ err407 = ServantErr { errHTTPCode = 407
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr $ err409 { errBody = "Transaction conflicts with 59879cb56c7c159231eeacdd503d755f7e835f74" }
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError $ err409 { errBody = "Transaction conflicts with 59879cb56c7c159231eeacdd503d755f7e835f74" }
|
||||
--
|
||||
err409 :: ServantErr
|
||||
err409 = ServantErr { errHTTPCode = 409
|
||||
|
@ -251,8 +254,8 @@ err409 = ServantErr { errHTTPCode = 409
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr $ err410 { errBody = "I know it was here at some point, but.. I blame bad luck." }
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError $ err410 { errBody = "I know it was here at some point, but.. I blame bad luck." }
|
||||
--
|
||||
err410 :: ServantErr
|
||||
err410 = ServantErr { errHTTPCode = 410
|
||||
|
@ -265,8 +268,8 @@ err410 = ServantErr { errHTTPCode = 410
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr err411
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError err411
|
||||
--
|
||||
err411 :: ServantErr
|
||||
err411 = ServantErr { errHTTPCode = 411
|
||||
|
@ -279,8 +282,8 @@ err411 = ServantErr { errHTTPCode = 411
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr $ err412 { errBody = "Precondition fail: x < 42 && y > 57" }
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError $ err412 { errBody = "Precondition fail: x < 42 && y > 57" }
|
||||
--
|
||||
err412 :: ServantErr
|
||||
err412 = ServantErr { errHTTPCode = 412
|
||||
|
@ -293,8 +296,8 @@ err412 = ServantErr { errHTTPCode = 412
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr $ err413 { errBody = "Request exceeded 64k." }
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError $ err413 { errBody = "Request exceeded 64k." }
|
||||
--
|
||||
err413 :: ServantErr
|
||||
err413 = ServantErr { errHTTPCode = 413
|
||||
|
@ -307,8 +310,8 @@ err413 = ServantErr { errHTTPCode = 413
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr $ err414 { errBody = "Maximum length is 64." }
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError $ err414 { errBody = "Maximum length is 64." }
|
||||
--
|
||||
err414 :: ServantErr
|
||||
err414 = ServantErr { errHTTPCode = 414
|
||||
|
@ -321,8 +324,8 @@ err414 = ServantErr { errHTTPCode = 414
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr $ err415 { errBody = "Supported media types: gif, png" }
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError $ err415 { errBody = "Supported media types: gif, png" }
|
||||
--
|
||||
err415 :: ServantErr
|
||||
err415 = ServantErr { errHTTPCode = 415
|
||||
|
@ -335,8 +338,8 @@ err415 = ServantErr { errHTTPCode = 415
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr $ err416 { errBody = "Valid range is [0, 424242]." }
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError $ err416 { errBody = "Valid range is [0, 424242]." }
|
||||
--
|
||||
err416 :: ServantErr
|
||||
err416 = ServantErr { errHTTPCode = 416
|
||||
|
@ -349,8 +352,8 @@ err416 = ServantErr { errHTTPCode = 416
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr $ err417 { errBody = "I found a quux in the request. This isn't going to work." }
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError $ err417 { errBody = "I found a quux in the request. This isn't going to work." }
|
||||
--
|
||||
err417 :: ServantErr
|
||||
err417 = ServantErr { errHTTPCode = 417
|
||||
|
@ -363,8 +366,8 @@ err417 = ServantErr { errHTTPCode = 417
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr $ err500 { errBody = "Exception in module A.B.C:55. Have a great day!" }
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError $ err500 { errBody = "Exception in module A.B.C:55. Have a great day!" }
|
||||
--
|
||||
err500 :: ServantErr
|
||||
err500 = ServantErr { errHTTPCode = 500
|
||||
|
@ -377,8 +380,8 @@ err500 = ServantErr { errHTTPCode = 500
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr $ err501 { errBody = "/v1/foo is not supported with quux in the request." }
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError $ err501 { errBody = "/v1/foo is not supported with quux in the request." }
|
||||
--
|
||||
err501 :: ServantErr
|
||||
err501 = ServantErr { errHTTPCode = 501
|
||||
|
@ -391,8 +394,8 @@ err501 = ServantErr { errHTTPCode = 501
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr $ err502 { errBody = "Tried gateway foo, bar, and baz. None responded." }
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError $ err502 { errBody = "Tried gateway foo, bar, and baz. None responded." }
|
||||
--
|
||||
err502 :: ServantErr
|
||||
err502 = ServantErr { errHTTPCode = 502
|
||||
|
@ -405,8 +408,8 @@ err502 = ServantErr { errHTTPCode = 502
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr $ err503 { errBody = "We're rewriting in PHP." }
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError $ err503 { errBody = "We're rewriting in PHP." }
|
||||
--
|
||||
err503 :: ServantErr
|
||||
err503 = ServantErr { errHTTPCode = 503
|
||||
|
@ -419,8 +422,8 @@ err503 = ServantErr { errHTTPCode = 503
|
|||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr $ err504 { errBody = "Backend foobar did not respond in 5 seconds." }
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError $ err504 { errBody = "Backend foobar did not respond in 5 seconds." }
|
||||
--
|
||||
err504 :: ServantErr
|
||||
err504 = ServantErr { errHTTPCode = 504
|
||||
|
@ -433,8 +436,8 @@ err504 = ServantErr { errHTTPCode = 504
|
|||
--
|
||||
-- Example usage:
|
||||
--
|
||||
-- > failingHandler :: ExceptT ServantErr IO ()
|
||||
-- > failingHandler = throwErr $ err505 { errBody = "I support HTTP/4.0 only." }
|
||||
-- > failingHandler :: Handler ()
|
||||
-- > failingHandler = throwError $ err505 { errBody = "I support HTTP/4.0 only." }
|
||||
--
|
||||
err505 :: ServantErr
|
||||
err505 = ServantErr { errHTTPCode = 505
|
||||
|
|
|
@ -1,11 +1,10 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
module Servant.Server.Internal.EnterSpec where
|
||||
module Servant.ArbitraryMonadServerSpec where
|
||||
|
||||
import qualified Control.Category as C
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.Proxy
|
||||
import Servant.API
|
||||
import Servant.Server
|
||||
|
@ -15,7 +14,7 @@ import Test.Hspec.Wai (get, matchStatus, post,
|
|||
shouldRespondWith, with)
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "module Servant.Server.Enter" $ do
|
||||
spec = describe "Arbitrary monad server" $ do
|
||||
enterSpec
|
||||
|
||||
type ReaderAPI = "int" :> Get '[JSON] Int
|
||||
|
@ -34,7 +33,7 @@ combinedAPI = Proxy
|
|||
readerServer' :: ServerT ReaderAPI (Reader String)
|
||||
readerServer' = return 1797 :<|> ask
|
||||
|
||||
fReader :: Reader String :~> ExceptT ServantErr IO
|
||||
fReader :: Reader String :~> Handler
|
||||
fReader = generalizeNat C.. (runReaderTNat "hi")
|
||||
|
||||
readerServer :: Server ReaderAPI
|
|
@ -53,6 +53,23 @@ errorOrderApi = Proxy
|
|||
errorOrderServer :: Server ErrorOrderApi
|
||||
errorOrderServer = \_ _ _ -> throwE err402
|
||||
|
||||
-- On error priorities:
|
||||
--
|
||||
-- We originally had
|
||||
--
|
||||
-- 404, 405, 401, 415, 400, 406, 402
|
||||
--
|
||||
-- but we changed this to
|
||||
--
|
||||
-- 404, 405, 401, 406, 415, 400, 402
|
||||
--
|
||||
-- for servant-0.7.
|
||||
--
|
||||
-- This change is due to the body check being irreversible (to support
|
||||
-- streaming). Any check done after the body check has to be made fatal,
|
||||
-- breaking modularity. We've therefore moved the accept check before
|
||||
-- the body check, to allow it being recoverable and modular, and this
|
||||
-- goes along with promoting the error priority of 406.
|
||||
errorOrderSpec :: Spec
|
||||
errorOrderSpec =
|
||||
describe "HTTP error order" $
|
||||
|
@ -86,18 +103,18 @@ errorOrderSpec =
|
|||
request goodMethod goodUrl [badAuth, badContentType, badAccept] badBody
|
||||
`shouldRespondWith` 401
|
||||
|
||||
it "has 415 as its fourth highest priority error" $ do
|
||||
it "has 406 as its fourth highest priority error" $ do
|
||||
request goodMethod goodUrl [goodAuth, badContentType, badAccept] badBody
|
||||
`shouldRespondWith` 406
|
||||
|
||||
it "has 415 as its fifth highest priority error" $ do
|
||||
request goodMethod goodUrl [goodAuth, badContentType, goodAccept] badBody
|
||||
`shouldRespondWith` 415
|
||||
|
||||
it "has 400 as its fifth highest priority error" $ do
|
||||
request goodMethod goodUrl [goodAuth, goodContentType, badAccept] badBody
|
||||
it "has 400 as its sixth highest priority error" $ do
|
||||
request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] badBody
|
||||
`shouldRespondWith` 400
|
||||
|
||||
it "has 406 as its sixth highest priority error" $ do
|
||||
request goodMethod goodUrl [goodAuth, goodContentType, badAccept] goodBody
|
||||
`shouldRespondWith` 406
|
||||
|
||||
it "has handler-level errors as last priority" $ do
|
||||
request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] goodBody
|
||||
`shouldRespondWith` 402
|
||||
|
|
|
@ -1,9 +1,9 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# OPTIONS_GHC -fdefer-type-errors #-}
|
||||
{-# OPTIONS_GHC -fdefer-type-errors -Wwarn #-}
|
||||
module Servant.Server.Internal.ContextSpec (spec) where
|
||||
|
||||
import Data.Proxy (Proxy (..))
|
||||
import Test.Hspec (Spec, describe, it, shouldBe, pending, context)
|
||||
import Test.Hspec (Spec, describe, it, shouldBe, context)
|
||||
import Test.ShouldNotTypecheck (shouldNotTypecheck)
|
||||
|
||||
import Servant.API
|
||||
|
@ -26,16 +26,17 @@ spec = do
|
|||
shouldNotTypecheck x
|
||||
|
||||
context "Show instance" $ do
|
||||
let cxt = 'a' :. True :. EmptyContext
|
||||
it "has a Show instance" $ do
|
||||
let cxt = 'a' :. True :. EmptyContext
|
||||
show cxt `shouldBe` "'a' :. True :. EmptyContext"
|
||||
|
||||
context "bracketing" $ do
|
||||
it "works" $ do
|
||||
let cxt = 'a' :. True :. EmptyContext
|
||||
show (Just cxt) `shouldBe` "Just ('a' :. True :. EmptyContext)"
|
||||
|
||||
it "works with operators" $ do
|
||||
let cxt = (1 :. 'a' :. EmptyContext) :<|> ('b' :. True :. EmptyContext)
|
||||
let cxt = ((1 :: Integer) :. 'a' :. EmptyContext) :<|> ('b' :. True :. EmptyContext)
|
||||
show cxt `shouldBe` "(1 :. 'a' :. EmptyContext) :<|> ('b' :. True :. EmptyContext)"
|
||||
|
||||
describe "descendIntoNamedContext" $ do
|
||||
|
|
294
servant-server/test/Servant/Server/RouterSpec.hs
Normal file
294
servant-server/test/Servant/Server/RouterSpec.hs
Normal 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
|
|
@ -9,9 +9,8 @@
|
|||
module Servant.Server.StreamingSpec where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Exception
|
||||
import Control.Exception hiding (Handler)
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import qualified Data.ByteString as Strict
|
||||
import qualified Data.ByteString.Lazy as Lazy
|
||||
import Network.HTTP.Types
|
||||
|
@ -66,7 +65,7 @@ spec = do
|
|||
-- - receives the first chunk
|
||||
-- - notifies serverReceivedFirstChunk
|
||||
-- - receives the rest of the request
|
||||
let handler :: Lazy.ByteString -> ExceptT ServantErr IO NoContent
|
||||
let handler :: Lazy.ByteString -> Handler NoContent
|
||||
handler input = liftIO $ do
|
||||
let prefix = Lazy.take 3 input
|
||||
prefix `shouldBe` "foo"
|
||||
|
|
|
@ -5,7 +5,6 @@
|
|||
|
||||
module Servant.Server.UsingContextSpec where
|
||||
|
||||
import Control.Monad.Trans.Except
|
||||
import Network.Wai
|
||||
import Test.Hspec (Spec, describe, it)
|
||||
import Test.Hspec.Wai
|
||||
|
@ -25,7 +24,7 @@ spec = do
|
|||
type OneEntryAPI =
|
||||
ExtractFromContext :> Get '[JSON] String
|
||||
|
||||
testServer :: String -> ExceptT ServantErr IO String
|
||||
testServer :: String -> Handler String
|
||||
testServer s = return s
|
||||
|
||||
oneEntryApp :: Application
|
||||
|
|
|
@ -20,7 +20,6 @@ module Servant.Server.UsingContextSpec.TestCombinators where
|
|||
import GHC.TypeLits
|
||||
|
||||
import Servant
|
||||
import Servant.Server.Internal.RoutingApplication
|
||||
|
||||
data ExtractFromContext
|
||||
|
||||
|
@ -31,12 +30,12 @@ instance (HasContextEntry context String, HasServer subApi context) =>
|
|||
String -> ServerT subApi m
|
||||
|
||||
route Proxy context delayed =
|
||||
route subProxy context (fmap (inject context) delayed :: Delayed (Server subApi))
|
||||
route subProxy context (fmap inject delayed)
|
||||
where
|
||||
subProxy :: Proxy subApi
|
||||
subProxy = Proxy
|
||||
|
||||
inject context f = f (getContextEntry context)
|
||||
inject f = f (getContextEntry context)
|
||||
|
||||
data InjectIntoContext
|
||||
|
||||
|
|
|
@ -13,14 +13,13 @@
|
|||
|
||||
module Servant.ServerSpec where
|
||||
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
import Control.Applicative ((<$>))
|
||||
#endif
|
||||
import Control.Monad (forM_, when, unless)
|
||||
import Control.Monad.Trans.Except (ExceptT, throwE)
|
||||
import Control.Monad.Trans.Except (throwE)
|
||||
import Data.Aeson (FromJSON, ToJSON, decode', encode)
|
||||
import qualified Data.ByteString.Base64 as Base64
|
||||
import Data.ByteString.Conversion ()
|
||||
import Data.Char (toUpper)
|
||||
import Data.Monoid
|
||||
import Data.Proxy (Proxy (Proxy))
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions (cs)
|
||||
|
@ -30,11 +29,11 @@ import Network.HTTP.Types (Status (..), hAccept, hContentType,
|
|||
methodDelete, methodGet,
|
||||
methodHead, methodPatch,
|
||||
methodPost, methodPut, ok200,
|
||||
imATeaPot418,
|
||||
parseQuery)
|
||||
import Network.Wai (Application, Request, requestHeaders, pathInfo,
|
||||
queryString, rawQueryString,
|
||||
responseBuilder, responseLBS)
|
||||
import Network.Wai.Internal (Response (ResponseBuilder))
|
||||
responseLBS)
|
||||
import Network.Wai.Test (defaultRequest, request,
|
||||
runSession, simpleBody,
|
||||
simpleHeaders, simpleStatus)
|
||||
|
@ -49,8 +48,9 @@ import Servant.API ((:<|>) (..), (:>), AuthProtect,
|
|||
Raw, RemoteHost, ReqBody,
|
||||
StdMethod (..), Verb, addHeader)
|
||||
import Servant.API.Internal.Test.ComprehensiveAPI
|
||||
import Servant.Server (ServantErr (..), Server, err401, err404,
|
||||
serve, serveWithContext, Context((:.), EmptyContext))
|
||||
import Servant.Server (Server, Handler, err401, err403,
|
||||
err404, serve, serveWithContext,
|
||||
Context((:.), EmptyContext))
|
||||
import Test.Hspec (Spec, context, describe, it,
|
||||
shouldBe, shouldContain)
|
||||
import qualified Test.Hspec.Wai as THW
|
||||
|
@ -63,11 +63,6 @@ import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthChec
|
|||
import Servant.Server.Experimental.Auth
|
||||
(AuthHandler, AuthServerData,
|
||||
mkAuthHandler)
|
||||
import Servant.Server.Internal.RoutingApplication
|
||||
(toApplication, RouteResult(..))
|
||||
import Servant.Server.Internal.Router
|
||||
(tweakResponse, runRouter,
|
||||
Router, Router'(LeafRouter))
|
||||
import Servant.Server.Internal.Context
|
||||
(NamedContext(..))
|
||||
|
||||
|
@ -91,7 +86,6 @@ spec = do
|
|||
rawSpec
|
||||
alternativeSpec
|
||||
responseHeadersSpec
|
||||
routerSpec
|
||||
miscCombinatorSpec
|
||||
basicAuthSpec
|
||||
genAuthSpec
|
||||
|
@ -105,6 +99,9 @@ type VerbApi method status
|
|||
:<|> "noContent" :> Verb method status '[JSON] NoContent
|
||||
:<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person)
|
||||
:<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent)
|
||||
:<|> "accept" :> ( Verb method status '[JSON] Person
|
||||
:<|> Verb method status '[PlainText] String
|
||||
)
|
||||
|
||||
verbSpec :: Spec
|
||||
verbSpec = describe "Servant.API.Verb" $ do
|
||||
|
@ -113,6 +110,7 @@ verbSpec = describe "Servant.API.Verb" $ do
|
|||
:<|> return NoContent
|
||||
:<|> return (addHeader 5 alice)
|
||||
:<|> return (addHeader 10 NoContent)
|
||||
:<|> (return alice :<|> return "B")
|
||||
get200 = Proxy :: Proxy (VerbApi 'GET 200)
|
||||
post210 = Proxy :: Proxy (VerbApi 'POST 210)
|
||||
put203 = Proxy :: Proxy (VerbApi 'PUT 203)
|
||||
|
@ -167,6 +165,12 @@ verbSpec = describe "Servant.API.Verb" $ do
|
|||
[(hAccept, "application/json")] ""
|
||||
liftIO $ statusCode (simpleStatus response) `shouldBe` status
|
||||
|
||||
unless (status `elem` [214, 215] || method == methodHead) $
|
||||
it "allows modular specification of supported content types" $ do
|
||||
response <- THW.request method "/accept" [(hAccept, "text/plain")] ""
|
||||
liftIO $ statusCode (simpleStatus response) `shouldBe` status
|
||||
liftIO $ simpleBody response `shouldBe` "B"
|
||||
|
||||
it "sets the Content-Type header" $ do
|
||||
response <- THW.request method "" [] ""
|
||||
liftIO $ simpleHeaders response `shouldContain`
|
||||
|
@ -187,7 +191,7 @@ verbSpec = describe "Servant.API.Verb" $ do
|
|||
type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal
|
||||
captureApi :: Proxy CaptureApi
|
||||
captureApi = Proxy
|
||||
captureServer :: Integer -> ExceptT ServantErr IO Animal
|
||||
captureServer :: Integer -> Handler Animal
|
||||
captureServer legs = case legs of
|
||||
4 -> return jerry
|
||||
2 -> return tweety
|
||||
|
@ -343,11 +347,11 @@ headerApi = Proxy
|
|||
headerSpec :: Spec
|
||||
headerSpec = describe "Servant.API.Header" $ do
|
||||
|
||||
let expectsInt :: Maybe Int -> ExceptT ServantErr IO ()
|
||||
let expectsInt :: Maybe Int -> Handler ()
|
||||
expectsInt (Just x) = when (x /= 5) $ error "Expected 5"
|
||||
expectsInt Nothing = error "Expected an int"
|
||||
|
||||
let expectsString :: Maybe String -> ExceptT ServantErr IO ()
|
||||
let expectsString :: Maybe String -> Handler ()
|
||||
expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you"
|
||||
expectsString Nothing = error "Expected a string"
|
||||
|
||||
|
@ -479,28 +483,6 @@ responseHeadersSpec = describe "ResponseHeaders" $ do
|
|||
THW.request method "" [(hAccept, "crazy/mime")] ""
|
||||
`shouldRespondWith` 406
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * routerSpec {{{
|
||||
------------------------------------------------------------------------------
|
||||
routerSpec :: Spec
|
||||
routerSpec = do
|
||||
describe "Servant.Server.Internal.Router" $ do
|
||||
let app' :: Application
|
||||
app' = toApplication $ runRouter router'
|
||||
|
||||
router', router :: Router
|
||||
router' = tweakResponse (twk <$>) router
|
||||
router = LeafRouter $ \_ cont -> cont (Route $ responseBuilder (Status 201 "") [] "")
|
||||
|
||||
twk :: Response -> Response
|
||||
twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b
|
||||
twk b = b
|
||||
|
||||
describe "tweakResponse" . with (return app') $ do
|
||||
it "calls f on route result" $ do
|
||||
get "" `shouldRespondWith` 202
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * miscCombinatorSpec {{{
|
||||
|
@ -542,20 +524,24 @@ miscCombinatorSpec = with (return $ serve miscApi miscServ) $
|
|||
-- * Basic Authentication {{{
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
type BasicAuthAPI = BasicAuth "foo" () :> "basic" :> Get '[JSON] Animal
|
||||
type BasicAuthAPI =
|
||||
BasicAuth "foo" () :> "basic" :> Get '[JSON] Animal
|
||||
:<|> Raw
|
||||
|
||||
basicAuthApi :: Proxy BasicAuthAPI
|
||||
basicAuthApi = Proxy
|
||||
|
||||
basicAuthServer :: Server BasicAuthAPI
|
||||
basicAuthServer = const (return jerry)
|
||||
basicAuthServer =
|
||||
const (return jerry) :<|>
|
||||
(\ _ respond -> respond $ responseLBS imATeaPot418 [] "")
|
||||
|
||||
basicAuthContext :: Context '[ BasicAuthCheck () ]
|
||||
basicAuthContext =
|
||||
let basicHandler = BasicAuthCheck $ (\(BasicAuthData usr pass) ->
|
||||
let basicHandler = BasicAuthCheck $ \(BasicAuthData usr pass) ->
|
||||
if usr == "servant" && pass == "server"
|
||||
then return (Authorized ())
|
||||
else return Unauthorized
|
||||
)
|
||||
then return (Authorized ())
|
||||
else return Unauthorized
|
||||
in basicHandler :. EmptyContext
|
||||
|
||||
basicAuthSpec :: Spec
|
||||
|
@ -564,10 +550,21 @@ basicAuthSpec = do
|
|||
with (return (serveWithContext basicAuthApi basicAuthContext basicAuthServer)) $ do
|
||||
|
||||
context "Basic Authentication" $ do
|
||||
it "returns with 401 with bad password" $ do
|
||||
let basicAuthHeaders user password =
|
||||
[("Authorization", "Basic " <> Base64.encode (user <> ":" <> password))]
|
||||
it "returns 401 when no credentials given" $ do
|
||||
get "/basic" `shouldRespondWith` 401
|
||||
|
||||
it "returns 403 when invalid credentials given" $ do
|
||||
THW.request methodGet "/basic" (basicAuthHeaders "servant" "wrong") ""
|
||||
`shouldRespondWith` 403
|
||||
|
||||
it "returns 200 with the right password" $ do
|
||||
THW.request methodGet "/basic" [("Authorization","Basic c2VydmFudDpzZXJ2ZXI=")] "" `shouldRespondWith` 200
|
||||
THW.request methodGet "/basic" (basicAuthHeaders "servant" "server") ""
|
||||
`shouldRespondWith` 200
|
||||
|
||||
it "plays nice with subsequent Raw endpoints" $ do
|
||||
get "/foo" `shouldRespondWith` 418
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
|
@ -575,33 +572,43 @@ basicAuthSpec = do
|
|||
------------------------------------------------------------------------------
|
||||
|
||||
type GenAuthAPI = AuthProtect "auth" :> "auth" :> Get '[JSON] Animal
|
||||
authApi :: Proxy GenAuthAPI
|
||||
authApi = Proxy
|
||||
authServer :: Server GenAuthAPI
|
||||
authServer = const (return tweety)
|
||||
:<|> Raw
|
||||
|
||||
genAuthApi :: Proxy GenAuthAPI
|
||||
genAuthApi = Proxy
|
||||
|
||||
genAuthServer :: Server GenAuthAPI
|
||||
genAuthServer = const (return tweety)
|
||||
:<|> (\ _ respond -> respond $ responseLBS imATeaPot418 [] "")
|
||||
|
||||
type instance AuthServerData (AuthProtect "auth") = ()
|
||||
|
||||
genAuthContext :: Context '[ AuthHandler Request () ]
|
||||
genAuthContext :: Context '[AuthHandler Request ()]
|
||||
genAuthContext =
|
||||
let authHandler = (\req ->
|
||||
if elem ("Auth", "secret") (requestHeaders req)
|
||||
then return ()
|
||||
else throwE err401
|
||||
)
|
||||
let authHandler = \req -> case lookup "Auth" (requestHeaders req) of
|
||||
Just "secret" -> return ()
|
||||
Just _ -> throwE err403
|
||||
Nothing -> throwE err401
|
||||
in mkAuthHandler authHandler :. EmptyContext
|
||||
|
||||
genAuthSpec :: Spec
|
||||
genAuthSpec = do
|
||||
describe "Servant.API.Auth" $ do
|
||||
with (return (serveWithContext authApi genAuthContext authServer)) $ do
|
||||
with (return (serveWithContext genAuthApi genAuthContext genAuthServer)) $ do
|
||||
|
||||
context "Custom Auth Protection" $ do
|
||||
it "returns 401 when missing headers" $ do
|
||||
get "/auth" `shouldRespondWith` 401
|
||||
|
||||
it "returns 403 on wrong passwords" $ do
|
||||
THW.request methodGet "/auth" [("Auth","wrong")] "" `shouldRespondWith` 403
|
||||
|
||||
it "returns 200 with the right header" $ do
|
||||
THW.request methodGet "/auth" [("Auth","secret")] "" `shouldRespondWith` 200
|
||||
|
||||
it "plays nice with subsequent Raw endpoints" $ do
|
||||
get "/foo" `shouldRespondWith` 418
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * Test data types {{{
|
||||
|
|
|
@ -1,5 +1,11 @@
|
|||
0.7.1
|
||||
-----
|
||||
|
||||
* Add module `Servant.Utils.Enter` (https://github.com/haskell-servant/servant/pull/478)
|
||||
* Allow to set the same header multiple times in responses.
|
||||
|
||||
0.5
|
||||
----
|
||||
---
|
||||
|
||||
* Add `WithNamedConfig` combinator.
|
||||
* Add `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators
|
||||
|
|
|
@ -1,13 +1,13 @@
|
|||
name: servant
|
||||
version: 0.6
|
||||
version: 0.7.1
|
||||
synopsis: A family of combinators for defining webservices APIs
|
||||
description:
|
||||
A family of combinators for defining webservices APIs and serving them
|
||||
.
|
||||
You can learn about the basics in the <http://haskell-servant.github.io/tutorial tutorial>.
|
||||
You can learn about the basics in the <http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html tutorial>.
|
||||
.
|
||||
<https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md CHANGELOG>
|
||||
homepage: http://haskell-servant.github.io/
|
||||
homepage: http://haskell-servant.readthedocs.org/
|
||||
Bug-reports: http://github.com/haskell-servant/servant/issues
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
|
@ -16,9 +16,11 @@ maintainer: haskell-servant-maintainers@googlegroups.com
|
|||
copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors
|
||||
category: Web
|
||||
build-type: Simple
|
||||
extra-source-files: include/*.h
|
||||
cabal-version: >=1.10
|
||||
tested-with: GHC >= 7.8
|
||||
extra-source-files:
|
||||
include/*.h
|
||||
CHANGELOG.md
|
||||
source-repository head
|
||||
type: git
|
||||
location: http://github.com/haskell-servant/servant.git
|
||||
|
@ -45,8 +47,9 @@ library
|
|||
Servant.API.Verbs
|
||||
Servant.API.WithNamedContext
|
||||
Servant.Utils.Links
|
||||
Servant.Utils.Enter
|
||||
build-depends:
|
||||
base >= 4.7 && < 4.9
|
||||
base >= 4.7 && < 4.10
|
||||
, base-compat >= 0.9
|
||||
, aeson >= 0.7
|
||||
, attoparsec >= 0.12
|
||||
|
@ -56,6 +59,8 @@ library
|
|||
, http-api-data >= 0.1 && < 0.3
|
||||
, http-media >= 0.4 && < 0.7
|
||||
, http-types >= 0.8 && < 0.10
|
||||
, mtl >= 2 && < 3
|
||||
, mmorph >= 1
|
||||
, text >= 1 && < 2
|
||||
, string-conversions >= 0.3 && < 0.5
|
||||
, network-uri >= 2.6
|
||||
|
@ -83,12 +88,13 @@ library
|
|||
, TypeSynonymInstances
|
||||
, UndecidableInstances
|
||||
ghc-options: -Wall
|
||||
if impl(ghc >= 8.0)
|
||||
ghc-options: -Wno-redundant-constraints
|
||||
include-dirs: include
|
||||
|
||||
test-suite spec
|
||||
type: exitcode-stdio-1.0
|
||||
ghc-options:
|
||||
-Wall -fno-warn-name-shadowing -fno-warn-missing-signatures
|
||||
ghc-options: -Wall
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
main-is: Spec.hs
|
||||
|
@ -98,6 +104,7 @@ test-suite spec
|
|||
Servant.Utils.LinksSpec
|
||||
build-depends:
|
||||
base == 4.*
|
||||
, base-compat
|
||||
, aeson
|
||||
, attoparsec
|
||||
, bytestring
|
||||
|
@ -120,5 +127,5 @@ test-suite doctests
|
|||
main-is: test/Doctests.hs
|
||||
buildable: True
|
||||
default-language: Haskell2010
|
||||
ghc-options: -threaded
|
||||
ghc-options: -Wall -threaded
|
||||
include-dirs: include
|
||||
|
|
|
@ -1,9 +1,7 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
#endif
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# OPTIONS_HADDOCK not-home #-}
|
||||
|
|
|
@ -1,12 +1,13 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
|
||||
module Servant.API.BasicAuth where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Typeable (Typeable)
|
||||
import GHC.TypeLits (Symbol)
|
||||
import GHC.TypeLits (Symbol)
|
||||
|
||||
|
||||
-- | Combinator for <https://tools.ietf.org/html/rfc2617#section-2 Basic Access Authentication>.
|
||||
|
|
|
@ -154,7 +154,7 @@ newtype AcceptHeader = AcceptHeader BS.ByteString
|
|||
-- > instance Accept MyContentType where
|
||||
-- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8")
|
||||
-- >
|
||||
-- > instance Show a => MimeRender MyContentType where
|
||||
-- > instance Show a => MimeRender MyContentType a where
|
||||
-- > mimeRender _ val = pack ("This is MINE! " ++ show val)
|
||||
-- >
|
||||
-- > type MyAPI = "path" :> Get '[MyContentType] Int
|
||||
|
@ -169,7 +169,7 @@ class (AllMime list) => AllCTRender (list :: [*]) a where
|
|||
handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
|
||||
|
||||
instance OVERLAPPABLE_
|
||||
(AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where
|
||||
(Accept ct, AllMime cts, AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where
|
||||
handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
|
||||
where pctyps = Proxy :: Proxy (ct ': cts)
|
||||
amrs = allMimeRender pctyps val
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
module Servant.API.Experimental.Auth where
|
||||
|
||||
import Data.Typeable (Typeable)
|
||||
|
@ -11,4 +11,3 @@ import Data.Typeable (Typeable)
|
|||
--
|
||||
-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE.
|
||||
data AuthProtect (tag :: k) deriving (Typeable)
|
||||
|
||||
|
|
|
@ -3,7 +3,9 @@
|
|||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# OPTIONS_HADDOCK not-home #-}
|
||||
module Servant.API.Header where
|
||||
module Servant.API.Header (
|
||||
Header(..),
|
||||
) where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Typeable (Typeable)
|
||||
|
@ -25,5 +27,3 @@ data Header (sym :: Symbol) a = Header a
|
|||
-- >>> import Servant.API
|
||||
-- >>> import Data.Aeson
|
||||
-- >>> import Data.Text
|
||||
-- >>> data Book
|
||||
-- >>> instance ToJSON Book where { toJSON = undefined }
|
||||
|
|
|
@ -68,8 +68,7 @@ class BuildHeadersTo hs where
|
|||
instance OVERLAPPING_ BuildHeadersTo '[] where
|
||||
buildHeadersTo _ = HNil
|
||||
|
||||
instance OVERLAPPABLE_ ( FromByteString v, BuildHeadersTo xs, KnownSymbol h
|
||||
, Contains h xs ~ 'False)
|
||||
instance OVERLAPPABLE_ ( FromByteString v, BuildHeadersTo xs, KnownSymbol h )
|
||||
=> BuildHeadersTo ((Header h v) ': xs) where
|
||||
buildHeadersTo headers =
|
||||
let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
|
||||
|
@ -89,7 +88,7 @@ class GetHeaders ls where
|
|||
instance OVERLAPPING_ GetHeaders (HList '[]) where
|
||||
getHeaders _ = []
|
||||
|
||||
instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs))
|
||||
instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs) )
|
||||
=> GetHeaders (HList (Header h x ': xs)) where
|
||||
getHeaders hdrs = case hdrs of
|
||||
Header val `HCons` rest -> (headerName , toByteString' val):getHeaders rest
|
||||
|
@ -100,7 +99,7 @@ instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs))
|
|||
instance OVERLAPPING_ GetHeaders (Headers '[] a) where
|
||||
getHeaders _ = []
|
||||
|
||||
instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToByteString v)
|
||||
instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToByteString v )
|
||||
=> GetHeaders (Headers (Header h v ': rest) a) where
|
||||
getHeaders hs = getHeaders $ getHeadersHList hs
|
||||
|
||||
|
@ -112,20 +111,15 @@ class AddHeader h v orig new
|
|||
addHeader :: v -> orig -> new -- ^ N.B.: The same header can't be added multiple times
|
||||
|
||||
|
||||
instance OVERLAPPING_ ( KnownSymbol h, ToByteString v, Contains h (fst ': rest) ~ 'False)
|
||||
instance OVERLAPPING_ ( KnownSymbol h, ToByteString v )
|
||||
=> AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where
|
||||
addHeader a (Headers resp heads) = Headers resp (HCons (Header a) heads)
|
||||
|
||||
instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString v
|
||||
, new ~ (Headers '[Header h v] a))
|
||||
, new ~ (Headers '[Header h v] a) )
|
||||
=> AddHeader h v a new where
|
||||
addHeader a resp = Headers resp (HCons (Header a) HNil)
|
||||
|
||||
type family Contains x xs where
|
||||
Contains x ((Header x a) ': xs) = 'True
|
||||
Contains x ((Header y a) ': xs) = Contains x xs
|
||||
Contains x '[] = 'False
|
||||
|
||||
-- $setup
|
||||
-- >>> import Servant.API
|
||||
-- >>> import Data.Aeson
|
||||
|
|
|
@ -9,8 +9,8 @@ import Data.Vault.Lazy (Vault)
|
|||
--
|
||||
-- | Use 'Vault' in your API types to provide access to the 'Vault'
|
||||
-- of the request, which is a location shared by middlewares and applications
|
||||
-- to store arbitrary data. See 'Vault' for more details on how to actually
|
||||
-- use the vault in your handlers
|
||||
-- to store arbitrary data. See <https://hackage.haskell.org/package/vault vault>
|
||||
-- for more details on how to actually use the vault in your handlers
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
|
|
|
@ -14,7 +14,9 @@ import GHC.Generics (Generic)
|
|||
import GHC.TypeLits (Nat)
|
||||
import Network.HTTP.Types.Method (Method, StdMethod (..),
|
||||
methodDelete, methodGet, methodHead,
|
||||
methodPatch, methodPost, methodPut)
|
||||
methodPatch, methodPost, methodPut,
|
||||
methodTrace, methodConnect,
|
||||
methodOptions)
|
||||
|
||||
-- | @Verb@ is a general type for representing HTTP verbs (a.k.a. methods). For
|
||||
-- convenience, type synonyms for each verb with a 200 response code are
|
||||
|
@ -167,3 +169,12 @@ instance ReflectMethod 'PATCH where
|
|||
|
||||
instance ReflectMethod 'HEAD where
|
||||
reflectMethod _ = methodHead
|
||||
|
||||
instance ReflectMethod 'OPTIONS where
|
||||
reflectMethod _ = methodOptions
|
||||
|
||||
instance ReflectMethod 'TRACE where
|
||||
reflectMethod _ = methodTrace
|
||||
|
||||
instance ReflectMethod 'CONNECT where
|
||||
reflectMethod _ = methodConnect
|
||||
|
|
|
@ -8,12 +8,9 @@
|
|||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Servant.Server.Internal.Enter where
|
||||
module Servant.Utils.Enter where
|
||||
|
||||
import qualified Control.Category as C
|
||||
#if MIN_VERSION_mtl(2,2,1)
|
||||
import Control.Monad.Except
|
||||
#endif
|
||||
import Control.Monad.Identity
|
||||
import Control.Monad.Morph
|
||||
import Control.Monad.Reader
|
|
@ -72,14 +72,8 @@
|
|||
-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] ())
|
||||
-- >>> safeLink api bad_link
|
||||
-- ...
|
||||
-- Could not deduce (Or
|
||||
-- (IsElem' (Verb 'DELETE 200 '[JSON] ()) (Verb 'GET 200 '[JSON] Int))
|
||||
-- (IsElem'
|
||||
-- ("hello" :> Delete '[JSON] ())
|
||||
-- ("bye" :> (QueryParam "name" String :> Delete '[JSON] ()))))
|
||||
-- arising from a use of ‘safeLink’
|
||||
-- In the expression: safeLink api bad_link
|
||||
-- In an equation for ‘it’: it = safeLink api bad_link
|
||||
-- ...Could not deduce...
|
||||
-- ...
|
||||
--
|
||||
-- This error is essentially saying that the type family couldn't find
|
||||
-- bad_link under api after trying the open (but empty) type family
|
||||
|
@ -112,10 +106,12 @@ import Prelude ()
|
|||
import Prelude.Compat
|
||||
|
||||
import Web.HttpApiData
|
||||
import Servant.API.BasicAuth ( BasicAuth )
|
||||
import Servant.API.Capture ( Capture )
|
||||
import Servant.API.ReqBody ( ReqBody )
|
||||
import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag )
|
||||
import Servant.API.Header ( Header )
|
||||
import Servant.API.RemoteHost ( RemoteHost )
|
||||
import Servant.API.Verbs ( Verb )
|
||||
import Servant.API.Sub ( type (:>) )
|
||||
import Servant.API.Raw ( Raw )
|
||||
|
@ -292,6 +288,14 @@ instance HasLink sub => HasLink (Header sym a :> sub) where
|
|||
type MkLink (Header sym a :> sub) = MkLink sub
|
||||
toLink _ = toLink (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (RemoteHost :> sub) where
|
||||
type MkLink (RemoteHost :> sub) = MkLink sub
|
||||
toLink _ = toLink (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (BasicAuth realm a :> sub) where
|
||||
type MkLink (BasicAuth realm a :> sub) = MkLink sub
|
||||
toLink _ = toLink (Proxy :: Proxy sub)
|
||||
|
||||
-- Verb (terminal) instances
|
||||
instance HasLink (Verb m s ct a) where
|
||||
type MkLink (Verb m s ct a) = URI
|
||||
|
|
|
@ -3,14 +3,14 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Servant.API.ContentTypesSpec where
|
||||
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
import Control.Applicative
|
||||
import Data.Monoid
|
||||
#endif
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Control.Arrow
|
||||
import Data.Aeson
|
||||
import Data.ByteString.Char8 (ByteString, append, pack)
|
||||
|
@ -28,7 +28,7 @@ import GHC.Generics
|
|||
import Network.URL (exportParams, importParams)
|
||||
import Test.Hspec
|
||||
import Test.QuickCheck
|
||||
import Test.QuickCheck.Instances ()
|
||||
import "quickcheck-instances" Test.QuickCheck.Instances ()
|
||||
|
||||
import Servant.API.ContentTypes
|
||||
|
||||
|
|
|
@ -67,27 +67,27 @@ spec = describe "Servant.Utils.Links" $ do
|
|||
--
|
||||
-- >>> apiLink (Proxy :: Proxy WrongPath)
|
||||
-- ...
|
||||
-- Could not deduce ...
|
||||
-- ...Could not deduce...
|
||||
-- ...
|
||||
--
|
||||
-- >>> apiLink (Proxy :: Proxy WrongReturnType)
|
||||
-- ...
|
||||
-- Could not deduce ...
|
||||
-- ...Could not deduce...
|
||||
-- ...
|
||||
--
|
||||
-- >>> apiLink (Proxy :: Proxy WrongContentType)
|
||||
-- ...
|
||||
-- Could not deduce ...
|
||||
-- ...Could not deduce...
|
||||
-- ...
|
||||
--
|
||||
-- >>> apiLink (Proxy :: Proxy WrongMethod)
|
||||
-- ...
|
||||
-- Could not deduce ...
|
||||
-- ...Could not deduce...
|
||||
-- ...
|
||||
--
|
||||
-- >>> apiLink (Proxy :: Proxy NotALink)
|
||||
-- ...
|
||||
-- Could not deduce ...
|
||||
-- ...Could not deduce...
|
||||
-- ...
|
||||
--
|
||||
-- sanity check
|
||||
|
|
|
@ -1,10 +1,7 @@
|
|||
servant
|
||||
servant-cassava
|
||||
servant-server
|
||||
servant-client
|
||||
servant-docs
|
||||
servant-foreign
|
||||
servant-js
|
||||
servant-server
|
||||
servant-blaze
|
||||
servant-lucid
|
||||
servant-mock
|
||||
|
|
|
@ -1,28 +1,28 @@
|
|||
flags: {}
|
||||
packages:
|
||||
- servant/
|
||||
- servant-blaze/
|
||||
- servant-cassava/
|
||||
- servant-client/
|
||||
- servant-docs/
|
||||
- servant-examples/
|
||||
- servant-foreign/
|
||||
- servant-js/
|
||||
- servant-lucid/
|
||||
- servant-mock/
|
||||
- servant-server/
|
||||
extra-deps:
|
||||
- base-compat-0.9.0
|
||||
- hspec-2.2.0
|
||||
- hspec-core-2.2.0
|
||||
- hspec-discover-2.2.0
|
||||
- hspec-expectations-0.7.2
|
||||
- doctest-0.10.1
|
||||
- engine-io-1.2.10
|
||||
- engine-io-wai-1.0.3
|
||||
- socket-io-1.3.3
|
||||
- stm-delay-0.1.1.1
|
||||
- base-compat-0.9.1
|
||||
- control-monad-omega-0.3.1
|
||||
- http-api-data-0.1.1.1
|
||||
- should-not-typecheck-2.0.1
|
||||
- cryptonite-0.6
|
||||
- doctest-0.11.0
|
||||
- hspec-2.2.3
|
||||
- hspec-core-2.2.3
|
||||
- hspec-discover-2.2.3
|
||||
- hspec-expectations-0.7.2
|
||||
- http-api-data-0.2.2
|
||||
- primitive-0.6.1.0
|
||||
- servant-0.7.1
|
||||
- servant-client-0.7.1
|
||||
- servant-docs-0.7.1
|
||||
- servant-server-0.7.1
|
||||
- should-not-typecheck-2.1.0
|
||||
- time-locale-compat-0.1.1.1
|
||||
- wai-app-static-3.1.5
|
||||
resolver: lts-2.22
|
||||
|
|
11
stack-ghc-8.0.1.yaml
Normal file
11
stack-ghc-8.0.1.yaml
Normal 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
16
stack.yaml
|
@ -1,24 +1,12 @@
|
|||
flags:
|
||||
servant-js:
|
||||
example: false
|
||||
flags: {}
|
||||
packages:
|
||||
- servant/
|
||||
- servant-blaze/
|
||||
- servant-cassava/
|
||||
- servant-client/
|
||||
- servant-docs/
|
||||
- servant-foreign/
|
||||
- servant-js/
|
||||
- servant-lucid/
|
||||
- servant-mock/
|
||||
- servant-server/
|
||||
- doc/tutorial
|
||||
extra-deps:
|
||||
- base-compat-0.9.0
|
||||
- engine-io-wai-1.0.2
|
||||
- control-monad-omega-0.3.1
|
||||
- should-not-typecheck-2.0.1
|
||||
- markdown-unlit-0.4.0
|
||||
- aeson-0.11.0.0
|
||||
- fail-4.9.0.0
|
||||
resolver: nightly-2016-03-17
|
||||
resolver: lts-6.0
|
||||
|
|
|
@ -6,7 +6,7 @@ for package in $(cat sources.txt) doc/tutorial ; do
|
|||
echo testing $package
|
||||
pushd $package
|
||||
tinc
|
||||
cabal configure --enable-tests --disable-optimization
|
||||
cabal configure --enable-tests --disable-optimization --ghc-options='-Werror'
|
||||
cabal build
|
||||
cabal test
|
||||
popd
|
||||
|
|
Loading…
Reference in a new issue