Merge remote-tracking branch 'servant-client/prepare-merge' into merge
This commit is contained in:
commit
1eedad4073
12 changed files with 1365 additions and 0 deletions
15
servant-client/CHANGELOG.md
Normal file
15
servant-client/CHANGELOG.md
Normal file
|
@ -0,0 +1,15 @@
|
|||
0.3
|
||||
---
|
||||
* Support content-type aware combinators and `Accept`/`Content-type` headers
|
||||
* Added a lot of tests
|
||||
* Support multiple concurrent threads
|
||||
* Use `ServantError` to report Errors instead of `String`
|
||||
* Make the clients for `Raw` endpoints return the whole `Response` value (to be able to access response headers for example)
|
||||
* Support for PATCH
|
||||
* Make () instances expect No Content status code, and not try to decode body.
|
||||
* `Canonicalize` API types before generating client functions for them
|
||||
|
||||
0.2.2
|
||||
-----
|
||||
* Add TLS support
|
||||
* Add matrix parameter support
|
30
servant-client/LICENSE
Normal file
30
servant-client/LICENSE
Normal file
|
@ -0,0 +1,30 @@
|
|||
Copyright (c) 2014, Zalora South East Asia Pte Ltd
|
||||
|
||||
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 Zalora South East Asia Pte Ltd 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.
|
23
servant-client/README.md
Normal file
23
servant-client/README.md
Normal file
|
@ -0,0 +1,23 @@
|
|||
# servant-client
|
||||
|
||||
[![Build Status](https://secure.travis-ci.org/haskell-servant/servant-client.svg)](http://travis-ci.org/haskell-servant/servant-client)
|
||||
[![Coverage Status](https://coveralls.io/repos/haskell-servant/servant-client/badge.svg)](https://coveralls.io/r/haskell-servant/servant-client)
|
||||
|
||||
![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png)
|
||||
|
||||
This library lets you automatically derive Haskell functions that let you query each endpoint of a *servant* webservice.
|
||||
|
||||
## Example
|
||||
|
||||
``` haskell
|
||||
type MyApi = "books" :> Get [Book] -- GET /books
|
||||
:<|> "books" :> ReqBody Book :> Post Book -- POST /books
|
||||
|
||||
myApi :: Proxy MyApi
|
||||
myApi = Proxy
|
||||
|
||||
getAllBooks :: BaseUrl -> EitherT String IO [Book]
|
||||
postNewBook :: Book -> BaseUrl -> EitherT String IO Book
|
||||
-- 'client' allows you to produce operations to query an API from a client.
|
||||
(getAllBooks :<|> postNewBook) = client myApi
|
||||
```
|
2
servant-client/Setup.hs
Normal file
2
servant-client/Setup.hs
Normal file
|
@ -0,0 +1,2 @@
|
|||
import Distribution.Simple
|
||||
main = defaultMain
|
52
servant-client/docs.sh
Normal file
52
servant-client/docs.sh
Normal file
|
@ -0,0 +1,52 @@
|
|||
SERVANT_DIR=/tmp/servant-client-gh-pages
|
||||
|
||||
# Make a temporary clone
|
||||
|
||||
rm -rf $SERVANT_DIR
|
||||
|
||||
git clone . $SERVANT_DIR
|
||||
|
||||
cd $SERVANT_DIR
|
||||
|
||||
# Make sure to pull the latest
|
||||
|
||||
git remote add haskell-servant git@github.com:haskell-servant/servant-client.git
|
||||
|
||||
git fetch haskell-servant
|
||||
|
||||
git reset --hard haskell-servant/gh-pages
|
||||
|
||||
# Clear everything away
|
||||
|
||||
git rm -rf $SERVANT_DIR/*
|
||||
|
||||
# Switch back and build the haddocks
|
||||
|
||||
cd -
|
||||
|
||||
cabal configure --builddir=$SERVANT_DIR
|
||||
|
||||
cabal haddock --hoogle --hyperlink-source --html-location='https://hackage.haskell.org/package/$pkg-$version/docs' --builddir=$SERVANT_DIR
|
||||
|
||||
commit_hash=$(git rev-parse HEAD)
|
||||
|
||||
# Move the HTML docs to the root
|
||||
|
||||
cd $SERVANT_DIR
|
||||
|
||||
rm *
|
||||
rm -rf build
|
||||
mv doc/html/servant-client/* .
|
||||
rm -r doc/
|
||||
|
||||
# Add everything
|
||||
|
||||
git add .
|
||||
|
||||
git commit -m "Built from $commit_hash"
|
||||
|
||||
# Push to update the pages
|
||||
|
||||
git push haskell-servant HEAD:gh-pages
|
||||
|
||||
rm -rf $SERVANT_DIR
|
85
servant-client/servant-client.cabal
Normal file
85
servant-client/servant-client.cabal
Normal file
|
@ -0,0 +1,85 @@
|
|||
name: servant-client
|
||||
version: 0.2.2
|
||||
synopsis: automatical derivation of querying functions for servant webservices
|
||||
description:
|
||||
This library lets you derive automatically Haskell functions that
|
||||
let you query each endpoint of a <http://hackage.haskell.org/package/servant servant> webservice.
|
||||
.
|
||||
Example below.
|
||||
.
|
||||
> type MyApi = "books" :> Get [Book] -- GET /books
|
||||
> :<|> "books" :> ReqBody Book :> Post Book -- POST /books
|
||||
>
|
||||
> myApi :: Proxy MyApi
|
||||
> myApi = Proxy
|
||||
>
|
||||
> getAllBooks :: BaseUrl -> EitherT String IO [Book]
|
||||
> postNewBook :: Book -> BaseUrl -> EitherT String IO Book
|
||||
> (getAllBooks :<|> postNewBook) = client myApi
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Alp Mestanogullari, Sönke Hahn, Julian K. Arni
|
||||
maintainer: alpmestan@gmail.com
|
||||
copyright: 2014 Zalora South East Asia Pte Ltd
|
||||
category: Web
|
||||
build-type: Simple
|
||||
cabal-version: >=1.10
|
||||
tested-with: GHC >= 7.8
|
||||
homepage: http://haskell-servant.github.io/
|
||||
Bug-reports: http://github.com/haskell-servant/servant-client/issues
|
||||
source-repository head
|
||||
type: git
|
||||
location: http://github.com/haskell-servant/servant-client.git
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Servant.Client
|
||||
Servant.Common.BaseUrl
|
||||
Servant.Common.Req
|
||||
build-depends:
|
||||
base >=4.7 && <5
|
||||
, aeson
|
||||
, attoparsec
|
||||
, bytestring
|
||||
, either
|
||||
, exceptions
|
||||
, http-client
|
||||
, http-client-tls
|
||||
, http-media
|
||||
, http-types
|
||||
, network-uri >= 2.6
|
||||
, safe
|
||||
, servant >= 0.2.2
|
||||
, string-conversions
|
||||
, text
|
||||
, transformers
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall
|
||||
|
||||
test-suite spec
|
||||
type: exitcode-stdio-1.0
|
||||
ghc-options:
|
||||
-Wall -fno-warn-name-shadowing -fno-warn-missing-signatures
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
main-is: Spec.hs
|
||||
build-depends:
|
||||
base == 4.*
|
||||
, aeson
|
||||
, bytestring
|
||||
, deepseq
|
||||
, either
|
||||
, hspec == 2.*
|
||||
, http-client
|
||||
, http-media
|
||||
, http-types
|
||||
, HUnit
|
||||
, network >= 2.6
|
||||
, QuickCheck >= 2.7
|
||||
, servant >= 0.2.1
|
||||
, servant-client
|
||||
, servant-server >= 0.2.1
|
||||
, text
|
||||
, wai
|
||||
, warp
|
504
servant-client/src/Servant/Client.hs
Normal file
504
servant-client/src/Servant/Client.hs
Normal file
|
@ -0,0 +1,504 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE OverlappingInstances #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
-- | This module provides 'client' which can automatically generate
|
||||
-- querying functions for each endpoint just from the type representing your
|
||||
-- API.
|
||||
module Servant.Client
|
||||
( client
|
||||
, HasClient(..)
|
||||
, Client
|
||||
, ServantError(..)
|
||||
, module Servant.Common.BaseUrl
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Either
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Data.List
|
||||
import Data.Proxy
|
||||
import Data.String.Conversions
|
||||
import Data.Text (unpack)
|
||||
import GHC.TypeLits
|
||||
import Network.HTTP.Client (Response)
|
||||
import Network.HTTP.Media
|
||||
import qualified Network.HTTP.Types as H
|
||||
import Servant.API
|
||||
import Servant.API.ContentTypes
|
||||
import Servant.Common.BaseUrl
|
||||
import Servant.Common.Req
|
||||
|
||||
-- * Accessing APIs as a Client
|
||||
|
||||
-- | 'client' allows you to produce operations to query an API from a client.
|
||||
--
|
||||
-- > type MyApi = "books" :> Get [Book] -- GET /books
|
||||
-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getAllBooks :: BaseUrl -> EitherT String IO [Book]
|
||||
-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
|
||||
-- > (getAllBooks :<|> postNewBook) = client myApi
|
||||
client :: HasClient (Canonicalize layout) => Proxy layout -> Client layout
|
||||
client p = clientWithRoute (canonicalize p) defReq
|
||||
|
||||
-- | This class lets us define how each API combinator
|
||||
-- influences the creation of an HTTP request. It's mostly
|
||||
-- an internal class, you can just use 'client'.
|
||||
class HasClient layout where
|
||||
type Client' layout :: *
|
||||
clientWithRoute :: Proxy layout -> Req -> Client' layout
|
||||
|
||||
type Client layout = Client' (Canonicalize layout)
|
||||
|
||||
-- | A client querying function for @a ':<|>' b@ will actually hand you
|
||||
-- one function for querying @a@ and another one for querying @b@,
|
||||
-- stitching them together with ':<|>', which really is just like a pair.
|
||||
--
|
||||
-- > type MyApi = "books" :> Get [Book] -- GET /books
|
||||
-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getAllBooks :: BaseUrl -> EitherT String IO [Book]
|
||||
-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
|
||||
-- > (getAllBooks :<|> postNewBook) = client myApi
|
||||
instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
|
||||
type Client' (a :<|> b) = Client' a :<|> Client' b
|
||||
clientWithRoute Proxy req =
|
||||
clientWithRoute (Proxy :: Proxy a) req :<|>
|
||||
clientWithRoute (Proxy :: Proxy b) req
|
||||
|
||||
-- | If you use a 'Capture' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take
|
||||
-- an additional argument of the type specified by your 'Capture'.
|
||||
-- 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 values for this type are turned into
|
||||
-- text by specifying a 'ToText' instance for your type.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> Capture "isbn" Text :> Get Book
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getBook :: Text -> BaseUrl -> EitherT String IO Book
|
||||
-- > getBook = client myApi
|
||||
-- > -- then you can just use "getBook" to query that endpoint
|
||||
instance (KnownSymbol capture, ToText a, HasClient sublayout)
|
||||
=> HasClient (Capture capture a :> sublayout) where
|
||||
|
||||
type Client' (Capture capture a :> sublayout) =
|
||||
a -> Client' sublayout
|
||||
|
||||
clientWithRoute Proxy req val =
|
||||
clientWithRoute (Proxy :: Proxy sublayout) $
|
||||
appendToPath p req
|
||||
|
||||
where p = unpack (toText val)
|
||||
|
||||
-- | If you have a 'Delete' endpoint in your API, the client
|
||||
-- side querying function that is created when calling 'client'
|
||||
-- will just require an argument that specifies the scheme, host
|
||||
-- and port to send the request to.
|
||||
instance HasClient Delete where
|
||||
type Client' Delete = BaseUrl -> EitherT ServantError IO ()
|
||||
|
||||
clientWithRoute Proxy req host =
|
||||
void $ performRequest H.methodDelete req (`elem` [200, 202, 204]) host
|
||||
|
||||
-- | If you have a 'Get' endpoint in your API, the client
|
||||
-- side querying function that is created when calling 'client'
|
||||
-- will just require an argument that specifies the scheme, host
|
||||
-- and port to send the request to.
|
||||
instance (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where
|
||||
type Client' (Get (ct ': cts) result) = BaseUrl -> EitherT ServantError IO result
|
||||
clientWithRoute Proxy req host =
|
||||
performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] host
|
||||
|
||||
-- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content
|
||||
-- HTTP header.
|
||||
instance HasClient (Get (ct ': cts) ()) where
|
||||
type Client' (Get (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
|
||||
clientWithRoute Proxy req host =
|
||||
performRequestNoBody H.methodGet req [204] host
|
||||
|
||||
-- | If you use a 'Header' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take
|
||||
-- an additional argument of the type specified by your 'Header',
|
||||
-- wrapped in Maybe.
|
||||
--
|
||||
-- That function will take care of encoding this argument as Text
|
||||
-- in the request headers.
|
||||
--
|
||||
-- All you need is for your type to have a 'ToText' instance.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > newtype Referer = Referer Text
|
||||
-- > deriving (Eq, Show, FromText, ToText)
|
||||
-- >
|
||||
-- > -- GET /view-my-referer
|
||||
-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get Referer
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > viewReferer :: Maybe Referer -> BaseUrl -> EitherT String IO Book
|
||||
-- > viewReferer = client myApi
|
||||
-- > -- then you can just use "viewRefer" to query that endpoint
|
||||
-- > -- specifying Nothing or Just "http://haskell.org/" as arguments
|
||||
instance (KnownSymbol sym, ToText a, HasClient sublayout)
|
||||
=> HasClient (Header sym a :> sublayout) where
|
||||
|
||||
type Client' (Header sym a :> sublayout) =
|
||||
Maybe a -> Client' sublayout
|
||||
|
||||
clientWithRoute Proxy req mval =
|
||||
clientWithRoute (Proxy :: Proxy sublayout) $
|
||||
maybe req (\value -> Servant.Common.Req.addHeader hname value req) mval
|
||||
|
||||
where hname = symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
-- | If you have a 'Post' endpoint in your API, the client
|
||||
-- side querying function that is created when calling 'client'
|
||||
-- will just require an argument that specifies the scheme, host
|
||||
-- and port to send the request to.
|
||||
instance (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where
|
||||
type Client' (Post (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
|
||||
|
||||
clientWithRoute Proxy req uri =
|
||||
performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] uri
|
||||
|
||||
-- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content
|
||||
-- HTTP header.
|
||||
instance HasClient (Post (ct ': cts) ()) where
|
||||
type Client' (Post (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
|
||||
clientWithRoute Proxy req host =
|
||||
void $ performRequestNoBody H.methodPost req [204] host
|
||||
|
||||
-- | If you have a 'Put' endpoint in your API, the client
|
||||
-- side querying function that is created when calling 'client'
|
||||
-- will just require an argument that specifies the scheme, host
|
||||
-- and port to send the request to.
|
||||
instance (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where
|
||||
type Client' (Put (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
|
||||
|
||||
clientWithRoute Proxy req host =
|
||||
performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] host
|
||||
|
||||
-- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content
|
||||
-- HTTP header.
|
||||
instance HasClient (Put (ct ': cts) ()) where
|
||||
type Client' (Put (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
|
||||
clientWithRoute Proxy req host =
|
||||
void $ performRequestNoBody H.methodPut req [204] host
|
||||
|
||||
-- | If you have a 'Patch' endpoint in your API, the client
|
||||
-- side querying function that is created when calling 'client'
|
||||
-- will just require an argument that specifies the scheme, host
|
||||
-- and port to send the request to.
|
||||
instance (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where
|
||||
type Client' (Patch (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
|
||||
|
||||
clientWithRoute Proxy req host =
|
||||
performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] host
|
||||
|
||||
-- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content
|
||||
-- HTTP header.
|
||||
instance HasClient (Patch (ct ': cts) ()) where
|
||||
type Client' (Patch (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
|
||||
clientWithRoute Proxy req host =
|
||||
void $ performRequestNoBody H.methodPatch req [204] host
|
||||
|
||||
-- | If you use a 'QueryParam' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take
|
||||
-- an additional argument of the type specified by your 'QueryParam',
|
||||
-- enclosed in Maybe.
|
||||
--
|
||||
-- If you give Nothing, nothing will be added to the query string.
|
||||
--
|
||||
-- If you give a non-'Nothing' value, this function will take care
|
||||
-- of inserting a textual representation of this value in the query string.
|
||||
--
|
||||
-- You can control how values for your type are turned into
|
||||
-- text by specifying a 'ToText' instance for your type.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> QueryParam "author" Text :> Get [Book]
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getBooksBy :: Maybe Text -> BaseUrl -> EitherT String IO [Book]
|
||||
-- > getBooksBy = client myApi
|
||||
-- > -- then you can just use "getBooksBy" to query that endpoint.
|
||||
-- > -- 'getBooksBy Nothing' for all books
|
||||
-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
|
||||
instance (KnownSymbol sym, ToText a, HasClient sublayout)
|
||||
=> HasClient (QueryParam sym a :> sublayout) where
|
||||
|
||||
type Client' (QueryParam sym a :> sublayout) =
|
||||
Maybe a -> Client' sublayout
|
||||
|
||||
-- if mparam = Nothing, we don't add it to the query string
|
||||
clientWithRoute Proxy req mparam =
|
||||
clientWithRoute (Proxy :: Proxy sublayout) $
|
||||
maybe req (flip (appendToQueryString pname) req . Just) mparamText
|
||||
|
||||
where pname = cs pname'
|
||||
pname' = symbolVal (Proxy :: Proxy sym)
|
||||
mparamText = fmap toText mparam
|
||||
|
||||
-- | If you use a 'QueryParams' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take
|
||||
-- an additional argument, a list of values of the type specified
|
||||
-- by your 'QueryParams'.
|
||||
--
|
||||
-- If you give an empty list, nothing will be added to the query string.
|
||||
--
|
||||
-- Otherwise, this function will take care
|
||||
-- of inserting a textual representation of your values in the query string,
|
||||
-- under the same query string parameter name.
|
||||
--
|
||||
-- You can control how values for your type are turned into
|
||||
-- text by specifying a 'ToText' instance for your type.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> QueryParams "authors" Text :> Get [Book]
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getBooksBy :: [Text] -> BaseUrl -> EitherT String IO [Book]
|
||||
-- > getBooksBy = client myApi
|
||||
-- > -- then you can just use "getBooksBy" to query that endpoint.
|
||||
-- > -- 'getBooksBy []' for all books
|
||||
-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
|
||||
-- > -- to get all books by Asimov and Heinlein
|
||||
instance (KnownSymbol sym, ToText a, HasClient sublayout)
|
||||
=> HasClient (QueryParams sym a :> sublayout) where
|
||||
|
||||
type Client' (QueryParams sym a :> sublayout) =
|
||||
[a] -> Client' sublayout
|
||||
|
||||
clientWithRoute Proxy req paramlist =
|
||||
clientWithRoute (Proxy :: Proxy sublayout) $
|
||||
foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) req paramlist'
|
||||
|
||||
where pname = cs pname'
|
||||
pname' = symbolVal (Proxy :: Proxy sym)
|
||||
paramlist' = map (Just . toText) paramlist
|
||||
|
||||
-- | If you use a 'QueryFlag' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take
|
||||
-- an additional 'Bool' argument.
|
||||
--
|
||||
-- If you give 'False', nothing will be added to the query string.
|
||||
--
|
||||
-- Otherwise, this function will insert a value-less query string
|
||||
-- parameter under the name associated to your 'QueryFlag'.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> QueryFlag "published" :> Get [Book]
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getBooks :: Bool -> BaseUrl -> EitherT String IO [Book]
|
||||
-- > getBooks = client myApi
|
||||
-- > -- then you can just use "getBooks" to query that endpoint.
|
||||
-- > -- 'getBooksBy False' for all books
|
||||
-- > -- 'getBooksBy True' to only get _already published_ books
|
||||
instance (KnownSymbol sym, HasClient sublayout)
|
||||
=> HasClient (QueryFlag sym :> sublayout) where
|
||||
|
||||
type Client' (QueryFlag sym :> sublayout) =
|
||||
Bool -> Client' sublayout
|
||||
|
||||
clientWithRoute Proxy req flag =
|
||||
clientWithRoute (Proxy :: Proxy sublayout) $
|
||||
if flag
|
||||
then appendToQueryString paramname Nothing req
|
||||
else req
|
||||
|
||||
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
-- | If you use a 'MatrixParam' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take
|
||||
-- an additional argument of the type specified by your 'MatrixParam',
|
||||
-- enclosed in Maybe.
|
||||
--
|
||||
-- If you give Nothing, nothing will be added to the query string.
|
||||
--
|
||||
-- If you give a non-'Nothing' value, this function will take care
|
||||
-- of inserting a textual representation of this value in the query string.
|
||||
--
|
||||
-- You can control how values for your type are turned into
|
||||
-- text by specifying a 'ToText' instance for your type.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> MatrixParam "author" Text :> Get [Book]
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getBooksBy :: Maybe Text -> BaseUrl -> EitherT String IO [Book]
|
||||
-- > getBooksBy = client myApi
|
||||
-- > -- then you can just use "getBooksBy" to query that endpoint.
|
||||
-- > -- 'getBooksBy Nothing' for all books
|
||||
-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
|
||||
instance (KnownSymbol sym, ToText a, HasClient sublayout)
|
||||
=> HasClient (MatrixParam sym a :> sublayout) where
|
||||
|
||||
type Client' (MatrixParam sym a :> sublayout) =
|
||||
Maybe a -> Client' sublayout
|
||||
|
||||
-- if mparam = Nothing, we don't add it to the query string
|
||||
clientWithRoute Proxy req mparam =
|
||||
clientWithRoute (Proxy :: Proxy sublayout) $
|
||||
maybe req (flip (appendToMatrixParams pname . Just) req) mparamText
|
||||
|
||||
where pname = symbolVal (Proxy :: Proxy sym)
|
||||
mparamText = fmap (cs . toText) mparam
|
||||
|
||||
-- | If you use a 'MatrixParams' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take an
|
||||
-- additional argument, a list of values of the type specified by your
|
||||
-- 'MatrixParams'.
|
||||
--
|
||||
-- If you give an empty list, nothing will be added to the query string.
|
||||
--
|
||||
-- Otherwise, this function will take care of inserting a textual
|
||||
-- representation of your values in the path segment string, under the
|
||||
-- same matrix string parameter name.
|
||||
--
|
||||
-- You can control how values for your type are turned into text by
|
||||
-- specifying a 'ToText' instance for your type.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> MatrixParams "authors" Text :> Get [Book]
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getBooksBy :: [Text] -> BaseUrl -> EitherT String IO [Book]
|
||||
-- > getBooksBy = client myApi
|
||||
-- > -- then you can just use "getBooksBy" to query that endpoint.
|
||||
-- > -- 'getBooksBy []' for all books
|
||||
-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
|
||||
-- > -- to get all books by Asimov and Heinlein
|
||||
instance (KnownSymbol sym, ToText a, HasClient sublayout)
|
||||
=> HasClient (MatrixParams sym a :> sublayout) where
|
||||
|
||||
type Client' (MatrixParams sym a :> sublayout) =
|
||||
[a] -> Client' sublayout
|
||||
|
||||
clientWithRoute Proxy req paramlist =
|
||||
clientWithRoute (Proxy :: Proxy sublayout) $
|
||||
foldl' (\ req' value -> maybe req' (flip (appendToMatrixParams pname) req' . Just . cs) value) req paramlist'
|
||||
|
||||
where pname = cs pname'
|
||||
pname' = symbolVal (Proxy :: Proxy sym)
|
||||
paramlist' = map (Just . toText) paramlist
|
||||
|
||||
-- | If you use a 'MatrixFlag' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take an
|
||||
-- additional 'Bool' argument.
|
||||
--
|
||||
-- If you give 'False', nothing will be added to the path segment.
|
||||
--
|
||||
-- Otherwise, this function will insert a value-less matrix parameter
|
||||
-- under the name associated to your 'MatrixFlag'.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> MatrixFlag "published" :> Get [Book]
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getBooks :: Bool -> BaseUrl -> EitherT String IO [Book]
|
||||
-- > getBooks = client myApi
|
||||
-- > -- then you can just use "getBooks" to query that endpoint.
|
||||
-- > -- 'getBooksBy False' for all books
|
||||
-- > -- 'getBooksBy True' to only get _already published_ books
|
||||
instance (KnownSymbol sym, HasClient sublayout)
|
||||
=> HasClient (MatrixFlag sym :> sublayout) where
|
||||
|
||||
type Client' (MatrixFlag sym :> sublayout) =
|
||||
Bool -> Client' sublayout
|
||||
|
||||
clientWithRoute Proxy req flag =
|
||||
clientWithRoute (Proxy :: Proxy sublayout) $
|
||||
if flag
|
||||
then appendToMatrixParams paramname Nothing req
|
||||
else req
|
||||
|
||||
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
-- | Pick a 'Method' and specify where the server you want to query is. You get
|
||||
-- back the full `Response`.
|
||||
instance HasClient Raw where
|
||||
type Client' Raw = H.Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, Response ByteString)
|
||||
|
||||
clientWithRoute :: Proxy Raw -> Req -> Client' Raw
|
||||
clientWithRoute Proxy req httpMethod host = do
|
||||
performRequest httpMethod req (const True) host
|
||||
|
||||
-- | If you use a 'ReqBody' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take
|
||||
-- an additional argument of the type specified by your 'ReqBody'.
|
||||
-- That function will take care of encoding this argument as JSON and
|
||||
-- of using it as the request body.
|
||||
--
|
||||
-- All you need is for your type to have a 'ToJSON' instance.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> ReqBody Book :> Post Book
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > addBook :: Book -> BaseUrl -> EitherT String IO Book
|
||||
-- > addBook = client myApi
|
||||
-- > -- then you can just use "addBook" to query that endpoint
|
||||
instance (MimeRender ct a, HasClient sublayout)
|
||||
=> HasClient (ReqBody (ct ': cts) a :> sublayout) where
|
||||
|
||||
type Client' (ReqBody (ct ': cts) a :> sublayout) =
|
||||
a -> Client' sublayout
|
||||
|
||||
clientWithRoute Proxy req body =
|
||||
clientWithRoute (Proxy :: Proxy sublayout) $ do
|
||||
let ctProxy = Proxy :: Proxy ct
|
||||
setRQBody (mimeRender ctProxy body) (contentType ctProxy) req
|
||||
|
||||
-- | Make the querying function append @path@ to the request path.
|
||||
instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
|
||||
type Client' (path :> sublayout) = Client' sublayout
|
||||
|
||||
clientWithRoute Proxy req =
|
||||
clientWithRoute (Proxy :: Proxy sublayout) $
|
||||
appendToPath p req
|
||||
|
||||
where p = symbolVal (Proxy :: Proxy path)
|
||||
|
55
servant-client/src/Servant/Common/BaseUrl.hs
Normal file
55
servant-client/src/Servant/Common/BaseUrl.hs
Normal file
|
@ -0,0 +1,55 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
module Servant.Common.BaseUrl where
|
||||
|
||||
import Data.List
|
||||
import GHC.Generics
|
||||
import Network.URI
|
||||
import Safe
|
||||
import Text.Read
|
||||
|
||||
-- | URI scheme to use
|
||||
data Scheme =
|
||||
Http -- ^ http://
|
||||
| Https -- ^ https://
|
||||
deriving (Show, Eq, Ord, Generic)
|
||||
|
||||
-- | Simple data type to represent the target of HTTP requests
|
||||
-- for servant's automatically-generated clients.
|
||||
data BaseUrl = BaseUrl
|
||||
{ baseUrlScheme :: Scheme -- ^ URI scheme to use
|
||||
, baseUrlHost :: String -- ^ host (eg "haskell.org")
|
||||
, baseUrlPort :: Int -- ^ port (eg 80)
|
||||
} deriving (Show, Eq, Ord, Generic)
|
||||
|
||||
showBaseUrl :: BaseUrl -> String
|
||||
showBaseUrl (BaseUrl urlscheme host port) =
|
||||
schemeString ++ "//" ++ host ++ portString
|
||||
where
|
||||
schemeString = case urlscheme of
|
||||
Http -> "http:"
|
||||
Https -> "https:"
|
||||
portString = case (urlscheme, port) of
|
||||
(Http, 80) -> ""
|
||||
(Https, 443) -> ""
|
||||
_ -> ":" ++ show port
|
||||
|
||||
parseBaseUrl :: String -> Either String BaseUrl
|
||||
parseBaseUrl s = case parseURI (removeTrailingSlash s) of
|
||||
-- This is a rather hacky implementation and should be replaced with something
|
||||
-- implemented in attoparsec (which is already a dependency anyhow (via aeson)).
|
||||
Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->
|
||||
Right (BaseUrl Http host port)
|
||||
Just (URI "http:" (Just (URIAuth "" host "")) "" "" "") ->
|
||||
Right (BaseUrl Http host 80)
|
||||
Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->
|
||||
Right (BaseUrl Https host port)
|
||||
Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") ->
|
||||
Right (BaseUrl Https host 443)
|
||||
_ -> if "://" `isInfixOf` s
|
||||
then Left ("invalid base url: " ++ s)
|
||||
else parseBaseUrl ("http://" ++ s)
|
||||
where
|
||||
removeTrailingSlash str = case lastMay str of
|
||||
Just '/' -> init str
|
||||
_ -> str
|
184
servant-client/src/Servant/Common/Req.hs
Normal file
184
servant-client/src/Servant/Common/Req.hs
Normal file
|
@ -0,0 +1,184 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
module Servant.Common.Req where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
import Control.Monad.Catch (MonadThrow)
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Either
|
||||
import Data.ByteString.Lazy hiding (pack, filter, map, null, elem)
|
||||
import Data.IORef
|
||||
import Data.String
|
||||
import Data.String.Conversions
|
||||
import Data.Proxy
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding
|
||||
import Network.HTTP.Client hiding (Proxy)
|
||||
import Network.HTTP.Client.TLS
|
||||
import Network.HTTP.Media
|
||||
import Network.HTTP.Types
|
||||
import Network.URI
|
||||
import Servant.API.ContentTypes
|
||||
import Servant.Common.BaseUrl
|
||||
import Servant.Common.Text
|
||||
import System.IO.Unsafe
|
||||
|
||||
import qualified Network.HTTP.Client as Client
|
||||
|
||||
data ServantError
|
||||
= FailureResponse
|
||||
{ responseStatus :: Status
|
||||
, responseContentType :: MediaType
|
||||
, responseBody :: ByteString
|
||||
}
|
||||
| DecodeFailure
|
||||
{ decodeError :: String
|
||||
, responseContentType :: MediaType
|
||||
, responseBody :: ByteString
|
||||
}
|
||||
| UnsupportedContentType
|
||||
{ responseContentType :: MediaType
|
||||
, responseBody :: ByteString
|
||||
}
|
||||
| ConnectionError
|
||||
{ connectionError :: HttpException
|
||||
}
|
||||
| InvalidContentTypeHeader
|
||||
{ responseContentTypeHeader :: ByteString
|
||||
, responseBody :: ByteString
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data Req = Req
|
||||
{ reqPath :: String
|
||||
, qs :: QueryText
|
||||
, reqBody :: Maybe (ByteString, MediaType)
|
||||
, reqAccept :: [MediaType]
|
||||
, headers :: [(String, Text)]
|
||||
}
|
||||
|
||||
defReq :: Req
|
||||
defReq = Req "" [] Nothing [] []
|
||||
|
||||
appendToPath :: String -> Req -> Req
|
||||
appendToPath p req =
|
||||
req { reqPath = reqPath req ++ "/" ++ p }
|
||||
|
||||
appendToMatrixParams :: String
|
||||
-> Maybe String
|
||||
-> Req
|
||||
-> Req
|
||||
appendToMatrixParams pname pvalue req =
|
||||
req { reqPath = reqPath req ++ ";" ++ pname ++ maybe "" ("=" ++) pvalue }
|
||||
|
||||
appendToQueryString :: Text -- ^ param name
|
||||
-> Maybe Text -- ^ param value
|
||||
-> Req
|
||||
-> Req
|
||||
appendToQueryString pname pvalue req =
|
||||
req { qs = qs req ++ [(pname, pvalue)]
|
||||
}
|
||||
|
||||
addHeader :: ToText a => String -> a -> Req -> Req
|
||||
addHeader name val req = req { headers = headers req
|
||||
++ [(name, toText val)]
|
||||
}
|
||||
|
||||
setRQBody :: ByteString -> MediaType -> Req -> Req
|
||||
setRQBody b t req = req { reqBody = Just (b, t) }
|
||||
|
||||
reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
|
||||
reqToRequest req (BaseUrl reqScheme reqHost reqPort) =
|
||||
fmap (setheaders . setAccept . setrqb . setQS ) $ parseUrl url
|
||||
|
||||
where url = show $ nullURI { uriScheme = case reqScheme of
|
||||
Http -> "http:"
|
||||
Https -> "https:"
|
||||
, uriAuthority = Just $
|
||||
URIAuth { uriUserInfo = ""
|
||||
, uriRegName = reqHost
|
||||
, uriPort = ":" ++ show reqPort
|
||||
}
|
||||
, uriPath = reqPath req
|
||||
}
|
||||
|
||||
setrqb r = case reqBody req of
|
||||
Nothing -> r
|
||||
Just (b,t) -> r { requestBody = RequestBodyLBS b
|
||||
, requestHeaders = requestHeaders r
|
||||
++ [(hContentType, cs . show $ t)] }
|
||||
setQS = setQueryString $ queryTextToQuery (qs req)
|
||||
setheaders r = r { requestHeaders = requestHeaders r
|
||||
<> fmap toProperHeader (headers req) }
|
||||
setAccept r = r { requestHeaders = filter ((/= "Accept") . fst) (requestHeaders r)
|
||||
<> [("Accept", renderHeader $ reqAccept req)
|
||||
| not . null . reqAccept $ req] }
|
||||
toProperHeader (name, val) =
|
||||
(fromString name, encodeUtf8 val)
|
||||
|
||||
|
||||
-- * performing requests
|
||||
|
||||
{-# NOINLINE __manager #-}
|
||||
__manager :: IORef Manager
|
||||
__manager = unsafePerformIO (newManager tlsManagerSettings >>= newIORef)
|
||||
|
||||
__withGlobalManager :: (Manager -> IO a) -> IO a
|
||||
__withGlobalManager action = readIORef __manager >>= action
|
||||
|
||||
|
||||
displayHttpRequest :: Method -> String
|
||||
displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
|
||||
|
||||
|
||||
performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, Response ByteString)
|
||||
performRequest reqMethod req isWantedStatus reqHost = do
|
||||
partialRequest <- liftIO $ reqToRequest req reqHost
|
||||
|
||||
let request = partialRequest { Client.method = reqMethod
|
||||
, checkStatus = \ _status _headers _cookies -> Nothing
|
||||
}
|
||||
|
||||
eResponse <- liftIO $ __withGlobalManager $ \ manager ->
|
||||
catchHttpException $
|
||||
Client.httpLbs request manager
|
||||
case eResponse of
|
||||
Left err ->
|
||||
left $ ConnectionError err
|
||||
|
||||
Right response -> do
|
||||
let status = Client.responseStatus response
|
||||
body = Client.responseBody response
|
||||
status_code = statusCode status
|
||||
ct <- case lookup "Content-Type" $ Client.responseHeaders response of
|
||||
Nothing -> pure $ "application"//"octet-stream"
|
||||
Just t -> case parseAccept t of
|
||||
Nothing -> left $ InvalidContentTypeHeader (cs t) body
|
||||
Just t' -> pure t'
|
||||
unless (isWantedStatus status_code) $
|
||||
left $ FailureResponse status ct body
|
||||
return (status_code, body, ct, response)
|
||||
|
||||
performRequestCT :: MimeUnrender ct result =>
|
||||
Proxy ct -> Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO result
|
||||
performRequestCT ct reqMethod req wantedStatus reqHost = do
|
||||
let acceptCT = contentType ct
|
||||
(_status, respBody, respCT, _response) <-
|
||||
performRequest reqMethod (req { reqAccept = [acceptCT] }) (`elem` wantedStatus) reqHost
|
||||
unless (matches respCT (acceptCT)) $
|
||||
left $ UnsupportedContentType respCT respBody
|
||||
either
|
||||
(left . (\s -> DecodeFailure s respCT respBody))
|
||||
return
|
||||
(mimeUnrender ct respBody)
|
||||
|
||||
performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO ()
|
||||
performRequestNoBody reqMethod req wantedStatus reqHost = do
|
||||
_ <- performRequest reqMethod req (`elem` wantedStatus) reqHost
|
||||
return ()
|
||||
|
||||
catchHttpException :: IO a -> IO (Either HttpException a)
|
||||
catchHttpException action =
|
||||
catch (Right <$> action) (pure . Left)
|
345
servant-client/test/Servant/ClientSpec.hs
Normal file
345
servant-client/test/Servant/ClientSpec.hs
Normal file
|
@ -0,0 +1,345 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# OPTIONS_GHC -fcontext-stack=25 #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Servant.ClientSpec where
|
||||
|
||||
import Control.Applicative
|
||||
import qualified Control.Arrow as Arrow
|
||||
import Control.Concurrent
|
||||
import Control.Exception
|
||||
import Control.Monad.Trans.Either
|
||||
import Data.Aeson
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Data.Char
|
||||
import Data.Foldable (forM_)
|
||||
import Data.Monoid
|
||||
import Data.Proxy
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics
|
||||
import qualified Network.HTTP.Client as C
|
||||
import Network.HTTP.Media
|
||||
import Network.HTTP.Types
|
||||
import Network.Socket
|
||||
import Network.Wai hiding (Response)
|
||||
import Network.Wai.Handler.Warp
|
||||
import Test.Hspec
|
||||
import Test.Hspec.QuickCheck
|
||||
import Test.HUnit
|
||||
import Test.QuickCheck
|
||||
|
||||
import Servant.API
|
||||
import Servant.Client
|
||||
import Servant.Server
|
||||
|
||||
-- * test data types
|
||||
|
||||
data Person = Person {
|
||||
name :: String,
|
||||
age :: Integer
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance ToJSON Person
|
||||
instance FromJSON Person
|
||||
|
||||
instance ToFormUrlEncoded Person where
|
||||
toFormUrlEncoded Person{..} =
|
||||
[("name", T.pack name), ("age", T.pack (show age))]
|
||||
|
||||
lookupEither :: (Show a, Eq a) => a -> [(a,b)] -> Either String b
|
||||
lookupEither x xs = do
|
||||
maybe (Left $ "could not find key " <> show x) return $ lookup x xs
|
||||
|
||||
instance FromFormUrlEncoded Person where
|
||||
fromFormUrlEncoded xs = do
|
||||
n <- lookupEither "name" xs
|
||||
a <- lookupEither "age" xs
|
||||
return $ Person (T.unpack n) (read $ T.unpack a)
|
||||
|
||||
deriving instance Eq ServantError
|
||||
|
||||
instance Eq C.HttpException where
|
||||
a == b = show a == show b
|
||||
|
||||
alice :: Person
|
||||
alice = Person "Alice" 42
|
||||
|
||||
type Api =
|
||||
"get" :> Get '[JSON] Person
|
||||
:<|> "delete" :> Delete
|
||||
:<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
|
||||
:<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
|
||||
:<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
|
||||
:<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
|
||||
:<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool
|
||||
:<|> "matrixparam" :> MatrixParam "name" String :> Get '[JSON] Person
|
||||
:<|> "matrixparams" :> MatrixParams "name" String :> Get '[JSON] [Person]
|
||||
:<|> "matrixflag" :> MatrixFlag "flag" :> Get '[JSON] Bool
|
||||
:<|> "rawSuccess" :> Raw
|
||||
:<|> "rawFailure" :> Raw
|
||||
:<|> "multiple" :>
|
||||
Capture "first" String :>
|
||||
QueryParam "second" Int :>
|
||||
QueryFlag "third" :>
|
||||
ReqBody '[JSON] [(String, [Rational])] :>
|
||||
Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
|
||||
api :: Proxy Api
|
||||
api = Proxy
|
||||
|
||||
server :: Application
|
||||
server = serve api (
|
||||
return alice
|
||||
:<|> return ()
|
||||
:<|> (\ name -> return $ Person name 0)
|
||||
:<|> return
|
||||
:<|> (\ name -> case name of
|
||||
Just "alice" -> return alice
|
||||
Just name -> left (400, name ++ " not found")
|
||||
Nothing -> left (400, "missing parameter"))
|
||||
:<|> (\ names -> return (zipWith Person names [0..]))
|
||||
:<|> return
|
||||
:<|> (\ name -> case name of
|
||||
Just "alice" -> return alice
|
||||
Just name -> left (400, name ++ " not found")
|
||||
Nothing -> left (400, "missing parameter"))
|
||||
:<|> (\ names -> return (zipWith Person names [0..]))
|
||||
:<|> return
|
||||
:<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess")
|
||||
:<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure")
|
||||
:<|> \ a b c d -> return (a, b, c, d)
|
||||
)
|
||||
|
||||
withServer :: (BaseUrl -> IO a) -> IO a
|
||||
withServer action = withWaiDaemon (return server) action
|
||||
|
||||
getGet :: BaseUrl -> EitherT ServantError IO Person
|
||||
getDelete :: BaseUrl -> EitherT ServantError IO ()
|
||||
getCapture :: String -> BaseUrl -> EitherT ServantError IO Person
|
||||
getBody :: Person -> BaseUrl -> EitherT ServantError IO Person
|
||||
getQueryParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person
|
||||
getQueryParams :: [String] -> BaseUrl -> EitherT ServantError IO [Person]
|
||||
getQueryFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool
|
||||
getMatrixParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person
|
||||
getMatrixParams :: [String] -> BaseUrl -> EitherT ServantError IO [Person]
|
||||
getMatrixFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool
|
||||
getRawSuccess :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, C.Response ByteString)
|
||||
getRawFailure :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, C.Response ByteString)
|
||||
getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
|
||||
-> BaseUrl
|
||||
-> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])])
|
||||
( getGet
|
||||
:<|> getDelete
|
||||
:<|> getCapture
|
||||
:<|> getBody
|
||||
:<|> getQueryParam
|
||||
:<|> getQueryParams
|
||||
:<|> getQueryFlag
|
||||
:<|> getMatrixParam
|
||||
:<|> getMatrixParams
|
||||
:<|> getMatrixFlag
|
||||
:<|> getRawSuccess
|
||||
:<|> getRawFailure
|
||||
:<|> getMultiple)
|
||||
= client api
|
||||
|
||||
type FailApi =
|
||||
"get" :> Raw
|
||||
:<|> "capture" :> Capture "name" String :> Raw
|
||||
:<|> "body" :> Raw
|
||||
failApi :: Proxy FailApi
|
||||
failApi = Proxy
|
||||
|
||||
failServer :: Application
|
||||
failServer = serve failApi (
|
||||
(\ _request respond -> respond $ responseLBS ok200 [] "")
|
||||
:<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "")
|
||||
:<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")
|
||||
)
|
||||
|
||||
withFailServer :: (BaseUrl -> IO a) -> IO a
|
||||
withFailServer action = withWaiDaemon (return failServer) action
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
it "Servant.API.Get" $ withServer $ \ host -> do
|
||||
(Arrow.left show <$> runEitherT (getGet host)) `shouldReturn` Right alice
|
||||
|
||||
it "Servant.API.Delete" $ withServer $ \ host -> do
|
||||
(Arrow.left show <$> runEitherT (getDelete host)) `shouldReturn` Right ()
|
||||
|
||||
it "Servant.API.Capture" $ withServer $ \ host -> do
|
||||
(Arrow.left show <$> runEitherT (getCapture "Paula" host)) `shouldReturn` Right (Person "Paula" 0)
|
||||
|
||||
it "Servant.API.ReqBody" $ withServer $ \ host -> do
|
||||
let p = Person "Clara" 42
|
||||
(Arrow.left show <$> runEitherT (getBody p host)) `shouldReturn` Right p
|
||||
|
||||
it "Servant.API.QueryParam" $ withServer $ \ host -> do
|
||||
Arrow.left show <$> runEitherT (getQueryParam (Just "alice") host) `shouldReturn` Right alice
|
||||
Left FailureResponse{..} <- runEitherT (getQueryParam (Just "bob") host)
|
||||
responseStatus `shouldBe` Status 400 "bob not found"
|
||||
|
||||
it "Servant.API.QueryParam.QueryParams" $ withServer $ \ host -> do
|
||||
(Arrow.left show <$> runEitherT (getQueryParams [] host)) `shouldReturn` Right []
|
||||
(Arrow.left show <$> runEitherT (getQueryParams ["alice", "bob"] host))
|
||||
`shouldReturn` Right [Person "alice" 0, Person "bob" 1]
|
||||
|
||||
context "Servant.API.QueryParam.QueryFlag" $
|
||||
forM_ [False, True] $ \ flag ->
|
||||
it (show flag) $ withServer $ \ host -> do
|
||||
(Arrow.left show <$> runEitherT (getQueryFlag flag host)) `shouldReturn` Right flag
|
||||
|
||||
it "Servant.API.MatrixParam" $ withServer $ \ host -> do
|
||||
Arrow.left show <$> runEitherT (getMatrixParam (Just "alice") host) `shouldReturn` Right alice
|
||||
Left FailureResponse{..} <- runEitherT (getMatrixParam (Just "bob") host)
|
||||
responseStatus `shouldBe` Status 400 "bob not found"
|
||||
|
||||
it "Servant.API.MatrixParam.MatrixParams" $ withServer $ \ host -> do
|
||||
Arrow.left show <$> runEitherT (getMatrixParams [] host) `shouldReturn` Right []
|
||||
Arrow.left show <$> runEitherT (getMatrixParams ["alice", "bob"] host)
|
||||
`shouldReturn` Right [Person "alice" 0, Person "bob" 1]
|
||||
|
||||
context "Servant.API.MatrixParam.MatrixFlag" $
|
||||
forM_ [False, True] $ \ flag ->
|
||||
it (show flag) $ withServer $ \ host -> do
|
||||
Arrow.left show <$> runEitherT (getMatrixFlag flag host) `shouldReturn` Right flag
|
||||
|
||||
it "Servant.API.Raw on success" $ withServer $ \ host -> do
|
||||
res <- runEitherT (getRawSuccess methodGet host)
|
||||
case res of
|
||||
Left e -> assertFailure $ show e
|
||||
Right (code, body, ct, response) -> do
|
||||
(code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream")
|
||||
C.responseBody response `shouldBe` body
|
||||
C.responseStatus response `shouldBe` ok200
|
||||
|
||||
it "Servant.API.Raw on failure" $ withServer $ \ host -> do
|
||||
res <- runEitherT (getRawFailure methodGet host)
|
||||
case res of
|
||||
Left e -> assertFailure $ show e
|
||||
Right (code, body, ct, response) -> do
|
||||
(code, body, ct) `shouldBe` (400, "rawFailure", "application"//"octet-stream")
|
||||
C.responseBody response `shouldBe` body
|
||||
C.responseStatus response `shouldBe` badRequest400
|
||||
|
||||
modifyMaxSuccess (const 20) $ do
|
||||
it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $
|
||||
property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
|
||||
ioProperty $ do
|
||||
withServer $ \ host -> do
|
||||
result <- Arrow.left show <$> runEitherT (getMultiple cap num flag body host)
|
||||
return $
|
||||
result === Right (cap, num, flag, body)
|
||||
|
||||
|
||||
context "client correctly handles error status codes" $ do
|
||||
let test :: (WrappedApi, String) -> Spec
|
||||
test (WrappedApi api, desc) =
|
||||
it desc $
|
||||
withWaiDaemon (return (serve api (left (500, "error message")))) $
|
||||
\ host -> do
|
||||
let getResponse :: BaseUrl -> EitherT ServantError IO ()
|
||||
getResponse = client api
|
||||
Left FailureResponse{..} <- runEitherT (getResponse host)
|
||||
responseStatus `shouldBe` (Status 500 "error message")
|
||||
mapM_ test $
|
||||
(WrappedApi (Proxy :: Proxy Delete), "Delete") :
|
||||
(WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
|
||||
(WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :
|
||||
(WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :
|
||||
[]
|
||||
|
||||
context "client returns errors appropriately" $ do
|
||||
it "reports FailureResponse" $ withFailServer $ \ host -> do
|
||||
Left res <- runEitherT (getDelete host)
|
||||
case res of
|
||||
FailureResponse (Status 404 "Not Found") _ _ -> return ()
|
||||
_ -> fail $ "expected 404 response, but got " <> show res
|
||||
|
||||
it "reports DecodeFailure" $ withFailServer $ \ host -> do
|
||||
Left res <- runEitherT (getCapture "foo" host)
|
||||
case res of
|
||||
DecodeFailure _ ("application/json") _ -> return ()
|
||||
_ -> fail $ "expected DecodeFailure, but got " <> show res
|
||||
|
||||
it "reports ConnectionError" $ do
|
||||
Right host <- return $ parseBaseUrl "127.0.0.1:987654"
|
||||
Left res <- runEitherT (getGet host)
|
||||
case res of
|
||||
ConnectionError (C.FailedConnectionException2 "127.0.0.1" 987654 False _) -> return ()
|
||||
_ -> fail $ "expected ConnectionError, but got " <> show res
|
||||
|
||||
it "reports UnsupportedContentType" $ withFailServer $ \ host -> do
|
||||
Left res <- runEitherT (getGet host)
|
||||
case res of
|
||||
UnsupportedContentType ("application/octet-stream") _ -> return ()
|
||||
_ -> fail $ "expected UnsupportedContentType, but got " <> show res
|
||||
|
||||
it "reports InvalidContentTypeHeader" $ withFailServer $ \ host -> do
|
||||
Left res <- runEitherT (getBody alice host)
|
||||
case res of
|
||||
InvalidContentTypeHeader "fooooo" _ -> return ()
|
||||
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
|
||||
|
||||
data WrappedApi where
|
||||
WrappedApi :: (HasServer (Canonicalize api), Server api ~ EitherT (Int, String) IO a,
|
||||
HasClient (Canonicalize api), Client api ~ (BaseUrl -> EitherT ServantError IO ())) =>
|
||||
Proxy api -> WrappedApi
|
||||
|
||||
|
||||
-- * utils
|
||||
|
||||
withWaiDaemon :: IO Application -> (BaseUrl -> IO a) -> IO a
|
||||
withWaiDaemon mkApplication action = do
|
||||
application <- mkApplication
|
||||
bracket (acquire application) free (\ (_, _, baseUrl) -> action baseUrl)
|
||||
where
|
||||
acquire application = do
|
||||
(notifyStart, waitForStart) <- lvar
|
||||
(notifyKilled, waitForKilled) <- lvar
|
||||
thread <- forkIO $ (do
|
||||
(krakenPort, socket) <- openTestSocket
|
||||
let settings =
|
||||
setPort krakenPort $ -- set here just for consistency, shouldn't be
|
||||
-- used (it's set in the socket)
|
||||
setBeforeMainLoop (notifyStart krakenPort)
|
||||
defaultSettings
|
||||
runSettingsSocket settings socket application)
|
||||
`finally` notifyKilled ()
|
||||
krakenPort <- waitForStart
|
||||
let baseUrl = (BaseUrl Http "localhost" 80){baseUrlPort = krakenPort}
|
||||
return (thread, waitForKilled, baseUrl)
|
||||
free (thread, waitForKilled, _) = do
|
||||
killThread thread
|
||||
waitForKilled
|
||||
|
||||
lvar :: IO (a -> IO (), IO a)
|
||||
lvar = do
|
||||
mvar <- newEmptyMVar
|
||||
let put = putMVar mvar
|
||||
wait = readMVar mvar
|
||||
return (put, wait)
|
||||
|
||||
openTestSocket :: IO (Port, Socket)
|
||||
openTestSocket = do
|
||||
s <- socket AF_INET Stream defaultProtocol
|
||||
localhost <- inet_addr "127.0.0.1"
|
||||
bind s (SockAddrInet aNY_PORT localhost)
|
||||
listen s 1
|
||||
port <- socketPort s
|
||||
return (fromIntegral port, s)
|
||||
|
||||
pathGen :: Gen (NonEmptyList Char)
|
||||
pathGen = fmap NonEmpty path
|
||||
where
|
||||
path = listOf1 $ elements $
|
||||
filter (not . (`elem` "?%[]/#;")) $
|
||||
filter isPrint $
|
||||
map chr [0..127]
|
69
servant-client/test/Servant/Common/BaseUrlSpec.hs
Normal file
69
servant-client/test/Servant/Common/BaseUrlSpec.hs
Normal file
|
@ -0,0 +1,69 @@
|
|||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Servant.Common.BaseUrlSpec where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.DeepSeq
|
||||
import Test.Hspec
|
||||
import Test.QuickCheck
|
||||
|
||||
import Servant.Common.BaseUrl
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "showBaseUrl" $ do
|
||||
it "shows a BaseUrl" $ do
|
||||
showBaseUrl (BaseUrl Http "foo.com" 80) `shouldBe` "http://foo.com"
|
||||
|
||||
it "shows a https BaseUrl" $ do
|
||||
showBaseUrl (BaseUrl Https "foo.com" 443) `shouldBe` "https://foo.com"
|
||||
|
||||
describe "httpBaseUrl" $ do
|
||||
it "allows to construct default http BaseUrls" $ do
|
||||
BaseUrl Http "bar" 80 `shouldBe` BaseUrl Http "bar" 80
|
||||
|
||||
describe "parseBaseUrl" $ do
|
||||
it "is total" $ do
|
||||
property $ \ string ->
|
||||
deepseq (fmap show (parseBaseUrl string)) True
|
||||
|
||||
it "is the inverse of showBaseUrl" $ do
|
||||
property $ \ baseUrl ->
|
||||
counterexample (showBaseUrl baseUrl) $
|
||||
parseBaseUrl (showBaseUrl baseUrl) ===
|
||||
Right baseUrl
|
||||
|
||||
it "allows trailing slashes" $ do
|
||||
parseBaseUrl "foo.com/" `shouldBe` Right (BaseUrl Http "foo.com" 80)
|
||||
|
||||
context "urls without scheme" $ do
|
||||
it "assumes http" $ do
|
||||
parseBaseUrl "foo.com" `shouldBe` Right (BaseUrl Http "foo.com" 80)
|
||||
|
||||
it "allows port numbers" $ do
|
||||
parseBaseUrl "foo.com:8080" `shouldBe` Right (BaseUrl Http "foo.com" 8080)
|
||||
|
||||
it "rejects ftp urls" $ do
|
||||
parseBaseUrl "ftp://foo.com" `shouldSatisfy` isLeft
|
||||
|
||||
instance Arbitrary BaseUrl where
|
||||
arbitrary = BaseUrl <$>
|
||||
elements [Http, Https] <*>
|
||||
hostNameGen <*>
|
||||
portGen
|
||||
where
|
||||
-- this does not perfectly mirror the url standard, but I hope it's good
|
||||
-- enough.
|
||||
hostNameGen = do
|
||||
let letters = ['a' .. 'z'] ++ ['A' .. 'Z']
|
||||
first <- elements letters
|
||||
middle <- listOf1 $ elements (letters ++ ['0' .. '9'] ++ ['.', '-'])
|
||||
last <- elements letters
|
||||
return (first : middle ++ [last])
|
||||
portGen = frequency $
|
||||
(1, return 80) :
|
||||
(1, return 443) :
|
||||
(1, choose (1, 20000)) :
|
||||
[]
|
||||
|
||||
isLeft :: Either a b -> Bool
|
||||
isLeft = either (const True) (const False)
|
1
servant-client/test/Spec.hs
Normal file
1
servant-client/test/Spec.hs
Normal file
|
@ -0,0 +1 @@
|
|||
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
Loading…
Reference in a new issue