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

Merge branch 'master' of github.com:haskell-servant/servant into client-ghcjs

Browse source
This commit is contained in:
Falco Peijnenburg 2016-09-26 14:48:39 +02:00
commit 2082abf17b
55 changed files with 814 additions and 736 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

28
.travis.yml
View file

@ -3,33 +3,27 @@ sudo: false
language: c
env:
- GHCVER=7.8.4 CABALVER=1.22
- GHCVER=7.10.3 CABALVER=1.22
- GHCVER=8.0.1 CABALVER=1.24
- STACK_YAML=stack-ghc-7.8.4.yaml
- STACK_YAML=stack.yaml
- STACK_YAML=stack-ghc-8.0.1.yaml
addons:
apt:
sources:
- hvr-ghc
packages:
- ghc-7.8.4
- 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/$CABALVER/bin:$PATH
- ghc --version
- cabal --version
- travis_retry cabal update
- sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
- mkdir -p ~/.local/bin
- export PATH=$HOME/.local/bin:$PATH
- travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
- stack --version
- stack setup --no-terminal
- (cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc)
script:
- ./travis.sh
- if [ "$TRAVIS_EVENT_TYPE" = "cron" ] ; then ./scripts/ci-cron.sh ; else stack test --ghc-options=-Werror --no-terminal ; fi
cache:
directories:
- $HOME/.tinc/cache
- $HOME/.stack

3
CONTRIBUTING.md
View file

@ -8,9 +8,10 @@ repository. You can use `cabal`:
./scripts/test-all.sh # Run all the tests
```
`stack`:
Or `stack`:
```shell
stack setup # Downloads and installs a proper GHC version if necessary
stack build # Install and build packages
stack test # Run all the tests
```

2
doc/requirements.txt
View file

@ -17,7 +17,7 @@ recommonmark==0.4.0
singledispatch==3.4.0.3
six==1.10.0
snowballstemmer==1.2.1
Sphinx==1.3.4
Sphinx==1.3.6
sphinx-autobuild==0.5.2
sphinx-rtd-theme==0.1.9
tornado==4.3

12
doc/tutorial/ApiType.lhs
View file

@ -58,6 +58,14 @@ Let's break that down:
is equivalent to `/list-all/users`. This means that sometimes `:>` is somehow
equivalent to `/`, but sometimes it just lets you chain another combinator.
Tip: If your endpoint responds to `/` (the root path), just omit any combinators
that introduce path segments. E.g. the following api has only one endpoint on `/`:
``` haskell
type RootEndpoint =
Get '[JSON] User
```
We can also describe APIs with multiple endpoints by using the `:<|>`
combinators. Here's an example:
@ -311,8 +319,8 @@ Which is used like so:
``` haskell
type ProtectedAPI12
= UserAPI -- this is public
:<|> BasicAuth "my-real" User :> UserAPI2 -- this is protected by auth
= UserAPI -- this is public
:<|> BasicAuth "my-realm" User :> UserAPI2 -- this is protected by auth
```
### Interoperability with `wai`: `Raw`

27
doc/tutorial/Client.lhs
View file

@ -15,11 +15,10 @@ need to have some language extensions and imports:
module Client where
import Control.Monad.Trans.Except (ExceptT, runExceptT)
import Data.Aeson
import Data.Proxy
import GHC.Generics
import Network.HTTP.Client (Manager, newManager, defaultManagerSettings)
import Network.HTTP.Client (newManager, defaultManagerSettings)
import Servant.API
import Servant.Client
```
@ -71,19 +70,13 @@ What we are going to get with **servant-client** here is 3 functions, one to que
``` haskell
position :: Int -- ^ value for "x"
-> Int -- ^ value for "y"
-> Manager -- ^ the HTTP client to use
-> BaseUrl -- ^ the URL at which the API can be found
-> ExceptT ServantError IO Position
-> ClientM Position
hello :: Maybe String -- ^ an optional value for "name"
-> Manager -- ^ the HTTP client to use
-> BaseUrl -- ^ the URL at which the API can be found
-> ExceptT ServantError IO HelloMessage
-> ClientM HelloMessage
marketing :: ClientInfo -- ^ value for the request body
-> Manager -- ^ the HTTP client to use
-> BaseUrl -- ^ the URL at which the API can be found
-> ExceptT ServantError IO Email
-> ClientM Email
```
Each function makes available as an argument any value that the response may
@ -120,17 +113,17 @@ data BaseUrl = BaseUrl
That's it. Let's now write some code that uses our client functions.
``` haskell
queries :: Manager -> BaseUrl -> ExceptT ServantError IO (Position, HelloMessage, Email)
queries manager baseurl = do
pos <- position 10 10 manager baseurl
message <- hello (Just "servant") manager baseurl
em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]) manager baseurl
queries :: ClientM (Position, HelloMessage, Email)
queries = do
pos <- position 10 10
message <- hello (Just "servant")
em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"])
return (pos, message, em)
run :: IO ()
run = do
manager <- newManager defaultManagerSettings
res <- runExceptT (queries manager (BaseUrl Http "localhost" 8081 ""))
res <- runClientM queries (ClientEnv manager (BaseUrl Http "localhost" 8081 ""))
case res of
Left err -> putStrLn $ "Error: " ++ show err
Right (pos, message, em) -> do

334
doc/tutorial/Javascript.lhs
View file

@ -151,21 +151,120 @@ so we need a `Proxy` for our API type `API'` without its `Raw` endpoint.
Very similarly to how one can derive haskell functions, we can derive the
javascript with just a simple function call to `jsForAPI` from
`Servant.JQuery`.
`Servant.JS`.
``` haskell
apiJS :: Text
apiJS = jsForAPI api vanillaJS
apiJS1 :: Text
apiJS1 = jsForAPI api jquery
```
This `Text` contains 2 Javascript functions, 'getPoint' and 'getBooks':
``` javascript
var getPoint = function(onSuccess, onError)
{
$.ajax(
{ url: '/point'
, success: onSuccess
, error: onError
, type: 'GET'
});
}
var getBooks = function(q, onSuccess, onError)
{
$.ajax(
{ url: '/books' + '?q=' + encodeURIComponent(q)
, success: onSuccess
, error: onError
, type: 'GET'
});
}
```
We created a directory `static` that contains two static files: `index.html`,
which is the entrypoint to our little web application; and `ui.js`, which
contains some hand-written javascript. This javascript code assumes the two
generated functions `getPoint` and `getBooks` in scope. Therefore we need to
write the generated javascript into a file:
``` haskell
writeJSFiles :: IO ()
writeJSFiles = do
T.writeFile "static/api.js" apiJS1
jq <- T.readFile =<< Language.Javascript.JQuery.file
T.writeFile "static/jq.js" jq
```
(We're also writing the jquery library into a file, as it's also used by
`ui.js`.) `static/api.js` will be included in `index.html` and the two
generated functions will therefore be available in `ui.js`.
And we're good to go. You can start the `main` function of this file and go to
`http://localhost:8000/`. Start typing in the name of one of the authors in our
database or part of a book title, and check out how long it takes to
approximate pi using the method mentioned above.
## Customizations
Instead of calling `jquery`, you can call its variant `jqueryWith`.
Here are the type definitions
```haskell ignore
jquery :: JavaScriptGenerator
jqueryWith :: CommonGeneratorOptions -> JavaScriptGenerator
```
The `CommonGeneratorOptions` will let you define different behaviors to
change how functions are generated. Here is the definition of currently
available options:
```haskell ignore
data CommonGeneratorOptions = CommonGeneratorOptions
{
-- | function generating function names
functionNameBuilder :: FunctionName -> Text
-- | name used when a user want to send the request body (to let you redefine it)
, requestBody :: Text
-- | name of the callback parameter when the request was successful
, successCallback :: Text
-- | name of the callback parameter when the request reported an error
, errorCallback :: Text
-- | namespace on which we define the js function (empty mean local var)
, moduleName :: Text
-- | a prefix that should be prepended to the URL in the generated JS
, urlPrefix :: Text
}
```
This pattern is available with all supported backends, and default values are provided.
## Vanilla support
If you don't use JQuery for your application, you can reduce your
dependencies to simply use the `XMLHttpRequest` object from the standard API.
Use the same code as before but simply replace the previous `apiJS` with
the following one:
``` haskell
apiJS2 :: Text
apiJS2 = jsForAPI api vanillaJS
```
The rest is *completely* unchanged.
The output file is a bit different, but it has the same parameters,
``` javascript
var getPoint = function(onSuccess, onError)
{
var xhr = new XMLHttpRequest();
xhr.open('GET', '/point', true);
xhr.setRequestHeader("Accept","application/json");
xhr.setRequestHeader(\"Accept\",\"application/json\");
xhr.onreadystatechange = function (e) {
if (xhr.readyState == 4) {
if (xhr.status == 204 || xhr.status == 205) {
@ -186,7 +285,7 @@ var getBooks = function(q, onSuccess, onError)
{
var xhr = new XMLHttpRequest();
xhr.open('GET', '/books' + '?q=' + encodeURIComponent(q), true);
xhr.setRequestHeader("Accept","application/json");
xhr.setRequestHeader(\"Accept\",\"application/json\");
xhr.onreadystatechange = function (e) {
if (xhr.readyState == 4) {
if (xhr.status == 204 || xhr.status == 205) {
@ -202,27 +301,218 @@ var getBooks = function(q, onSuccess, onError)
}
xhr.send(null);
}
```
We created a directory `static` that contains two static files: `index.html`,
which is the entrypoint to our little web application; and `ui.js`, which
contains some hand-written javascript. This javascript code assumes the two
generated functions `getPoint` and `getBooks` in scope. Therefore we need to
write the generated javascript into a file:
And that's all, your web service can of course be accessible from those
two clients at the same time!
## Axios support
### Simple usage
If you use Axios library for your application, we support that too!
Use the same code as before but simply replace the previous `apiJS` with
the following one:
``` haskell
writeJSFiles :: IO ()
writeJSFiles = do
T.writeFile "static/api.js" apiJS
jq <- T.readFile =<< Language.Javascript.JQuery.file
T.writeFile "static/jq.js" jq
apiJS3 :: Text
apiJS3 = jsForAPI api $ axios defAxiosOptions
```
(We're also writing the jquery library into a file, as it's also used by
`ui.js`.) `static/api.js` will be included in `index.html` and the two
generated functions will therefore be available in `ui.js`.
The rest is *completely* unchanged.
The output file is a bit different,
``` javascript
var getPoint = function()
{
return axios({ url: '/point'
, method: 'get'
});
}
var getBooks = function(q)
{
return axios({ url: '/books' + '?q=' + encodeURIComponent(q)
, method: 'get'
});
}
```
**Caution:** In order to support the promise style of the API, there are no onSuccess
nor onError callback functions.
### Defining Axios configuration
Axios lets you define a 'configuration' to determine the behavior of the
program when the AJAX request is sent.
We mapped this into a configuration
``` haskell
data AxiosOptions = AxiosOptions
{ -- | indicates whether or not cross-site Access-Control requests
-- should be made using credentials
withCredentials :: !Bool
-- | the name of the cookie to use as a value for xsrf token
, xsrfCookieName :: !(Maybe Text)
-- | the name of the header to use as a value for xsrf token
, xsrfHeaderName :: !(Maybe Text)
}
```
## Angular support
### Simple usage
You can apply the same procedure as with `vanillaJS` and `jquery`, and
generate top level functions.
The difference is that `angular` Generator always takes an argument.
``` haskell
apiJS4 :: Text
apiJS4 = jsForAPI api $ angular defAngularOptions
```
The generated code will be a bit different than previous generators. An extra
argument `$http` will be added to let Angular magical Dependency Injector
operate.
**Caution:** In order to support the promise style of the API, there are no onSuccess
nor onError callback functions.
``` javascript
var getPoint = function($http)
{
return $http(
{ url: '/point'
, method: 'GET'
});
}
var getBooks = function($http, q)
{
return $http(
{ url: '/books' + '?q=' + encodeURIComponent(q)
, method: 'GET'
});
}
```
You can then build your controllers easily
``` javascript
app.controller("MyController", function($http) {
this.getPoint = getPoint($http)
.success(/* Do something */)
.error(/* Report error */);
this.getPoint = getBooks($http, q)
.success(/* Do something */)
.error(/* Report error */);
});
```
### Service generator
You can also generate automatically a service to wrap the whole API as
a single Angular service:
``` javascript
app.service('MyService', function($http) {
return ({
postCounter: function()
{
return $http(
{ url: '/counter'
, method: 'POST'
});
},
getCounter: function()
{
return $http(
{ url: '/books' + '?q=' + encodeURIComponent(q), true);
, method: 'GET'
});
}
});
});
```
To do so, you just have to use an alternate generator.
``` haskell
apiJS5 :: Text
apiJS5 = jsForAPI api $ angularService defAngularOptions
```
Again, it is possible to customize some portions with the options.
``` haskell
data AngularOptions = AngularOptions
{ -- | When generating code with wrapInService, name of the service to generate, default is 'app'
serviceName :: Text
, -- | beginning of the service definition
prologue :: Text -> Text -> Text
, -- | end of the service definition
epilogue :: Text
}
```
# Custom function name builder
Servant comes with three name builders included:
- camelCase (the default)
- concatCase
- snakeCase
Keeping the JQuery as an example, let's see the impact:
``` haskell
apiJS6 :: Text
apiJS6 = jsForAPI api $ jqueryWith defCommonGeneratorOptions { functionNameBuilder= snakeCase }
```
This `Text` contains 2 Javascript functions:
``` javascript
var get_point = function(onSuccess, onError)
{
$.ajax(
{ url: '/point'
, success: onSuccess
, error: onError
, type: 'GET'
});
}
var get_books = function(q, onSuccess, onError)
{
$.ajax(
{ url: '/books' + '?q=' + encodeURIComponent(q)
, success: onSuccess
, error: onError
, type: 'GET'
});
}
```
And we're good to go. You can start the `main` function of this file and go to
`http://localhost:8000/`. Start typing in the name of one of the authors in our
database or part of a book title, and check out how long it takes to
approximate pi using the method mentioned above.

7
doc/tutorial/test/JavascriptSpec.hs
View file

@ -15,7 +15,10 @@ spec = do
describe "apiJS" $ do
it "is contained verbatim in Javascript.lhs" $ do
code <- readFile "Javascript.lhs"
cs apiJS `shouldSatisfy` (`isInfixOf` code)
cs apiJS1 `shouldSatisfy` (`isInfixOf` code)
cs apiJS3 `shouldSatisfy` (`isInfixOf` code)
cs apiJS4 `shouldSatisfy` (`isInfixOf` code)
cs apiJS6 `shouldSatisfy` (`isInfixOf` code)
describe "writeJSFiles" $ do
it "[not a test] write apiJS to static/api.js" $ do
@ -24,7 +27,7 @@ spec = do
describe "app" $ with (return app) $ do
context "/api.js" $ do
it "delivers apiJS" $ do
get "/api.js" `shouldRespondWith` (fromString (cs apiJS))
get "/api.js" `shouldRespondWith` (fromString (cs apiJS1))
context "/" $ do
it "delivers something" $ do

12
doc/tutorial/tutorial.cabal
View file

@ -1,5 +1,5 @@
name: tutorial
version: 0.8
version: 0.9
synopsis: The servant tutorial
homepage: http://haskell-servant.readthedocs.org/
license: BSD3
@ -25,11 +25,11 @@ library
, directory
, blaze-markup
, containers
, servant == 0.8.*
, servant-server == 0.8.*
, servant-client == 0.8.*
, servant-docs == 0.8.*
, servant-js == 0.8.*
, servant == 0.9.*
, servant-server == 0.9.*
, servant-client == 0.9.*
, servant-docs == 0.9.*
, servant-js == 0.9.*
, warp
, http-media
, lucid

9
travis.sh → scripts/ci-cron.sh
View file

@ -1,8 +1,15 @@
#!/usr/bin/env bash
set -o nounset
set -o errexit
set -o verbose
for package in $(cat sources.txt) doc/tutorial ; do
export PATH=$(stack path --bin-path):$PATH
stack install cabal-install
cabal update
for package in $(cat sources.txt) ; do
echo testing $package
pushd $package
tinc

7
servant-client/CHANGELOG.md
View file

@ -1,3 +1,10 @@
0.9
---
* BACKWARDS INCOMPATIBLE: `client` now returns a ClientM which is a Reader for
BasicEnv. BasicEnv comprises the HttpManager and BaseUrl that have had to be
passed to each method returned by `client`.
0.7.1
-----

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

@ -1,5 +1,5 @@
name: servant-client
version: 0.8
version: 0.9
synopsis: automatical derivation of querying functions for servant webservices
description:
This library lets you derive automatically Haskell functions that
@ -45,23 +45,24 @@ library
Servant.Client.PerformRequest.GHC
build-depends:
base >= 4.7 && < 4.10
, aeson >= 0.7 && < 0.12
, aeson >= 0.7 && < 1.1
, attoparsec >= 0.12 && < 0.14
, base64-bytestring >= 1.0.0.1 && < 1.1
, bytestring >= 0.10 && < 0.11
, exceptions >= 0.8 && < 0.9
, http-api-data >= 0.1 && < 0.3
, http-api-data >= 0.3 && < 0.4
, http-client >= 0.4.18.1 && < 0.6
, http-client-tls >= 0.2.2 && < 0.4
, http-media >= 0.6.2 && < 0.7
, http-types >= 0.8.6 && < 0.10
, network-uri >= 2.6 && < 2.7
, safe >= 0.3.9 && < 0.4
, servant == 0.8.*
, servant == 0.9.*
, string-conversions >= 0.3 && < 0.5
, text >= 1.2 && < 1.3
, transformers >= 0.3 && < 0.6
, transformers-compat >= 0.4 && < 0.6
, mtl
if impl(ghcjs)
build-depends:
ghcjs-base
@ -106,14 +107,16 @@ test-suite spec
, bytestring
, deepseq
, hspec >= 2.2.1 && < 2.3
, http-api-data
, http-client
, http-media
, http-types
, HUnit
, mtl
, network >= 2.6
, QuickCheck >= 2.7
, servant == 0.8.*
, servant-server == 0.8.*
, servant == 0.9.*
, servant-server == 0.9.*
, text
, wai
, warp

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

@ -20,6 +20,8 @@ module Servant.Client
, client
, HasClient(..)
, ClientM
, runClientM
, ClientEnv (ClientEnv)
, mkAuthenticateReq
, ServantError(..)
, module Servant.Common.BaseUrl
@ -34,7 +36,7 @@ import Data.Proxy
import Data.String.Conversions
import Data.Text (unpack)
import GHC.TypeLits
import Network.HTTP.Client (Manager, Response)
import Network.HTTP.Client (Response)
import Network.HTTP.Media
import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types.Header as HTTP
@ -119,21 +121,53 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient api)
where p = unpack (toUrlPiece val)
-- | If you use a 'CaptureAll' in one of your endpoints in your API,
-- the corresponding querying function will automatically take an
-- additional argument of a list of the type specified by your
-- 'CaptureAll'. That function will take care of inserting a textual
-- representation of this value at the right place in the request
-- path.
--
-- You can control how these values are turned into text by specifying
-- a 'ToHttpApiData' instance of your type.
--
-- Example:
--
-- > type MyAPI = "src" :> CaptureAll Text -> Get '[JSON] SourceFile
-- >
-- > myApi :: Proxy
-- > myApi = Proxy
--
-- > getSourceFile :: [Text] -> Manager -> BaseUrl -> ClientM SourceFile
-- > getSourceFile = client myApi
-- > -- then you can use "getSourceFile" to query that endpoint
instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout)
=> HasClient (CaptureAll capture a :> sublayout) where
type Client (CaptureAll capture a :> sublayout) =
[a] -> Client sublayout
clientWithRoute Proxy req vals =
clientWithRoute (Proxy :: Proxy sublayout)
(foldl' (flip appendToPath) req ps)
where ps = map (unpack . toUrlPiece) vals
instance OVERLAPPABLE_
-- Note [Non-Empty Content Types]
(MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient (Verb method status cts' a) where
type Client (Verb method status cts' a) = Manager -> BaseUrl -> ClientM a
clientWithRoute Proxy req manager baseurl =
snd <$> performRequestCT (Proxy :: Proxy ct) method req manager baseurl
type Client (Verb method status cts' a) = ClientM a
clientWithRoute Proxy req = do
snd <$> performRequestCT (Proxy :: Proxy ct) method req
where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_
(ReflectMethod method) => HasClient (Verb method status cts NoContent) where
type Client (Verb method status cts NoContent)
= Manager -> BaseUrl -> ClientM NoContent
clientWithRoute Proxy req manager baseurl =
performRequestNoBody method req manager baseurl >> return NoContent
= ClientM NoContent
clientWithRoute Proxy req = do
performRequestNoBody method req >> return NoContent
where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_
@ -141,10 +175,10 @@ instance OVERLAPPING_
( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient (Verb method status cts' (Headers ls a)) where
type Client (Verb method status cts' (Headers ls a))
= Manager -> BaseUrl -> ClientM (Headers ls a)
clientWithRoute Proxy req manager baseurl = do
= ClientM (Headers ls a)
clientWithRoute Proxy req = do
let method = reflectMethod (Proxy :: Proxy method)
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req manager baseurl
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req
return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs
}
@ -153,10 +187,10 @@ instance OVERLAPPING_
( BuildHeadersTo ls, ReflectMethod method
) => HasClient (Verb method status cts (Headers ls NoContent)) where
type Client (Verb method status cts (Headers ls NoContent))
= Manager -> BaseUrl -> ClientM (Headers ls NoContent)
clientWithRoute Proxy req manager baseurl = do
= ClientM (Headers ls NoContent)
clientWithRoute Proxy req = do
let method = reflectMethod (Proxy :: Proxy method)
hdrs <- performRequestNoBody method req manager baseurl
hdrs <- performRequestNoBody method req
return $ Headers { getResponse = NoContent
, getHeadersHList = buildHeadersTo hdrs
}
@ -341,7 +375,7 @@ instance (KnownSymbol sym, HasClient api)
-- back the full `Response`.
instance HasClient Raw where
type Client Raw
= H.Method -> Manager -> BaseUrl -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
= H.Method -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
clientWithRoute :: Proxy Raw -> Req -> Client Raw
clientWithRoute Proxy req httpMethod = do

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

@ -1,7 +1,9 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
#if MIN_VERSION_base(4,9,0)
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
@ -15,14 +17,25 @@ import Control.Applicative
import Control.Exception
import Control.Monad
import Control.Monad.Catch (MonadThrow)
import Control.Monad.IO.Class
#if MIN_VERSION_mtl(2,2,0)
import Control.Monad.Except (MonadError(..))
#else
import Control.Monad.Error.Class (MonadError(..))
#endif
import Control.Monad.Trans.Except
import GHC.Generics
import Control.Monad.IO.Class ()
import Control.Monad.Reader
import Data.ByteString.Lazy hiding (pack, filter, map, null, elem)
import Data.String
import Data.String.Conversions
import Data.Proxy
import Data.Text (Text)
import Data.Text.Encoding
import Data.Typeable
import Network.HTTP.Client hiding (Proxy, path)
import Network.HTTP.Media
import Network.HTTP.Types
@ -68,7 +81,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 <$> parseUrlThrow url
setheaders . setAccept . setrqb . setQS <$> parseRequest url
where url = show $ nullURI { uriScheme = case reqScheme of
Http -> "http:"
@ -94,8 +107,18 @@ 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
-- 'parseRequest' is introduced in http-client-0.4.30
-- it differs from 'parseUrl', by not throwing exceptions on non-2xx http statuses
--
-- See for implementations:
-- http://hackage.haskell.org/package/http-client-0.4.30/docs/src/Network-HTTP-Client-Request.html#parseRequest
-- http://hackage.haskell.org/package/http-client-0.5.0/docs/src/Network-HTTP-Client-Request.html#parseRequest
parseRequest :: MonadThrow m => String -> m Request
parseRequest url = liftM disableStatusCheck (parseUrl url)
where
disableStatusCheck req = req { checkStatus = \ _status _headers _cookies -> Nothing }
#endif
@ -104,21 +127,40 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
displayHttpRequest :: Method -> String
displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
type ClientM = ExceptT ServantError IO
data ClientEnv
= ClientEnv
{ manager :: Manager
, baseUrl :: BaseUrl
}
performRequest :: Method -> Req -> Manager -> BaseUrl
-- | @ClientM@ is the monad in which client functions run. Contains the
-- 'Manager' and 'BaseUrl' used for requests in the reader environment.
newtype ClientM a = ClientM { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }
deriving ( Functor, Applicative, Monad, MonadIO, Generic
, MonadReader ClientEnv
, MonadError ServantError
)
runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm
performRequest :: Method -> Req
-> ClientM ( Int, ByteString, MediaType
, [HTTP.Header], Response ByteString)
performRequest reqMethod req manager reqHost = do
performRequest reqMethod req = do
m <- asks manager
reqHost <- asks baseUrl
partialRequest <- liftIO $ reqToRequest req reqHost
let request = disableStatusCheck $
partialRequest { Client.method = reqMethod }
let request = partialRequest { Client.method = reqMethod }
eResponse <- liftIO $ performHttpRequest manager request
eResponse <- liftIO $ performHttpRequest m request
case eResponse of
Left err ->
throwE . ConnectionError $ SomeException err
throwError . ConnectionError $ SomeException err
Right response -> do
let status = Client.responseStatus response
@ -128,33 +170,24 @@ performRequest reqMethod req manager reqHost = do
ct <- case lookup "Content-Type" $ Client.responseHeaders response of
Nothing -> pure $ "application"//"octet-stream"
Just t -> case parseAccept t of
Nothing -> throwE $ InvalidContentTypeHeader (cs t) body
Nothing -> throwError $ InvalidContentTypeHeader (cs t) body
Just t' -> pure t'
unless (status_code >= 200 && status_code < 300) $
throwE $ FailureResponse status ct body
throwError $ FailureResponse status ct body
return (status_code, body, ct, hdrs, response)
disableStatusCheck :: Request -> Request
#if MIN_VERSION_http_client(0,5,0)
disableStatusCheck req = req { checkResponse = \ _req _res -> return () }
#else
disableStatusCheck req = req { checkStatus = \ _status _headers _cookies -> Nothing }
#endif
performRequestCT :: MimeUnrender ct result =>
Proxy ct -> Method -> Req -> Manager -> BaseUrl
performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req
-> ClientM ([HTTP.Header], result)
performRequestCT ct reqMethod req manager reqHost = do
performRequestCT ct reqMethod req = do
let acceptCT = contentType ct
(_status, respBody, respCT, hdrs, _response) <-
performRequest reqMethod (req { reqAccept = [acceptCT] }) manager reqHost
unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody
performRequest reqMethod (req { reqAccept = [acceptCT] })
unless (matches respCT (acceptCT)) $ throwError $ UnsupportedContentType respCT respBody
case mimeUnrender ct respBody of
Left err -> throwE $ DecodeFailure err respCT respBody
Left err -> throwError $ DecodeFailure err respCT respBody
Right val -> return (hdrs, val)
performRequestNoBody :: Method -> Req -> Manager -> BaseUrl
-> ClientM [HTTP.Header]
performRequestNoBody reqMethod req manager reqHost = do
(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req manager reqHost
performRequestNoBody :: Method -> Req -> ClientM [HTTP.Header]
performRequestNoBody reqMethod req = do
(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req
return hdrs

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

@ -26,14 +26,13 @@ import Prelude ()
import Prelude.Compat
import Control.Arrow (left)
import Control.Monad.Trans.Except (runExceptT, throwE)
import Control.Monad.Trans.Except (throwE )
import Data.Aeson
import qualified Data.ByteString.Lazy as BS
import Data.Char (chr, isPrint)
import Data.Foldable (forM_)
import Data.Monoid hiding (getLast)
import Data.Proxy
import qualified Data.Text as T
import GHC.Generics (Generic)
import qualified Network.HTTP.Client as C
import Network.HTTP.Media
@ -46,10 +45,12 @@ import Test.HUnit
import Test.Hspec
import Test.Hspec.QuickCheck
import Test.QuickCheck
import Web.FormUrlEncoded (FromForm, ToForm)
import Servant.API
import Servant.Client
import Servant.Client.TestServer
import Servant.Client.TestServer.GHC
import qualified Servant.Common.Req as SCR
import Servant.Server
import Servant.Server.Experimental.Auth
@ -117,19 +118,8 @@ data Person = Person {
instance ToJSON Person
instance FromJSON Person
instance ToFormUrlEncoded Person where
toFormUrlEncoded Person{..} =
[("name", T.pack name), ("age", T.pack (show age))]
lookupEither :: (Show a, Eq a) => a -> [(a,b)] -> Either String b
lookupEither x xs = do
maybe (Left $ "could not find key " <> show x) return $ lookup x xs
instance FromFormUrlEncoded Person where
fromFormUrlEncoded xs = do
n <- lookupEither "name" xs
a <- lookupEither "age" xs
return $ Person (T.unpack n) (read $ T.unpack a)
instance ToForm Person where
instance FromForm Person where
alice :: Person
alice = Person "Alice" 42
@ -140,6 +130,7 @@ type Api =
"get" :> Get '[JSON] Person
:<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent
:<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
:<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
:<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
:<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
:<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
@ -157,24 +148,26 @@ type Api =
api :: Proxy Api
api = Proxy
getGet :: C.Manager -> BaseUrl -> SCR.ClientM Person
getDeleteEmpty :: C.Manager -> BaseUrl -> SCR.ClientM NoContent
getCapture :: String -> C.Manager -> BaseUrl -> SCR.ClientM Person
getBody :: Person -> C.Manager -> BaseUrl -> SCR.ClientM Person
getQueryParam :: Maybe String -> C.Manager -> BaseUrl -> SCR.ClientM Person
getQueryParams :: [String] -> C.Manager -> BaseUrl -> SCR.ClientM [Person]
getQueryFlag :: Bool -> C.Manager -> BaseUrl -> SCR.ClientM Bool
getRawSuccess :: HTTP.Method -> C.Manager -> BaseUrl
getGet :: SCR.ClientM Person
getDeleteEmpty :: SCR.ClientM NoContent
getCapture :: String -> SCR.ClientM Person
getCaptureAll :: [String] -> SCR.ClientM [Person]
getBody :: Person -> SCR.ClientM Person
getQueryParam :: Maybe String -> SCR.ClientM Person
getQueryParams :: [String] -> SCR.ClientM [Person]
getQueryFlag :: Bool -> SCR.ClientM Bool
getRawSuccess :: HTTP.Method
-> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)
getRawFailure :: HTTP.Method -> C.Manager -> BaseUrl
getRawFailure :: HTTP.Method
-> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)
getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> C.Manager -> BaseUrl
getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
-> SCR.ClientM (String, Maybe Int, Bool, [(String, [Rational])])
getRespHeaders :: C.Manager -> BaseUrl -> SCR.ClientM (Headers TestHeaders Bool)
getDeleteContentType :: C.Manager -> BaseUrl -> SCR.ClientM NoContent
getRespHeaders :: SCR.ClientM (Headers TestHeaders Bool)
getDeleteContentType :: SCR.ClientM NoContent
getGet
:<|> getDeleteEmpty
:<|> getCapture
:<|> getCaptureAll
:<|> getBody
:<|> getQueryParam
:<|> getQueryParams
@ -190,6 +183,7 @@ server = TestServer "server" $ serve api (
return alice
:<|> return NoContent
:<|> (\ name -> return $ Person name 0)
:<|> (\ names -> return (zipWith Person names [0..]))
:<|> return
:<|> (\ name -> case name of
Just "alice" -> return alice
@ -275,38 +269,42 @@ sucessSpec :: Spec
sucessSpec = around (withTestServer "server") $ do
it "Servant.API.Get" $ \baseUrl -> do
(left show <$> runExceptT (getGet manager baseUrl)) `shouldReturn` Right alice
(left show <$> (runClientM getGet (ClientEnv manager baseUrl))) `shouldReturn` Right alice
describe "Servant.API.Delete" $ do
it "allows empty content type" $ \baseUrl -> do
(left show <$> runExceptT (getDeleteEmpty manager baseUrl)) `shouldReturn` Right NoContent
(left show <$> (runClientM getDeleteEmpty (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent
it "allows content type" $ \baseUrl -> do
(left show <$> runExceptT (getDeleteContentType manager baseUrl)) `shouldReturn` Right NoContent
(left show <$> (runClientM getDeleteContentType (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent
it "Servant.API.Capture" $ \baseUrl -> do
(left show <$> runExceptT (getCapture "Paula" manager baseUrl)) `shouldReturn` Right (Person "Paula" 0)
(left show <$> (runClientM (getCapture "Paula") (ClientEnv manager baseUrl))) `shouldReturn` Right (Person "Paula" 0)
it "Servant.API.CaptureAll" $ \baseUrl -> do
let expected = [(Person "Paula" 0), (Person "Peta" 1)]
(left show <$> (runClientM (getCaptureAll ["Paula", "Peta"]) (ClientEnv manager baseUrl))) `shouldReturn` Right expected
it "Servant.API.ReqBody" $ \baseUrl -> do
let p = Person "Clara" 42
(left show <$> runExceptT (getBody p manager baseUrl)) `shouldReturn` Right p
(left show <$> runClientM (getBody p) (ClientEnv manager baseUrl)) `shouldReturn` Right p
it "Servant.API.QueryParam" $ \baseUrl -> do
left show <$> runExceptT (getQueryParam (Just "alice") manager baseUrl) `shouldReturn` Right alice
Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob") manager baseUrl)
left show <$> runClientM (getQueryParam (Just "alice")) (ClientEnv manager baseUrl) `shouldReturn` Right alice
Left FailureResponse{..} <- runClientM (getQueryParam (Just "bob")) (ClientEnv manager baseUrl)
responseStatus `shouldBe` HTTP.Status 400 "bob not found"
it "Servant.API.QueryParam.QueryParams" $ \baseUrl -> do
(left show <$> runExceptT (getQueryParams [] manager baseUrl)) `shouldReturn` Right []
(left show <$> runExceptT (getQueryParams ["alice", "bob"] manager baseUrl))
(left show <$> runClientM (getQueryParams []) (ClientEnv manager baseUrl)) `shouldReturn` Right []
(left show <$> runClientM (getQueryParams ["alice", "bob"]) (ClientEnv manager baseUrl))
`shouldReturn` Right [Person "alice" 0, Person "bob" 1]
context "Servant.API.QueryParam.QueryFlag" $
forM_ [False, True] $ \ flag -> it (show flag) $ \baseUrl -> do
(left show <$> runExceptT (getQueryFlag flag manager baseUrl)) `shouldReturn` Right flag
(left show <$> runClientM (getQueryFlag flag) (ClientEnv manager baseUrl)) `shouldReturn` Right flag
it "Servant.API.Raw on success" $ \baseUrl -> do
res <- runExceptT (getRawSuccess HTTP.methodGet manager baseUrl)
res <- runClientM (getRawSuccess HTTP.methodGet) (ClientEnv manager baseUrl)
case res of
Left e -> assertFailure $ show e
Right (code, body, ct, _, response) -> do
@ -315,7 +313,7 @@ sucessSpec = around (withTestServer "server") $ do
C.responseStatus response `shouldBe` HTTP.ok200
it "Servant.API.Raw should return a Left in case of failure" $ \baseUrl -> do
res <- runExceptT (getRawFailure HTTP.methodGet manager baseUrl)
res <- runClientM (getRawFailure HTTP.methodGet) (ClientEnv manager baseUrl)
case res of
Right _ -> assertFailure "expected Left, but got Right"
Left e -> do
@ -323,7 +321,7 @@ sucessSpec = around (withTestServer "server") $ do
Servant.Client.responseBody e `shouldBe` "rawFailure"
it "Returns headers appropriately" $ \baseUrl -> do
res <- runExceptT (getRespHeaders manager baseUrl)
res <- runClientM getRespHeaders (ClientEnv manager baseUrl)
case res of
Left e -> assertFailure $ show e
Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
@ -332,7 +330,7 @@ sucessSpec = around (withTestServer "server") $ do
it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \baseUrl ->
property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
ioProperty $ do
result <- left show <$> runExceptT (getMultiple cap num flag body manager baseUrl)
result <- left show <$> runClientM (getMultiple cap num flag body) (ClientEnv manager baseUrl)
return $
result === Right (cap, num, flag, body)
@ -358,9 +356,9 @@ errorSpec =
it "reports error statuses correctly" $ \baseUrl -> do
let delete :<|> get :<|> post :<|> put =
client errorApi
actions = map (\ f -> f manager baseUrl) [delete, get, post, put]
actions = [delete, get, post, put]
forM_ actions $ \ clientAction -> do
Left FailureResponse{..} <- runExceptT clientAction
Left FailureResponse{..} <- runClientM clientAction (ClientEnv manager baseUrl)
responseStatus `shouldBe` HTTP.Status 500 "error message"
basicAuthSpec :: Spec
@ -370,14 +368,14 @@ basicAuthSpec = around (withTestServer "basicAuthServer") $ do
it "Authenticates a BasicAuth protected server appropriately" $ \baseUrl -> do
let getBasic = client basicAuthAPI
let basicAuthData = BasicAuthData "servant" "server"
(left show <$> runExceptT (getBasic basicAuthData manager baseUrl)) `shouldReturn` Right alice
(left show <$> runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)) `shouldReturn` Right alice
context "Authentication is rejected when requests are not authenticated properly" $ do
it "Authenticates a BasicAuth protected server appropriately" $ \baseUrl -> do
let getBasic = client basicAuthAPI
let basicAuthData = BasicAuthData "not" "password"
Left FailureResponse{..} <- runExceptT (getBasic basicAuthData manager baseUrl)
Left FailureResponse{..} <- runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)
responseStatus `shouldBe` HTTP.Status 403 "Forbidden"
genAuthSpec :: Spec
@ -387,14 +385,14 @@ genAuthSpec = around (withTestServer "genAuthServer") $ do
it "Authenticates a AuthProtect protected server appropriately" $ \baseUrl -> do
let getProtected = client genAuthAPI
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req)
(left show <$> runExceptT (getProtected authRequest manager baseUrl)) `shouldReturn` Right alice
(left show <$> runClientM (getProtected authRequest) (ClientEnv manager baseUrl)) `shouldReturn` Right alice
context "Authentication is rejected when requests are not authenticated properly" $ do
it "Authenticates a AuthProtect protected server appropriately" $ \baseUrl -> do
let getProtected = client genAuthAPI
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req)
Left FailureResponse{..} <- runExceptT (getProtected authRequest manager baseUrl)
Left FailureResponse{..} <- runClientM (getProtected authRequest) (ClientEnv manager baseUrl)
responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")
failSpec :: Spec
@ -403,35 +401,36 @@ failSpec = around (withTestServer "failServer") $ do
context "client returns errors appropriately" $ do
it "reports FailureResponse" $ \baseUrl -> do
let (_ :<|> getDeleteEmpty :<|> _) = client api
Left res <- runExceptT (getDeleteEmpty manager baseUrl)
Left res <- runClientM getDeleteEmpty (ClientEnv manager baseUrl)
case res of
FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return ()
_ -> fail $ "expected 404 response, but got " <> show res
it "reports DecodeFailure" $ \baseUrl -> do
let (_ :<|> _ :<|> getCapture :<|> _) = client api
Left res <- runExceptT (getCapture "foo" manager baseUrl)
Left res <- runClientM (getCapture "foo") (ClientEnv manager baseUrl)
case res of
DecodeFailure _ ("application/json") _ -> return ()
_ -> fail $ "expected DecodeFailure, but got " <> show res
it "reports ConnectionError" $ \_ -> do
let (getGetWrongHost :<|> _) = client api
Left res <- runExceptT (getGetWrongHost manager (BaseUrl Http "127.0.0.1" 19872 ""))
Left res <- runClientM getGetWrongHost (ClientEnv manager (BaseUrl Http "127.0.0.1" 19872 ""))
case res of
ConnectionError _ -> return ()
_ -> fail $ "expected ConnectionError, but got " <> show res
it "reports UnsupportedContentType" $ \baseUrl -> do
let (getGet :<|> _ ) = client api
Left res <- runExceptT (getGet manager baseUrl)
Left res <- runClientM getGet (ClientEnv manager baseUrl)
case res of
UnsupportedContentType ("application/octet-stream") _ -> return ()
_ -> fail $ "expected UnsupportedContentType, but got " <> show res
it "reports InvalidContentTypeHeader" $ \baseUrl -> do
let (_ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
Left res <- runExceptT (getBody alice manager baseUrl)
let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
Left res <- runClientM (getBody alice) (ClientEnv manager baseUrl)
case res of
InvalidContentTypeHeader "fooooo" _ -> return ()
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res

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

@ -1,5 +1,5 @@
name: servant-docs
version: 0.8
version: 0.9
synopsis: generate API docs for your servant webservice
description:
Library for generating API docs from a servant API definition.
@ -36,13 +36,12 @@ library
, aeson
, aeson-pretty
, bytestring
, bytestring-conversion
, case-insensitive
, hashable
, http-media >= 0.6
, http-types >= 0.7
, lens
, servant == 0.8.*
, servant == 0.9.*
, string-conversions
, text
, unordered-containers
@ -61,7 +60,6 @@ executable greet-docs
build-depends:
base
, aeson
, bytestring-conversion
, lens
, servant
, servant-docs

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

@ -25,7 +25,6 @@ import Control.Arrow (second)
import Control.Lens (makeLenses, mapped, over, traversed, view, (%~),
(&), (.~), (<>~), (^.), (|>))
import qualified Control.Monad.Omega as Omega
import Data.ByteString.Conversion (ToByteString, toByteString)
import Data.ByteString.Lazy.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BSC
import qualified Data.CaseInsensitive as CI
@ -461,12 +460,12 @@ class AllHeaderSamples ls where
instance AllHeaderSamples '[] where
allHeaderToSample _ = []
instance (ToByteString l, AllHeaderSamples ls, ToSample l, KnownSymbol h)
instance (ToHttpApiData l, AllHeaderSamples ls, ToSample l, KnownSymbol h)
=> AllHeaderSamples (Header h l ': ls) where
allHeaderToSample _ = mkHeader (toSample (Proxy :: Proxy l)) :
allHeaderToSample (Proxy :: Proxy ls)
where headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy h)
mkHeader (Just x) = (headerName, cs $ toByteString x)
mkHeader (Just x) = (headerName, cs $ toHeader x)
mkHeader Nothing = (headerName, "<no header sample provided>")
-- | Synthesise a sample value of a type, encoded in the specified media types.
@ -702,6 +701,22 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)
symP = Proxy :: Proxy sym
-- | @"books" :> 'CaptureAll' "isbn" Text@ will appear as
-- @/books/:isbn@ in the docs.
instance (KnownSymbol sym, ToCapture (CaptureAll sym a), HasDocs sublayout)
=> HasDocs (CaptureAll sym a :> sublayout) where
docsFor Proxy (endpoint, action) =
docsFor sublayoutP (endpoint', action')
where sublayoutP = Proxy :: Proxy sublayout
captureP = Proxy :: Proxy (CaptureAll sym a)
action' = over captures (|> toCapture captureP) action
endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint
symP = Proxy :: Proxy sym
instance OVERLAPPABLE_
(ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
, ReflectMethod method)

2
servant-docs/test/Servant/DocsSpec.hs
View file

@ -34,6 +34,8 @@ instance ToParam (QueryFlag "foo") where
toParam = error "unused"
instance ToCapture (Capture "foo" Int) where
toCapture = error "unused"
instance ToCapture (CaptureAll "foo" Int) where
toCapture = error "unused"
-- * specs

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

@ -1,5 +1,5 @@
name: servant-foreign
version: 0.8
version: 0.9
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
@ -32,7 +32,7 @@ library
, Servant.Foreign.Inflections
build-depends: base == 4.*
, lens == 4.*
, servant == 0.8.*
, servant == 0.9.*
, text >= 1.2 && < 1.3
, http-types
hs-source-dirs: src

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

@ -211,6 +211,21 @@ instance (KnownSymbol sym, HasForeignType lang ftype t, HasForeign lang ftype ap
{ _argName = PathSegment str
, _argType = ftype }
instance (KnownSymbol sym, HasForeignType lang ftype [t], HasForeign lang ftype sublayout)
=> HasForeign lang ftype (CaptureAll sym t :> sublayout) where
type Foreign ftype (CaptureAll sym t :> sublayout) = Foreign ftype sublayout
foreignFor lang Proxy Proxy req =
foreignFor lang Proxy (Proxy :: Proxy sublayout) $
req & reqUrl . path <>~ [Segment (Cap arg)]
& reqFuncName . _FunctionName %~ (++ ["by", str])
where
str = pack . symbolVal $ (Proxy :: Proxy sym)
ftype = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy [t])
arg = Arg
{ _argName = PathSegment str
, _argType = ftype }
instance (Elem JSON list, HasForeignType lang ftype a, ReflectMethod method)
=> HasForeign lang ftype (Verb method status list a) where
type Foreign ftype (Verb method status list a) = Req ftype

18
servant-foreign/test/Servant/ForeignSpec.hs
View file

@ -46,6 +46,7 @@ type TestApi
:<|> "test" :> QueryParam "param" Int :> ReqBody '[JSON] [String] :> Post '[JSON] NoContent
:<|> "test" :> QueryParams "params" Int :> ReqBody '[JSON] String :> Put '[JSON] NoContent
:<|> "test" :> Capture "id" Int :> Delete '[JSON] NoContent
:<|> "test" :> CaptureAll "ids" Int :> Get '[JSON] [Int]
testApi :: [Req String]
testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy String) (Proxy :: Proxy TestApi)
@ -53,9 +54,9 @@ testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy String) (Proxy :: P
listFromAPISpec :: Spec
listFromAPISpec = describe "listFromAPI" $ do
it "generates 4 endpoints for TestApi" $ do
length testApi `shouldBe` 4
length testApi `shouldBe` 5
let [getReq, postReq, putReq, deleteReq] = testApi
let [getReq, postReq, putReq, deleteReq, captureAllReq] = testApi
it "collects all info for get request" $ do
shouldBe getReq $ defReq
@ -106,3 +107,16 @@ listFromAPISpec = describe "listFromAPI" $ do
, _reqReturnType = Just "voidX"
, _reqFuncName = FunctionName ["delete", "test", "by", "id"]
}
it "collects all info for capture all request" $ do
shouldBe captureAllReq $ defReq
{ _reqUrl = Url
[ Segment $ Static "test"
, Segment $ Cap (Arg "ids" "listX of intX") ]
[]
, _reqMethod = "GET"
, _reqHeaders = []
, _reqBody = Nothing
, _reqReturnType = Just "listX of intX"
, _reqFuncName = FunctionName ["get", "test", "by", "ids"]
}

4
servant-js/README.md
View file

@ -78,8 +78,8 @@ server counter = counterPlusOne counter -- (+1) on the TVar
:<|> currentValue counter -- read the TVar
server' :: TVar Counter -> Server TestApi'
server counter = server counter
:<|> serveDirectory www -- serve static files
server' counter = server counter
:<|> serveDirectory www -- serve static files
runServer :: TVar Counter -- ^ shared variable for the counter
-> Int -- ^ port the server should listen on

3
servant-js/examples/counter.hs
View file

@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
import Control.Concurrent.STM
@ -92,7 +93,7 @@ main = do
writeJSForAPI testApi (angular defAngularOptions) (www </> "angular" </> "api.js")
writeJSForAPI testApi axios (www </> "axios" </> "api.js")
writeJSForAPI testApi (axios defAxiosOptions) (www </> "axios" </> "api.js")
writeServiceJS (www </> "angular" </> "api.service.js")

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

@ -1,5 +1,5 @@
name: servant-js
version: 0.8
version: 0.9
synopsis: Automatically derive javascript functions to query servant webservices.
description:
Automatically derive javascript functions to query servant webservices.
@ -45,8 +45,8 @@ library
, base-compat >= 0.9
, charset >= 0.3
, lens >= 4
, servant-foreign == 0.8.*
, servant == 0.8.*
, servant-foreign == 0.9.*
, servant == 0.9.*
, text >= 1.2 && < 1.3
hs-source-dirs: src
@ -65,11 +65,11 @@ executable counter
buildable: False
build-depends: base >= 4.7 && < 5
, aeson >= 0.7 && < 0.12
, aeson >= 0.7 && < 1.1
, filepath >= 1
, lens >= 4
, servant == 0.8.*
, servant-server == 0.8.*
, servant == 0.9.*
, servant-server == 0.9.*
, servant-js
, stm
, transformers

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

@ -112,6 +112,7 @@ module Servant.JS
, javascript
, NoTypes
, GenerateList(..)
, FunctionName(..)
) where
import Prelude hiding (writeFile)

2
servant-js/test/Servant/JSSpec.hs
View file

@ -33,7 +33,7 @@ import Servant.JSSpec.CustomHeaders
-- * comprehensive api
-- This declaration simply checks that all instances are in place.
_ = jsForAPI comprehensiveAPI vanillaJS :: Text
_ = jsForAPI comprehensiveAPIWithoutRaw vanillaJS :: Text
-- * specs

1
servant-mock/.ghci
View file

@ -1 +0,0 @@
:set -Wall -itest -isrc -optP-include -optPdist/build/autogen/cabal_macros.h -Iinclude

30
servant-mock/LICENSE
View file

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

2
servant-mock/Setup.hs
View file

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

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

@ -1,26 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
import Data.Aeson
import GHC.Generics
import Network.Wai.Handler.Warp
import Servant
import Servant.Mock
import Test.QuickCheck.Arbitrary
newtype User = User { username :: String }
deriving (Eq, Show, Arbitrary, Generic)
instance ToJSON User
type API = "user" :> Get '[JSON] User
api :: Proxy API
api = Proxy
main :: IO ()
main = run 8080 (serve api $ mock api Proxy)

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

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

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

@ -1,73 +0,0 @@
name: servant-mock
version: 0.8
synopsis: Derive a mock server for free from your servant API types
description:
Derive a mock server for free from your servant API types
.
See the @Servant.Mock@ module for the documentation and an example.
homepage: http://github.com/haskell-servant/servant
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
flag example
description: Build the example too
default: True
library
exposed-modules:
Servant.Mock
build-depends:
base >=4.7 && <5,
bytestring >= 0.10 && <0.11,
http-types >= 0.8 && <0.10,
servant == 0.8.*,
servant-server == 0.8.*,
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
hs-source-dirs: example
default-language: Haskell2010
build-depends: aeson, base, servant-mock, servant-server, QuickCheck, warp
if flag(example)
buildable: True
else
buildable: False
ghc-options: -Wall
test-suite spec
type: exitcode-stdio-1.0
ghc-options: -Wall
default-language: Haskell2010
hs-source-dirs: test
main-is: Spec.hs
other-modules:
Servant.MockSpec
build-depends:
base,
hspec,
hspec-wai,
QuickCheck,
servant,
servant-server,
servant-mock,
aeson,
bytestring-conversion,
wai

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

@ -1,185 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
#include "overlapping-compat.h"
-- |
-- Module : Servant.Mock
-- Copyright : 2015 Alp Mestanogullari
-- License : BSD3
--
-- Maintainer : Alp Mestanogullari <alpmestan@gmail.com>
-- Stability : experimental
-- Portability : portable
--
-- Automatically derive a mock webserver that implements some API type,
-- just from the said API type's definition.
--
-- Using this module couldn't be simpler. Given some API type, like:
--
-- > type API = "user" :> Get '[JSON] User
--
-- that describes your web application, all you have to do is define
-- a 'Proxy' to it:
--
-- > myAPI :: Proxy API
-- > myAPI = Proxy
--
-- and call 'mock', which has the following type:
--
-- @
-- 'mock' :: 'HasMock' api context => 'Proxy' api -> 'Proxy' context -> 'Server' api
-- @
--
-- What this says is, given some API type @api@ that it knows it can
-- "mock", 'mock' hands you an implementation of the API type. It does so
-- by having each request handler generate a random value of the
-- appropriate type (@User@ in our case). All you need for this to work is
-- to provide 'Arbitrary' instances for the data types returned as response
-- bodies, hence appearing next to 'Delete', 'Get', 'Patch', 'Post' and 'Put'.
--
-- To put this all to work and run the mock server, just call 'serve' on the
-- result of 'mock' to get an 'Application' that you can then run with warp.
--
-- @
-- main :: IO ()
-- main = Network.Wai.Handler.Warp.run 8080 $
-- 'serve' myAPI ('mock' myAPI Proxy)
-- @
module Servant.Mock ( HasMock(..) ) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Control.Monad.IO.Class
import Data.ByteString.Lazy.Char8 (pack)
import Data.Proxy
import GHC.TypeLits
import Network.HTTP.Types.Status
import Network.Wai
import Servant
import Servant.API.ContentTypes
import Test.QuickCheck.Arbitrary (Arbitrary (..), vector)
import Test.QuickCheck.Gen (Gen, generate)
-- | 'HasMock' defines an interpretation of API types
-- than turns them into random-response-generating
-- request handlers, hence providing an instance for
-- all the combinators of the core /servant/ library.
class HasServer api context => HasMock api context where
-- | Calling this method creates request handlers of
-- the right type to implement the API described by
-- @api@ that just generate random response values of
-- the right type. E.g:
--
-- @
-- type API = "user" :> Get '[JSON] User
-- :<|> "book" :> Get '[JSON] Book
--
-- api :: Proxy API
-- api = Proxy
--
-- -- let's say we will start with the frontend,
-- -- and hence need a placeholder server
-- server :: Server API
-- server = mock api Proxy
-- @
--
-- What happens here is that @'Server' API@
-- actually "means" 2 request handlers, of the following types:
--
-- @
-- getUser :: Handler User
-- getBook :: Handler Book
-- @
--
-- So under the hood, 'mock' uses the 'IO' bit to generate
-- random values of type 'User' and 'Book' every time these
-- endpoints are requested.
mock :: Proxy api -> Proxy context -> Server api
instance (HasMock a context, HasMock b context) => HasMock (a :<|> b) context where
mock _ context = mock (Proxy :: Proxy a) context :<|> mock (Proxy :: Proxy b) context
instance (KnownSymbol path, HasMock rest context) => HasMock (path :> rest) context where
mock _ = mock (Proxy :: Proxy rest)
instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) => HasMock (Capture s a :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance (AllCTUnrender ctypes a, HasMock rest context) => HasMock (ReqBody ctypes a :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance HasMock rest context => HasMock (RemoteHost :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance HasMock rest context => HasMock (IsSecure :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance HasMock rest context => HasMock (Vault :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance HasMock rest context => HasMock (HttpVersion :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance (KnownSymbol s, FromHttpApiData a, HasMock rest context)
=> HasMock (QueryParam s a :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance (KnownSymbol s, FromHttpApiData a, HasMock rest context)
=> HasMock (QueryParams s a :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance (KnownSymbol s, HasMock rest context) => HasMock (QueryFlag s :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance (KnownSymbol h, FromHttpApiData a, HasMock rest context) => HasMock (Header h a :> rest) context where
mock _ context = \_ -> mock (Proxy :: Proxy rest) context
instance (Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a)
=> HasMock (Verb method status ctypes a) context where
mock _ _ = mockArbitrary
instance OVERLAPPING_
(GetHeaders (Headers headerTypes a), Arbitrary (HList headerTypes),
Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a)
=> HasMock (Verb method status ctypes (Headers headerTypes a)) context where
mock _ _ = mockArbitrary
instance HasMock Raw context where
mock _ _ = \_req respond -> do
bdy <- genBody
respond $ responseLBS status200 [] bdy
where genBody = pack <$> generate (vector 100 :: Gen [Char])
instance (HasContextEntry context (NamedContext name subContext), HasMock rest subContext) =>
HasMock (WithNamedContext name subContext rest) context where
mock _ _ = mock (Proxy :: Proxy rest) (Proxy :: Proxy subContext)
mockArbitrary :: (MonadIO m, Arbitrary a) => m a
mockArbitrary = liftIO (generate arbitrary)
-- utility instance
instance (Arbitrary (HList ls), Arbitrary a)
=> Arbitrary (Headers ls a) where
arbitrary = Headers <$> arbitrary <*> arbitrary
instance Arbitrary (HList '[]) where
arbitrary = pure HNil
instance (Arbitrary a, Arbitrary (HList hs))
=> Arbitrary (HList (Header h a ': hs)) where
arbitrary = HCons <$> fmap Header arbitrary <*> arbitrary
instance Arbitrary NoContent where
arbitrary = pure NoContent

85
servant-mock/test/Servant/MockSpec.hs
View file

@ -1,85 +0,0 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
module Servant.MockSpec where
import Data.Aeson as Aeson
import Data.ByteString.Conversion.To
import Data.Proxy
import Data.String
import GHC.Generics
import Network.Wai
import Servant.API
import Test.Hspec hiding (pending)
import Test.Hspec.Wai
import Test.QuickCheck
import Servant
import Servant.API.Internal.Test.ComprehensiveAPI
import Servant.Mock
-- This declaration simply checks that all instances are in place.
_ = mock comprehensiveAPI (Proxy :: Proxy '[NamedContext "foo" '[]])
data Body
= Body
| ArbitraryBody
deriving (Generic)
instance ToJSON Body
instance Arbitrary Body where
arbitrary = return ArbitraryBody
data TestHeader
= TestHeader
| ArbitraryHeader
deriving (Show)
instance ToByteString TestHeader where
builder = fromString . show
instance Arbitrary TestHeader where
arbitrary = return ArbitraryHeader
spec :: Spec
spec = do
describe "mock" $ do
context "Get" $ do
let api :: Proxy (Get '[JSON] Body)
api = Proxy
app = serve api (mock api Proxy)
with (return app) $ do
it "serves arbitrary response bodies" $ do
get "/" `shouldRespondWith` 200{
matchBody = Just $ Aeson.encode ArbitraryBody
}
context "response headers" $ do
let withHeader :: Proxy (Get '[JSON] (Headers '[Header "foo" TestHeader] Body))
withHeader = Proxy
withoutHeader :: Proxy (Get '[JSON] (Headers '[] Body))
withoutHeader = Proxy
toApp :: (HasMock api '[]) => Proxy api -> IO Application
toApp api = return $ serve api (mock api (Proxy :: Proxy '[]))
with (toApp withHeader) $ do
it "serves arbitrary response bodies" $ do
get "/" `shouldRespondWith` 200{
matchHeaders = return $ MatchHeader $ \ h ->
if h == [("Content-Type", "application/json"), ("foo", "ArbitraryHeader")]
then Nothing
else Just ("headers not correct\n")
}
with (toApp withoutHeader) $ do
it "works for no additional headers" $ do
get "/" `shouldRespondWith` 200{
matchHeaders = return $ MatchHeader $ \ h ->
if h == [("Content-Type", "application/json")]
then Nothing
else Just ("headers not correct\n")
}

1
servant-mock/test/Spec.hs
View file

@ -1 +0,0 @@
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

5
servant-mock/tinc.yaml
View file

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

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

@ -1,5 +1,5 @@
name: servant-server
version: 0.8
version: 0.9
synopsis: A family of combinators for defining webservices APIs and serving them
description:
A family of combinators for defining webservices APIs and serving them
@ -47,18 +47,18 @@ library
build-depends:
base >= 4.7 && < 4.10
, base-compat >= 0.9 && < 0.10
, aeson >= 0.7 && < 0.12
, aeson >= 0.7 && < 1.1
, attoparsec >= 0.12 && < 0.14
, base64-bytestring >= 1.0 && < 1.1
, bytestring >= 0.10 && < 0.11
, containers >= 0.5 && < 0.6
, http-api-data >= 0.1 && < 0.3
, http-api-data >= 0.3 && < 0.4
, http-types >= 0.8 && < 0.10
, network-uri >= 2.6 && < 2.7
, mtl >= 2 && < 2.3
, network >= 2.6 && < 2.7
, safe >= 0.3 && < 0.4
, servant == 0.8.*
, servant == 0.9.*
, split >= 0.2 && < 0.3
, string-conversions >= 0.3 && < 0.5
, system-filepath >= 0.4 && < 0.5
@ -99,6 +99,7 @@ test-suite spec
hs-source-dirs: test
main-is: Spec.hs
other-modules:
Servant.ArbitraryMonadServerSpec
Servant.Server.ErrorSpec
Servant.Server.Internal.ContextSpec
Servant.Server.RouterSpec
@ -113,7 +114,6 @@ test-suite spec
, aeson
, base64-bytestring
, bytestring
, bytestring-conversion
, directory
, exceptions
, hspec == 2.*

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

@ -42,16 +42,16 @@ import Network.Wai (Application, Request, Response,
responseLBS, vault)
import Prelude ()
import Prelude.Compat
import Web.HttpApiData (FromHttpApiData)
import Web.HttpApiData.Internal (parseHeaderMaybe,
import Web.HttpApiData (FromHttpApiData, parseHeaderMaybe,
parseQueryParamMaybe,
parseUrlPieceMaybe)
parseUrlPieceMaybe,
parseUrlPieces)
import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture,
Verb, ReflectMethod(reflectMethod),
IsSecure(..), Header,
QueryFlag, QueryParam, QueryParams,
Raw, RemoteHost, ReqBody, Vault,
CaptureAll, Verb,
ReflectMethod(reflectMethod),
IsSecure(..), Header, QueryFlag,
QueryParam, QueryParams, Raw,
RemoteHost, ReqBody, Vault,
WithNamedContext)
import Servant.API.ContentTypes (AcceptHeader (..),
AllCTRender (..),
@ -128,11 +128,44 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
CaptureRouter $
route (Proxy :: Proxy api)
context
(addCapture d $ \ txt -> case parseUrlPieceMaybe txt :: Maybe a of
(addCapture d $ \ txt -> case parseUrlPieceMaybe txt of
Nothing -> delayedFail err400
Just v -> return v
)
-- | If you use 'CaptureAll' in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a
-- function that takes an argument of a list of the type specified by
-- the 'CaptureAll'. This lets servant worry about getting values from
-- the URL and turning them into values of the type you specify.
--
-- You can control how they'll be converted from 'Text' to your type
-- by simply providing an instance of 'FromHttpApiData' for your type.
--
-- Example:
--
-- > type MyApi = "src" :> CaptureAll "segments" Text :> Get '[JSON] SourceFile
-- >
-- > server :: Server MyApi
-- > server = getSourceFile
-- > where getSourceFile :: [Text] -> Handler Book
-- > getSourceFile pathSegments = ...
instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context)
=> HasServer (CaptureAll capture a :> sublayout) context where
type ServerT (CaptureAll capture a :> sublayout) m =
[a] -> ServerT sublayout m
route Proxy context d =
CaptureAllRouter $
route (Proxy :: Proxy sublayout)
context
(addCapture d $ \ txts -> case parseUrlPieces txts of
Left _ -> delayedFail err400
Right v -> return v
)
allowedMethodHead :: Method -> Request -> Bool
allowedMethodHead method request = method == methodGet && requestMethod request == methodHead

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

@ -31,6 +31,9 @@ data Router' env a =
| CaptureRouter (Router' (Text, env) a)
-- ^ first path component is passed to the child router in its
-- environment and removed afterwards
| CaptureAllRouter (Router' ([Text], env) a)
-- ^ all path components are passed to the child router in its
-- environment and are removed afterwards
| RawRouter (env -> a)
-- ^ to be used for routes we do not know anything about
| Choice (Router' env a) (Router' env a)
@ -90,6 +93,9 @@ routerStructure (StaticRouter m ls) =
routerStructure (CaptureRouter router) =
CaptureRouterStructure $
routerStructure router
routerStructure (CaptureAllRouter router) =
CaptureRouterStructure $
routerStructure router
routerStructure (RawRouter _) =
RawRouterStructure
routerStructure (Choice r1 r2) =
@ -163,6 +169,10 @@ runRouterEnv router env request respond =
first : rest
-> let request' = request { pathInfo = rest }
in runRouterEnv router' (first, env) request' respond
CaptureAllRouter router' ->
let segments = pathInfo request
request' = request { pathInfo = [] }
in runRouterEnv router' (segments, env) request' respond
RawRouter app ->
app env request respond
Choice r1 r2 ->

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

@ -11,7 +11,6 @@ module Servant.Server.Internal.RoutingApplication where
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 ()
@ -161,8 +160,8 @@ withRequest f = DelayedIO (\ req -> runDelayedIO (f req) req)
-- | Add a capture to the end of the capture block.
addCapture :: Delayed env (a -> b)
-> (Text -> DelayedIO a)
-> Delayed (Text, env) b
-> (captured -> DelayedIO a)
-> Delayed (captured, env) b
addCapture Delayed{..} new =
Delayed
{ capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt

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

@ -17,7 +17,6 @@ import Control.Monad (forM_, when, unless)
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))
@ -39,7 +38,7 @@ import Network.Wai.Test (defaultRequest, request,
simpleHeaders, simpleStatus)
import Servant.API ((:<|>) (..), (:>), AuthProtect,
BasicAuth, BasicAuthData(BasicAuthData),
Capture, Delete, Get, Header (..),
Capture, CaptureAll, Delete, Get, Header (..),
Headers, HttpVersion,
IsSecure (..), JSON,
NoContent (..), Patch, PlainText,
@ -216,6 +215,58 @@ captureSpec = do
it "strips the captured path snippet from pathInfo" $ do
get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))
-- }}}
------------------------------------------------------------------------------
-- * captureAllSpec {{{
------------------------------------------------------------------------------
type CaptureAllApi = CaptureAll "legs" Integer :> Get '[JSON] Animal
captureAllApi :: Proxy CaptureAllApi
captureAllApi = Proxy
captureAllServer :: [Integer] -> Handler Animal
captureAllServer legs = case sum legs of
4 -> return jerry
2 -> return tweety
0 -> return beholder
_ -> throwE err404
captureAllSpec :: Spec
captureAllSpec = do
describe "Servant.API.CaptureAll" $ do
with (return (serve captureAllApi captureAllServer)) $ do
it "can capture a single element of the 'pathInfo'" $ do
response <- get "/2"
liftIO $ decode' (simpleBody response) `shouldBe` Just tweety
it "can capture multiple elements of the 'pathInfo'" $ do
response <- get "/2/2"
liftIO $ decode' (simpleBody response) `shouldBe` Just jerry
it "can capture arbitrarily many elements of the 'pathInfo'" $ do
response <- get "/1/1/0/1/0/1"
liftIO $ decode' (simpleBody response) `shouldBe` Just jerry
it "can capture when there are no elements in 'pathInfo'" $ do
response <- get "/"
liftIO $ decode' (simpleBody response) `shouldBe` Just beholder
it "returns 400 if the decoding fails" $ do
get "/notAnInt" `shouldRespondWith` 400
it "returns 400 if the decoding fails, regardless of which element" $ do
get "/1/0/0/notAnInt/3/" `shouldRespondWith` 400
it "returns 400 if the decoding fails, even when it's multiple elements" $ do
get "/1/0/0/notAnInt/3/orange/" `shouldRespondWith` 400
with (return (serve
(Proxy :: Proxy (CaptureAll "segments" String :> Raw))
(\ _captured request_ respond ->
respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
it "consumes everything from pathInfo" $ do
get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int])))
-- }}}
------------------------------------------------------------------------------
-- * queryParamSpec {{{
@ -644,4 +695,7 @@ jerry = Animal "Mouse" 4
tweety :: Animal
tweety = Animal "Bird" 2
beholder :: Animal
beholder = Animal "Beholder" 0
-- }}}

12
servant/CHANGELOG.md
View file

@ -1,3 +1,15 @@
0.9
---
* Added Eq, Show, Read, Generic and Ord instances to IsSecure
* BACKWARDS INCOMPATIBLE: replace use of `ToFromByteString` with `To/FromHttpApiData` for `GetHeaders/BuildHeadersTo`
* BACKWARDS INCOMPATIBLE: Moved `From/ToFormUrlEncoded` classes, which were renamed to `From/ToForm` to `http-api-data`
0.8.1
----
* Add `CaptureAll` combinator. Captures all of the remaining segments in a URL.
0.8
---

7
servant/servant.cabal
View file

@ -1,5 +1,5 @@
name: servant
version: 0.8
version: 0.9
synopsis: A family of combinators for defining webservices APIs
description:
A family of combinators for defining webservices APIs and serving them
@ -51,12 +51,11 @@ library
build-depends:
base >= 4.7 && < 4.10
, base-compat >= 0.9 && < 0.10
, aeson >= 0.7 && < 0.12
, aeson >= 0.7 && < 1.1
, attoparsec >= 0.12 && < 0.14
, bytestring >= 0.10 && < 0.11
, bytestring-conversion >= 0.3 && < 0.4
, case-insensitive >= 1.2 && < 1.3
, http-api-data >= 0.1 && < 0.3
, http-api-data >= 0.3 && < 0.4
, http-media >= 0.4 && < 0.7
, http-types >= 0.8 && < 0.10
, mtl >= 2.0 && < 2.3

8
servant/src/Servant/API.hs
View file

@ -8,7 +8,7 @@ module Servant.API (
-- * Accessing information from the request
module Servant.API.Capture,
-- | Capturing parts of the url path as parsed values: @'Capture'@
-- | Capturing parts of the url path as parsed values: @'Capture'@ and @'CaptureAll'@
module Servant.API.Header,
-- | Retrieving specific headers from the request
module Servant.API.HttpVersion,
@ -60,12 +60,12 @@ module Servant.API (
import Servant.API.Alternative ((:<|>) (..))
import Servant.API.BasicAuth (BasicAuth,BasicAuthData(..))
import Servant.API.Capture (Capture)
import Servant.API.Capture (Capture, CaptureAll)
import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,
FromFormUrlEncoded (..), JSON,
JSON,
MimeRender (..), NoContent (NoContent),
MimeUnrender (..), OctetStream,
PlainText, ToFormUrlEncoded (..))
PlainText)
import Servant.API.Experimental.Auth (AuthProtect)
import Servant.API.Header (Header (..))
import Servant.API.HttpVersion (HttpVersion (..))

15
servant/src/Servant/API/Capture.hs
View file

@ -2,7 +2,7 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE PolyKinds #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Capture (Capture) where
module Servant.API.Capture (Capture, CaptureAll) where
import Data.Typeable (Typeable)
import GHC.TypeLits (Symbol)
@ -15,9 +15,22 @@ import GHC.TypeLits (Symbol)
data Capture (sym :: Symbol) a
deriving (Typeable)
-- | Capture all remaining values from the request path under a certain type
-- @a@.
--
-- Example:
--
-- >>> -- GET /src/*
-- >>> type MyAPI = "src" :> CaptureAll "segments" Text :> Get '[JSON] SourceFile
data CaptureAll (sym :: Symbol) a
deriving (Typeable)
-- $setup
-- >>> import Servant.API
-- >>> import Data.Aeson
-- >>> import Data.Text
-- >>> data Book
-- >>> instance ToJSON Book where { toJSON = undefined }
-- >>> data SourceFile
-- >>> instance ToJSON SourceFile where { toJSON = undefined }

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

@ -66,8 +66,6 @@ module Servant.API.ContentTypes
, AllMime(..)
, AllMimeRender(..)
, AllMimeUnrender(..)
, FromFormUrlEncoded(..)
, ToFormUrlEncoded(..)
, eitherDecodeLenient
, canHandleAcceptH
) where
@ -82,10 +80,8 @@ import Data.Attoparsec.ByteString.Char8 (endOfInput, parseOnly,
import qualified Data.ByteString as BS
import Data.ByteString.Lazy (ByteString, fromStrict,
toStrict)
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Lazy.Char8 as BC
import Data.Maybe (isJust)
import Data.Monoid.Compat
import Data.String.Conversions (cs)
import qualified Data.Text as TextS
import qualified Data.Text.Encoding as TextS
@ -94,8 +90,9 @@ import qualified Data.Text.Lazy.Encoding as TextL
import Data.Typeable
import GHC.Generics (Generic)
import qualified Network.HTTP.Media as M
import Network.URI (escapeURIString,
isUnreserved, unEscapeString)
import Web.FormUrlEncoded (FromForm, ToForm,
urlEncodeAsForm,
urlDecodeAsForm)
import Prelude ()
import Prelude.Compat
@ -290,12 +287,12 @@ instance OVERLAPPABLE_
ToJSON a => MimeRender JSON a where
mimeRender _ = encode
-- | @encodeFormUrlEncoded . toFormUrlEncoded@
-- | @urlEncodeAsForm@
-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
-- holds if every element of x is non-null (i.e., not @("", "")@)
instance OVERLAPPABLE_
ToFormUrlEncoded a => MimeRender FormUrlEncoded a where
mimeRender _ = encodeFormUrlEncoded . toFormUrlEncoded
ToForm a => MimeRender FormUrlEncoded a where
mimeRender _ = urlEncodeAsForm
-- | `TextL.encodeUtf8`
instance MimeRender PlainText TextL.Text where
@ -348,11 +345,11 @@ eitherDecodeLenient input =
instance FromJSON a => MimeUnrender JSON a where
mimeUnrender _ = eitherDecodeLenient
-- | @decodeFormUrlEncoded >=> fromFormUrlEncoded@
-- | @urlDecodeAsForm@
-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
-- holds if every element of x is non-null (i.e., not @("", "")@)
instance FromFormUrlEncoded a => MimeUnrender FormUrlEncoded a where
mimeUnrender _ = decodeFormUrlEncoded >=> fromFormUrlEncoded
instance FromForm a => MimeUnrender FormUrlEncoded a where
mimeUnrender _ = left TextS.unpack . urlDecodeAsForm
-- | @left show . TextL.decodeUtf8'@
instance MimeUnrender PlainText TextL.Text where
@ -375,49 +372,6 @@ instance MimeUnrender OctetStream BS.ByteString where
mimeUnrender _ = Right . toStrict
--------------------------------------------------------------------------
-- * FormUrlEncoded
-- | A type that can be converted to @application/x-www-form-urlencoded@
class ToFormUrlEncoded a where
toFormUrlEncoded :: a -> [(TextS.Text, TextS.Text)]
instance ToFormUrlEncoded [(TextS.Text, TextS.Text)] where
toFormUrlEncoded = id
-- | A type that can be converted from @application/x-www-form-urlencoded@,
-- with the possibility of failure.
class FromFormUrlEncoded a where
fromFormUrlEncoded :: [(TextS.Text, TextS.Text)] -> Either String a
instance FromFormUrlEncoded [(TextS.Text, TextS.Text)] where
fromFormUrlEncoded = return
encodeFormUrlEncoded :: [(TextS.Text, TextS.Text)] -> ByteString
encodeFormUrlEncoded xs =
let escape :: TextS.Text -> ByteString
escape = cs . escapeURIString isUnreserved . cs
encodePair :: (TextS.Text, TextS.Text) -> ByteString
encodePair (k, "") = escape k
encodePair (k, v) = escape k <> "=" <> escape v
in B.intercalate "&" $ map encodePair xs
decodeFormUrlEncoded :: ByteString -> Either String [(TextS.Text, TextS.Text)]
decodeFormUrlEncoded "" = return []
decodeFormUrlEncoded q = do
let xs :: [TextS.Text]
xs = TextS.splitOn "&" . cs $ q
parsePair :: TextS.Text -> Either String (TextS.Text, TextS.Text)
parsePair p =
case TextS.splitOn "=" p of
[k,v] -> return ( unescape k
, unescape v
)
[k] -> return ( unescape k, "" )
_ -> Left $ "not a valid pair: " <> cs p
unescape :: TextS.Text -> TextS.Text
unescape = cs . unEscapeString . cs . TextS.intercalate "%20" . TextS.splitOn "+"
mapM parsePair xs
-- $setup
-- >>> import Servant.API

15
servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs
View file

@ -13,6 +13,13 @@ import Servant.API
type GET = Get '[JSON] NoContent
type ComprehensiveAPI =
ComprehensiveAPIWithoutRaw :<|>
Raw
comprehensiveAPI :: Proxy ComprehensiveAPI
comprehensiveAPI = Proxy
type ComprehensiveAPIWithoutRaw =
GET :<|>
Get '[JSON] Int :<|>
Capture "foo" Int :> GET :<|>
@ -22,7 +29,6 @@ type ComprehensiveAPI =
QueryParam "foo" Int :> GET :<|>
QueryParams "foo" Int :> GET :<|>
QueryFlag "foo" :> GET :<|>
-- Raw :<|>
RemoteHost :> GET :<|>
ReqBody '[JSON] Int :> GET :<|>
Get '[JSON] (Headers '[Header "foo" Int] NoContent) :<|>
@ -30,7 +36,8 @@ type ComprehensiveAPI =
Vault :> GET :<|>
Verb 'POST 204 '[JSON] NoContent :<|>
Verb 'POST 204 '[JSON] Int :<|>
WithNamedContext "foo" '[] GET
WithNamedContext "foo" '[] GET :<|>
CaptureAll "foo" Int :> GET
comprehensiveAPI :: Proxy ComprehensiveAPI
comprehensiveAPI = Proxy
comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPIWithoutRaw
comprehensiveAPIWithoutRaw = Proxy

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

@ -1,10 +1,12 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
module Servant.API.IsSecure
( -- $issecure
IsSecure(..)
) where
import Data.Typeable
import GHC.Generics (Generic)
-- | Was this request made over an SSL connection?
--
@ -19,7 +21,7 @@ data IsSecure = Secure -- ^ the connection to the server
-- is secure (HTTPS)
| NotSecure -- ^ the connection to the server
-- is not secure (HTTP)
deriving Typeable
deriving (Eq, Show, Read, Generic, Ord, Typeable)
-- $issecure
--

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

@ -31,8 +31,8 @@ module Servant.API.ResponseHeaders
) where
import Data.ByteString.Char8 as BS (pack, unlines, init)
import Data.ByteString.Conversion (ToByteString, toByteString',
FromByteString, fromByteString)
import Web.HttpApiData (ToHttpApiData, toHeader,
FromHttpApiData, parseHeader)
import qualified Data.CaseInsensitive as CI
import Data.Proxy
import GHC.TypeLits (KnownSymbol, symbolVal)
@ -68,17 +68,17 @@ class BuildHeadersTo hs where
instance OVERLAPPING_ BuildHeadersTo '[] where
buildHeadersTo _ = HNil
instance OVERLAPPABLE_ ( FromByteString v, BuildHeadersTo xs, KnownSymbol h )
instance OVERLAPPABLE_ ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbol h )
=> BuildHeadersTo ((Header h v) ': xs) where
buildHeadersTo headers =
let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
matching = snd <$> filter (\(h, _) -> h == wantedHeader) headers
in case matching of
[] -> MissingHeader `HCons` buildHeadersTo headers
xs -> case fromByteString (BS.init $ BS.unlines xs) of
Nothing -> UndecodableHeader (BS.init $ BS.unlines xs)
xs -> case parseHeader (BS.init $ BS.unlines xs) of
Left _err -> UndecodableHeader (BS.init $ BS.unlines xs)
`HCons` buildHeadersTo headers
Just h -> Header h `HCons` buildHeadersTo headers
Right h -> Header h `HCons` buildHeadersTo headers
-- * Getting
@ -88,18 +88,18 @@ class GetHeaders ls where
instance OVERLAPPING_ GetHeaders (HList '[]) where
getHeaders _ = []
instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs) )
instance OVERLAPPABLE_ ( KnownSymbol h, ToHttpApiData 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
UndecodableHeader h `HCons` rest -> (headerName, h) : getHeaders rest
Header val `HCons` rest -> (headerName , toHeader val):getHeaders rest
UndecodableHeader h `HCons` rest -> (headerName, h) :getHeaders rest
MissingHeader `HCons` rest -> getHeaders rest
where headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
instance OVERLAPPING_ GetHeaders (Headers '[] a) where
getHeaders _ = []
instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToByteString v )
instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToHttpApiData v )
=> GetHeaders (Headers (Header h v ': rest) a) where
getHeaders hs = getHeaders $ getHeadersHList hs
@ -111,11 +111,11 @@ 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 )
instance OVERLAPPING_ ( KnownSymbol h, ToHttpApiData 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
instance OVERLAPPABLE_ ( KnownSymbol h, ToHttpApiData v
, new ~ (Headers '[Header h v] a) )
=> AddHeader h v a new where
addHeader a resp = Headers resp (HCons (Header a) HNil)

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

@ -107,7 +107,7 @@ import Prelude.Compat
import Web.HttpApiData
import Servant.API.BasicAuth ( BasicAuth )
import Servant.API.Capture ( Capture )
import Servant.API.Capture ( Capture, CaptureAll )
import Servant.API.ReqBody ( ReqBody )
import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag )
import Servant.API.Header ( Header )
@ -163,6 +163,8 @@ type family IsElem endpoint api :: Constraint where
IsElem sa (ReqBody y x :> sb) = IsElem sa sb
IsElem (Capture z y :> sa) (Capture x y :> sb)
= IsElem sa sb
IsElem (CaptureAll z y :> sa) (CaptureAll x y :> sb)
= IsElem sa sb
IsElem sa (QueryParam x y :> sb) = IsElem sa sb
IsElem sa (QueryParams x y :> sb) = IsElem sa sb
IsElem sa (QueryFlag x :> sb) = IsElem sa sb
@ -284,6 +286,13 @@ instance (ToHttpApiData v, HasLink sub)
toLink (Proxy :: Proxy sub) $
addSegment (escape . Text.unpack $ toUrlPiece v) l
instance (ToHttpApiData v, HasLink sub)
=> HasLink (CaptureAll sym v :> sub) where
type MkLink (CaptureAll sym v :> sub) = [v] -> MkLink sub
toLink _ l vs =
toLink (Proxy :: Proxy sub) $
foldl' (flip $ addSegment . escape . Text.unpack . toUrlPiece) l vs
instance HasLink sub => HasLink (Header sym a :> sub) where
type MkLink (Header sym a :> sub) = MkLink sub
toLink _ = toLink (Proxy :: Proxy sub)

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

@ -11,7 +11,6 @@ module Servant.API.ContentTypesSpec where
import Prelude ()
import Prelude.Compat
import Control.Arrow
import Data.Aeson
import Data.ByteString.Char8 (ByteString, append, pack)
import qualified Data.ByteString.Lazy as BSL
@ -25,7 +24,6 @@ import Data.String.Conversions (cs)
import qualified Data.Text as TextS
import qualified Data.Text.Lazy as TextL
import GHC.Generics
import Network.URL (exportParams, importParams)
import Test.Hspec
import Test.QuickCheck
import "quickcheck-instances" Test.QuickCheck.Instances ()
@ -68,21 +66,6 @@ spec = describe "Servant.API.ContentTypes" $ do
it "has mimeUnrender reverse mimeRender for valid top-level json " $ do
property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData)
describe "The FormUrlEncoded Content-Type type" $ do
let p = Proxy :: Proxy FormUrlEncoded
it "has mimeUnrender reverse mimeRender" $ do
property $ \x -> mempty `notElem` x
==> mimeUnrender p (mimeRender p x) == Right (x::[(TextS.Text,TextS.Text)])
it "has mimeUnrender reverse exportParams (Network.URL)" $ do
property $ \x -> mempty `notElem` x
==> (mimeUnrender p . cs . exportParams . map (cs *** cs) $ x) == Right (x::[(TextS.Text,TextS.Text)])
it "has importParams (Network.URL) reverse mimeRender" $ do
property $ \x -> mempty `notElem` x
==> (fmap (map (cs *** cs)) . importParams . cs . mimeRender p $ x) == Just (x::[(TextS.Text,TextS.Text)])
describe "The PlainText Content-Type type" $ do
let p = Proxy :: Proxy PlainText

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

@ -13,6 +13,7 @@ import Servant.API
type TestApi =
-- Capture and query params
"hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete '[JSON] NoContent
:<|> "all" :> CaptureAll "names" String :> Get '[JSON] NoContent
-- Flags
:<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] NoContent
@ -46,6 +47,10 @@ spec = describe "Servant.Utils.Links" $ do
:> Delete '[JSON] NoContent)
apiLink l2 "bye" (Just True) `shouldBeURI` "hello/bye?capital=true"
it "generates correct links for CaptureAll" $ do
apiLink (Proxy :: Proxy ("all" :> CaptureAll "names" String :> Get '[JSON] NoContent))
["roads", "lead", "to", "rome"]
`shouldBeURI` "all/roads/lead/to/rome"
it "generates correct links for query flags" $ do
let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy"

1
sources.txt
View file

@ -4,4 +4,3 @@ servant-client
servant-docs
servant-foreign
servant-js
servant-mock

8
stack-ghc-7.8.4.yaml
View file

@ -5,7 +5,6 @@ packages:
- servant-docs/
- servant-foreign/
- servant-js/
- servant-mock/
- servant-server/
extra-deps:
- base-compat-0.9.1
@ -16,13 +15,10 @@ extra-deps:
- hspec-core-2.2.3
- hspec-discover-2.2.3
- hspec-expectations-0.7.2
- http-api-data-0.2.2
- http-api-data-0.3
- 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
- uri-bytestring-0.2.2.0
- wai-app-static-3.1.5
resolver: lts-2.22

5
stack-ghc-8.0.1.yaml
View file

@ -5,7 +5,8 @@ packages:
- servant-docs/
- servant-foreign/
- servant-js/
- servant-mock/
- servant-server/
extra-deps: []
extra-deps:
- http-api-data-0.3
- uri-bytestring-0.2.2.0
flags: {}

2
stack.yaml
View file

@ -5,8 +5,8 @@ packages:
- servant-docs/
- servant-foreign/
- servant-js/
- servant-mock/
- servant-server/
- doc/tutorial
extra-deps:
- http-api-data-0.3
resolver: lts-6.0