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 language: c
env: env:
- GHCVER=7.8.4 CABALVER=1.22 - STACK_YAML=stack-ghc-7.8.4.yaml
- GHCVER=7.10.3 CABALVER=1.22 - STACK_YAML=stack.yaml
- GHCVER=8.0.1 CABALVER=1.24 - STACK_YAML=stack-ghc-8.0.1.yaml
addons: addons:
apt: apt:
sources:
- hvr-ghc
packages: packages:
- ghc-7.8.4
- ghc-7.10.3
- ghc-8.0.1
- cabal-install-1.22
- cabal-install-1.24
- libgmp-dev - libgmp-dev
install: install:
- (mkdir -p $HOME/.local/bin && cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc) - mkdir -p ~/.local/bin
- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH - export PATH=$HOME/.local/bin:$PATH
- ghc --version - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
- cabal --version - stack --version
- travis_retry cabal update - stack setup --no-terminal
- sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config - (cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc)
script: script:
- ./travis.sh - if [ "$TRAVIS_EVENT_TYPE" = "cron" ] ; then ./scripts/ci-cron.sh ; else stack test --ghc-options=-Werror --no-terminal ; fi
cache: cache:
directories: directories:
- $HOME/.tinc/cache - $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 ./scripts/test-all.sh # Run all the tests
``` ```
`stack`: Or `stack`:
```shell ```shell
stack setup # Downloads and installs a proper GHC version if necessary
stack build # Install and build packages stack build # Install and build packages
stack test # Run all the tests 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 singledispatch==3.4.0.3
six==1.10.0 six==1.10.0
snowballstemmer==1.2.1 snowballstemmer==1.2.1
Sphinx==1.3.4 Sphinx==1.3.6
sphinx-autobuild==0.5.2 sphinx-autobuild==0.5.2
sphinx-rtd-theme==0.1.9 sphinx-rtd-theme==0.1.9
tornado==4.3 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 is equivalent to `/list-all/users`. This means that sometimes `:>` is somehow
equivalent to `/`, but sometimes it just lets you chain another combinator. 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 `:<|>` We can also describe APIs with multiple endpoints by using the `:<|>`
combinators. Here's an example: combinators. Here's an example:
@ -311,8 +319,8 @@ Which is used like so:
``` haskell ``` haskell
type ProtectedAPI12 type ProtectedAPI12
= UserAPI -- this is public = UserAPI -- this is public
:<|> BasicAuth "my-real" User :> UserAPI2 -- this is protected by auth :<|> BasicAuth "my-realm" User :> UserAPI2 -- this is protected by auth
``` ```
### Interoperability with `wai`: `Raw` ### 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 module Client where
import Control.Monad.Trans.Except (ExceptT, runExceptT)
import Data.Aeson import Data.Aeson
import Data.Proxy import Data.Proxy
import GHC.Generics import GHC.Generics
import Network.HTTP.Client (Manager, newManager, defaultManagerSettings) import Network.HTTP.Client (newManager, defaultManagerSettings)
import Servant.API import Servant.API
import Servant.Client import Servant.Client
``` ```
@ -71,19 +70,13 @@ What we are going to get with **servant-client** here is 3 functions, one to que
``` haskell ``` haskell
position :: Int -- ^ value for "x" position :: Int -- ^ value for "x"
-> Int -- ^ value for "y" -> Int -- ^ value for "y"
-> Manager -- ^ the HTTP client to use -> ClientM Position
-> BaseUrl -- ^ the URL at which the API can be found
-> ExceptT ServantError IO Position
hello :: Maybe String -- ^ an optional value for "name" hello :: Maybe String -- ^ an optional value for "name"
-> Manager -- ^ the HTTP client to use -> ClientM HelloMessage
-> BaseUrl -- ^ the URL at which the API can be found
-> ExceptT ServantError IO HelloMessage
marketing :: ClientInfo -- ^ value for the request body marketing :: ClientInfo -- ^ value for the request body
-> Manager -- ^ the HTTP client to use -> ClientM Email
-> BaseUrl -- ^ the URL at which the API can be found
-> ExceptT ServantError IO Email
``` ```
Each function makes available as an argument any value that the response may 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. That's it. Let's now write some code that uses our client functions.
``` haskell ``` haskell
queries :: Manager -> BaseUrl -> ExceptT ServantError IO (Position, HelloMessage, Email) queries :: ClientM (Position, HelloMessage, Email)
queries manager baseurl = do queries = do
pos <- position 10 10 manager baseurl pos <- position 10 10
message <- hello (Just "servant") manager baseurl message <- hello (Just "servant")
em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]) manager baseurl em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"])
return (pos, message, em) return (pos, message, em)
run :: IO () run :: IO ()
run = do run = do
manager <- newManager defaultManagerSettings manager <- newManager defaultManagerSettings
res <- runExceptT (queries manager (BaseUrl Http "localhost" 8081 "")) res <- runClientM queries (ClientEnv manager (BaseUrl Http "localhost" 8081 ""))
case res of case res of
Left err -> putStrLn $ "Error: " ++ show err Left err -> putStrLn $ "Error: " ++ show err
Right (pos, message, em) -> do 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 Very similarly to how one can derive haskell functions, we can derive the
javascript with just a simple function call to `jsForAPI` from javascript with just a simple function call to `jsForAPI` from
`Servant.JQuery`. `Servant.JS`.
``` haskell ``` haskell
apiJS :: Text apiJS1 :: Text
apiJS = jsForAPI api vanillaJS apiJS1 = jsForAPI api jquery
``` ```
This `Text` contains 2 Javascript functions, 'getPoint' and 'getBooks': This `Text` contains 2 Javascript functions, 'getPoint' and 'getBooks':
``` javascript ``` 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 getPoint = function(onSuccess, onError)
{ {
var xhr = new XMLHttpRequest(); var xhr = new XMLHttpRequest();
xhr.open('GET', '/point', true); xhr.open('GET', '/point', true);
xhr.setRequestHeader("Accept","application/json"); xhr.setRequestHeader(\"Accept\",\"application/json\");
xhr.onreadystatechange = function (e) { xhr.onreadystatechange = function (e) {
if (xhr.readyState == 4) { if (xhr.readyState == 4) {
if (xhr.status == 204 || xhr.status == 205) { if (xhr.status == 204 || xhr.status == 205) {
@ -186,7 +285,7 @@ var getBooks = function(q, onSuccess, onError)
{ {
var xhr = new XMLHttpRequest(); var xhr = new XMLHttpRequest();
xhr.open('GET', '/books' + '?q=' + encodeURIComponent(q), true); xhr.open('GET', '/books' + '?q=' + encodeURIComponent(q), true);
xhr.setRequestHeader("Accept","application/json"); xhr.setRequestHeader(\"Accept\",\"application/json\");
xhr.onreadystatechange = function (e) { xhr.onreadystatechange = function (e) {
if (xhr.readyState == 4) { if (xhr.readyState == 4) {
if (xhr.status == 204 || xhr.status == 205) { if (xhr.status == 204 || xhr.status == 205) {
@ -202,27 +301,218 @@ var getBooks = function(q, onSuccess, onError)
} }
xhr.send(null); xhr.send(null);
} }
``` ```
We created a directory `static` that contains two static files: `index.html`, And that's all, your web service can of course be accessible from those
which is the entrypoint to our little web application; and `ui.js`, which two clients at the same time!
contains some hand-written javascript. This javascript code assumes the two
generated functions `getPoint` and `getBooks` in scope. Therefore we need to ## Axios support
write the generated javascript into a file:
### 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 ``` haskell
writeJSFiles :: IO () apiJS3 :: Text
writeJSFiles = do apiJS3 = jsForAPI api $ axios defAxiosOptions
T.writeFile "static/api.js" apiJS
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 The rest is *completely* unchanged.
`ui.js`.) `static/api.js` will be included in `index.html` and the two
generated functions will therefore be available in `ui.js`. 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 describe "apiJS" $ do
it "is contained verbatim in Javascript.lhs" $ do it "is contained verbatim in Javascript.lhs" $ do
code <- readFile "Javascript.lhs" 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 describe "writeJSFiles" $ do
it "[not a test] write apiJS to static/api.js" $ do it "[not a test] write apiJS to static/api.js" $ do
@ -24,7 +27,7 @@ spec = do
describe "app" $ with (return app) $ do describe "app" $ with (return app) $ do
context "/api.js" $ do context "/api.js" $ do
it "delivers apiJS" $ do it "delivers apiJS" $ do
get "/api.js" `shouldRespondWith` (fromString (cs apiJS)) get "/api.js" `shouldRespondWith` (fromString (cs apiJS1))
context "/" $ do context "/" $ do
it "delivers something" $ do it "delivers something" $ do

12
doc/tutorial/tutorial.cabal
View File

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

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

@ -1,8 +1,15 @@
#!/usr/bin/env bash #!/usr/bin/env bash
set -o nounset
set -o errexit 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 echo testing $package
pushd $package pushd $package
tinc 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 0.7.1
----- -----

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

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

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

@ -20,6 +20,8 @@ module Servant.Client
, client , client
, HasClient(..) , HasClient(..)
, ClientM , ClientM
, runClientM
, ClientEnv (ClientEnv)
, mkAuthenticateReq , mkAuthenticateReq
, ServantError(..) , ServantError(..)
, module Servant.Common.BaseUrl , module Servant.Common.BaseUrl
@ -34,7 +36,7 @@ import Data.Proxy
import Data.String.Conversions import Data.String.Conversions
import Data.Text (unpack) import Data.Text (unpack)
import GHC.TypeLits import GHC.TypeLits
import Network.HTTP.Client (Manager, Response) import Network.HTTP.Client (Response)
import Network.HTTP.Media import Network.HTTP.Media
import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types.Header as HTTP import qualified Network.HTTP.Types.Header as HTTP
@ -119,21 +121,53 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient api)
where p = unpack (toUrlPiece val) 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_ instance OVERLAPPABLE_
-- Note [Non-Empty Content Types] -- Note [Non-Empty Content Types]
(MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient (Verb method status cts' a) where ) => HasClient (Verb method status cts' a) where
type Client (Verb method status cts' a) = Manager -> BaseUrl -> ClientM a type Client (Verb method status cts' a) = ClientM a
clientWithRoute Proxy req manager baseurl = clientWithRoute Proxy req = do
snd <$> performRequestCT (Proxy :: Proxy ct) method req manager baseurl snd <$> performRequestCT (Proxy :: Proxy ct) method req
where method = reflectMethod (Proxy :: Proxy method) where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_ instance OVERLAPPING_
(ReflectMethod method) => HasClient (Verb method status cts NoContent) where (ReflectMethod method) => HasClient (Verb method status cts NoContent) where
type Client (Verb method status cts NoContent) type Client (Verb method status cts NoContent)
= Manager -> BaseUrl -> ClientM NoContent = ClientM NoContent
clientWithRoute Proxy req manager baseurl = clientWithRoute Proxy req = do
performRequestNoBody method req manager baseurl >> return NoContent performRequestNoBody method req >> return NoContent
where method = reflectMethod (Proxy :: Proxy method) where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_ instance OVERLAPPING_
@ -141,10 +175,10 @@ instance OVERLAPPING_
( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts) ( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient (Verb method status cts' (Headers ls a)) where ) => HasClient (Verb method status cts' (Headers ls a)) where
type Client (Verb method status cts' (Headers ls a)) type Client (Verb method status cts' (Headers ls a))
= Manager -> BaseUrl -> ClientM (Headers ls a) = ClientM (Headers ls a)
clientWithRoute Proxy req manager baseurl = do clientWithRoute Proxy req = do
let method = reflectMethod (Proxy :: Proxy method) 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 return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs , getHeadersHList = buildHeadersTo hdrs
} }
@ -153,10 +187,10 @@ instance OVERLAPPING_
( BuildHeadersTo ls, ReflectMethod method ( BuildHeadersTo ls, ReflectMethod method
) => HasClient (Verb method status cts (Headers ls NoContent)) where ) => HasClient (Verb method status cts (Headers ls NoContent)) where
type Client (Verb method status cts (Headers ls NoContent)) type Client (Verb method status cts (Headers ls NoContent))
= Manager -> BaseUrl -> ClientM (Headers ls NoContent) = ClientM (Headers ls NoContent)
clientWithRoute Proxy req manager baseurl = do clientWithRoute Proxy req = do
let method = reflectMethod (Proxy :: Proxy method) let method = reflectMethod (Proxy :: Proxy method)
hdrs <- performRequestNoBody method req manager baseurl hdrs <- performRequestNoBody method req
return $ Headers { getResponse = NoContent return $ Headers { getResponse = NoContent
, getHeadersHList = buildHeadersTo hdrs , getHeadersHList = buildHeadersTo hdrs
} }
@ -341,7 +375,7 @@ instance (KnownSymbol sym, HasClient api)
-- back the full `Response`. -- back the full `Response`.
instance HasClient Raw where instance HasClient Raw where
type Client Raw 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 Raw -> Req -> Client Raw
clientWithRoute Proxy req httpMethod = do clientWithRoute Proxy req httpMethod = do

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

@ -1,7 +1,9 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
#if MIN_VERSION_base(4,9,0) #if MIN_VERSION_base(4,9,0)
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
@ -15,14 +17,25 @@ import Control.Applicative
import Control.Exception import Control.Exception
import Control.Monad import Control.Monad
import Control.Monad.Catch (MonadThrow) 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 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.ByteString.Lazy hiding (pack, filter, map, null, elem)
import Data.String import Data.String
import Data.String.Conversions import Data.String.Conversions
import Data.Proxy import Data.Proxy
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding import Data.Text.Encoding
import Data.Typeable
import Network.HTTP.Client hiding (Proxy, path) import Network.HTTP.Client hiding (Proxy, path)
import Network.HTTP.Media import Network.HTTP.Media
import Network.HTTP.Types 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 :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
reqToRequest req (BaseUrl reqScheme reqHost reqPort path) = reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
setheaders . setAccept . setrqb . setQS <$> parseUrlThrow url setheaders . setAccept . setrqb . setQS <$> parseRequest url
where url = show $ nullURI { uriScheme = case reqScheme of where url = show $ nullURI { uriScheme = case reqScheme of
Http -> "http:" Http -> "http:"
@ -94,8 +107,18 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
| not . null . reqAccept $ req] } | not . null . reqAccept $ req] }
toProperHeader (name, val) = toProperHeader (name, val) =
(fromString name, encodeUtf8 val) (fromString name, encodeUtf8 val)
#if !MIN_VERSION_http_client(0,4,30) #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 #endif
@ -104,21 +127,40 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
displayHttpRequest :: Method -> String displayHttpRequest :: Method -> String
displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" 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 -> ClientM ( Int, ByteString, MediaType
, [HTTP.Header], Response ByteString) , [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 partialRequest <- liftIO $ reqToRequest req reqHost
let request = disableStatusCheck $ let request = partialRequest { Client.method = reqMethod }
partialRequest { Client.method = reqMethod }
eResponse <- liftIO $ performHttpRequest manager request eResponse <- liftIO $ performHttpRequest m request
case eResponse of case eResponse of
Left err -> Left err ->
throwE . ConnectionError $ SomeException err throwError . ConnectionError $ SomeException err
Right response -> do Right response -> do
let status = Client.responseStatus response let status = Client.responseStatus response
@ -128,33 +170,24 @@ performRequest reqMethod req manager reqHost = do
ct <- case lookup "Content-Type" $ Client.responseHeaders response of ct <- case lookup "Content-Type" $ Client.responseHeaders response of
Nothing -> pure $ "application"//"octet-stream" Nothing -> pure $ "application"//"octet-stream"
Just t -> case parseAccept t of Just t -> case parseAccept t of
Nothing -> throwE $ InvalidContentTypeHeader (cs t) body Nothing -> throwError $ InvalidContentTypeHeader (cs t) body
Just t' -> pure t' Just t' -> pure t'
unless (status_code >= 200 && status_code < 300) $ unless (status_code >= 200 && status_code < 300) $
throwE $ FailureResponse status ct body throwError $ FailureResponse status ct body
return (status_code, body, ct, hdrs, response) return (status_code, body, ct, hdrs, response)
disableStatusCheck :: Request -> Request performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req
#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
-> ClientM ([HTTP.Header], result) -> ClientM ([HTTP.Header], result)
performRequestCT ct reqMethod req manager reqHost = do performRequestCT ct reqMethod req = do
let acceptCT = contentType ct let acceptCT = contentType ct
(_status, respBody, respCT, hdrs, _response) <- (_status, respBody, respCT, hdrs, _response) <-
performRequest reqMethod (req { reqAccept = [acceptCT] }) manager reqHost performRequest reqMethod (req { reqAccept = [acceptCT] })
unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody unless (matches respCT (acceptCT)) $ throwError $ UnsupportedContentType respCT respBody
case mimeUnrender ct respBody of case mimeUnrender ct respBody of
Left err -> throwE $ DecodeFailure err respCT respBody Left err -> throwError $ DecodeFailure err respCT respBody
Right val -> return (hdrs, val) Right val -> return (hdrs, val)
performRequestNoBody :: Method -> Req -> Manager -> BaseUrl performRequestNoBody :: Method -> Req -> ClientM [HTTP.Header]
-> ClientM [HTTP.Header] performRequestNoBody reqMethod req = do
performRequestNoBody reqMethod req manager reqHost = do (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req
(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req manager reqHost
return hdrs return hdrs

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

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

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

@ -1,5 +1,5 @@
name: servant-docs name: servant-docs
version: 0.8 version: 0.9
synopsis: generate API docs for your servant webservice synopsis: generate API docs for your servant webservice
description: description:
Library for generating API docs from a servant API definition. Library for generating API docs from a servant API definition.
@ -36,13 +36,12 @@ library
, aeson , aeson
, aeson-pretty , aeson-pretty
, bytestring , bytestring
, bytestring-conversion
, case-insensitive , case-insensitive
, hashable , hashable
, http-media >= 0.6 , http-media >= 0.6
, http-types >= 0.7 , http-types >= 0.7
, lens , lens
, servant == 0.8.* , servant == 0.9.*
, string-conversions , string-conversions
, text , text
, unordered-containers , unordered-containers
@ -61,7 +60,6 @@ executable greet-docs
build-depends: build-depends:
base base
, aeson , aeson
, bytestring-conversion
, lens , lens
, servant , servant
, servant-docs , 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 Control.Lens (makeLenses, mapped, over, traversed, view, (%~),
(&), (.~), (<>~), (^.), (|>)) (&), (.~), (<>~), (^.), (|>))
import qualified Control.Monad.Omega as Omega import qualified Control.Monad.Omega as Omega
import Data.ByteString.Conversion (ToByteString, toByteString)
import Data.ByteString.Lazy.Char8 (ByteString) import Data.ByteString.Lazy.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Char8 as BSC
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
@ -461,12 +460,12 @@ class AllHeaderSamples ls where
instance AllHeaderSamples '[] where instance AllHeaderSamples '[] where
allHeaderToSample _ = [] 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 => AllHeaderSamples (Header h l ': ls) where
allHeaderToSample _ = mkHeader (toSample (Proxy :: Proxy l)) : allHeaderToSample _ = mkHeader (toSample (Proxy :: Proxy l)) :
allHeaderToSample (Proxy :: Proxy ls) allHeaderToSample (Proxy :: Proxy ls)
where headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy h) 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>") mkHeader Nothing = (headerName, "<no header sample provided>")
-- | Synthesise a sample value of a type, encoded in the specified media types. -- | 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 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_ instance OVERLAPPABLE_
(ToSample a, AllMimeRender (ct ': cts) a, KnownNat status (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
, ReflectMethod method) , ReflectMethod method)

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

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

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

@ -1,5 +1,5 @@
name: servant-foreign name: servant-foreign
version: 0.8 version: 0.9
synopsis: Helpers for generating clients for servant APIs in any programming language synopsis: Helpers for generating clients for servant APIs in any programming language
description: description:
Helper types and functions for generating client functions for servant APIs in any programming language Helper types and functions for generating client functions for servant APIs in any programming language
@ -32,7 +32,7 @@ library
, Servant.Foreign.Inflections , Servant.Foreign.Inflections
build-depends: base == 4.* build-depends: base == 4.*
, lens == 4.* , lens == 4.*
, servant == 0.8.* , servant == 0.9.*
, text >= 1.2 && < 1.3 , text >= 1.2 && < 1.3
, http-types , http-types
hs-source-dirs: src 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 { _argName = PathSegment str
, _argType = ftype } , _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) instance (Elem JSON list, HasForeignType lang ftype a, ReflectMethod method)
=> HasForeign lang ftype (Verb method status list a) where => HasForeign lang ftype (Verb method status list a) where
type Foreign ftype (Verb method status list a) = Req ftype 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" :> QueryParam "param" Int :> ReqBody '[JSON] [String] :> Post '[JSON] NoContent
:<|> "test" :> QueryParams "params" Int :> ReqBody '[JSON] String :> Put '[JSON] NoContent :<|> "test" :> QueryParams "params" Int :> ReqBody '[JSON] String :> Put '[JSON] NoContent
:<|> "test" :> Capture "id" Int :> Delete '[JSON] NoContent :<|> "test" :> Capture "id" Int :> Delete '[JSON] NoContent
:<|> "test" :> CaptureAll "ids" Int :> Get '[JSON] [Int]
testApi :: [Req String] testApi :: [Req String]
testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy String) (Proxy :: Proxy TestApi) 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 :: Spec
listFromAPISpec = describe "listFromAPI" $ do listFromAPISpec = describe "listFromAPI" $ do
it "generates 4 endpoints for TestApi" $ 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 it "collects all info for get request" $ do
shouldBe getReq $ defReq shouldBe getReq $ defReq
@ -106,3 +107,16 @@ listFromAPISpec = describe "listFromAPI" $ do
, _reqReturnType = Just "voidX" , _reqReturnType = Just "voidX"
, _reqFuncName = FunctionName ["delete", "test", "by", "id"] , _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 :<|> currentValue counter -- read the TVar
server' :: TVar Counter -> Server TestApi' server' :: TVar Counter -> Server TestApi'
server counter = server counter server' counter = server counter
:<|> serveDirectory www -- serve static files :<|> serveDirectory www -- serve static files
runServer :: TVar Counter -- ^ shared variable for the counter runServer :: TVar Counter -- ^ shared variable for the counter
-> Int -- ^ port the server should listen on -> Int -- ^ port the server should listen on

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

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

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

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

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

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

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

@ -33,7 +33,7 @@ import Servant.JSSpec.CustomHeaders
-- * comprehensive api -- * comprehensive api
-- This declaration simply checks that all instances are in place. -- This declaration simply checks that all instances are in place.
_ = jsForAPI comprehensiveAPI vanillaJS :: Text _ = jsForAPI comprehensiveAPIWithoutRaw vanillaJS :: Text
-- * specs -- * 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 name: servant-server
version: 0.8 version: 0.9
synopsis: A family of combinators for defining webservices APIs and serving them synopsis: A family of combinators for defining webservices APIs and serving them
description: description:
A family of combinators for defining webservices APIs and serving them A family of combinators for defining webservices APIs and serving them
@ -47,18 +47,18 @@ library
build-depends: build-depends:
base >= 4.7 && < 4.10 base >= 4.7 && < 4.10
, base-compat >= 0.9 && < 0.10 , base-compat >= 0.9 && < 0.10
, aeson >= 0.7 && < 0.12 , aeson >= 0.7 && < 1.1
, attoparsec >= 0.12 && < 0.14 , attoparsec >= 0.12 && < 0.14
, base64-bytestring >= 1.0 && < 1.1 , base64-bytestring >= 1.0 && < 1.1
, bytestring >= 0.10 && < 0.11 , bytestring >= 0.10 && < 0.11
, containers >= 0.5 && < 0.6 , 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 , http-types >= 0.8 && < 0.10
, network-uri >= 2.6 && < 2.7 , network-uri >= 2.6 && < 2.7
, mtl >= 2 && < 2.3 , mtl >= 2 && < 2.3
, network >= 2.6 && < 2.7 , network >= 2.6 && < 2.7
, safe >= 0.3 && < 0.4 , safe >= 0.3 && < 0.4
, servant == 0.8.* , servant == 0.9.*
, split >= 0.2 && < 0.3 , split >= 0.2 && < 0.3
, string-conversions >= 0.3 && < 0.5 , string-conversions >= 0.3 && < 0.5
, system-filepath >= 0.4 && < 0.5 , system-filepath >= 0.4 && < 0.5
@ -99,6 +99,7 @@ test-suite spec
hs-source-dirs: test hs-source-dirs: test
main-is: Spec.hs main-is: Spec.hs
other-modules: other-modules:
Servant.ArbitraryMonadServerSpec
Servant.Server.ErrorSpec Servant.Server.ErrorSpec
Servant.Server.Internal.ContextSpec Servant.Server.Internal.ContextSpec
Servant.Server.RouterSpec Servant.Server.RouterSpec
@ -113,7 +114,6 @@ test-suite spec
, aeson , aeson
, base64-bytestring , base64-bytestring
, bytestring , bytestring
, bytestring-conversion
, directory , directory
, exceptions , exceptions
, hspec == 2.* , hspec == 2.*

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

@ -42,16 +42,16 @@ import Network.Wai (Application, Request, Response,
responseLBS, vault) responseLBS, vault)
import Prelude () import Prelude ()
import Prelude.Compat import Prelude.Compat
import Web.HttpApiData (FromHttpApiData) import Web.HttpApiData (FromHttpApiData, parseHeaderMaybe,
import Web.HttpApiData.Internal (parseHeaderMaybe,
parseQueryParamMaybe, parseQueryParamMaybe,
parseUrlPieceMaybe) parseUrlPieceMaybe,
parseUrlPieces)
import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture, import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture,
Verb, ReflectMethod(reflectMethod), CaptureAll, Verb,
IsSecure(..), Header, ReflectMethod(reflectMethod),
QueryFlag, QueryParam, QueryParams, IsSecure(..), Header, QueryFlag,
Raw, RemoteHost, ReqBody, Vault, QueryParam, QueryParams, Raw,
RemoteHost, ReqBody, Vault,
WithNamedContext) WithNamedContext)
import Servant.API.ContentTypes (AcceptHeader (..), import Servant.API.ContentTypes (AcceptHeader (..),
AllCTRender (..), AllCTRender (..),
@ -128,11 +128,44 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
CaptureRouter $ CaptureRouter $
route (Proxy :: Proxy api) route (Proxy :: Proxy api)
context context
(addCapture d $ \ txt -> case parseUrlPieceMaybe txt :: Maybe a of (addCapture d $ \ txt -> case parseUrlPieceMaybe txt of
Nothing -> delayedFail err400 Nothing -> delayedFail err400
Just v -> return v 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 -> Bool
allowedMethodHead method request = method == methodGet && requestMethod request == methodHead 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) | CaptureRouter (Router' (Text, env) a)
-- ^ first path component is passed to the child router in its -- ^ first path component is passed to the child router in its
-- environment and removed afterwards -- 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) | RawRouter (env -> a)
-- ^ to be used for routes we do not know anything about -- ^ to be used for routes we do not know anything about
| Choice (Router' env a) (Router' env a) | Choice (Router' env a) (Router' env a)
@ -90,6 +93,9 @@ routerStructure (StaticRouter m ls) =
routerStructure (CaptureRouter router) = routerStructure (CaptureRouter router) =
CaptureRouterStructure $ CaptureRouterStructure $
routerStructure router routerStructure router
routerStructure (CaptureAllRouter router) =
CaptureRouterStructure $
routerStructure router
routerStructure (RawRouter _) = routerStructure (RawRouter _) =
RawRouterStructure RawRouterStructure
routerStructure (Choice r1 r2) = routerStructure (Choice r1 r2) =
@ -163,6 +169,10 @@ runRouterEnv router env request respond =
first : rest first : rest
-> let request' = request { pathInfo = rest } -> let request' = request { pathInfo = rest }
in runRouterEnv router' (first, env) request' respond 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 -> RawRouter app ->
app env request respond app env request respond
Choice r1 r2 -> 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 (ap, liftM)
import Control.Monad.Trans (MonadIO(..)) import Control.Monad.Trans (MonadIO(..))
import Control.Monad.Trans.Except (runExceptT) import Control.Monad.Trans.Except (runExceptT)
import Data.Text (Text)
import Network.Wai (Application, Request, import Network.Wai (Application, Request,
Response, ResponseReceived) Response, ResponseReceived)
import Prelude () import Prelude ()
@ -161,8 +160,8 @@ withRequest f = DelayedIO (\ req -> runDelayedIO (f req) req)
-- | Add a capture to the end of the capture block. -- | Add a capture to the end of the capture block.
addCapture :: Delayed env (a -> b) addCapture :: Delayed env (a -> b)
-> (Text -> DelayedIO a) -> (captured -> DelayedIO a)
-> Delayed (Text, env) b -> Delayed (captured, env) b
addCapture Delayed{..} new = addCapture Delayed{..} new =
Delayed Delayed
{ capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt { 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 Control.Monad.Trans.Except (throwE)
import Data.Aeson (FromJSON, ToJSON, decode', encode) import Data.Aeson (FromJSON, ToJSON, decode', encode)
import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Base64 as Base64
import Data.ByteString.Conversion ()
import Data.Char (toUpper) import Data.Char (toUpper)
import Data.Monoid import Data.Monoid
import Data.Proxy (Proxy (Proxy)) import Data.Proxy (Proxy (Proxy))
@ -39,7 +38,7 @@ import Network.Wai.Test (defaultRequest, request,
simpleHeaders, simpleStatus) simpleHeaders, simpleStatus)
import Servant.API ((:<|>) (..), (:>), AuthProtect, import Servant.API ((:<|>) (..), (:>), AuthProtect,
BasicAuth, BasicAuthData(BasicAuthData), BasicAuth, BasicAuthData(BasicAuthData),
Capture, Delete, Get, Header (..), Capture, CaptureAll, Delete, Get, Header (..),
Headers, HttpVersion, Headers, HttpVersion,
IsSecure (..), JSON, IsSecure (..), JSON,
NoContent (..), Patch, PlainText, NoContent (..), Patch, PlainText,
@ -216,6 +215,58 @@ captureSpec = do
it "strips the captured path snippet from pathInfo" $ do it "strips the captured path snippet from pathInfo" $ do
get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) 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 {{{ -- * queryParamSpec {{{
@ -644,4 +695,7 @@ jerry = Animal "Mouse" 4
tweety :: Animal tweety :: Animal
tweety = Animal "Bird" 2 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 0.8
--- ---

7
servant/servant.cabal
View File

@ -1,5 +1,5 @@
name: servant name: servant
version: 0.8 version: 0.9
synopsis: A family of combinators for defining webservices APIs synopsis: A family of combinators for defining webservices APIs
description: description:
A family of combinators for defining webservices APIs and serving them A family of combinators for defining webservices APIs and serving them
@ -51,12 +51,11 @@ library
build-depends: build-depends:
base >= 4.7 && < 4.10 base >= 4.7 && < 4.10
, base-compat >= 0.9 && < 0.10 , base-compat >= 0.9 && < 0.10
, aeson >= 0.7 && < 0.12 , aeson >= 0.7 && < 1.1
, attoparsec >= 0.12 && < 0.14 , attoparsec >= 0.12 && < 0.14
, bytestring >= 0.10 && < 0.11 , bytestring >= 0.10 && < 0.11
, bytestring-conversion >= 0.3 && < 0.4
, case-insensitive >= 1.2 && < 1.3 , 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-media >= 0.4 && < 0.7
, http-types >= 0.8 && < 0.10 , http-types >= 0.8 && < 0.10
, mtl >= 2.0 && < 2.3 , 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 -- * Accessing information from the request
module Servant.API.Capture, 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, module Servant.API.Header,
-- | Retrieving specific headers from the request -- | Retrieving specific headers from the request
module Servant.API.HttpVersion, module Servant.API.HttpVersion,
@ -60,12 +60,12 @@ module Servant.API (
import Servant.API.Alternative ((:<|>) (..)) import Servant.API.Alternative ((:<|>) (..))
import Servant.API.BasicAuth (BasicAuth,BasicAuthData(..)) import Servant.API.BasicAuth (BasicAuth,BasicAuthData(..))
import Servant.API.Capture (Capture) import Servant.API.Capture (Capture, CaptureAll)
import Servant.API.ContentTypes (Accept (..), FormUrlEncoded, import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,
FromFormUrlEncoded (..), JSON, JSON,
MimeRender (..), NoContent (NoContent), MimeRender (..), NoContent (NoContent),
MimeUnrender (..), OctetStream, MimeUnrender (..), OctetStream,
PlainText, ToFormUrlEncoded (..)) PlainText)
import Servant.API.Experimental.Auth (AuthProtect) import Servant.API.Experimental.Auth (AuthProtect)
import Servant.API.Header (Header (..)) import Servant.API.Header (Header (..))
import Servant.API.HttpVersion (HttpVersion (..)) import Servant.API.HttpVersion (HttpVersion (..))

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

@ -2,7 +2,7 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# OPTIONS_HADDOCK not-home #-} {-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Capture (Capture) where module Servant.API.Capture (Capture, CaptureAll) where
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import GHC.TypeLits (Symbol) import GHC.TypeLits (Symbol)
@ -15,9 +15,22 @@ import GHC.TypeLits (Symbol)
data Capture (sym :: Symbol) a data Capture (sym :: Symbol) a
deriving (Typeable) 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 -- $setup
-- >>> import Servant.API -- >>> import Servant.API
-- >>> import Data.Aeson -- >>> import Data.Aeson
-- >>> import Data.Text -- >>> import Data.Text
-- >>> data Book -- >>> data Book
-- >>> instance ToJSON Book where { toJSON = undefined } -- >>> 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(..) , AllMime(..)
, AllMimeRender(..) , AllMimeRender(..)
, AllMimeUnrender(..) , AllMimeUnrender(..)
, FromFormUrlEncoded(..)
, ToFormUrlEncoded(..)
, eitherDecodeLenient , eitherDecodeLenient
, canHandleAcceptH , canHandleAcceptH
) where ) where
@ -82,10 +80,8 @@ import Data.Attoparsec.ByteString.Char8 (endOfInput, parseOnly,
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.ByteString.Lazy (ByteString, fromStrict, import Data.ByteString.Lazy (ByteString, fromStrict,
toStrict) toStrict)
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Lazy.Char8 as BC import qualified Data.ByteString.Lazy.Char8 as BC
import Data.Maybe (isJust) import Data.Maybe (isJust)
import Data.Monoid.Compat
import Data.String.Conversions (cs) import Data.String.Conversions (cs)
import qualified Data.Text as TextS import qualified Data.Text as TextS
import qualified Data.Text.Encoding 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 Data.Typeable
import GHC.Generics (Generic) import GHC.Generics (Generic)
import qualified Network.HTTP.Media as M import qualified Network.HTTP.Media as M
import Network.URI (escapeURIString, import Web.FormUrlEncoded (FromForm, ToForm,
isUnreserved, unEscapeString) urlEncodeAsForm,
urlDecodeAsForm)
import Prelude () import Prelude ()
import Prelude.Compat import Prelude.Compat
@ -290,12 +287,12 @@ instance OVERLAPPABLE_
ToJSON a => MimeRender JSON a where ToJSON a => MimeRender JSON a where
mimeRender _ = encode mimeRender _ = encode
-- | @encodeFormUrlEncoded . toFormUrlEncoded@ -- | @urlEncodeAsForm@
-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only -- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
-- holds if every element of x is non-null (i.e., not @("", "")@) -- holds if every element of x is non-null (i.e., not @("", "")@)
instance OVERLAPPABLE_ instance OVERLAPPABLE_
ToFormUrlEncoded a => MimeRender FormUrlEncoded a where ToForm a => MimeRender FormUrlEncoded a where
mimeRender _ = encodeFormUrlEncoded . toFormUrlEncoded mimeRender _ = urlEncodeAsForm
-- | `TextL.encodeUtf8` -- | `TextL.encodeUtf8`
instance MimeRender PlainText TextL.Text where instance MimeRender PlainText TextL.Text where
@ -348,11 +345,11 @@ eitherDecodeLenient input =
instance FromJSON a => MimeUnrender JSON a where instance FromJSON a => MimeUnrender JSON a where
mimeUnrender _ = eitherDecodeLenient mimeUnrender _ = eitherDecodeLenient
-- | @decodeFormUrlEncoded >=> fromFormUrlEncoded@ -- | @urlDecodeAsForm@
-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only -- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
-- holds if every element of x is non-null (i.e., not @("", "")@) -- holds if every element of x is non-null (i.e., not @("", "")@)
instance FromFormUrlEncoded a => MimeUnrender FormUrlEncoded a where instance FromForm a => MimeUnrender FormUrlEncoded a where
mimeUnrender _ = decodeFormUrlEncoded >=> fromFormUrlEncoded mimeUnrender _ = left TextS.unpack . urlDecodeAsForm
-- | @left show . TextL.decodeUtf8'@ -- | @left show . TextL.decodeUtf8'@
instance MimeUnrender PlainText TextL.Text where instance MimeUnrender PlainText TextL.Text where
@ -375,49 +372,6 @@ instance MimeUnrender OctetStream BS.ByteString where
mimeUnrender _ = Right . toStrict 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 -- $setup
-- >>> import Servant.API -- >>> 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 GET = Get '[JSON] NoContent
type ComprehensiveAPI = type ComprehensiveAPI =
ComprehensiveAPIWithoutRaw :<|>
Raw
comprehensiveAPI :: Proxy ComprehensiveAPI
comprehensiveAPI = Proxy
type ComprehensiveAPIWithoutRaw =
GET :<|> GET :<|>
Get '[JSON] Int :<|> Get '[JSON] Int :<|>
Capture "foo" Int :> GET :<|> Capture "foo" Int :> GET :<|>
@ -22,7 +29,6 @@ type ComprehensiveAPI =
QueryParam "foo" Int :> GET :<|> QueryParam "foo" Int :> GET :<|>
QueryParams "foo" Int :> GET :<|> QueryParams "foo" Int :> GET :<|>
QueryFlag "foo" :> GET :<|> QueryFlag "foo" :> GET :<|>
-- Raw :<|>
RemoteHost :> GET :<|> RemoteHost :> GET :<|>
ReqBody '[JSON] Int :> GET :<|> ReqBody '[JSON] Int :> GET :<|>
Get '[JSON] (Headers '[Header "foo" Int] NoContent) :<|> Get '[JSON] (Headers '[Header "foo" Int] NoContent) :<|>
@ -30,7 +36,8 @@ type ComprehensiveAPI =
Vault :> GET :<|> Vault :> GET :<|>
Verb 'POST 204 '[JSON] NoContent :<|> Verb 'POST 204 '[JSON] NoContent :<|>
Verb 'POST 204 '[JSON] Int :<|> Verb 'POST 204 '[JSON] Int :<|>
WithNamedContext "foo" '[] GET WithNamedContext "foo" '[] GET :<|>
CaptureAll "foo" Int :> GET
comprehensiveAPI :: Proxy ComprehensiveAPI comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPIWithoutRaw
comprehensiveAPI = Proxy comprehensiveAPIWithoutRaw = Proxy

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

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

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

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

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

@ -107,7 +107,7 @@ import Prelude.Compat
import Web.HttpApiData import Web.HttpApiData
import Servant.API.BasicAuth ( BasicAuth ) import Servant.API.BasicAuth ( BasicAuth )
import Servant.API.Capture ( Capture ) import Servant.API.Capture ( Capture, CaptureAll )
import Servant.API.ReqBody ( ReqBody ) import Servant.API.ReqBody ( ReqBody )
import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag ) import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag )
import Servant.API.Header ( Header ) import Servant.API.Header ( Header )
@ -163,6 +163,8 @@ type family IsElem endpoint api :: Constraint where
IsElem sa (ReqBody y x :> sb) = IsElem sa sb IsElem sa (ReqBody y x :> sb) = IsElem sa sb
IsElem (Capture z y :> sa) (Capture x y :> sb) IsElem (Capture z y :> sa) (Capture x y :> sb)
= IsElem sa 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 (QueryParam x y :> sb) = IsElem sa sb
IsElem sa (QueryParams x y :> sb) = IsElem sa sb IsElem sa (QueryParams x y :> sb) = IsElem sa sb
IsElem sa (QueryFlag x :> 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) $ toLink (Proxy :: Proxy sub) $
addSegment (escape . Text.unpack $ toUrlPiece v) l 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 instance HasLink sub => HasLink (Header sym a :> sub) where
type MkLink (Header sym a :> sub) = MkLink sub type MkLink (Header sym a :> sub) = MkLink sub
toLink _ = toLink (Proxy :: Proxy sub) toLink _ = toLink (Proxy :: Proxy sub)

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

@ -11,7 +11,6 @@ module Servant.API.ContentTypesSpec where
import Prelude () import Prelude ()
import Prelude.Compat import Prelude.Compat
import Control.Arrow
import Data.Aeson import Data.Aeson
import Data.ByteString.Char8 (ByteString, append, pack) import Data.ByteString.Char8 (ByteString, append, pack)
import qualified Data.ByteString.Lazy as BSL 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 as TextS
import qualified Data.Text.Lazy as TextL import qualified Data.Text.Lazy as TextL
import GHC.Generics import GHC.Generics
import Network.URL (exportParams, importParams)
import Test.Hspec import Test.Hspec
import Test.QuickCheck import Test.QuickCheck
import "quickcheck-instances" Test.QuickCheck.Instances () 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 it "has mimeUnrender reverse mimeRender for valid top-level json " $ do
property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData) 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 describe "The PlainText Content-Type type" $ do
let p = Proxy :: Proxy PlainText let p = Proxy :: Proxy PlainText

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

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

1
sources.txt
View File

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

8
stack-ghc-7.8.4.yaml
View File

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

5
stack-ghc-8.0.1.yaml
View File

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

2
stack.yaml
View File

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