Merge remote-tracking branch 'servant-client/prepare-merge' into merge

This commit is contained in:
Julian K. Arni 2015-04-20 11:23:45 +02:00
commit 1eedad4073
12 changed files with 1365 additions and 0 deletions

View 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
View 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
View 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
View file

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

52
servant-client/docs.sh Normal file
View 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

View 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

View 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)

View 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

View 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)

View 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]

View 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)

View file

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