first shot at splitting servant into servant, servant-client and servant-docs

servant-client.cabal

@@ -0,0 +1,59 @@
+name:                servant-client
+version:             0.2
+-- synopsis:
+-- description:
+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
+
+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-types
+    , network-uri >= 2.6
+    , safe
+    , servant
+    , string-conversions
+    , text
+    , transformers
+  hs-source-dirs: src
+  default-language: Haskell2010
+  ghc-options: -O0 -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-types
+    , network >= 2.6
+    , QuickCheck
+    , servant
+    , servant-client
+    , wai
+    , warp

src/Servant/Client.hs

@@ -0,0 +1,305 @@
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# 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(..)
+  , module Servant.Common.BaseUrl
+  ) where
+
+import Control.Monad.Trans.Either
+import Data.Aeson
+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.Types
+import Servant.API
+import Servant.Common.BaseUrl
+import Servant.Common.Req
+import Servant.Common.Text
+
+-- * 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 layout => Proxy layout -> Client layout
+client p = clientWithRoute p defReq
+
+-- | This class lets us define how each API combinator
+-- influences the creation of an HTTP request. Use 'client'
+-- directly, this class implements the client-side
+-- behavior of each combinator but you don't have to worry about it.
+class HasClient layout where
+  type Client layout :: *
+  clientWithRoute :: Proxy layout -> Req -> Client 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 String IO ()
+
+  clientWithRoute Proxy req host =
+    performRequestJSON methodDelete req 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 FromJSON result => HasClient (Get result) where
+  type Client (Get result) = BaseUrl -> EitherT String IO result
+  clientWithRoute Proxy req host =
+    performRequestJSON methodGet req 200 host
+
+-- | 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 FromJSON a => HasClient (Post a) where
+  type Client (Post a) = BaseUrl -> EitherT String IO a
+
+  clientWithRoute Proxy req uri =
+    performRequestJSON methodPost req 201 uri
+
+-- | 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 FromJSON a => HasClient (Put a) where
+  type Client (Put a) = BaseUrl -> EitherT String IO a
+
+  clientWithRoute Proxy req host =
+    performRequestJSON methodPut req 200 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) $
+      appendToQueryString pname mparamText req
+
+    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' (\ value req' -> appendToQueryString pname req' value) 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)
+
+-- | Pick a 'Method' and specify where the server you want to query is. You get
+-- back the status code and the response body as a 'ByteString'.
+instance HasClient Raw where
+  type Client Raw = Method -> BaseUrl -> EitherT String IO (Int, ByteString)
+
+  clientWithRoute :: Proxy Raw -> Req -> Client Raw
+  clientWithRoute Proxy req httpMethod host =
+    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 (ToJSON a, HasClient sublayout)
+      => HasClient (ReqBody a :> sublayout) where
+
+  type Client (ReqBody a :> sublayout) =
+    a -> Client sublayout
+
+  clientWithRoute Proxy req body =
+    clientWithRoute (Proxy :: Proxy sublayout) $
+      setRQBody (encode body) 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)
+

src/Servant/Common/BaseUrl.hs

@@ -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

src/Servant/Common/Req.hs

@@ -0,0 +1,132 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Servant.Common.Req where
+
+import Control.Applicative
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+import Control.Monad.Catch (MonadThrow)
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Either
+import Data.Aeson
+import Data.Aeson.Parser
+import Data.Aeson.Types
+import Data.Attoparsec.ByteString
+import Data.ByteString.Lazy
+import Data.String.Conversions
+import Data.Text
+import Network.HTTP.Client
+import Network.HTTP.Types
+import Network.URI
+import Servant.Common.BaseUrl
+import System.IO.Unsafe
+
+import qualified Network.HTTP.Client as Client
+
+data Req = Req
+  { reqPath  :: String
+  , qs       :: QueryText
+  , reqBody  :: ByteString
+  }
+
+defReq :: Req
+defReq = Req "" [] ""
+
+appendToPath :: String -> Req -> Req
+appendToPath p req =
+  req { reqPath = reqPath req ++ "/" ++ p }
+
+appendToQueryString :: Text       -- ^ param name
+                    -> Maybe Text -- ^ param value
+                    -> Req
+                    -> Req
+appendToQueryString pname pvalue req =
+  req { qs = qs req ++ [(pname, pvalue)]
+      }
+
+setRQBody :: ByteString -> Req -> Req
+setRQBody b req = req { reqBody = b }
+
+reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
+reqToRequest req (BaseUrl reqScheme reqHost reqPort) = fmap (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 = r { requestBody = RequestBodyLBS (reqBody req) }
+        setQS = setQueryString $ queryTextToQuery (qs req)
+
+
+-- * performing requests
+
+{-# NOINLINE __manager #-}
+__manager :: MVar Manager
+__manager = unsafePerformIO (newManager defaultManagerSettings >>= newMVar)
+
+__withGlobalManager :: (Manager -> IO a) -> IO a
+__withGlobalManager action = modifyMVar __manager $ \ manager -> do
+  result <- action manager
+  return (manager, result)
+
+
+displayHttpRequest :: Method -> String
+displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
+
+
+performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT String IO (Int, 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 ->
+    catchStatusCodeException $
+    Client.httpLbs request manager
+  case eResponse of
+    Left status ->
+      left (displayHttpRequest reqMethod ++ " failed with status: " ++ showStatus status)
+
+    Right response -> do
+      let status = Client.responseStatus response
+      unless (isWantedStatus (statusCode status)) $
+        left (displayHttpRequest reqMethod ++ " failed with status: " ++ showStatus status)
+      return $ (statusCode status, Client.responseBody response)
+  where
+    showStatus (Status code message) =
+      show code ++ " - " ++ cs message
+
+
+performRequestJSON :: FromJSON result =>
+  Method -> Req -> Int -> BaseUrl -> EitherT String IO result
+performRequestJSON reqMethod req wantedStatus reqHost = do
+  (_status, respBody) <- performRequest reqMethod req (== wantedStatus) reqHost
+  either
+    (\ message -> left (displayHttpRequest reqMethod ++ " returned invalid json: " ++ message))
+    return
+    (decodeLenient respBody)
+
+
+catchStatusCodeException :: IO a -> IO (Either Status a)
+catchStatusCodeException action =
+  catch (Right <$> action) $ \e ->
+    case e of
+      Client.StatusCodeException status _ _ -> return $ Left status
+      exc -> throwIO exc
+
+-- | Like 'Data.Aeson.decode' but allows all JSON values instead of just
+-- objects and arrays.
+decodeLenient :: FromJSON a => ByteString -> Either String a
+decodeLenient input = do
+  v :: Value <- parseOnly (Data.Aeson.Parser.value <* endOfInput) (cs input)
+  parseEither parseJSON v

test/Servant/ClientSpec.hs

@@ -0,0 +1,218 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Servant.ClientSpec where
+
+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.Proxy
+import Data.Typeable
+import GHC.Generics
+import Network.HTTP.Types
+import Network.Socket
+import Network.Wai
+import Network.Wai.Handler.Warp
+import Test.Hspec
+import Test.Hspec.QuickCheck
+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
+
+alice :: Person
+alice = Person "Alice" 42
+
+type Api =
+       "get" :> Get Person
+  :<|> "capture" :> Capture "name" String :> Get Person
+  :<|> "body" :> ReqBody Person :> Post Person
+  :<|> "param" :> QueryParam "name" String :> Get Person
+  :<|> "params" :> QueryParams "names" String :> Get [Person]
+  :<|> "flag" :> QueryFlag "flag" :> Get Bool
+  :<|> "rawSuccess" :> Raw
+  :<|> "rawFailure" :> Raw
+  :<|> "multiple" :>
+            Capture "first" String :>
+            QueryParam "second" Int :>
+            QueryFlag "third" :>
+            ReqBody [(String, [Rational])] :>
+            Get (String, Maybe Int, Bool, [(String, [Rational])])
+api :: Proxy Api
+api = Proxy
+
+server :: Application
+server = serve api (
+       return alice
+  :<|> (\ 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
+  :<|> (\ _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 String IO Person
+getCapture :: String -> BaseUrl -> EitherT String IO Person
+getBody :: Person -> BaseUrl -> EitherT String IO Person
+getQueryParam :: Maybe String -> BaseUrl -> EitherT String IO Person
+getQueryParams :: [String] -> BaseUrl -> EitherT String IO [Person]
+getQueryFlag :: Bool -> BaseUrl -> EitherT String IO Bool
+getRawSuccess :: Method -> BaseUrl -> EitherT String IO (Int, ByteString)
+getRawFailure :: Method -> BaseUrl -> EitherT String IO (Int, ByteString)
+getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
+  -> BaseUrl
+  -> EitherT String IO (String, Maybe Int, Bool, [(String, [Rational])])
+(     getGet
+ :<|> getCapture
+ :<|> getBody
+ :<|> getQueryParam
+ :<|> getQueryParams
+ :<|> getQueryFlag
+ :<|> getRawSuccess
+ :<|> getRawFailure
+ :<|> getMultiple)
+    = client api
+
+spec :: Spec
+spec = do
+  it "Servant.API.Get" $ withServer $ \ host -> do
+    runEitherT (getGet host) `shouldReturn` Right alice
+
+  it "Servant.API.Capture" $ withServer $ \ host -> do
+    runEitherT (getCapture "Paula" host) `shouldReturn` Right (Person "Paula" 0)
+
+  it "Servant.API.ReqBody" $ withServer $ \ host -> do
+    let p = Person "Clara" 42
+    runEitherT (getBody p host) `shouldReturn` Right p
+
+  it "Servant.API.QueryParam" $ withServer $ \ host -> do
+    runEitherT (getQueryParam (Just "alice") host) `shouldReturn` Right alice
+    Left result <- runEitherT (getQueryParam (Just "bob") host)
+    result `shouldContain` "bob not found"
+
+  it "Servant.API.QueryParam.QueryParams" $ withServer $ \ host -> do
+    runEitherT (getQueryParams [] host) `shouldReturn` Right []
+    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
+      runEitherT (getQueryFlag flag host) `shouldReturn` Right flag
+
+  it "Servant.API.Raw on success" $ withServer $ \ host -> do
+    runEitherT (getRawSuccess methodGet host) `shouldReturn` Right (200, "rawSuccess")
+
+  it "Servant.API.Raw on failure" $ withServer $ \ host -> do
+    runEitherT (getRawFailure methodGet host) `shouldReturn` Right (400, "rawFailure")
+
+  modifyMaxSuccess (const 20) $ do
+    it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $
+      property $ forAllShrink pathGen shrink $ \ a -> \ b c d ->
+        ioProperty $ do
+          withServer $ \ host -> do
+            result <- runEitherT (getMultiple a b c d host)
+            return $
+              result === Right (a, b, c, d)
+
+
+  context "client correctly handles error status codes" $ do
+    let test :: WrappedApi -> Spec
+        test (WrappedApi api) =
+          it (show (typeOf api)) $
+          withWaiDaemon (return (serve api (left (500, "error message")))) $
+          \ host -> do
+            let getResponse :: BaseUrl -> EitherT String IO ()
+                getResponse = client api
+            Left result <- runEitherT (getResponse host)
+            result `shouldContain` "error message"
+    mapM_ test $
+      (WrappedApi (Proxy :: Proxy Delete)) :
+      (WrappedApi (Proxy :: Proxy (Get ()))) :
+      (WrappedApi (Proxy :: Proxy (Post ()))) :
+      (WrappedApi (Proxy :: Proxy (Put ()))) :
+      []
+
+data WrappedApi where
+  WrappedApi :: (HasServer api, Server api ~ EitherT (Int, String) IO a,
+                 HasClient api, Client api ~ (BaseUrl -> EitherT String IO ()),
+                 Typeable api) =>
+    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 String
+pathGen = listOf $ elements $
+  filter (not . (`elem` "?%[]/#")) $
+  filter isPrint $
+  map chr [0..127]

test/Servant/Common/BaseUrlSpec.hs

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

test/Spec.hs

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