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

Merge pull request #803 from haskell-servant/pr800

Browse source 
Factor out servant-client-core
This commit is contained in:
Julian Arni 2017-09-18 13:51:55 -04:00 committed by GitHub
commit 28fe7a0d0f
28 changed files with 1292 additions and 986 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
doc/tutorial/Client.lhs
View file

@ -128,15 +128,15 @@ That's it. Let's now write some code that uses our client functions.
``` haskell ``` haskell
queries :: ClientM (Position, HelloMessage, Email) queries :: ClientM (Position, HelloMessage, Email)
queries = do queries = do
pos <- position 10 10 pos <- position 10 10
message <- hello (Just "servant") message <- hello (Just "servant")
em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]) em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"])
return (pos, message, em) return (pos, message, em)
run :: IO () run :: IO ()
run = do run = do
manager <- newManager defaultManagerSettings manager' <- newManager defaultManagerSettings
res <- runClientM queries (ClientEnv manager (BaseUrl Http "localhost" 8081 "")) res <- runClientM queries (ClientEnv manager' (BaseUrl Http "localhost" 8081 ""))
case res of case res of
Left err -> putStrLn $ "Error: " ++ show err Left err -> putStrLn $ "Error: " ++ show err
Right (pos, message, em) -> do Right (pos, message, em) -> do

6
servant-client-core/CHANGELOG.md Normal file
View file

@ -0,0 +1,6 @@
# Revision history for servant-client-core
## 0.12 -- YYYY-mm-dd
* First version. Factored out of servant-client all the functionality that was
independent of the http-client backend.

30
servant-client-core/LICENSE Normal file
View file

@ -0,0 +1,30 @@
Copyright (c) 2017, Servant Contributors
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Servant Contributors 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.

30
servant-client-core/README.md Normal file
View file

@ -0,0 +1,30 @@
# servant-client-core
![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png)
HTTP-client-agnostic client functions for servant APIs.
This library should mainly be of interest to backend- and combinator-writers.
## For backend-writers
If you are creating a new backend, you'll need to:
1. Define a `RunClient` instance for your datatype (call it `MyMonad`)
2. Define a `ClientLike` instance. This will look like:
``` haskell
instance ClientLike (MyMonad a) (MyMonad a) where
mkClient = id
```
3. Re-export the module Servant.Client.Core.Reexport so that your end-users
can be blissfully unaware of 'servant-client-core', and so each
backend-package comes closer to the warm hearth of the drop-in-replacement
equivalence class.
## For combinator-writers
You'll need to define a new `HasClient` instance for your combinator. There are
plenty of examples to guide you in the
[HasClient](src/Servant/Client/Core/Internal/HasClient.hs) module.

2
servant-client-core/Setup.hs Normal file
View file

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

8
servant-client-core/include/overlapping-compat.h Normal file
View file

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

74
servant-client-core/servant-client-core.cabal Normal file
View file

@ -0,0 +1,74 @@
name: servant-client-core
version: 0.11
synopsis: Core functionality and class for client function generation for servant APIs
description:
This library provides backend-agnostic generation of client functions. For
more information, see the README.
license: BSD3
license-file: LICENSE
author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com
homepage: http://haskell-servant.readthedocs.org/
bug-reports: http://github.com/haskell-servant/servant/issues
cabal-version: >=1.10
copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant Contributors
category: Web
build-type: Simple
extra-source-files:
include/*.h
CHANGELOG.md
README.md
source-repository head
type: git
location: http://github.com/haskell-servant/servant.git
library
exposed-modules:
Servant.Client.Core
Servant.Client.Core.Reexport
Servant.Client.Core.Internal.Auth
Servant.Client.Core.Internal.BaseUrl
Servant.Client.Core.Internal.BasicAuth
Servant.Client.Core.Internal.Generic
Servant.Client.Core.Internal.HasClient
Servant.Client.Core.Internal.Request
Servant.Client.Core.Internal.RunClient
build-depends:
base >= 4.7 && < 4.11
, base-compat >= 0.9.1 && < 0.10
, base64-bytestring >= 1.0.0.1 && < 1.1
, bytestring >= 0.10 && < 0.11
, containers >= 0.5 && < 0.6
, exceptions >= 0.8 && < 0.9
, generics-sop >= 0.1.0.0 && < 0.4
, http-api-data >= 0.3.6 && < 0.4
, http-media >= 0.6.2 && < 0.8
, http-types >= 0.8.6 && < 0.10
, mtl >= 2.1 && < 2.3
, network-uri >= 2.6 && < 2.7
, safe >= 0.3.9 && < 0.4
, servant == 0.11.*
, text >= 1.2 && < 1.3
if !impl(ghc >= 8.0)
build-depends:
semigroups >=0.16.2.2 && <0.19
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall
include-dirs: include
test-suite spec
type: exitcode-stdio-1.0
ghc-options: -Wall
default-language: Haskell2010
hs-source-dirs: test
main-is: Spec.hs
build-depends:
base
, base-compat
, deepseq
, servant-client-core
, hspec == 2.*
, QuickCheck >= 2.7 && < 2.11
other-modules:
Servant.Client.Core.Internal.BaseUrlSpec

65
servant-client-core/src/Servant/Client/Core.hs Normal file
View file

@ -0,0 +1,65 @@
-- | This module provides backend-agnostic functionality for generating clients
-- from @servant@ APIs. By "backend," we mean something that concretely
-- executes the request, such as:
--
-- * The @http-client@ library
-- * The @haxl@ library
-- * GHCJS via FFI
--
-- etc.
--
-- Each backend is encapsulated in a monad that is an instance of the
-- 'RunClient' class.
--
-- This library is primarily of interest to backend-writers and
-- combinator-writers. For more information, see the README.md
module Servant.Client.Core
(
-- * Client generation
clientIn
, HasClient(..)
-- * Request
, Request
, RequestF(..)
, defaultRequest
, RequestBody(..)
-- * Authentication
, mkAuthenticatedRequest
, basicAuthReq
, AuthenticatedRequest(..)
, AuthClientData
-- * Generic Client
, ClientLike(..)
, genericMkClientL
, genericMkClientP
, ServantError(..)
, EmptyClient(..)
-- * Response
, Response(..)
, RunClient(..)
, module Servant.Client.Core.Internal.BaseUrl
-- * Writing HasClient instances
-- | These functions need not be re-exported by backend libraries.
, addHeader
, appendToQueryString
, appendToPath
, setRequestBodyLBS
, setRequestBody
) where
import Servant.Client.Core.Internal.Auth
import Servant.Client.Core.Internal.BaseUrl (BaseUrl (..),
InvalidBaseUrlException,
Scheme (..),
parseBaseUrl,
showBaseUrl)
import Servant.Client.Core.Internal.BasicAuth
import Servant.Client.Core.Internal.HasClient
import Servant.Client.Core.Internal.Generic
import Servant.Client.Core.Internal.Request
import Servant.Client.Core.Internal.RunClient

24
servant-client/src/Servant/Client/Experimental/Auth.hs → servant-client-core/src/Servant/Client/Core/Internal/Auth.hs
View file

@ -1,16 +1,12 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TypeFamilies #-}
-- | Authentication for clients -- | Authentication for clients
module Servant.Client.Experimental.Auth ( module Servant.Client.Core.Internal.Auth where
AuthenticateReq(AuthenticateReq, unAuthReq)
, AuthClientData
, mkAuthenticateReq
) where
import Servant.Common.Req (Req) import Servant.Client.Core.Internal.Request (Request)
-- | For a resource protected by authentication (e.g. AuthProtect), we need -- | For a resource protected by authentication (e.g. AuthProtect), we need
-- to provide the client with some data used to add authentication data -- to provide the client with some data used to add authentication data
@ -24,13 +20,13 @@ type family AuthClientData a :: *
-- data to a request -- data to a request
-- --
-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
newtype AuthenticateReq a = newtype AuthenticatedRequest a =
AuthenticateReq { unAuthReq :: (AuthClientData a, AuthClientData a -> Req -> Req) } AuthenticatedRequest { unAuthReq :: (AuthClientData a, AuthClientData a -> Request -> Request) }
-- | Handy helper to avoid wrapping datatypes in tuples everywhere. -- | Handy helper to avoid wrapping datatypes in tuples everywhere.
-- --
-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
mkAuthenticateReq :: AuthClientData a mkAuthenticatedRequest :: AuthClientData a
-> (AuthClientData a -> Req -> Req) -> (AuthClientData a -> Request -> Request)
-> AuthenticateReq a -> AuthenticatedRequest a
mkAuthenticateReq val func = AuthenticateReq (val, func) mkAuthenticatedRequest val func = AuthenticatedRequest (val, func)

12
servant-client/src/Servant/Common/BaseUrl.hs → servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs
View file

@ -1,21 +1,13 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
module Servant.Common.BaseUrl ( module Servant.Client.Core.Internal.BaseUrl where
-- * types
BaseUrl (..)
, InvalidBaseUrlException
, Scheme (..)
-- * functions
, parseBaseUrl
, showBaseUrl
) where
import Control.Monad.Catch (Exception, MonadThrow, throwM) import Control.Monad.Catch (Exception, MonadThrow, throwM)
import Data.List import Data.List
import Data.Typeable import Data.Typeable
import GHC.Generics import GHC.Generics
import Network.URI hiding (path) import Network.URI hiding (path)
import Safe import Safe
import Text.Read import Text.Read

19
servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hs Normal file
View file

@ -0,0 +1,19 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
-- | Basic Authentication for clients
module Servant.Client.Core.Internal.BasicAuth where
import Data.ByteString.Base64 (encode)
import Data.Monoid ((<>))
import Data.Text.Encoding (decodeUtf8)
import Servant.API.BasicAuth (BasicAuthData (BasicAuthData))
import Servant.Client.Core.Internal.Request (Request, addHeader)
-- | Authenticate a request using Basic Authentication
basicAuthReq :: BasicAuthData -> Request -> Request
basicAuthReq (BasicAuthData user pass) req =
let authText = decodeUtf8 ("Basic " <> encode (user <> ":" <> pass))
in addHeader "Authorization" authText req

10
servant-client/src/Servant/Client/Generic.hs → servant-client-core/src/Servant/Client/Core/Internal/Generic.hs
View file

@ -10,15 +10,10 @@
#include "overlapping-compat.h" #include "overlapping-compat.h"
module Servant.Client.Generic module Servant.Client.Core.Internal.Generic where
( ClientLike(..)
, genericMkClientL
, genericMkClientP
) where
import Generics.SOP (Code, Generic, I(..), NP(..), NS(Z), SOP(..), to) import Generics.SOP (Code, Generic, I(..), NP(..), NS(Z), SOP(..), to)
import Servant.API ((:<|>)(..)) import Servant.API ((:<|>)(..))
import Servant.Client (ClientM)
-- | This class allows us to match client structure with client functions -- | This class allows us to match client structure with client functions
-- produced with 'client' without explicit pattern-matching. -- produced with 'client' without explicit pattern-matching.
@ -111,9 +106,6 @@ instance ClientLike client custom
=> ClientLike (a -> client) (a -> custom) where => ClientLike (a -> client) (a -> custom) where
mkClient c = mkClient . c mkClient c = mkClient . c
instance ClientLike (ClientM a) (ClientM a) where
mkClient = id
-- | Match client structure with client functions, regarding left-nested API clients -- | Match client structure with client functions, regarding left-nested API clients
-- as separate data structures. -- as separate data structures.
class GClientLikeP client xs where class GClientLikeP client xs where

541
servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs Normal file
View file

@ -0,0 +1,541 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#include "overlapping-compat.h"
module Servant.Client.Core.Internal.HasClient where
import Prelude ()
import Prelude.Compat
import Data.Foldable (toList)
import Data.List (foldl')
import Data.Proxy (Proxy (Proxy))
import Data.Sequence (fromList)
import Data.String (fromString)
import Data.Text (pack)
import GHC.TypeLits (KnownSymbol, symbolVal)
import qualified Network.HTTP.Types as H
import Servant.API ((:<|>) ((:<|>)), (:>),
AuthProtect, BasicAuth,
BasicAuthData,
BuildHeadersTo (..),
Capture, CaptureAll,
Description, EmptyAPI,
Header, Headers (..),
HttpVersion, IsSecure,
MimeRender (mimeRender),
MimeUnrender (mimeUnrender),
NoContent (NoContent),
QueryFlag, QueryParam,
QueryParams, Raw,
ReflectMethod (..),
RemoteHost, ReqBody,
Summary, ToHttpApiData,
Vault, Verb,
WithNamedContext,
contentType,
getHeadersHList,
getResponse,
toQueryParam,
toUrlPiece)
import Servant.API.ContentTypes (contentTypes)
import Servant.Client.Core.Internal.Auth
import Servant.Client.Core.Internal.BasicAuth
import Servant.Client.Core.Internal.Request
import Servant.Client.Core.Internal.RunClient
-- * Accessing APIs as a Client
-- | 'clientIn' allows you to produce operations to query an API from a client
-- within a 'RunClient' monad.
--
-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > clientM :: Proxy ClientM
-- > clientM = Proxy
-- >
-- > getAllBooks :: ClientM [Book]
-- > postNewBook :: Book -> ClientM Book
-- > (getAllBooks :<|> postNewBook) = myApi `clientIn` clientM
clientIn :: HasClient m api => Proxy api -> Proxy m -> Client m api
clientIn p pm = clientWithRoute pm p defaultRequest
-- | This class lets us define how each API combinator influences the creation
-- of an HTTP request.
--
-- Unless you are writing a new backend for @servant-client-core@ or new
-- combinators that you want to support client-generation, you can ignore this
-- class.
class RunClient m => HasClient m api where
type Client (m :: * -> *) (api :: *) :: *
clientWithRoute :: Proxy m -> Proxy api -> Request -> Client m api
-- | 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 '[JSON] [Book] -- GET /books
-- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > getAllBooks :: ClientM [Book]
-- > postNewBook :: Book -> ClientM Book
-- > (getAllBooks :<|> postNewBook) = client myApi
instance (HasClient m a, HasClient m b) => HasClient m (a :<|> b) where
type Client m (a :<|> b) = Client m a :<|> Client m b
clientWithRoute pm Proxy req =
clientWithRoute pm (Proxy :: Proxy a) req :<|>
clientWithRoute pm (Proxy :: Proxy b) req
-- | Singleton type representing a client for an empty API.
data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum)
-- | The client for 'EmptyAPI' is simply 'EmptyClient'.
--
-- > type MyAPI = "books" :> Get '[JSON] [Book] -- GET /books
-- > :<|> "nothing" :> EmptyAPI
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > getAllBooks :: ClientM [Book]
-- > (getAllBooks :<|> EmptyClient) = client myApi
instance RunClient m => HasClient m EmptyAPI where
type Client m EmptyAPI = EmptyClient
clientWithRoute _pm Proxy _ = EmptyClient
-- | 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 'ToHttpApiData' instance for your type.
--
-- Example:
--
-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > getBook :: Text -> ClientM Book
-- > getBook = client myApi
-- > -- then you can just use "getBook" to query that endpoint
instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)
=> HasClient m (Capture capture a :> api) where
type Client m (Capture capture a :> api) =
a -> Client m api
clientWithRoute pm Proxy req val =
clientWithRoute pm (Proxy :: Proxy api)
(appendToPath p req)
where p = (toUrlPiece val)
-- | If you use a 'CaptureAll' in one of your endpoints in your API,
-- the corresponding querying function will automatically take an
-- additional argument of a list of the type specified by your
-- 'CaptureAll'. That function will take care of inserting a textual
-- representation of this value at the right place in the request
-- path.
--
-- You can control how these values are turned into text by specifying
-- a 'ToHttpApiData' instance of your type.
--
-- Example:
--
-- > type MyAPI = "src" :> CaptureAll Text -> Get '[JSON] SourceFile
-- >
-- > myApi :: Proxy
-- > myApi = Proxy
--
-- > getSourceFile :: [Text] -> ClientM SourceFile
-- > getSourceFile = client myApi
-- > -- then you can use "getSourceFile" to query that endpoint
instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
=> HasClient m (CaptureAll capture a :> sublayout) where
type Client m (CaptureAll capture a :> sublayout) =
[a] -> Client m sublayout
clientWithRoute pm Proxy req vals =
clientWithRoute pm (Proxy :: Proxy sublayout)
(foldl' (flip appendToPath) req ps)
where ps = map (toUrlPiece) vals
instance OVERLAPPABLE_
-- Note [Non-Empty Content Types]
( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient m (Verb method status cts' a) where
type Client m (Verb method status cts' a) = m a
clientWithRoute _pm Proxy req = do
response <- runRequest req
{ requestAccept = fromList $ toList accept
, requestMethod = method
}
response `decodedAs` (Proxy :: Proxy ct)
where
accept = contentTypes (Proxy :: Proxy ct)
method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_
( RunClient m, ReflectMethod method
) => HasClient m (Verb method status cts NoContent) where
type Client m (Verb method status cts NoContent)
= m NoContent
clientWithRoute _pm Proxy req = do
_response <- runRequest req { requestMethod = method }
return NoContent
where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_
-- Note [Non-Empty Content Types]
( RunClient m, MimeUnrender ct a, BuildHeadersTo ls
, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient m (Verb method status cts' (Headers ls a)) where
type Client m (Verb method status cts' (Headers ls a))
= m (Headers ls a)
clientWithRoute _pm Proxy req = do
response <- runRequest req
{ requestMethod = method
, requestAccept = fromList $ toList accept
}
case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of
Left err -> throwServantError $ DecodeFailure (pack err) response
Right val -> return $ Headers
{ getResponse = val
, getHeadersHList = buildHeadersTo . toList $ responseHeaders response
}
where method = reflectMethod (Proxy :: Proxy method)
accept = contentTypes (Proxy :: Proxy ct)
instance OVERLAPPING_
( RunClient m, BuildHeadersTo ls, ReflectMethod method
) => HasClient m (Verb method status cts (Headers ls NoContent)) where
type Client m (Verb method status cts (Headers ls NoContent))
= m (Headers ls NoContent)
clientWithRoute _pm Proxy req = do
let method = reflectMethod (Proxy :: Proxy method)
response <- runRequest req { requestMethod = method }
return $ Headers { getResponse = NoContent
, getHeadersHList = buildHeadersTo . toList $ responseHeaders response
}
-- | 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 'ToHttpApiData' instance.
--
-- Example:
--
-- > newtype Referer = Referer { referrer :: Text }
-- > deriving (Eq, Show, Generic, ToHttpApiData)
-- >
-- > -- GET /view-my-referer
-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > viewReferer :: Maybe Referer -> ClientM Book
-- > viewReferer = client myApi
-- > -- then you can just use "viewRefer" to query that endpoint
-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
=> HasClient m (Header sym a :> api) where
type Client m (Header sym a :> api) =
Maybe a -> Client m api
clientWithRoute pm Proxy req mval =
clientWithRoute pm (Proxy :: Proxy api)
(maybe req
(\value -> addHeader hname value req)
mval
)
where hname = fromString $ symbolVal (Proxy :: Proxy sym)
-- | Using a 'HttpVersion' combinator in your API doesn't affect the client
-- functions.
instance HasClient m api
=> HasClient m (HttpVersion :> api) where
type Client m (HttpVersion :> api) =
Client m api
clientWithRoute pm Proxy =
clientWithRoute pm (Proxy :: Proxy api)
-- | Ignore @'Summary'@ in client functions.
instance HasClient m api => HasClient m (Summary desc :> api) where
type Client m (Summary desc :> api) = Client m api
clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
-- | Ignore @'Description'@ in client functions.
instance HasClient m api => HasClient m (Description desc :> api) where
type Client m (Description desc :> api) = Client m api
clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
-- | 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 'ToHttpApiData' instance for your type.
--
-- Example:
--
-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > getBooksBy :: Maybe Text -> ClientM [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, ToHttpApiData a, HasClient m api)
=> HasClient m (QueryParam sym a :> api) where
type Client m (QueryParam sym a :> api) =
Maybe a -> Client m api
-- if mparam = Nothing, we don't add it to the query string
clientWithRoute pm Proxy req mparam =
clientWithRoute pm (Proxy :: Proxy api)
(maybe req
(flip (appendToQueryString pname) req . Just)
mparamText
)
where pname = pack $ symbolVal (Proxy :: Proxy sym)
mparamText = fmap toQueryParam 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 'ToHttpApiData' instance for your type.
--
-- Example:
--
-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > getBooksBy :: [Text] -> ClientM [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, ToHttpApiData a, HasClient m api)
=> HasClient m (QueryParams sym a :> api) where
type Client m (QueryParams sym a :> api) =
[a] -> Client m api
clientWithRoute pm Proxy req paramlist =
clientWithRoute pm (Proxy :: Proxy api)
(foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))
req
paramlist'
)
where pname = pack $ symbolVal (Proxy :: Proxy sym)
paramlist' = map (Just . toQueryParam) 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 '[JSON] [Book]
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > getBooks :: Bool -> ClientM [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 m api)
=> HasClient m (QueryFlag sym :> api) where
type Client m (QueryFlag sym :> api) =
Bool -> Client m api
clientWithRoute pm Proxy req flag =
clientWithRoute pm (Proxy :: Proxy api)
(if flag
then appendToQueryString paramname Nothing req
else req
)
where paramname = pack $ symbolVal (Proxy :: Proxy sym)
-- | Pick a 'Method' and specify where the server you want to query is. You get
-- back the full `Response`.
instance RunClient m => HasClient m Raw where
type Client m Raw
= H.Method -> m Response
clientWithRoute :: Proxy m -> Proxy Raw -> Request -> Client m Raw
clientWithRoute _pm Proxy req httpMethod = do
runRequest req { requestMethod = httpMethod }
-- | 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 '[JSON] Book :> Post '[JSON] Book
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > addBook :: Book -> ClientM Book
-- > addBook = client myApi
-- > -- then you can just use "addBook" to query that endpoint
instance (MimeRender ct a, HasClient m api)
=> HasClient m (ReqBody (ct ': cts) a :> api) where
type Client m (ReqBody (ct ': cts) a :> api) =
a -> Client m api
clientWithRoute pm Proxy req body =
clientWithRoute pm (Proxy :: Proxy api)
(let ctProxy = Proxy :: Proxy ct
in setRequestBodyLBS (mimeRender ctProxy body)
-- We use first contentType from the Accept list
(contentType ctProxy)
req
)
-- | Make the querying function append @path@ to the request path.
instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
type Client m (path :> api) = Client m api
clientWithRoute pm Proxy req =
clientWithRoute pm (Proxy :: Proxy api)
(appendToPath p req)
where p = pack $ symbolVal (Proxy :: Proxy path)
instance HasClient m api => HasClient m (Vault :> api) where
type Client m (Vault :> api) = Client m api
clientWithRoute pm Proxy req =
clientWithRoute pm (Proxy :: Proxy api) req
instance HasClient m api => HasClient m (RemoteHost :> api) where
type Client m (RemoteHost :> api) = Client m api
clientWithRoute pm Proxy req =
clientWithRoute pm (Proxy :: Proxy api) req
instance HasClient m api => HasClient m (IsSecure :> api) where
type Client m (IsSecure :> api) = Client m api
clientWithRoute pm Proxy req =
clientWithRoute pm (Proxy :: Proxy api) req
instance HasClient m subapi =>
HasClient m (WithNamedContext name context subapi) where
type Client m (WithNamedContext name context subapi) = Client m subapi
clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi)
instance ( HasClient m api
) => HasClient m (AuthProtect tag :> api) where
type Client m (AuthProtect tag :> api)
= AuthenticatedRequest (AuthProtect tag) -> Client m api
clientWithRoute pm Proxy req (AuthenticatedRequest (val,func)) =
clientWithRoute pm (Proxy :: Proxy api) (func val req)
-- * Basic Authentication
instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
type Client m (BasicAuth realm usr :> api) = BasicAuthData -> Client m api
clientWithRoute pm Proxy req val =
clientWithRoute pm (Proxy :: Proxy api) (basicAuthReq val req)
{- Note [Non-Empty Content Types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Rather than have
instance (..., cts' ~ (ct ': cts)) => ... cts' ...
It may seem to make more sense to have:
instance (...) => ... (ct ': cts) ...
But this means that if another instance exists that does *not* require
non-empty lists, but is otherwise more specific, no instance will be overall
more specific. This in turn generally means adding yet another instance (one
for empty and one for non-empty lists).
-}

117
servant-client-core/src/Servant/Client/Core/Internal/Request.hs Normal file
View file

@ -0,0 +1,117 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Servant.Client.Core.Internal.Request where
import Prelude ()
import Prelude.Compat
import Control.Monad.Catch (Exception)
import qualified Data.ByteString.Builder as Builder
import qualified Data.ByteString.Lazy as LBS
import Data.Semigroup ((<>))
import qualified Data.Sequence as Seq
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Network.HTTP.Media (MediaType)
import Network.HTTP.Types (Header, HeaderName, HttpVersion,
Method, QueryItem, Status, http11,
methodGet)
import Web.HttpApiData (ToHttpApiData, toEncodedUrlPiece,
toHeader)
-- | A type representing possible errors in a request
--
-- Note that this type substantially changed in 0.12.
data ServantError =
-- | The server returned an error response
FailureResponse Response
-- | The body could not be decoded at the expected type
| DecodeFailure Text Response
-- | The content-type of the response is not supported
| UnsupportedContentType MediaType Response
-- | The content-type header is invalid
| InvalidContentTypeHeader Response
-- | There was a connection error, and no response was received
| ConnectionError Text
deriving (Eq, Show, Generic, Typeable)
instance Exception ServantError
data RequestF a = Request
{ requestPath :: a
, requestQueryString :: Seq.Seq QueryItem
, requestBody :: Maybe (RequestBody, MediaType)
, requestAccept :: Seq.Seq MediaType
, requestHeaders :: Seq.Seq Header
, requestHttpVersion :: HttpVersion
, requestMethod :: Method
} deriving (Eq, Show, Functor, Generic, Typeable)
type Request = RequestF Builder.Builder
-- | The request body. Currently only lazy ByteStrings are supported.
newtype RequestBody = RequestBodyLBS LBS.ByteString
deriving (Eq, Ord, Read, Show, Typeable)
data Response = Response
{ responseStatusCode :: Status
, responseBody :: LBS.ByteString
, responseHeaders :: Seq.Seq Header
, responseHttpVersion :: HttpVersion
} deriving (Eq, Show, Generic, Typeable)
-- A GET request to the top-level path
defaultRequest :: Request
defaultRequest = Request
{ requestPath = ""
, requestQueryString = Seq.empty
, requestBody = Nothing
, requestAccept = Seq.empty
, requestHeaders = Seq.empty
, requestHttpVersion = http11
, requestMethod = methodGet
}
appendToPath :: Text -> Request -> Request
appendToPath p req
= req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p }
appendToQueryString :: Text -- ^ param name
-> Maybe Text -- ^ param value
-> Request
-> Request
appendToQueryString pname pvalue req
= req { requestQueryString = requestQueryString req
Seq.|> (encodeUtf8 pname, encodeUtf8 <$> pvalue)}
addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request
addHeader name val req
= req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}
-- | Set body and media type of the request being constructed.
--
-- The body is set to the given bytestring using the 'RequestBodyLBS'
-- constructor.
--
-- @since 0.12
--
setRequestBodyLBS :: LBS.ByteString -> MediaType -> Request -> Request
setRequestBodyLBS b t req
= req { requestBody = Just (RequestBodyLBS b, t) }
-- | Set body and media type of the request being constructed.
--
-- @since 0.12
--
setRequestBody :: RequestBody -> MediaType -> Request -> Request
setRequestBody b t req = req { requestBody = Just (b, t) }

48
servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs Normal file
View file

@ -0,0 +1,48 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
-- | Types for possible backends to run client-side `Request` queries
module Servant.Client.Core.Internal.RunClient where
import Prelude ()
import Prelude.Compat
import Control.Monad (unless)
import Data.Foldable (toList)
import Data.Proxy (Proxy)
import qualified Data.Text as T
import Network.HTTP.Media (MediaType, matches,
parseAccept, (//))
import Servant.API (MimeUnrender,
contentTypes,
mimeUnrender)
import Servant.Client.Core.Internal.Request (Request, Response (..),
ServantError (..))
class (Monad m) => RunClient m where
-- | How to make a request.
runRequest :: Request -> m Response
throwServantError :: ServantError -> m a
catchServantError :: m a -> (ServantError -> m a) -> m a
checkContentTypeHeader :: RunClient m => Response -> m MediaType
checkContentTypeHeader response =
case lookup "Content-Type" $ toList $ responseHeaders response of
Nothing -> return $ "application"//"octet-stream"
Just t -> case parseAccept t of
Nothing -> throwServantError $ InvalidContentTypeHeader response
Just t' -> return t'
decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m)
=> Response -> Proxy ct -> m a
decodedAs response contentType = do
responseContentType <- checkContentTypeHeader response
unless (any (matches responseContentType) accept) $
throwServantError $ UnsupportedContentType responseContentType response
case mimeUnrender contentType $ responseBody response of
Left err -> throwServantError $ DecodeFailure (T.pack err) response
Right val -> return val
where
accept = toList $ contentTypes contentType

30
servant-client-core/src/Servant/Client/Core/Reexport.hs Normal file
View file

@ -0,0 +1,30 @@
-- | This module is a utility for @servant-client-core@ backend writers. It
-- contains all the functionality from @servant-client-core@ that should be
-- re-exported.
module Servant.Client.Core.Reexport
(
-- * HasClient
HasClient(..)
-- * Response (for @Raw@)
, Response(..)
-- * Generic Client
, ClientLike(..)
, genericMkClientL
, genericMkClientP
, ServantError(..)
, EmptyClient(..)
-- * BaseUrl
, BaseUrl(..)
, Scheme(..)
, showBaseUrl
, parseBaseUrl
, InvalidBaseUrlException
) where
import Servant.Client.Core.Internal.BaseUrl
import Servant.Client.Core.Internal.HasClient
import Servant.Client.Core.Internal.Generic
import Servant.Client.Core.Internal.Request

8
servant-client/test/Servant/Common/BaseUrlSpec.hs → servant-client-core/test/Servant/Client/Core/Internal/BaseUrlSpec.hs
View file

@ -1,5 +1,6 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Servant.Common.BaseUrlSpec where module Servant.Client.Core.Internal.BaseUrlSpec (spec) where
import Control.DeepSeq import Control.DeepSeq
import Prelude () import Prelude ()
@ -7,7 +8,7 @@ import Prelude.Compat
import Test.Hspec import Test.Hspec
import Test.QuickCheck import Test.QuickCheck
import Servant.Common.BaseUrl import Servant.Client.Core.Internal.BaseUrl
spec :: Spec spec :: Spec
spec = do spec = do
@ -78,6 +79,3 @@ instance Arbitrary BaseUrl where
(1, choose (1, 20000)) : (1, choose (1, 20000)) :
[] []
pathGen = listOf1 . elements $ letters pathGen = listOf1 . elements $ letters
isLeft :: Either a b -> Bool
isLeft = either (const True) (const False)

1
servant-client-core/test/Spec.hs Normal file
View file

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

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

@ -12,7 +12,7 @@ license: BSD3
license-file: LICENSE license-file: LICENSE
author: Servant Contributors author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant Contributors
category: Servant, Web category: Servant, Web
build-type: Simple build-type: Simple
cabal-version: >=1.10 cabal-version: >=1.10
@ -30,39 +30,27 @@ source-repository head
library library
exposed-modules: exposed-modules:
Servant.Client Servant.Client
Servant.Client.Generic Servant.Client.Internal.HttpClient
Servant.Client.Experimental.Auth
Servant.Common.BaseUrl
Servant.Common.BasicAuth
Servant.Common.Req
build-depends: build-depends:
base >= 4.7 && < 4.11 base >= 4.7 && < 4.11
, base-compat >= 0.9.1 && < 0.10 , base-compat >= 0.9.1 && < 0.10
, bytestring >= 0.10 && < 0.11
, aeson >= 0.7 && < 1.3 , aeson >= 0.7 && < 1.3
, attoparsec >= 0.12 && < 0.14 , attoparsec >= 0.12 && < 0.14
, base64-bytestring >= 1.0.0.1 && < 1.1 , containers >= 0.5 && < 0.6
, bytestring >= 0.10 && < 0.11 , http-client >= 0.4.30 && < 0.6
, exceptions >= 0.8 && < 0.9
, generics-sop >= 0.1.0.0 && < 0.4
, http-api-data >= 0.3.6 && < 0.4
, http-client >= 0.4.18.1 && < 0.6
, http-client-tls >= 0.2.2 && < 0.4 , http-client-tls >= 0.2.2 && < 0.4
, http-media >= 0.6.2 && < 0.8 , http-media >= 0.6.2 && < 0.8
, http-types >= 0.8.6 && < 0.10 , http-types >= 0.8.6 && < 0.10
, exceptions >= 0.8 && < 0.9
, monad-control >= 1.0.0.4 && < 1.1 , monad-control >= 1.0.0.4 && < 1.1
, network-uri >= 2.6 && < 2.7 , mtl >= 2.1 && < 2.3
, safe >= 0.3.9 && < 0.4
, semigroupoids >= 4.3 && < 5.3 , semigroupoids >= 4.3 && < 5.3
, servant == 0.11.* , servant-client-core == 0.11.*
, string-conversions >= 0.3 && < 0.5
, text >= 1.2 && < 1.3 , text >= 1.2 && < 1.3
, transformers >= 0.3 && < 0.6 , transformers >= 0.3 && < 0.6
, transformers-base >= 0.4.4 && < 0.5 , transformers-base >= 0.4.4 && < 0.5
, transformers-compat >= 0.4 && < 0.6 , transformers-compat >= 0.4 && < 0.6
, mtl
if !impl(ghc >= 8.0)
build-depends:
semigroups >=0.16.2.2 && <0.19
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall
@ -78,12 +66,12 @@ test-suite spec
main-is: Spec.hs main-is: Spec.hs
other-modules: other-modules:
Servant.ClientSpec Servant.ClientSpec
, Servant.Common.BaseUrlSpec
build-depends: build-depends:
base == 4.* base == 4.*
, aeson , aeson
, base-compat , base-compat
, bytestring , bytestring
, containers
, deepseq , deepseq
, hspec == 2.* , hspec == 2.*
, http-api-data , http-api-data
@ -96,6 +84,7 @@ test-suite spec
, QuickCheck >= 2.7 , QuickCheck >= 2.7
, servant , servant
, servant-client , servant-client
, servant-client-core
, servant-server == 0.11.* , servant-server == 0.11.*
, text , text
, transformers , transformers

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

@ -1,510 +1,13 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#include "overlapping-compat.h"
-- | This module provides 'client' which can automatically generate -- | This module provides 'client' which can automatically generate
-- querying functions for each endpoint just from the type representing your -- querying functions for each endpoint just from the type representing your
-- API. -- API.
module Servant.Client module Servant.Client
( AuthClientData ( client
, AuthenticateReq(..)
, client
, HasClient(..)
, ClientM , ClientM
, runClientM , runClientM
, ClientEnv (ClientEnv) , ClientEnv(..)
, mkAuthenticateReq , module Servant.Client.Core.Reexport
, ServantError(..)
, EmptyClient(..)
, module Servant.Common.BaseUrl
) where ) where
import Data.ByteString.Lazy (ByteString) import Servant.Client.Internal.HttpClient
import Data.List import Servant.Client.Core.Reexport
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 qualified Network.HTTP.Types.Header as HTTP
import Prelude ()
import Prelude.Compat
import Servant.API
import Servant.Client.Experimental.Auth
import Servant.Common.BaseUrl
import Servant.Common.BasicAuth
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 '[JSON] [Book] -- GET /books
-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > getAllBooks :: ClientM [Book]
-- > postNewBook :: Book -> ClientM Book
-- > (getAllBooks :<|> postNewBook) = client myApi
client :: HasClient api => Proxy api -> Client api
client p = clientWithRoute 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 api where
type Client api :: *
clientWithRoute :: Proxy api -> Req -> Client api
-- | 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 '[JSON] [Book] -- GET /books
-- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > getAllBooks :: ClientM [Book]
-- > postNewBook :: Book -> ClientM 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
-- | Singleton type representing a client for an empty API.
data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum)
-- | The client for 'EmptyAPI' is simply 'EmptyClient'.
--
-- > type MyAPI = "books" :> Get '[JSON] [Book] -- GET /books
-- > :<|> "nothing" :> EmptyAPI
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > getAllBooks :: ClientM [Book]
-- > (getAllBooks :<|> EmptyClient) = client myApi
instance HasClient EmptyAPI where
type Client EmptyAPI = EmptyClient
clientWithRoute Proxy _ = EmptyClient
-- | 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 'ToHttpApiData' instance for your type.
--
-- Example:
--
-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > getBook :: Text -> ClientM Book
-- > getBook = client myApi
-- > -- then you can just use "getBook" to query that endpoint
instance (KnownSymbol capture, ToHttpApiData a, HasClient api)
=> HasClient (Capture capture a :> api) where
type Client (Capture capture a :> api) =
a -> Client api
clientWithRoute Proxy req val =
clientWithRoute (Proxy :: Proxy api)
(appendToPath p req)
where p = unpack (toUrlPiece val)
-- | If you use a 'CaptureAll' in one of your endpoints in your API,
-- the corresponding querying function will automatically take an
-- additional argument of a list of the type specified by your
-- 'CaptureAll'. That function will take care of inserting a textual
-- representation of this value at the right place in the request
-- path.
--
-- You can control how these values are turned into text by specifying
-- a 'ToHttpApiData' instance of your type.
--
-- Example:
--
-- > type MyAPI = "src" :> CaptureAll Text -> Get '[JSON] SourceFile
-- >
-- > myApi :: Proxy
-- > myApi = Proxy
--
-- > getSourceFile :: [Text] -> ClientM SourceFile
-- > getSourceFile = client myApi
-- > -- then you can use "getSourceFile" to query that endpoint
instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout)
=> HasClient (CaptureAll capture a :> sublayout) where
type Client (CaptureAll capture a :> sublayout) =
[a] -> Client sublayout
clientWithRoute Proxy req vals =
clientWithRoute (Proxy :: Proxy sublayout)
(foldl' (flip appendToPath) req ps)
where ps = map (unpack . toUrlPiece) vals
instance OVERLAPPABLE_
-- Note [Non-Empty Content Types]
(MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient (Verb method status cts' a) where
type Client (Verb method status cts' a) = ClientM a
clientWithRoute Proxy req = do
snd <$> performRequestCT (Proxy :: Proxy ct) method req
where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_
(ReflectMethod method) => HasClient (Verb method status cts NoContent) where
type Client (Verb method status cts NoContent)
= ClientM NoContent
clientWithRoute Proxy req = do
performRequestNoBody method req >> return NoContent
where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_
-- Note [Non-Empty Content Types]
( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient (Verb method status cts' (Headers ls a)) where
type Client (Verb method status cts' (Headers ls a))
= ClientM (Headers ls a)
clientWithRoute Proxy req = do
let method = reflectMethod (Proxy :: Proxy method)
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req
return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs
}
instance OVERLAPPING_
( BuildHeadersTo ls, ReflectMethod method
) => HasClient (Verb method status cts (Headers ls NoContent)) where
type Client (Verb method status cts (Headers ls NoContent))
= ClientM (Headers ls NoContent)
clientWithRoute Proxy req = do
let method = reflectMethod (Proxy :: Proxy method)
hdrs <- performRequestNoBody method req
return $ Headers { getResponse = NoContent
, getHeadersHList = buildHeadersTo hdrs
}
-- | 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 'ToHttpApiData' instance.
--
-- Example:
--
-- > newtype Referer = Referer { referrer :: Text }
-- > deriving (Eq, Show, Generic, ToHttpApiData)
-- >
-- > -- GET /view-my-referer
-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > viewReferer :: Maybe Referer -> ClientM Book
-- > viewReferer = client myApi
-- > -- then you can just use "viewRefer" to query that endpoint
-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
instance (KnownSymbol sym, ToHttpApiData a, HasClient api)
=> HasClient (Header sym a :> api) where
type Client (Header sym a :> api) =
Maybe a -> Client api
clientWithRoute Proxy req mval =
clientWithRoute (Proxy :: Proxy api)
(maybe req
(\value -> Servant.Common.Req.addHeader hname value req)
mval
)
where hname = symbolVal (Proxy :: Proxy sym)
-- | Using a 'HttpVersion' combinator in your API doesn't affect the client
-- functions.
instance HasClient api
=> HasClient (HttpVersion :> api) where
type Client (HttpVersion :> api) =
Client api
clientWithRoute Proxy =
clientWithRoute (Proxy :: Proxy api)
-- | Ignore @'Summary'@ in client functions.
instance HasClient api => HasClient (Summary desc :> api) where
type Client (Summary desc :> api) = Client api
clientWithRoute _ = clientWithRoute (Proxy :: Proxy api)
-- | Ignore @'Description'@ in client functions.
instance HasClient api => HasClient (Description desc :> api) where
type Client (Description desc :> api) = Client api
clientWithRoute _ = clientWithRoute (Proxy :: Proxy api)
-- | 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 'ToHttpApiData' instance for your type.
--
-- Example:
--
-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > getBooksBy :: Maybe Text -> ClientM [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, ToHttpApiData a, HasClient api)
=> HasClient (QueryParam sym a :> api) where
type Client (QueryParam sym a :> api) =
Maybe a -> Client api
-- if mparam = Nothing, we don't add it to the query string
clientWithRoute Proxy req mparam =
clientWithRoute (Proxy :: Proxy api)
(maybe req
(flip (appendToQueryString pname) req . Just)
mparamText
)
where pname = cs pname'
pname' = symbolVal (Proxy :: Proxy sym)
mparamText = fmap toQueryParam 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 'ToHttpApiData' instance for your type.
--
-- Example:
--
-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > getBooksBy :: [Text] -> ClientM [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, ToHttpApiData a, HasClient api)
=> HasClient (QueryParams sym a :> api) where
type Client (QueryParams sym a :> api) =
[a] -> Client api
clientWithRoute Proxy req paramlist =
clientWithRoute (Proxy :: Proxy api)
(foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))
req
paramlist'
)
where pname = cs pname'
pname' = symbolVal (Proxy :: Proxy sym)
paramlist' = map (Just . toQueryParam) 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 '[JSON] [Book]
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > getBooks :: Bool -> ClientM [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 api)
=> HasClient (QueryFlag sym :> api) where
type Client (QueryFlag sym :> api) =
Bool -> Client api
clientWithRoute Proxy req flag =
clientWithRoute (Proxy :: Proxy api)
(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 full `Response`.
instance HasClient Raw where
type Client Raw
= H.Method -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
clientWithRoute :: Proxy Raw -> Req -> Client Raw
clientWithRoute Proxy req httpMethod = do
performRequest httpMethod req
-- | 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 '[JSON] Book :> Post '[JSON] Book
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > addBook :: Book -> ClientM Book
-- > addBook = client myApi
-- > -- then you can just use "addBook" to query that endpoint
instance (MimeRender ct a, HasClient api)
=> HasClient (ReqBody (ct ': cts) a :> api) where
type Client (ReqBody (ct ': cts) a :> api) =
a -> Client api
clientWithRoute Proxy req body =
clientWithRoute (Proxy :: Proxy api)
(let ctProxy = Proxy :: Proxy ct
in setReqBodyLBS (mimeRender ctProxy body)
-- We use first contentType from the Accept list
(contentType ctProxy)
req
)
-- | Make the querying function append @path@ to the request path.
instance (KnownSymbol path, HasClient api) => HasClient (path :> api) where
type Client (path :> api) = Client api
clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy api)
(appendToPath p req)
where p = symbolVal (Proxy :: Proxy path)
instance HasClient api => HasClient (Vault :> api) where
type Client (Vault :> api) = Client api
clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy api) req
instance HasClient api => HasClient (RemoteHost :> api) where
type Client (RemoteHost :> api) = Client api
clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy api) req
instance HasClient api => HasClient (IsSecure :> api) where
type Client (IsSecure :> api) = Client api
clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy api) req
instance HasClient subapi =>
HasClient (WithNamedContext name context subapi) where
type Client (WithNamedContext name context subapi) = Client subapi
clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi)
instance ( HasClient api
) => HasClient (AuthProtect tag :> api) where
type Client (AuthProtect tag :> api)
= AuthenticateReq (AuthProtect tag) -> Client api
clientWithRoute Proxy req (AuthenticateReq (val,func)) =
clientWithRoute (Proxy :: Proxy api) (func val req)
-- * Basic Authentication
instance HasClient api => HasClient (BasicAuth realm usr :> api) where
type Client (BasicAuth realm usr :> api) = BasicAuthData -> Client api
clientWithRoute Proxy req val =
clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req)
{- Note [Non-Empty Content Types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Rather than have
instance (..., cts' ~ (ct ': cts)) => ... cts' ...
It may seem to make more sense to have:
instance (...) => ... (ct ': cts) ...
But this means that if another instance exists that does *not* require
non-empty lists, but is otherwise more specific, no instance will be overall
more specific. This in turn generally means adding yet another instance (one
for empty and one for non-empty lists).
-}

149
servant-client/src/Servant/Client/Internal/HttpClient.hs Normal file
View file

@ -0,0 +1,149 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
-- | @http-client@-based client requests executor
module Servant.Client.Internal.HttpClient where
import Prelude ()
import Prelude.Compat
import Control.Exception
import Control.Monad
import Control.Monad.Base (MonadBase (..))
import Control.Monad.Catch (MonadCatch, MonadThrow)
import Control.Monad.Error.Class (MonadError (..))
import Control.Monad.Reader
import Control.Monad.Trans.Control (MonadBaseControl (..))
import Control.Monad.Trans.Except
import Data.ByteString.Builder (toLazyByteString)
import qualified Data.ByteString.Lazy as BSL
import Data.Foldable (toList)
import Data.Functor.Alt (Alt (..))
import Data.Monoid ((<>))
import Data.Proxy (Proxy (..))
import Data.Sequence (fromList)
import Data.String (fromString)
import qualified Data.Text as T
import GHC.Generics
import Network.HTTP.Media (renderHeader)
import Network.HTTP.Types (hContentType, renderQuery,
statusCode)
import Servant.Client.Core
import qualified Network.HTTP.Client as Client
-- | The environment in which a request is run.
data ClientEnv
= ClientEnv
{ manager :: Client.Manager
, baseUrl :: BaseUrl
}
-- | Generates a set of client functions for an API.
--
-- Example:
--
-- > type API = Capture "no" Int :> Get '[JSON] Int
-- > :<|> Get '[JSON] [Bool]
-- >
-- > api :: Proxy API
-- > api = Proxy
-- >
-- > getInt :: Int -> ClientM Int
-- > getBools :: ClientM [Bool]
-- > getInt :<|> getBools = client api
client :: HasClient ClientM api => Proxy api -> Client ClientM api
client api = api `clientIn` (Proxy :: Proxy ClientM)
-- | @ClientM@ is the monad in which client functions run. Contains the
-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment.
newtype ClientM a = ClientM
{ runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }
deriving ( Functor, Applicative, Monad, MonadIO, Generic
, MonadReader ClientEnv, MonadError ServantError, MonadThrow
, MonadCatch)
instance MonadBase IO ClientM where
liftBase = ClientM . liftBase
instance MonadBaseControl IO ClientM where
type StM ClientM a = Either ServantError a
liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . runClientM')))
restoreM st = ClientM (restoreM st)
-- | Try clients in order, last error is preserved.
instance Alt ClientM where
a <!> b = a `catchError` \_ -> b
instance RunClient ClientM where
runRequest = performRequest
throwServantError = throwError
catchServantError = catchError
instance ClientLike (ClientM a) (ClientM a) where
mkClient = id
runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm
performRequest :: Request -> ClientM Response
performRequest req = do
m <- asks manager
burl <- asks baseUrl
let request = requestToClientRequest burl req
eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m
case eResponse of
Left err -> throwError $ err
Right response -> do
let status = Client.responseStatus response
status_code = statusCode status
ourResponse = clientResponseToReponse response
unless (status_code >= 200 && status_code < 300) $
throwError $ FailureResponse ourResponse
return ourResponse
clientResponseToReponse :: Client.Response BSL.ByteString -> Response
clientResponseToReponse r = Response
{ responseStatusCode = Client.responseStatus r
, responseBody = Client.responseBody r
, responseHeaders = fromList $ Client.responseHeaders r
, responseHttpVersion = Client.responseVersion r
}
requestToClientRequest :: BaseUrl -> Request -> Client.Request
requestToClientRequest burl r = Client.defaultRequest
{ Client.method = requestMethod r
, Client.host = fromString $ baseUrlHost burl
, Client.port = baseUrlPort burl
, Client.path = BSL.toStrict
$ fromString (baseUrlPath burl)
<> toLazyByteString (requestPath r)
, Client.queryString = renderQuery True . toList $ requestQueryString r
, Client.requestHeaders =
let orig = toList $ requestHeaders r
in maybe orig (: orig) contentTypeHdr
, Client.requestBody = body
}
where
(body, contentTypeHdr) = case requestBody r of
Nothing -> (Client.RequestBodyLBS "", Nothing)
Just (RequestBodyLBS body', typ)
-> (Client.RequestBodyLBS body', Just (hContentType, renderHeader typ))
catchConnectionError :: IO a -> IO (Either ServantError a)
catchConnectionError action =
catch (Right <$> action) $ \e ->
pure . Left . ConnectionError . T.pack $ show (e :: Client.HttpException)

21
servant-client/src/Servant/Common/BasicAuth.hs
View file

@ -1,21 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TypeFamilies #-}
-- | Basic Authentication for clients
module Servant.Common.BasicAuth (
basicAuthReq
) where
import Data.ByteString.Base64 (encode)
import Data.Monoid ((<>))
import Data.Text.Encoding (decodeUtf8)
import Servant.Common.Req (addHeader, Req)
import Servant.API.BasicAuth (BasicAuthData(BasicAuthData))
-- | Authenticate a request using Basic Authentication
basicAuthReq :: BasicAuthData -> Req -> Req
basicAuthReq (BasicAuthData user pass) req =
let authText = decodeUtf8 ("Basic " <> encode (user <> ":" <> pass))
in addHeader "Authorization" authText req

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

@ -1,285 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Servant.Common.Req where
import Prelude ()
import Prelude.Compat
import Control.Exception
import Control.Monad
import Control.Monad.Catch (MonadThrow, MonadCatch)
import Data.Foldable (toList)
import Data.Functor.Alt (Alt (..))
import Data.Semigroup ((<>))
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Trans.Except
import GHC.Generics
import Control.Monad.Base (MonadBase (..))
import Control.Monad.IO.Class ()
import Control.Monad.Reader
import Control.Monad.Trans.Control (MonadBaseControl (..))
import qualified Data.ByteString.Builder as BS
import Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any)
import Data.String
import Data.String.Conversions (cs)
import Data.Proxy
import Data.Text (Text)
import Data.Text.Encoding
import Data.Typeable
import Network.HTTP.Media
import Network.HTTP.Types
import Network.HTTP.Client hiding (Proxy, path)
import qualified Network.HTTP.Types.Header as HTTP
import Network.URI hiding (path)
import Servant.API.ContentTypes
import Servant.Common.BaseUrl
import qualified Network.HTTP.Client as Client
import Web.HttpApiData
data ServantError
= FailureResponse
{ failingRequest :: UrlReq
, responseStatus :: Status
, responseContentType :: MediaType
, responseBody :: ByteString
}
| DecodeFailure
{ decodeError :: String
, responseContentType :: MediaType
, responseBody :: ByteString
}
| UnsupportedContentType
{ responseContentType :: MediaType
, responseBody :: ByteString
}
| InvalidContentTypeHeader
{ responseContentTypeHeader :: ByteString
, responseBody :: ByteString
}
| ConnectionError
{ connectionError :: SomeException
}
deriving (Show, Typeable)
instance Eq ServantError where
FailureResponse _ a b c == FailureResponse _ x y z =
(a, b, c) == (x, y, z)
DecodeFailure a b c == DecodeFailure x y z =
(a, b, c) == (x, y, z)
UnsupportedContentType a b == UnsupportedContentType x y =
(a, b) == (x, y)
InvalidContentTypeHeader a b == InvalidContentTypeHeader x y =
(a, b) == (x, y)
ConnectionError a == ConnectionError x =
show a == show x
_ == _ = False
instance Exception ServantError
data UrlReq = UrlReq BaseUrl Req
instance Show UrlReq where
show (UrlReq url req) = showBaseUrl url ++ path ++ "?" ++ show (qs req)
where
path = cs (BS.toLazyByteString (reqPath req))
data Req = Req
{ reqPath :: BS.Builder
, qs :: QueryText
, reqBody :: Maybe (RequestBody, MediaType)
, reqAccept :: [MediaType]
, headers :: [(String, Text)]
}
defReq :: Req
defReq = Req "" [] Nothing [] []
appendToPath :: String -> Req -> Req
appendToPath p req =
req { reqPath = reqPath req <> "/" <> toEncodedUrlPiece p }
appendToQueryString :: Text -- ^ param name
-> Maybe Text -- ^ param value
-> Req
-> Req
appendToQueryString pname pvalue req =
req { qs = qs req ++ [(pname, pvalue)]
}
addHeader :: ToHttpApiData a => String -> a -> Req -> Req
addHeader name val req = req { headers = headers req
++ [(name, decodeUtf8 (toHeader val))]
}
-- | Set body and media type of the request being constructed.
--
-- The body is set to the given bytestring using the 'RequestBodyLBS'
-- constructor.
--
{-# DEPRECATED setRQBody "Use setReqBodyLBS instead" #-}
setRQBody :: ByteString -> MediaType -> Req -> Req
setRQBody = setReqBodyLBS
-- | Set body and media type of the request being constructed.
--
-- The body is set to the given bytestring using the 'RequestBodyLBS'
-- constructor.
--
-- @since 0.9.2.0
--
setReqBodyLBS :: ByteString -> MediaType -> Req -> Req
setReqBodyLBS b t req = req { reqBody = Just (RequestBodyLBS b, t) }
-- | Set body and media type of the request being constructed.
--
-- @since 0.9.2.0
--
setReqBody :: RequestBody -> MediaType -> Req -> Req
setReqBody b t req = req { reqBody = Just (b, t) }
reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
setheaders . setAccept . setrqb . setQS <$> parseRequest url
where url = show $ nullURI { uriScheme = case reqScheme of
Http -> "http:"
Https -> "https:"
, uriAuthority = Just $
URIAuth { uriUserInfo = ""
, uriRegName = reqHost
, uriPort = ":" ++ show reqPort
}
, uriPath = fullPath
}
fullPath = path ++ cs (BS.toLazyByteString (reqPath req))
setrqb r = case reqBody req of
Nothing -> r
Just (b,t) -> r { requestBody = 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)
#if !MIN_VERSION_http_client(0,4,30)
-- 'parseRequest' is introduced in http-client-0.4.30
-- it differs from 'parseUrl', by not throwing exceptions on non-2xx http statuses
--
-- See for implementations:
-- http://hackage.haskell.org/package/http-client-0.4.30/docs/src/Network-HTTP-Client-Request.html#parseRequest
-- http://hackage.haskell.org/package/http-client-0.5.0/docs/src/Network-HTTP-Client-Request.html#parseRequest
parseRequest :: MonadThrow m => String -> m Request
parseRequest url = liftM disableStatusCheck (parseUrl url)
where
disableStatusCheck req = req { checkStatus = \ _status _headers _cookies -> Nothing }
#endif
-- * performing requests
displayHttpRequest :: Method -> String
displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
data ClientEnv
= ClientEnv
{ manager :: Manager
, baseUrl :: BaseUrl
}
-- | @ClientM@ is the monad in which client functions run. Contains the
-- 'Manager' and 'BaseUrl' used for requests in the reader environment.
newtype ClientM a = ClientM { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }
deriving ( Functor, Applicative, Monad, MonadIO, Generic
, MonadReader ClientEnv
, MonadError ServantError
, MonadThrow, MonadCatch
)
instance MonadBase IO ClientM where
liftBase = ClientM . liftBase
instance MonadBaseControl IO ClientM where
type StM ClientM a = Either ServantError a
-- liftBaseWith :: (RunInBase ClientM IO -> IO a) -> ClientM a
liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . runClientM')))
-- restoreM :: StM ClientM a -> ClientM a
restoreM st = ClientM (restoreM st)
-- | Try clients in order, last error is preserved.
instance Alt ClientM where
a <!> b = a `catchError` \_ -> b
runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm
performRequest :: Method -> Req
-> ClientM ( Int, ByteString, MediaType
, [HTTP.Header], Response ByteString)
performRequest reqMethod req = do
m <- asks manager
reqHost <- asks baseUrl
partialRequest <- liftIO $ reqToRequest req reqHost
let request = partialRequest { Client.method = reqMethod }
eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m
case eResponse of
Left err ->
throwError . ConnectionError $ SomeException err
Right response -> do
let status = Client.responseStatus response
body = Client.responseBody response
hdrs = Client.responseHeaders 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 -> throwError $ InvalidContentTypeHeader (cs t) body
Just t' -> pure t'
unless (status_code >= 200 && status_code < 300) $
throwError $ FailureResponse (UrlReq reqHost req) status ct body
return (status_code, body, ct, hdrs, response)
performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req
-> ClientM ([HTTP.Header], result)
performRequestCT ct reqMethod req = do
let acceptCTS = contentTypes ct
(_status, respBody, respCT, hdrs, _response) <-
performRequest reqMethod (req { reqAccept = toList acceptCTS })
unless (any (matches respCT) acceptCTS) $ throwError $ UnsupportedContentType respCT respBody
case mimeUnrender ct respBody of
Left err -> throwError $ DecodeFailure err respCT respBody
Right val -> return (hdrs, val)
performRequestNoBody :: Method -> Req -> ClientM [HTTP.Header]
performRequestNoBody reqMethod req = do
(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req
return hdrs
catchConnectionError :: IO a -> IO (Either ServantError a)
catchConnectionError action =
catch (Right <$> action) $ \e ->
pure . Left . ConnectionError $ SomeException (e :: HttpException)

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

@ -24,40 +24,57 @@
{-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
#include "overlapping-compat.h" #include "overlapping-compat.h"
module Servant.ClientSpec where module Servant.ClientSpec (spec) where
import Control.Arrow (left) import Prelude ()
import Control.Concurrent (forkIO, killThread, ThreadId)
import Control.Exception (bracket)
import Control.Monad.Error.Class (throwError )
import Data.Aeson
import qualified Data.ByteString.Lazy as BS
import Data.Char (chr, isPrint)
import Data.Foldable (forM_)
import Data.Monoid hiding (getLast)
import Data.Proxy
import qualified Generics.SOP as SOP
import GHC.Generics (Generic)
import qualified Network.HTTP.Client as C
import Network.HTTP.Media
import qualified Network.HTTP.Types as HTTP
import Network.Socket
import Network.Wai (Request, requestHeaders, responseLBS)
import Network.Wai.Handler.Warp
import Prelude ()
import Prelude.Compat import Prelude.Compat
import System.IO.Unsafe (unsafePerformIO)
import Test.HUnit import Control.Arrow (left)
import Control.Concurrent (ThreadId, forkIO,
killThread)
import Control.Exception (bracket)
import Control.Monad.Error.Class (throwError)
import Data.Aeson
import Data.Char (chr, isPrint)
import Data.Foldable (forM_)
import Data.Monoid hiding (getLast)
import Data.Proxy
import qualified Generics.SOP as SOP
import GHC.Generics (Generic)
import qualified Network.HTTP.Client as C
import qualified Network.HTTP.Types as HTTP
import Network.Socket
import qualified Network.Wai as Wai
import Network.Wai.Handler.Warp
import System.IO.Unsafe (unsafePerformIO)
import Test.Hspec import Test.Hspec
import Test.Hspec.QuickCheck import Test.Hspec.QuickCheck
import Test.HUnit
import Test.QuickCheck import Test.QuickCheck
import Web.FormUrlEncoded (FromForm, ToForm) import Web.FormUrlEncoded (FromForm, ToForm)
import Servant.API import Servant.API ((:<|>) ((:<|>)),
(:>), AuthProtect,
BasicAuth,
BasicAuthData (..),
Capture,
CaptureAll, Delete,
DeleteNoContent,
EmptyAPI, addHeader,
FormUrlEncoded,
Get, Header,
Headers, JSON,
NoContent (NoContent),
Post, Put, Raw,
QueryFlag,
QueryParam,
QueryParams,
ReqBody,
getHeaders)
import Servant.API.Internal.Test.ComprehensiveAPI import Servant.API.Internal.Test.ComprehensiveAPI
import Servant.Client import Servant.Client
import Servant.Client.Generic import qualified Servant.Client.Core.Internal.Request as Req
import qualified Servant.Common.Req as SCR import qualified Servant.Client.Core.Internal.Auth as Auth
import Servant.Server import Servant.Server
import Servant.Server.Experimental.Auth import Servant.Server.Experimental.Auth
@ -75,17 +92,16 @@ spec = describe "Servant.Client" $ do
-- * test data types -- * test data types
data Person = Person { data Person = Person
name :: String, { _name :: String
age :: Integer , _age :: Integer
} } deriving (Eq, Show, Generic)
deriving (Eq, Show, Generic)
instance ToJSON Person instance ToJSON Person
instance FromJSON Person instance FromJSON Person
instance ToForm Person where instance ToForm Person
instance FromForm Person where instance FromForm Person
alice :: Person alice :: Person
alice = Person "Alice" 42 alice = Person "Alice" 42
@ -116,22 +132,20 @@ type Api =
api :: Proxy Api api :: Proxy Api
api = Proxy api = Proxy
getGet :: SCR.ClientM Person getGet :: ClientM Person
getDeleteEmpty :: SCR.ClientM NoContent getDeleteEmpty :: ClientM NoContent
getCapture :: String -> SCR.ClientM Person getCapture :: String -> ClientM Person
getCaptureAll :: [String] -> SCR.ClientM [Person] getCaptureAll :: [String] -> ClientM [Person]
getBody :: Person -> SCR.ClientM Person getBody :: Person -> ClientM Person
getQueryParam :: Maybe String -> SCR.ClientM Person getQueryParam :: Maybe String -> ClientM Person
getQueryParams :: [String] -> SCR.ClientM [Person] getQueryParams :: [String] -> ClientM [Person]
getQueryFlag :: Bool -> SCR.ClientM Bool getQueryFlag :: Bool -> ClientM Bool
getRawSuccess :: HTTP.Method getRawSuccess :: HTTP.Method -> ClientM Response
-> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString) getRawFailure :: HTTP.Method -> ClientM Response
getRawFailure :: HTTP.Method
-> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)
getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
-> SCR.ClientM (String, Maybe Int, Bool, [(String, [Rational])]) -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])
getRespHeaders :: SCR.ClientM (Headers TestHeaders Bool) getRespHeaders :: ClientM (Headers TestHeaders Bool)
getDeleteContentType :: SCR.ClientM NoContent getDeleteContentType :: ClientM NoContent
getGet getGet
:<|> getDeleteEmpty :<|> getDeleteEmpty
@ -161,8 +175,8 @@ server = serve api (
Nothing -> throwError $ ServantErr 400 "missing parameter" "" []) Nothing -> throwError $ ServantErr 400 "missing parameter" "" [])
:<|> (\ names -> return (zipWith Person names [0..])) :<|> (\ names -> return (zipWith Person names [0..]))
:<|> return :<|> return
:<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess") :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
:<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure") :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")
:<|> (\ a b c d -> return (a, b, c, d)) :<|> (\ a b c d -> return (a, b, c, d))
:<|> (return $ addHeader 1729 $ addHeader "eg2" True) :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
:<|> return NoContent :<|> return NoContent
@ -178,9 +192,9 @@ failApi = Proxy
failServer :: Application failServer :: Application
failServer = serve failApi ( failServer = serve failApi (
(Tagged $ \ _request respond -> respond $ responseLBS HTTP.ok200 [] "") (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "")
:<|> (\ _capture -> Tagged $ \_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "") :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")
:<|> (Tagged $ \_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "") :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
) )
-- * basic auth stuff -- * basic auth stuff
@ -214,16 +228,16 @@ genAuthAPI :: Proxy GenAuthAPI
genAuthAPI = Proxy genAuthAPI = Proxy
type instance AuthServerData (AuthProtect "auth-tag") = () type instance AuthServerData (AuthProtect "auth-tag") = ()
type instance AuthClientData (AuthProtect "auth-tag") = () type instance Auth.AuthClientData (AuthProtect "auth-tag") = ()
genAuthHandler :: AuthHandler Request () genAuthHandler :: AuthHandler Wai.Request ()
genAuthHandler = genAuthHandler =
let handler req = case lookup "AuthHeader" (requestHeaders req) of let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of
Nothing -> throwError (err401 { errBody = "Missing auth header" }) Nothing -> throwError (err401 { errBody = "Missing auth header" })
Just _ -> return () Just _ -> return ()
in mkAuthHandler handler in mkAuthHandler handler
genAuthServerContext :: Context '[ AuthHandler Request () ] genAuthServerContext :: Context '[ AuthHandler Wai.Request () ]
genAuthServerContext = genAuthHandler :. EmptyContext genAuthServerContext = genAuthHandler :. EmptyContext
genAuthServer :: Application genAuthServer :: Application
@ -236,11 +250,11 @@ type GenericClientAPI
:<|> Capture "foo" String :> NestedAPI1 :<|> Capture "foo" String :> NestedAPI1
data GenericClient = GenericClient data GenericClient = GenericClient
{ getSqr :: Maybe Int -> SCR.ClientM Int { getSqr :: Maybe Int -> ClientM Int
, mkNestedClient1 :: String -> NestedClient1 , mkNestedClient1 :: String -> NestedClient1
} deriving Generic } deriving Generic
instance SOP.Generic GenericClient instance SOP.Generic GenericClient
instance (Client GenericClientAPI ~ client) => ClientLike client GenericClient instance (Client ClientM GenericClientAPI ~ client) => ClientLike client GenericClient
type NestedAPI1 type NestedAPI1
= QueryParam "int" Int :> NestedAPI2 = QueryParam "int" Int :> NestedAPI2
@ -248,21 +262,21 @@ type NestedAPI1
data NestedClient1 = NestedClient1 data NestedClient1 = NestedClient1
{ mkNestedClient2 :: Maybe Int -> NestedClient2 { mkNestedClient2 :: Maybe Int -> NestedClient2
, idChar :: Maybe Char -> SCR.ClientM Char , idChar :: Maybe Char -> ClientM Char
} deriving Generic } deriving Generic
instance SOP.Generic NestedClient1 instance SOP.Generic NestedClient1
instance (Client NestedAPI1 ~ client) => ClientLike client NestedClient1 instance (Client ClientM NestedAPI1 ~ client) => ClientLike client NestedClient1
type NestedAPI2 type NestedAPI2
= "sum" :> Capture "first" Int :> Capture "second" Int :> Get '[JSON] Int = "sum" :> Capture "first" Int :> Capture "second" Int :> Get '[JSON] Int
:<|> "void" :> Post '[JSON] () :<|> "void" :> Post '[JSON] ()
data NestedClient2 = NestedClient2 data NestedClient2 = NestedClient2
{ getSum :: Int -> Int -> SCR.ClientM Int { getSum :: Int -> Int -> ClientM Int
, doNothing :: SCR.ClientM () , doNothing :: ClientM ()
} deriving Generic } deriving Generic
instance SOP.Generic NestedClient2 instance SOP.Generic NestedClient2
instance (Client NestedAPI2 ~ client) => ClientLike client NestedClient2 instance (Client ClientM NestedAPI2 ~ client) => ClientLike client NestedClient2
genericClientServer :: Application genericClientServer :: Application
genericClientServer = serve (Proxy :: Proxy GenericClientAPI) ( genericClientServer = serve (Proxy :: Proxy GenericClientAPI) (
@ -276,67 +290,70 @@ genericClientServer = serve (Proxy :: Proxy GenericClientAPI) (
nestedServer1 _str = nestedServer2 :<|> (maybe (throwError $ ServantErr 400 "missing parameter" "" []) return) nestedServer1 _str = nestedServer2 :<|> (maybe (throwError $ ServantErr 400 "missing parameter" "" []) return)
nestedServer2 _int = (\ x y -> return (x + y)) :<|> return () nestedServer2 _int = (\ x y -> return (x + y)) :<|> return ()
{-# NOINLINE manager #-} {-# NOINLINE manager' #-}
manager :: C.Manager manager' :: C.Manager
manager = unsafePerformIO $ C.newManager C.defaultManagerSettings manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a)
runClient x baseUrl' = runClientM x (ClientEnv manager' baseUrl')
sucessSpec :: Spec sucessSpec :: Spec
sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
it "Servant.API.Get" $ \(_, baseUrl) -> do it "Servant.API.Get" $ \(_, baseUrl) -> do
(left show <$> (runClientM getGet (ClientEnv manager baseUrl))) `shouldReturn` Right alice left show <$> runClient getGet baseUrl `shouldReturn` Right alice
describe "Servant.API.Delete" $ do describe "Servant.API.Delete" $ do
it "allows empty content type" $ \(_, baseUrl) -> do it "allows empty content type" $ \(_, baseUrl) -> do
(left show <$> (runClientM getDeleteEmpty (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent left show <$> runClient getDeleteEmpty baseUrl `shouldReturn` Right NoContent
it "allows content type" $ \(_, baseUrl) -> do it "allows content type" $ \(_, baseUrl) -> do
(left show <$> (runClientM getDeleteContentType (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent left show <$> runClient getDeleteContentType baseUrl `shouldReturn` Right NoContent
it "Servant.API.Capture" $ \(_, baseUrl) -> do it "Servant.API.Capture" $ \(_, baseUrl) -> do
(left show <$> (runClientM (getCapture "Paula") (ClientEnv manager baseUrl))) `shouldReturn` Right (Person "Paula" 0) left show <$> runClient (getCapture "Paula") baseUrl `shouldReturn` Right (Person "Paula" 0)
it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do
let expected = [(Person "Paula" 0), (Person "Peta" 1)] let expected = [(Person "Paula" 0), (Person "Peta" 1)]
(left show <$> (runClientM (getCaptureAll ["Paula", "Peta"]) (ClientEnv manager baseUrl))) `shouldReturn` Right expected left show <$> runClient (getCaptureAll ["Paula", "Peta"]) baseUrl `shouldReturn` Right expected
it "Servant.API.ReqBody" $ \(_, baseUrl) -> do it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
let p = Person "Clara" 42 let p = Person "Clara" 42
(left show <$> runClientM (getBody p) (ClientEnv manager baseUrl)) `shouldReturn` Right p left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p
it "Servant.API.QueryParam" $ \(_, baseUrl) -> do it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
left show <$> runClientM (getQueryParam (Just "alice")) (ClientEnv manager baseUrl) `shouldReturn` Right alice left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice
Left FailureResponse{..} <- runClientM (getQueryParam (Just "bob")) (ClientEnv manager baseUrl) Left (FailureResponse r) <- runClient (getQueryParam (Just "bob")) baseUrl
responseStatus `shouldBe` HTTP.Status 400 "bob not found" responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"
it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
(left show <$> runClientM (getQueryParams []) (ClientEnv manager baseUrl)) `shouldReturn` Right [] left show <$> runClient (getQueryParams []) baseUrl `shouldReturn` Right []
(left show <$> runClientM (getQueryParams ["alice", "bob"]) (ClientEnv manager baseUrl)) left show <$> runClient (getQueryParams ["alice", "bob"]) baseUrl
`shouldReturn` Right [Person "alice" 0, Person "bob" 1] `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
context "Servant.API.QueryParam.QueryFlag" $ context "Servant.API.QueryParam.QueryFlag" $
forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
(left show <$> runClientM (getQueryFlag flag) (ClientEnv manager baseUrl)) `shouldReturn` Right flag left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag
it "Servant.API.Raw on success" $ \(_, baseUrl) -> do it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
res <- runClientM (getRawSuccess HTTP.methodGet) (ClientEnv manager baseUrl) res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
case res of case res of
Left e -> assertFailure $ show e Left e -> assertFailure $ show e
Right (code, body, ct, _, response) -> do Right r -> do
(code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream") responseStatusCode r `shouldBe` HTTP.status200
C.responseBody response `shouldBe` body responseBody r `shouldBe` "rawSuccess"
C.responseStatus response `shouldBe` HTTP.ok200
it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
res <- runClientM (getRawFailure HTTP.methodGet) (ClientEnv manager baseUrl) res <- runClient (getRawFailure HTTP.methodGet) baseUrl
case res of case res of
Right _ -> assertFailure "expected Left, but got Right" Right _ -> assertFailure "expected Left, but got Right"
Left e -> do Left (FailureResponse r) -> do
Servant.Client.responseStatus e `shouldBe` HTTP.status400 responseStatusCode r `shouldBe` HTTP.status400
Servant.Client.responseBody e `shouldBe` "rawFailure" responseBody r `shouldBe` "rawFailure"
Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e
it "Returns headers appropriately" $ \(_, baseUrl) -> do it "Returns headers appropriately" $ \(_, baseUrl) -> do
res <- runClientM getRespHeaders (ClientEnv manager baseUrl) res <- runClient getRespHeaders baseUrl
case res of case res of
Left e -> assertFailure $ show e Left e -> assertFailure $ show e
Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
@ -345,7 +362,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) -> it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
ioProperty $ do ioProperty $ do
result <- left show <$> runClientM (getMultiple cap num flag body) (ClientEnv manager baseUrl) result <- left show <$> runClient (getMultiple cap num flag body) baseUrl
return $ return $
result === Right (cap, num, flag, body) result === Right (cap, num, flag, body)
@ -357,10 +374,10 @@ wrappedApiSpec = describe "error status codes" $ do
let test :: (WrappedApi, String) -> Spec let test :: (WrappedApi, String) -> Spec
test (WrappedApi api, desc) = test (WrappedApi api, desc) =
it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
let getResponse :: SCR.ClientM () let getResponse :: ClientM ()
getResponse = client api getResponse = client api
Left FailureResponse{..} <- runClientM getResponse (ClientEnv manager baseUrl) Left (FailureResponse r) <- runClient getResponse baseUrl
responseStatus `shouldBe` (HTTP.Status 500 "error message") responseStatusCode r `shouldBe` (HTTP.Status 500 "error message")
in mapM_ test $ in mapM_ test $
(WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") : (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
(WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") : (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
@ -374,42 +391,42 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
context "client returns errors appropriately" $ do context "client returns errors appropriately" $ do
it "reports FailureResponse" $ \(_, baseUrl) -> do it "reports FailureResponse" $ \(_, baseUrl) -> do
let (_ :<|> getDeleteEmpty :<|> _) = client api let (_ :<|> getDeleteEmpty :<|> _) = client api
Left res <- runClientM getDeleteEmpty (ClientEnv manager baseUrl) Left res <- runClient getDeleteEmpty baseUrl
case res of case res of
FailureResponse _ (HTTP.Status 404 "Not Found") _ _ -> return () FailureResponse r | responseStatusCode r == HTTP.status404 -> return ()
_ -> fail $ "expected 404 response, but got " <> show res _ -> fail $ "expected 404 response, but got " <> show res
it "reports DecodeFailure" $ \(_, baseUrl) -> do it "reports DecodeFailure" $ \(_, baseUrl) -> do
let (_ :<|> _ :<|> getCapture :<|> _) = client api let (_ :<|> _ :<|> getCapture :<|> _) = client api
Left res <- runClientM (getCapture "foo") (ClientEnv manager baseUrl) Left res <- runClient (getCapture "foo") baseUrl
case res of case res of
DecodeFailure _ ("application/json") _ -> return () DecodeFailure _ _ -> return ()
_ -> fail $ "expected DecodeFailure, but got " <> show res _ -> fail $ "expected DecodeFailure, but got " <> show res
it "reports ConnectionError" $ \_ -> do it "reports ConnectionError" $ \_ -> do
let (getGetWrongHost :<|> _) = client api let (getGetWrongHost :<|> _) = client api
Left res <- runClientM getGetWrongHost (ClientEnv manager (BaseUrl Http "127.0.0.1" 19872 "")) Left res <- runClient getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "")
case res of case res of
ConnectionError _ -> return () ConnectionError _ -> return ()
_ -> fail $ "expected ConnectionError, but got " <> show res _ -> fail $ "expected ConnectionError, but got " <> show res
it "reports UnsupportedContentType" $ \(_, baseUrl) -> do it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
let (getGet :<|> _ ) = client api let (getGet :<|> _ ) = client api
Left res <- runClientM getGet (ClientEnv manager baseUrl) Left res <- runClient getGet baseUrl
case res of case res of
UnsupportedContentType ("application/octet-stream") _ -> return () UnsupportedContentType ("application/octet-stream") _ -> return ()
_ -> fail $ "expected UnsupportedContentType, but got " <> show res _ -> fail $ "expected UnsupportedContentType, but got " <> show res
it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
Left res <- runClientM (getBody alice) (ClientEnv manager baseUrl) Left res <- runClient (getBody alice) baseUrl
case res of case res of
InvalidContentTypeHeader "fooooo" _ -> return () InvalidContentTypeHeader _ -> return ()
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
data WrappedApi where data WrappedApi where
WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a, WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a,
HasClient api, Client api ~ SCR.ClientM ()) => HasClient ClientM api, Client ClientM api ~ ClientM ()) =>
Proxy api -> WrappedApi Proxy api -> WrappedApi
basicAuthSpec :: Spec basicAuthSpec :: Spec
@ -419,15 +436,15 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d
it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
let getBasic = client basicAuthAPI let getBasic = client basicAuthAPI
let basicAuthData = BasicAuthData "servant" "server" let basicAuthData = BasicAuthData "servant" "server"
(left show <$> runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)) `shouldReturn` Right alice left show <$> runClient (getBasic basicAuthData) baseUrl `shouldReturn` Right alice
context "Authentication is rejected when requests are not authenticated properly" $ do context "Authentication is rejected when requests are not authenticated properly" $ do
it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
let getBasic = client basicAuthAPI let getBasic = client basicAuthAPI
let basicAuthData = BasicAuthData "not" "password" let basicAuthData = BasicAuthData "not" "password"
Left FailureResponse{..} <- runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl) Left (FailureResponse r) <- runClient (getBasic basicAuthData) baseUrl
responseStatus `shouldBe` HTTP.Status 403 "Forbidden" responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden"
genAuthSpec :: Spec genAuthSpec :: Spec
genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
@ -435,16 +452,16 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
let getProtected = client genAuthAPI let getProtected = client genAuthAPI
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req) let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "AuthHeader" ("cool" :: String) req)
(left show <$> runClientM (getProtected authRequest) (ClientEnv manager baseUrl)) `shouldReturn` Right alice left show <$> runClient (getProtected authRequest) baseUrl `shouldReturn` Right alice
context "Authentication is rejected when requests are not authenticated properly" $ do context "Authentication is rejected when requests are not authenticated properly" $ do
it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
let getProtected = client genAuthAPI let getProtected = client genAuthAPI
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req) let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req)
Left FailureResponse{..} <- runClientM (getProtected authRequest) (ClientEnv manager baseUrl) Left (FailureResponse r) <- runClient (getProtected authRequest) baseUrl
responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized") responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")
genericClientSpec :: Spec genericClientSpec :: Spec
genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWaiApp $ do genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWaiApp $ do
@ -454,13 +471,13 @@ genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWa
NestedClient1{..} = mkNestedClient1 "example" NestedClient1{..} = mkNestedClient1 "example"
NestedClient2{..} = mkNestedClient2 (Just 42) NestedClient2{..} = mkNestedClient2 (Just 42)
it "works for top-level client function" $ \(_, baseUrl) -> do it "works for top-level client inClientM function" $ \(_, baseUrl) -> do
(left show <$> (runClientM (getSqr (Just 5)) (ClientEnv manager baseUrl))) `shouldReturn` Right 25 left show <$> runClient (getSqr (Just 5)) baseUrl `shouldReturn` Right 25
it "works for nested clients" $ \(_, baseUrl) -> do it "works for nested clients" $ \(_, baseUrl) -> do
(left show <$> (runClientM (idChar (Just 'c')) (ClientEnv manager baseUrl))) `shouldReturn` Right 'c' left show <$> runClient (idChar (Just 'c')) baseUrl `shouldReturn` Right 'c'
(left show <$> (runClientM (getSum 3 4) (ClientEnv manager baseUrl))) `shouldReturn` Right 7 left show <$> runClient (getSum 3 4) baseUrl `shouldReturn` Right 7
(left show <$> (runClientM doNothing (ClientEnv manager baseUrl))) `shouldReturn` Right () left show <$> runClient doNothing baseUrl `shouldReturn` Right ()
-- * utils -- * utils

1
stack-ghc-7.10.3.yaml
View file

@ -2,6 +2,7 @@ flags: {}
packages: packages:
- servant/ - servant/
- servant-client/ - servant-client/
- servant-client-core/
- servant-docs/ - servant-docs/
- servant-foreign/ - servant-foreign/
- servant-server/ - servant-server/

2
stack-ghc-7.8.4.yaml
View file

@ -2,6 +2,7 @@ flags: {}
packages: packages:
- servant/ - servant/
- servant-client/ - servant-client/
- servant-client-core/
- servant-docs/ - servant-docs/
- servant-foreign/ - servant-foreign/
- servant-server/ - servant-server/
@ -19,6 +20,7 @@ extra-deps:
- hspec-expectations-0.8.2 - hspec-expectations-0.8.2
- hspec-wai-0.8.0 - hspec-wai-0.8.0
- http-api-data-0.3.6 - http-api-data-0.3.6
- http-client-0.4.30
- natural-transformation-0.4 - natural-transformation-0.4
- primitive-0.6.1.0 - primitive-0.6.1.0
- servant-js-0.9.3 - servant-js-0.9.3

1
stack-ghc-8.2.1.yaml
View file

@ -1,6 +1,7 @@
resolver: nightly-2017-09-01 resolver: nightly-2017-09-01
packages: packages:
- servant-client/ - servant-client/
- servant-client-core/
- servant-docs/ - servant-docs/
- servant-foreign/ - servant-foreign/
- servant-server/ - servant-server/

1
stack.yaml
View file

@ -2,6 +2,7 @@ resolver: nightly-2017-04-01
packages: packages:
- servant/ - servant/
- servant-client/ - servant-client/
- servant-client-core/
- servant-docs/ - servant-docs/
- servant-foreign/ - servant-foreign/
- servant-server/ - servant-server/