servant-client-0.11/0000755000000000000000000000000013111232275012554 5ustar0000000000000000servant-client-0.11/CHANGELOG.md0000644000000000000000000000531713111232275014373 0ustar00000000000000000.11 ---- ### Other changes - Path components are escaped ([#696](https://github.com/haskell-servant/servant/pull/696)) - `Req` `reqPath` field changed from `String` to `BS.Builder` ([#696](https://github.com/haskell-servant/servant/pull/696)) - Include `Req` in failure errors ([#740](https://github.com/haskell-servant/servant/pull/740)) 0.10 ----- ### Breaking changes There shouldn't be breaking changes. Released as a part of `servant` suite. ### Other changes * Add MonadBase and MonadBaseControl instances for ClientM ([#663](https://github.com/haskell-servant/servant/issues/663)) * client asks for any content-type in Accept contentTypes non-empty list ([#615](https://github.com/haskell-servant/servant/pull/615)) * Add `ClientLike` class that matches client functions generated using `client` with client data structure. ([#640](https://github.com/haskell-servant/servant/pull/640)) * Allow direct use of 'RequestBody' ([#661](https://github.com/haskell-servant/servant/pull/661)) 0.9.1.1 ------- * Add MonadThrow and MonadCatch instances for ClientM 0.9 --- * BACKWARDS INCOMPATIBLE: `client` now returns a ClientM which is a Reader for BasicEnv. BasicEnv comprises the HttpManager and BaseUrl that have had to be passed to each method returned by `client`. 0.7.1 ----- * Support GHC 8.0 * `ServantError` has an `Eq` instance now. 0.6 --- * `client` no longer takes `BaseUrl` and `Manager` arguments. Instead, each function returned by `client` requires these two arguments. 0.5 --- * Use the `text` package instead of `String`. * Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators * Added support for `path` on `BaseUrl`. * `client` now takes an explicit `Manager` argument. * Use `http-api-data` instead of `Servant.Common.Text` * Client functions now consider any 2xx successful. * Remove matrix params. * Added support for Basic authentication * Add generalized authentication support via the `AuthClientData` type family and `AuthenticateReq` data type 0.4.1 ----- * The `HasClient` instance for `Delete cts ()` now does not care at all about content types provided. 0.4 --- * `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body * Support content-type aware combinators and `Accept`/`Content-type` headers * Added a lot of tests * Support multiple concurrent threads * Use `ServantError` to report Errors instead of `String` * Make the clients for `Raw` endpoints return the whole `Response` value (to be able to access response headers for example) * Support for PATCH * Make () instances expect No Content status code, and not try to decode body. * Add support for response headers 0.2.2 ----- * Add TLS support * Add matrix parameter support servant-client-0.11/LICENSE0000644000000000000000000000306113111232275013561 0ustar0000000000000000Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 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 Zalora South East Asia Pte Ltd nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. servant-client-0.11/Setup.hs0000644000000000000000000000007013111232275014205 0ustar0000000000000000import Distribution.Simple main = defaultMain servant-client-0.11/README.md0000644000000000000000000000124513111232275014035 0ustar0000000000000000# servant-client ![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) This library lets you automatically derive Haskell functions that let you query each endpoint of a *servant* webservice. ## Example ``` haskell type MyApi = "books" :> Get '[JSON] [Book] -- GET /books :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books myApi :: Proxy MyApi myApi = Proxy getAllBooks :: Manager -> BaseUrl -> ExceptT String IO [Book] postNewBook :: Book -> Manager -> BaseUrl -> ExceptT String IO Book -- 'client' allows you to produce operations to query an API from a client. (getAllBooks :<|> postNewBook) = client myApi ``` servant-client-0.11/servant-client.cabal0000644000000000000000000000653113111232275016503 0ustar0000000000000000name: servant-client version: 0.11 synopsis: automatical derivation of querying functions for servant webservices description: This library lets you derive automatically Haskell functions that let you query each endpoint of a webservice. . See . . license: BSD3 license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors category: Servant Web build-type: Simple cabal-version: >=1.10 tested-with: GHC >= 7.8 homepage: http://haskell-servant.readthedocs.org/ Bug-reports: http://github.com/haskell-servant/servant/issues 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 Servant.Client.Generic Servant.Client.Experimental.Auth Servant.Common.BaseUrl Servant.Common.BasicAuth Servant.Common.Req build-depends: base >= 4.7 && < 4.10 , base-compat >= 0.9.1 && < 0.10 , aeson >= 0.7 && < 1.3 , attoparsec >= 0.12 && < 0.14 , base64-bytestring >= 1.0.0.1 && < 1.1 , bytestring >= 0.10 && < 0.11 , 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-media >= 0.6.2 && < 0.7 , http-types >= 0.8.6 && < 0.10 , monad-control >= 1.0.0.4 && < 1.1 , network-uri >= 2.6 && < 2.7 , safe >= 0.3.9 && < 0.4 , semigroupoids >= 4.3 && < 5.3 , servant == 0.11.* , string-conversions >= 0.3 && < 0.5 , text >= 1.2 && < 1.3 , transformers >= 0.3 && < 0.6 , transformers-base >= 0.4.4 && < 0.5 , 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 default-language: Haskell2010 ghc-options: -Wall if impl(ghc >= 8.0) ghc-options: -Wno-redundant-constraints 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 other-modules: Servant.ClientSpec , Servant.Common.BaseUrlSpec build-depends: base == 4.* , aeson , base-compat , bytestring , deepseq , hspec == 2.* , http-api-data , http-client , http-media , http-types , HUnit , mtl , network >= 2.6 , QuickCheck >= 2.7 , servant , servant-client , servant-server == 0.11.* , text , transformers , transformers-compat , wai , warp , generics-sop servant-client-0.11/src/0000755000000000000000000000000013111232275013343 5ustar0000000000000000servant-client-0.11/src/Servant/0000755000000000000000000000000013111232275014765 5ustar0000000000000000servant-client-0.11/src/Servant/Client.hs0000644000000000000000000004206113111232275016542 0ustar0000000000000000{-# 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 -- querying functions for each endpoint just from the type representing your -- API. module Servant.Client ( AuthClientData , AuthenticateReq(..) , client , HasClient(..) , ClientM , runClientM , ClientEnv (ClientEnv) , mkAuthenticateReq , ServantError(..) , EmptyClient(..) , module Servant.Common.BaseUrl ) where import Data.ByteString.Lazy (ByteString) import Data.List import Data.Proxy import Data.String.Conversions import Data.Text (unpack) import GHC.TypeLits import Network.HTTP.Client (Response) import Network.HTTP.Media import qualified Network.HTTP.Types as H import 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) -- | 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). -} servant-client-0.11/src/Servant/Client/0000755000000000000000000000000013111232275016203 5ustar0000000000000000servant-client-0.11/src/Servant/Client/Generic.hs0000644000000000000000000001317213111232275020117 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} #include "overlapping-compat.h" module Servant.Client.Generic ( ClientLike(..) , genericMkClientL , genericMkClientP ) where import Generics.SOP (Code, Generic, I(..), NP(..), NS(Z), SOP(..), to) import Servant.API ((:<|>)(..)) import Servant.Client (ClientM) -- | This class allows us to match client structure with client functions -- produced with 'client' without explicit pattern-matching. -- -- The client structure needs a 'Generics.SOP.Generic' instance. -- -- Example: -- -- > type API -- > = "foo" :> Capture "x" Int :> Get '[JSON] Int -- > :<|> "bar" :> QueryParam "a" Char :> QueryParam "b" String :> Post '[JSON] [Int] -- > :<|> Capture "nested" Int :> NestedAPI -- > -- > type NestedAPI -- > = Get '[JSON] String -- > :<|> "baz" :> QueryParam "c" Char :> Post '[JSON] () -- > -- > data APIClient = APIClient -- > { getFoo :: Int -> ClientM Int -- > , postBar :: Maybe Char -> Maybe String -> ClientM [Int] -- > , mkNestedClient :: Int -> NestedClient -- > } deriving GHC.Generic -- > -- > instance Generics.SOP.Generic APIClient -- > instance (Client API ~ client) => ClientLike client APIClient -- > -- > data NestedClient = NestedClient -- > { getString :: ClientM String -- > , postBaz :: Maybe Char -> ClientM () -- > } deriving GHC.Generic -- > -- > instance Generics.SOP.Generic NestedClient -- > instance (Client NestedAPI ~ client) => ClientLike client NestedClient -- > -- > mkAPIClient :: APIClient -- > mkAPIClient = mkClient (client (Proxy :: Proxy API)) -- -- By default, left-nested alternatives are expanded: -- -- > type API1 -- > = "foo" :> Capture "x" Int :> Get '[JSON] Int -- > :<|> "bar" :> QueryParam "a" Char :> Post '[JSON] String -- > -- > type API2 -- > = "baz" :> QueryParam "c" Char :> Post '[JSON] () -- > -- > type API = API1 :<|> API2 -- > -- > data APIClient = APIClient -- > { getFoo :: Int -> ClientM Int -- > , postBar :: Maybe Char -> ClientM String -- > , postBaz :: Maybe Char -> ClientM () -- > } deriving GHC.Generic -- > -- > instance Generics.SOP.Generic APIClient -- > instance (Client API ~ client) => ClientLike client APIClient -- > -- > mkAPIClient :: APIClient -- > mkAPIClient = mkClient (client (Proxy :: Proxy API)) -- -- If you want to define client for @API1@ as a separate data structure, -- you can use 'genericMkClientP': -- -- > data APIClient1 = APIClient1 -- > { getFoo :: Int -> ClientM Int -- > , postBar :: Maybe Char -> ClientM String -- > } deriving GHC.Generic -- > -- > instance Generics.SOP.Generic APIClient1 -- > instance (Client API1 ~ client) => ClientLike client APIClient1 -- > -- > data APIClient = APIClient -- > { mkAPIClient1 :: APIClient1 -- > , postBaz :: Maybe Char -> ClientM () -- > } deriving GHC.Generic -- > -- > instance Generics.SOP.Generic APIClient -- > instance (Client API ~ client) => ClientLike client APIClient where -- > mkClient = genericMkClientP -- > -- > mkAPIClient :: APIClient -- > mkAPIClient = mkClient (client (Proxy :: Proxy API)) class ClientLike client custom where mkClient :: client -> custom default mkClient :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs) => client -> custom mkClient = genericMkClientL instance ClientLike client custom => ClientLike (a -> client) (a -> custom) where mkClient c = mkClient . c instance ClientLike (ClientM a) (ClientM a) where mkClient = id -- | Match client structure with client functions, regarding left-nested API clients -- as separate data structures. class GClientLikeP client xs where gMkClientP :: client -> NP I xs instance (GClientLikeP b (y ': xs), ClientLike a x) => GClientLikeP (a :<|> b) (x ': y ': xs) where gMkClientP (a :<|> b) = I (mkClient a) :* gMkClientP b instance ClientLike a x => GClientLikeP a '[x] where gMkClientP a = I (mkClient a) :* Nil -- | Match client structure with client functions, expanding left-nested API clients -- in the same structure. class GClientLikeL (xs :: [*]) (ys :: [*]) where gMkClientL :: NP I xs -> NP I ys instance GClientLikeL '[] '[] where gMkClientL Nil = Nil instance (ClientLike x y, GClientLikeL xs ys) => GClientLikeL (x ': xs) (y ': ys) where gMkClientL (I x :* xs) = I (mkClient x) :* gMkClientL xs type family ClientList (client :: *) (acc :: [*]) :: [*] where ClientList (a :<|> b) acc = ClientList a (ClientList b acc) ClientList a acc = a ': acc class GClientList client (acc :: [*]) where gClientList :: client -> NP I acc -> NP I (ClientList client acc) instance (GClientList b acc, GClientList a (ClientList b acc)) => GClientList (a :<|> b) acc where gClientList (a :<|> b) acc = gClientList a (gClientList b acc) instance OVERLAPPABLE_ (ClientList client acc ~ (client ': acc)) => GClientList client acc where gClientList c acc = I c :* acc -- | Generate client structure from client type, expanding left-nested API (done by default). genericMkClientL :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs) => client -> custom genericMkClientL = to . SOP . Z . gMkClientL . flip gClientList Nil -- | Generate client structure from client type, regarding left-nested API clients as separate data structures. genericMkClientP :: (Generic custom, Code custom ~ '[xs], GClientLikeP client xs) => client -> custom genericMkClientP = to . SOP . Z . gMkClientP servant-client-0.11/src/Servant/Client/Experimental/0000755000000000000000000000000013111232275020640 5ustar0000000000000000servant-client-0.11/src/Servant/Client/Experimental/Auth.hs0000644000000000000000000000234213111232275022076 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeFamilies #-} -- | Authentication for clients module Servant.Client.Experimental.Auth ( AuthenticateReq(AuthenticateReq, unAuthReq) , AuthClientData , mkAuthenticateReq ) where import Servant.Common.Req (Req) -- | For a resource protected by authentication (e.g. AuthProtect), we need -- to provide the client with some data used to add authentication data -- to a request -- -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE type family AuthClientData a :: * -- | For better type inference and to avoid usage of a data family, we newtype -- wrap the combination of some 'AuthClientData' and a function to add authentication -- data to a request -- -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE newtype AuthenticateReq a = AuthenticateReq { unAuthReq :: (AuthClientData a, AuthClientData a -> Req -> Req) } -- | Handy helper to avoid wrapping datatypes in tuples everywhere. -- -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE mkAuthenticateReq :: AuthClientData a -> (AuthClientData a -> Req -> Req) -> AuthenticateReq a mkAuthenticateReq val func = AuthenticateReq (val, func) servant-client-0.11/src/Servant/Common/0000755000000000000000000000000013111232275016215 5ustar0000000000000000servant-client-0.11/src/Servant/Common/Req.hs0000644000000000000000000002400713111232275017303 0ustar0000000000000000{-# 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) servant-client-0.11/src/Servant/Common/BaseUrl.hs0000644000000000000000000000533313111232275020112 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ViewPatterns #-} module Servant.Common.BaseUrl ( -- * types BaseUrl (..) , InvalidBaseUrlException , Scheme (..) -- * functions , parseBaseUrl , showBaseUrl ) where import Control.Monad.Catch (Exception, MonadThrow, throwM) import Data.List import Data.Typeable import GHC.Generics import Network.URI hiding (path) import Safe import Text.Read -- | URI scheme to use data Scheme = Http -- ^ http:// | Https -- ^ https:// deriving (Show, Eq, Ord, Generic) -- | Simple data type to represent the target of HTTP requests -- for servant's automatically-generated clients. data BaseUrl = BaseUrl { baseUrlScheme :: Scheme -- ^ URI scheme to use , baseUrlHost :: String -- ^ host (eg "haskell.org") , baseUrlPort :: Int -- ^ port (eg 80) , baseUrlPath :: String -- ^ path (eg "/a/b/c") } deriving (Show, Ord, Generic) instance Eq BaseUrl where BaseUrl a b c path == BaseUrl a' b' c' path' = a == a' && b == b' && c == c' && s path == s path' where s ('/':x) = x s x = x showBaseUrl :: BaseUrl -> String showBaseUrl (BaseUrl urlscheme host port path) = schemeString ++ "//" ++ host ++ (portString path) where a b = if "/" `isPrefixOf` b || null b then a ++ b else a ++ '/':b schemeString = case urlscheme of Http -> "http:" Https -> "https:" portString = case (urlscheme, port) of (Http, 80) -> "" (Https, 443) -> "" _ -> ":" ++ show port data InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show, Typeable) instance Exception InvalidBaseUrlException parseBaseUrl :: MonadThrow m => String -> m BaseUrl parseBaseUrl s = case parseURI (removeTrailingSlash s) of -- This is a rather hacky implementation and should be replaced with something -- implemented in attoparsec (which is already a dependency anyhow (via aeson)). Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) path "" "") -> return (BaseUrl Http host port path) Just (URI "http:" (Just (URIAuth "" host "")) path "" "") -> return (BaseUrl Http host 80 path) Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) path "" "") -> return (BaseUrl Https host port path) Just (URI "https:" (Just (URIAuth "" host "")) path "" "") -> return (BaseUrl Https host 443 path) _ -> if "://" `isInfixOf` s then throwM (InvalidBaseUrlException $ "Invalid base URL: " ++ s) else parseBaseUrl ("http://" ++ s) where removeTrailingSlash str = case lastMay str of Just '/' -> init str _ -> str servant-client-0.11/src/Servant/Common/BasicAuth.hs0000644000000000000000000000125113111232275020413 0ustar0000000000000000{-# 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 servant-client-0.11/include/0000755000000000000000000000000013111232275014177 5ustar0000000000000000servant-client-0.11/include/overlapping-compat.h0000644000000000000000000000032213111232275020154 0ustar0000000000000000#if __GLASGOW_HASKELL__ >= 710 #define OVERLAPPABLE_ {-# OVERLAPPABLE #-} #define OVERLAPPING_ {-# OVERLAPPING #-} #else {-# LANGUAGE OverlappingInstances #-} #define OVERLAPPABLE_ #define OVERLAPPING_ #endif servant-client-0.11/test/0000755000000000000000000000000013111232275013533 5ustar0000000000000000servant-client-0.11/test/Spec.hs0000644000000000000000000000005413111232275014760 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} servant-client-0.11/test/Servant/0000755000000000000000000000000013111232275015155 5ustar0000000000000000servant-client-0.11/test/Servant/ClientSpec.hs0000644000000000000000000004724613111232275017557 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 800 {-# OPTIONS_GHC -freduction-depth=100 #-} #else {-# OPTIONS_GHC -fcontext-stack=100 #-} #endif {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} #include "overlapping-compat.h" module Servant.ClientSpec where import Control.Arrow (left) 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 System.IO.Unsafe (unsafePerformIO) import Test.HUnit import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck import Web.FormUrlEncoded (FromForm, ToForm) import Servant.API import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Client import Servant.Client.Generic import qualified Servant.Common.Req as SCR import Servant.Server import Servant.Server.Experimental.Auth -- This declaration simply checks that all instances are in place. _ = client comprehensiveAPI spec :: Spec spec = describe "Servant.Client" $ do sucessSpec failSpec wrappedApiSpec basicAuthSpec genAuthSpec genericClientSpec -- * test data types data Person = Person { name :: String, age :: Integer } deriving (Eq, Show, Generic) instance ToJSON Person instance FromJSON Person instance ToForm Person where instance FromForm Person where alice :: Person alice = Person "Alice" 42 type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String] type Api = "get" :> Get '[JSON] Person :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person] :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person] :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool :<|> "rawSuccess" :> Raw :<|> "rawFailure" :> Raw :<|> "multiple" :> Capture "first" String :> QueryParam "second" Int :> QueryFlag "third" :> ReqBody '[JSON] [(String, [Rational])] :> Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])]) :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool) :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent :<|> "empty" :> EmptyAPI api :: Proxy Api api = Proxy getGet :: SCR.ClientM Person getDeleteEmpty :: SCR.ClientM NoContent getCapture :: String -> SCR.ClientM Person getCaptureAll :: [String] -> SCR.ClientM [Person] getBody :: Person -> SCR.ClientM Person getQueryParam :: Maybe String -> SCR.ClientM Person getQueryParams :: [String] -> SCR.ClientM [Person] getQueryFlag :: Bool -> SCR.ClientM Bool getRawSuccess :: HTTP.Method -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString) getRawFailure :: HTTP.Method -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString) getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> SCR.ClientM (String, Maybe Int, Bool, [(String, [Rational])]) getRespHeaders :: SCR.ClientM (Headers TestHeaders Bool) getDeleteContentType :: SCR.ClientM NoContent getGet :<|> getDeleteEmpty :<|> getCapture :<|> getCaptureAll :<|> getBody :<|> getQueryParam :<|> getQueryParams :<|> getQueryFlag :<|> getRawSuccess :<|> getRawFailure :<|> getMultiple :<|> getRespHeaders :<|> getDeleteContentType :<|> EmptyClient = client api server :: Application server = serve api ( return alice :<|> return NoContent :<|> (\ name -> return $ Person name 0) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return :<|> (\ name -> case name of Just "alice" -> return alice Just n -> throwError $ ServantErr 400 (n ++ " not found") "" [] Nothing -> throwError $ ServantErr 400 "missing parameter" "" []) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return :<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess") :<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure") :<|> (\ a b c d -> return (a, b, c, d)) :<|> (return $ addHeader 1729 $ addHeader "eg2" True) :<|> return NoContent :<|> emptyServer) type FailApi = "get" :> Raw :<|> "capture" :> Capture "name" String :> Raw :<|> "body" :> Raw failApi :: Proxy FailApi failApi = Proxy failServer :: Application failServer = serve failApi ( (Tagged $ \ _request respond -> respond $ responseLBS HTTP.ok200 [] "") :<|> (\ _capture -> Tagged $ \_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "") :<|> (Tagged $ \_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "") ) -- * basic auth stuff type BasicAuthAPI = BasicAuth "foo-realm" () :> "private" :> "basic" :> Get '[JSON] Person basicAuthAPI :: Proxy BasicAuthAPI basicAuthAPI = Proxy basicAuthHandler :: BasicAuthCheck () basicAuthHandler = let check (BasicAuthData username password) = if username == "servant" && password == "server" then return (Authorized ()) else return Unauthorized in BasicAuthCheck check basicServerContext :: Context '[ BasicAuthCheck () ] basicServerContext = basicAuthHandler :. EmptyContext basicAuthServer :: Application basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice)) -- * general auth stuff type GenAuthAPI = AuthProtect "auth-tag" :> "private" :> "auth" :> Get '[JSON] Person genAuthAPI :: Proxy GenAuthAPI genAuthAPI = Proxy type instance AuthServerData (AuthProtect "auth-tag") = () type instance AuthClientData (AuthProtect "auth-tag") = () genAuthHandler :: AuthHandler Request () genAuthHandler = let handler req = case lookup "AuthHeader" (requestHeaders req) of Nothing -> throwError (err401 { errBody = "Missing auth header" }) Just _ -> return () in mkAuthHandler handler genAuthServerContext :: Context '[ AuthHandler Request () ] genAuthServerContext = genAuthHandler :. EmptyContext genAuthServer :: Application genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice)) -- * generic client stuff type GenericClientAPI = QueryParam "sqr" Int :> Get '[JSON] Int :<|> Capture "foo" String :> NestedAPI1 data GenericClient = GenericClient { getSqr :: Maybe Int -> SCR.ClientM Int , mkNestedClient1 :: String -> NestedClient1 } deriving Generic instance SOP.Generic GenericClient instance (Client GenericClientAPI ~ client) => ClientLike client GenericClient type NestedAPI1 = QueryParam "int" Int :> NestedAPI2 :<|> QueryParam "id" Char :> Get '[JSON] Char data NestedClient1 = NestedClient1 { mkNestedClient2 :: Maybe Int -> NestedClient2 , idChar :: Maybe Char -> SCR.ClientM Char } deriving Generic instance SOP.Generic NestedClient1 instance (Client NestedAPI1 ~ client) => ClientLike client NestedClient1 type NestedAPI2 = "sum" :> Capture "first" Int :> Capture "second" Int :> Get '[JSON] Int :<|> "void" :> Post '[JSON] () data NestedClient2 = NestedClient2 { getSum :: Int -> Int -> SCR.ClientM Int , doNothing :: SCR.ClientM () } deriving Generic instance SOP.Generic NestedClient2 instance (Client NestedAPI2 ~ client) => ClientLike client NestedClient2 genericClientServer :: Application genericClientServer = serve (Proxy :: Proxy GenericClientAPI) ( (\ mx -> case mx of Just x -> return (x*x) Nothing -> throwError $ ServantErr 400 "missing parameter" "" [] ) :<|> nestedServer1 ) where nestedServer1 _str = nestedServer2 :<|> (maybe (throwError $ ServantErr 400 "missing parameter" "" []) return) nestedServer2 _int = (\ x y -> return (x + y)) :<|> return () {-# NOINLINE manager #-} manager :: C.Manager manager = unsafePerformIO $ C.newManager C.defaultManagerSettings sucessSpec :: Spec sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do it "Servant.API.Get" $ \(_, baseUrl) -> do (left show <$> (runClientM getGet (ClientEnv manager baseUrl))) `shouldReturn` Right alice describe "Servant.API.Delete" $ do it "allows empty content type" $ \(_, baseUrl) -> do (left show <$> (runClientM getDeleteEmpty (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent it "allows content type" $ \(_, baseUrl) -> do (left show <$> (runClientM getDeleteContentType (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent it "Servant.API.Capture" $ \(_, baseUrl) -> do (left show <$> (runClientM (getCapture "Paula") (ClientEnv manager baseUrl))) `shouldReturn` Right (Person "Paula" 0) it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do let expected = [(Person "Paula" 0), (Person "Peta" 1)] (left show <$> (runClientM (getCaptureAll ["Paula", "Peta"]) (ClientEnv manager baseUrl))) `shouldReturn` Right expected it "Servant.API.ReqBody" $ \(_, baseUrl) -> do let p = Person "Clara" 42 (left show <$> runClientM (getBody p) (ClientEnv manager baseUrl)) `shouldReturn` Right p it "Servant.API.QueryParam" $ \(_, baseUrl) -> do left show <$> runClientM (getQueryParam (Just "alice")) (ClientEnv manager baseUrl) `shouldReturn` Right alice Left FailureResponse{..} <- runClientM (getQueryParam (Just "bob")) (ClientEnv manager baseUrl) responseStatus `shouldBe` HTTP.Status 400 "bob not found" it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do (left show <$> runClientM (getQueryParams []) (ClientEnv manager baseUrl)) `shouldReturn` Right [] (left show <$> runClientM (getQueryParams ["alice", "bob"]) (ClientEnv manager baseUrl)) `shouldReturn` Right [Person "alice" 0, Person "bob" 1] context "Servant.API.QueryParam.QueryFlag" $ forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do (left show <$> runClientM (getQueryFlag flag) (ClientEnv manager baseUrl)) `shouldReturn` Right flag it "Servant.API.Raw on success" $ \(_, baseUrl) -> do res <- runClientM (getRawSuccess HTTP.methodGet) (ClientEnv manager baseUrl) case res of Left e -> assertFailure $ show e Right (code, body, ct, _, response) -> do (code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream") C.responseBody response `shouldBe` body C.responseStatus response `shouldBe` HTTP.ok200 it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do res <- runClientM (getRawFailure HTTP.methodGet) (ClientEnv manager baseUrl) case res of Right _ -> assertFailure "expected Left, but got Right" Left e -> do Servant.Client.responseStatus e `shouldBe` HTTP.status400 Servant.Client.responseBody e `shouldBe` "rawFailure" it "Returns headers appropriately" $ \(_, baseUrl) -> do res <- runClientM getRespHeaders (ClientEnv manager baseUrl) case res of Left e -> assertFailure $ show e Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] modifyMaxSuccess (const 20) $ do it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) -> property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> ioProperty $ do result <- left show <$> runClientM (getMultiple cap num flag body) (ClientEnv manager baseUrl) return $ result === Right (cap, num, flag, body) wrappedApiSpec :: Spec wrappedApiSpec = describe "error status codes" $ do let serveW api = serve api $ throwError $ ServantErr 500 "error message" "" [] context "are correctly handled by the client" $ let test :: (WrappedApi, String) -> Spec test (WrappedApi api, desc) = it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do let getResponse :: SCR.ClientM () getResponse = client api Left FailureResponse{..} <- runClientM getResponse (ClientEnv manager baseUrl) responseStatus `shouldBe` (HTTP.Status 500 "error message") in mapM_ test $ (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") : (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") : (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") : (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") : [] failSpec :: Spec failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do context "client returns errors appropriately" $ do it "reports FailureResponse" $ \(_, baseUrl) -> do let (_ :<|> getDeleteEmpty :<|> _) = client api Left res <- runClientM getDeleteEmpty (ClientEnv manager baseUrl) case res of FailureResponse _ (HTTP.Status 404 "Not Found") _ _ -> return () _ -> fail $ "expected 404 response, but got " <> show res it "reports DecodeFailure" $ \(_, baseUrl) -> do let (_ :<|> _ :<|> getCapture :<|> _) = client api Left res <- runClientM (getCapture "foo") (ClientEnv manager baseUrl) case res of DecodeFailure _ ("application/json") _ -> return () _ -> fail $ "expected DecodeFailure, but got " <> show res it "reports ConnectionError" $ \_ -> do let (getGetWrongHost :<|> _) = client api Left res <- runClientM getGetWrongHost (ClientEnv manager (BaseUrl Http "127.0.0.1" 19872 "")) case res of ConnectionError _ -> return () _ -> fail $ "expected ConnectionError, but got " <> show res it "reports UnsupportedContentType" $ \(_, baseUrl) -> do let (getGet :<|> _ ) = client api Left res <- runClientM getGet (ClientEnv manager baseUrl) case res of UnsupportedContentType ("application/octet-stream") _ -> return () _ -> fail $ "expected UnsupportedContentType, but got " <> show res it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api Left res <- runClientM (getBody alice) (ClientEnv manager baseUrl) case res of InvalidContentTypeHeader "fooooo" _ -> return () _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res data WrappedApi where WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a, HasClient api, Client api ~ SCR.ClientM ()) => Proxy api -> WrappedApi basicAuthSpec :: Spec basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ do context "Authentication works when requests are properly authenticated" $ do it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do let getBasic = client basicAuthAPI let basicAuthData = BasicAuthData "servant" "server" (left show <$> runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)) `shouldReturn` Right alice context "Authentication is rejected when requests are not authenticated properly" $ do it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do let getBasic = client basicAuthAPI let basicAuthData = BasicAuthData "not" "password" Left FailureResponse{..} <- runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl) responseStatus `shouldBe` HTTP.Status 403 "Forbidden" genAuthSpec :: Spec genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do context "Authentication works when requests are properly authenticated" $ do it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do let getProtected = client genAuthAPI let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req) (left show <$> runClientM (getProtected authRequest) (ClientEnv manager baseUrl)) `shouldReturn` Right alice context "Authentication is rejected when requests are not authenticated properly" $ do it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do let getProtected = client genAuthAPI let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req) Left FailureResponse{..} <- runClientM (getProtected authRequest) (ClientEnv manager baseUrl) responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized") genericClientSpec :: Spec genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWaiApp $ do describe "Servant.Client.Generic" $ do let GenericClient{..} = mkClient (client (Proxy :: Proxy GenericClientAPI)) NestedClient1{..} = mkNestedClient1 "example" NestedClient2{..} = mkNestedClient2 (Just 42) it "works for top-level client function" $ \(_, baseUrl) -> do (left show <$> (runClientM (getSqr (Just 5)) (ClientEnv manager baseUrl))) `shouldReturn` Right 25 it "works for nested clients" $ \(_, baseUrl) -> do (left show <$> (runClientM (idChar (Just 'c')) (ClientEnv manager baseUrl))) `shouldReturn` Right 'c' (left show <$> (runClientM (getSum 3 4) (ClientEnv manager baseUrl))) `shouldReturn` Right 7 (left show <$> (runClientM doNothing (ClientEnv manager baseUrl))) `shouldReturn` Right () -- * utils startWaiApp :: Application -> IO (ThreadId, BaseUrl) startWaiApp app = do (port, socket) <- openTestSocket let settings = setPort port $ defaultSettings thread <- forkIO $ runSettingsSocket settings socket app return (thread, BaseUrl Http "localhost" port "") endWaiApp :: (ThreadId, BaseUrl) -> IO () endWaiApp (thread, _) = killThread thread openTestSocket :: IO (Port, Socket) openTestSocket = do s <- socket AF_INET Stream defaultProtocol localhost <- inet_addr "127.0.0.1" bind s (SockAddrInet aNY_PORT localhost) listen s 1 port <- socketPort s return (fromIntegral port, s) pathGen :: Gen (NonEmptyList Char) pathGen = fmap NonEmpty path where path = listOf1 $ elements $ filter (not . (`elem` ("?%[]/#;" :: String))) $ filter isPrint $ map chr [0..127] servant-client-0.11/test/Servant/Common/0000755000000000000000000000000013111232275016405 5ustar0000000000000000servant-client-0.11/test/Servant/Common/BaseUrlSpec.hs0000644000000000000000000000551613111232275021120 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.Common.BaseUrlSpec where import Control.DeepSeq import Prelude () import Prelude.Compat import Test.Hspec import Test.QuickCheck import Servant.Common.BaseUrl spec :: Spec spec = do let parse = parseBaseUrl :: String -> Maybe BaseUrl describe "showBaseUrl" $ do it "shows a BaseUrl" $ do showBaseUrl (BaseUrl Http "foo.com" 80 "") `shouldBe` "http://foo.com" it "shows a https BaseUrl" $ do showBaseUrl (BaseUrl Https "foo.com" 443 "") `shouldBe` "https://foo.com" it "shows the path of a BaseUrl" $ do showBaseUrl (BaseUrl Http "foo.com" 80 "api") `shouldBe` "http://foo.com/api" it "shows the path of an https BaseUrl" $ do showBaseUrl (BaseUrl Https "foo.com" 443 "api") `shouldBe` "https://foo.com/api" it "handles leading slashes in path" $ do showBaseUrl (BaseUrl Https "foo.com" 443 "/api") `shouldBe` "https://foo.com/api" describe "httpBaseUrl" $ do it "allows to construct default http BaseUrls" $ do BaseUrl Http "bar" 80 "" `shouldBe` BaseUrl Http "bar" 80 "" describe "parseBaseUrl" $ do it "is total" $ do property $ \ string -> deepseq (fmap show (parse string )) True it "is the inverse of showBaseUrl" $ do property $ \ baseUrl -> counterexample (showBaseUrl baseUrl) $ parse (showBaseUrl baseUrl) === Just baseUrl context "trailing slashes" $ do it "allows trailing slashes" $ do parse "foo.com/" `shouldBe` Just (BaseUrl Http "foo.com" 80 "") it "allows trailing slashes in paths" $ do parse "foo.com/api/" `shouldBe` Just (BaseUrl Http "foo.com" 80 "api") context "urls without scheme" $ do it "assumes http" $ do parse "foo.com" `shouldBe` Just (BaseUrl Http "foo.com" 80 "") it "allows port numbers" $ do parse "foo.com:8080" `shouldBe` Just (BaseUrl Http "foo.com" 8080 "") it "can parse paths" $ do parse "http://foo.com/api" `shouldBe` Just (BaseUrl Http "foo.com" 80 "api") it "rejects ftp urls" $ do parse "ftp://foo.com" `shouldBe` Nothing instance Arbitrary BaseUrl where arbitrary = BaseUrl <$> elements [Http, Https] <*> hostNameGen <*> portGen <*> pathGen where letters = ['a' .. 'z'] ++ ['A' .. 'Z'] -- this does not perfectly mirror the url standard, but I hope it's good -- enough. hostNameGen = do first <- elements letters middle <- listOf1 $ elements (letters ++ ['0' .. '9'] ++ ['.', '-']) last' <- elements letters return (first : middle ++ [last']) portGen = frequency $ (1, return 80) : (1, return 443) : (1, choose (1, 20000)) : [] pathGen = listOf1 . elements $ letters isLeft :: Either a b -> Bool isLeft = either (const True) (const False)