servant-client-core-0.15/0000755000000000000000000000000007346545000013514 5ustar0000000000000000servant-client-core-0.15/CHANGELOG.md0000755000000000000000000001323307346545000015332 0ustar0000000000000000[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client-core/CHANGELOG.md) [Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) 0.15 ---- - Streaming refactoring. [#991](https://github.com/haskell-servant/servant/pull/991) [#1076](https://github.com/haskell-servant/servant/pull/1076) [#1077](https://github.com/haskell-servant/servant/pull/1077) The streaming functionality (`Servant.API.Stream`) is refactored to use `servant`'s own `SourceIO` type (see `Servant.Types.SourceT` documentation), which replaces both `StreamGenerator` and `ResultStream` types. New conversion type-classes are `ToSourceIO` and `FromSourceIO` (replacing `ToStreamGenerator` and `BuildFromStream`). There are instances for *conduit*, *pipes* and *machines* in new packages: [servant-conduit](https://hackage.haskell.org/package/servant-conduit) [servant-pipes](https://hackage.haskell.org/package/servant-pipes) and [servant-machines](https://hackage.haskell.org/package/servant-machines) respectively. Writing new framing strategies is simpler. Check existing strategies for examples. This change shouldn't affect you, if you don't use streaming endpoints. - *servant-client* Separate streaming client. [#1066](https://github.com/haskell-servant/servant/pull/1066) We now have two `http-client` based clients, in `Servant.Client` and `Servant.Client.Streaming`. Their API is the same, except for - `Servant.Client` **cannot** request `Stream` endpoints. - `Servant.Client` is *run* by direct `runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)` - `Servant.Client.Streaming` **can** request `Stream` endpoints. - `Servant.Client.Streaming` is *used* by CPSised `withClientM :: ClientM a -> ClientEnv -> (Either ServantError a -> IO b) -> IO b` To access `Stream` endpoints use `Servant.Client.Streaming` with `withClientM`; otherwise you can continue using `Servant.Client` with `runClientM`. You can use both too, `ClientEnv` and `BaseUrl` types are same for both. **Note:** `Servant.Client.Streaming` doesn't *stream* non-`Stream` endpoints. Requesting ordinary `Verb` endpoints (e.g. `Get`) will block until the whole response is received. There is `Servant.Client.Streaming.runClientM` function, but it has restricted type. `NFData a` constraint prevents using it with `SourceT`, `Conduit` etc. response types. ```haskell runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ServantError a) ``` This change shouldn't affect you, if you don't use streaming endpoints. - *servant-client-core* Related to the previous: `streamingResponse` is removed from `RunClient`. We have a new type-class: ```haskell class RunClient m => RunStreamingClient m where withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> m a ``` - Drop support for GHC older than 8.0 [#1008](https://github.com/haskell-servant/servant/pull/1008) [#1009](https://github.com/haskell-servant/servant/pull/1009) - *servant-client-core* Add `NFData (GenResponse a)` and `NFData ServantError` instances. [#1076](https://github.com/haskell-servant/servant/pull/1076) - *servant-client-core* Add `aeson` and `Lift BaseUrl` instances [#1037](https://github.com/haskell-servant/servant/pull/1037) 0.14.1 ------ - Merge in `servant-generic` (by [Patrick Chilton](https://github.com/chpatrick)) into `servant` (`Servant.API.Generic`), `servant-client-code` (`Servant.Client.Generic`) and `servant-server` (`Servant.Server.Generic`). 0.14 ---- - `Stream` takes a status code argument ```diff -Stream method framing ctype a +Stream method status framing ctype a ``` ([#966](https://github.com/haskell-servant/servant/pull/966) [#972](https://github.com/haskell-servant/servant/pull/972)) - `ToStreamGenerator` definition changed, so it's possible to write an instance for conduits. ```diff -class ToStreamGenerator f a where - toStreamGenerator :: f a -> StreamGenerator a +class ToStreamGenerator a b | a -> b where + toStreamGenerator :: a -> StreamGenerator b ``` ([#959](https://github.com/haskell-servant/servant/pull/959)) - Added `NoFraming` streaming strategy ([#959](https://github.com/haskell-servant/servant/pull/959)) - *servant-client-core* Free `Client` implementation. Useful for testing `HasClient` instances. ([#920](https://github.com/haskell-servant/servant/pull/920)) - *servant-client-core* Add `hoistClient` to `HasClient`. Just like `hoistServer` allows us to change the monad in which request handlers of a web application live in, we also have `hoistClient` for changing the monad in which *client functions* live. Read [tutorial section for more information](https://haskell-servant.readthedocs.io/en/release-0.14/tutorial/Client.html#changing-the-monad-the-client-functions-live-in). ([#936](https://github.com/haskell-servant/servant/pull/936)) iF you have own combinators, you'll need to define a new method of `HasClient` class, for example: ```haskell type Client m (MyCombinator :> api) = MyValue :> Client m api hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy api) nt . cl ``` 0.13.0.1 -------- - Support `base-compat-0.10` 0.13 ---- - Streaming endpoint support. ([#836](https://github.com/haskell-servant/servant/pull/836)) - *servant* Add `Servant.API.Modifiers` ([#873](https://github.com/haskell-servant/servant/pull/873)) 0.12 ---- - First version. Factored out of `servant-client` all the functionality that was independent of the `http-client` backend. servant-client-core-0.15/LICENSE0000644000000000000000000000300707346545000014521 0ustar0000000000000000Copyright (c) 2017-2018, 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. servant-client-core-0.15/README.md0000755000000000000000000000174107346545000015001 0ustar0000000000000000# 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. servant-client-core-0.15/Setup.hs0000644000000000000000000000007007346545000015145 0ustar0000000000000000import Distribution.Simple main = defaultMain servant-client-core-0.15/servant-client-core.cabal0000644000000000000000000000666607346545000020402 0ustar0000000000000000cabal-version: >=1.10 name: servant-client-core version: 0.15 synopsis: Core functionality and class for client function generation for servant APIs category: Servant, Web description: This library provides backend-agnostic generation of client functions. For more information, see the README. homepage: http://haskell-servant.readthedocs.org/ bug-reports: http://github.com/haskell-servant/servant/issues license: BSD3 license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors build-type: Simple tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.2 extra-source-files: 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.Free Servant.Client.Generic Servant.Client.Core.Reexport Servant.Client.Core.Internal.Auth Servant.Client.Core.Internal.BaseUrl Servant.Client.Core.Internal.BasicAuth Servant.Client.Core.Internal.ClientF Servant.Client.Core.Internal.Generic Servant.Client.Core.Internal.HasClient Servant.Client.Core.Internal.Request Servant.Client.Core.Internal.RunClient -- Bundled with GHC: Lower bound to not force re-installs -- text and mtl are bundled starting with GHC-8.4 -- -- note: mtl lower bound is so low because of GHC-7.8 build-depends: base >= 4.9 && < 4.13 , bytestring >= 0.10.8.1 && < 0.11 , containers >= 0.5.7.1 && < 0.7 , deepseq >= 1.4.2.0 && < 1.5 , text >= 1.2.3.0 && < 1.3 , transformers >= 0.5.2.0 && < 0.6 , template-haskell >= 2.11.1.0 && < 2.15 -- Servant dependencies build-depends: servant >= 0.15 && <0.16 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. build-depends: aeson >= 1.4.1.0 && < 1.5 , base-compat >= 0.10.5 && < 0.11 , base64-bytestring >= 1.0.0.1 && < 1.1 , exceptions >= 0.10.0 && < 0.11 , free >= 5.1 && < 5.2 , generics-sop >= 0.4.0.1 && < 0.5 , http-media >= 0.7.1.3 && < 0.8 , http-types >= 0.12.2 && < 0.13 , network-uri >= 2.6.1.0 && < 2.7 , safe >= 0.3.17 && < 0.4 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall 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.Client.Core.Internal.BaseUrlSpec -- Dependencies inherited from the library. No need to specify bounds. build-depends: base , base-compat , servant-client-core -- Additonal dependencies build-depends: deepseq >= 1.4.2.0 && < 1.5 , hspec >= 2.6.0 && < 2.7 , QuickCheck >= 2.12.6.1 && < 2.13 build-tool-depends: hspec-discover:hspec-discover >= 2.6.0 && <2.7 servant-client-core-0.15/src/Servant/Client/0000755000000000000000000000000007346545000017143 5ustar0000000000000000servant-client-core-0.15/src/Servant/Client/Core.hs0000644000000000000000000000341407346545000020371 0ustar0000000000000000-- | 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 , GenResponse (..) , RunClient(..) , module Servant.Client.Core.Internal.BaseUrl -- ** Streaming , RunStreamingClient(..) , StreamingResponse -- * 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.Generic import Servant.Client.Core.Internal.HasClient import Servant.Client.Core.Internal.Request import Servant.Client.Core.Internal.RunClient servant-client-core-0.15/src/Servant/Client/Core/Internal/0000755000000000000000000000000007346545000021607 5ustar0000000000000000servant-client-core-0.15/src/Servant/Client/Core/Internal/Auth.hs0000644000000000000000000000235107346545000023045 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} -- | Authentication for clients module Servant.Client.Core.Internal.Auth where import Servant.Client.Core.Internal.Request (Request) -- | 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 AuthenticatedRequest a = AuthenticatedRequest { unAuthReq :: (AuthClientData a, AuthClientData a -> Request -> Request) } -- | Handy helper to avoid wrapping datatypes in tuples everywhere. -- -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE mkAuthenticatedRequest :: AuthClientData a -> (AuthClientData a -> Request -> Request) -> AuthenticatedRequest a mkAuthenticatedRequest val func = AuthenticatedRequest (val, func) servant-client-core-0.15/src/Servant/Client/Core/Internal/BaseUrl.hs0000644000000000000000000001201507346545000023477 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE ViewPatterns #-} module Servant.Client.Core.Internal.BaseUrl where import Control.Monad.Catch (Exception, MonadThrow, throwM) import Data.Aeson (FromJSON (..), FromJSONKey (..), ToJSON (..), ToJSONKey (..)) import Data.Aeson.Types (FromJSONKeyFunction (..), contramapToJSONKeyFunction, withText) import Data.Data (Data) import Data.List import qualified Data.Text as T import GHC.Generics import Language.Haskell.TH.Syntax (Lift) 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, Lift, Data) -- | 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, Lift, Data) -- TODO: Ord is more precise than Eq -- TODO: Add Hashable instance? 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 -- | >>> traverse_ (LBS8.putStrLn . encode) $ parseBaseUrl "api.example.com" -- "http://api.example.com" instance ToJSON BaseUrl where toJSON = toJSON . showBaseUrl toEncoding = toEncoding . showBaseUrl -- | >>> parseBaseUrl "api.example.com" >>= decode . encode :: Maybe BaseUrl -- Just (BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = ""}) instance FromJSON BaseUrl where parseJSON = withText "BaseUrl" $ \t -> case parseBaseUrl (T.unpack t) of Just u -> return u Nothing -> fail $ "Invalid base url: " ++ T.unpack t -- | >>> :{ -- traverse_ (LBS8.putStrLn . encode) $ do -- u1 <- parseBaseUrl "api.example.com" -- u2 <- parseBaseUrl "example.com" -- return $ Map.fromList [(u1, 'x'), (u2, 'y')] -- :} -- {"http://api.example.com":"x","http://example.com":"y"} instance ToJSONKey BaseUrl where toJSONKey = contramapToJSONKeyFunction showBaseUrl toJSONKey instance FromJSONKey BaseUrl where fromJSONKey = FromJSONKeyTextParser $ \t -> case parseBaseUrl (T.unpack t) of Just u -> return u Nothing -> fail $ "Invalid base url: " ++ T.unpack t -- | >>> showBaseUrl <$> parseBaseUrl "api.example.com" -- "http://api.example.com" 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 newtype InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show) instance Exception InvalidBaseUrlException -- | -- -- >>> parseBaseUrl "api.example.com" -- BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = ""} -- -- /Note:/ trailing slash is removed -- -- >>> parseBaseUrl "api.example.com/" -- BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = ""} -- -- >>> parseBaseUrl "api.example.com/dir/" -- BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = "/dir"} -- 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 -- $setup -- -- >>> import Data.Aeson -- >>> import Data.Foldable (traverse_) -- >>> import qualified Data.ByteString.Lazy.Char8 as LBS8 -- >>> import qualified Data.Map.Strict as Map servant-client-core-0.15/src/Servant/Client/Core/Internal/BasicAuth.hs0000644000000000000000000000151407346545000024007 0ustar0000000000000000{-# 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 servant-client-core-0.15/src/Servant/Client/Core/Internal/ClientF.hs0000644000000000000000000000044707346545000023474 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} module Servant.Client.Core.Internal.ClientF where import Servant.Client.Core.Internal.Request data ClientF a = RunRequest Request (Response -> a) | StreamingRequest Request (StreamingResponse -> a) | Throw ServantError deriving (Functor) servant-client-core-0.15/src/Servant/Client/Core/Internal/Generic.hs0000644000000000000000000001302607346545000023521 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Servant.Client.Core.Internal.Generic where import Generics.SOP (Code, Generic, I (..), NP (..), NS (Z), SOP (..), to) import Servant.API ((:<|>) (..)) -- | 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 -- | 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-core-0.15/src/Servant/Client/Core/Internal/HasClient.hs0000644000000000000000000005525007346545000024024 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Servant.Client.Core.Internal.HasClient where import Prelude () import Prelude.Compat import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import Data.Foldable (toList) import Data.List (foldl') import Data.Proxy (Proxy (Proxy)) import Data.Sequence (fromList) import Data.String (fromString) import Data.Text (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, FramingUnrender (..), FromSourceIO (..), Header', Headers (..), HttpVersion, IsSecure, MimeRender (mimeRender), MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag, QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData, Vault, Verb, WithNamedContext, contentType, getHeadersHList, getResponse, toQueryParam, toUrlPiece) import Servant.API.ContentTypes (contentTypes) import Servant.API.Modifiers (FoldRequired, RequiredArgument, foldRequiredArgument) import qualified Servant.Types.SourceT as S 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 hoistClientMonad :: Proxy m -> Proxy api -> (forall x. mon x -> mon' x) -> Client mon api -> Client mon' 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 hoistClientMonad pm _ f (ca :<|> cb) = hoistClientMonad pm (Proxy :: Proxy a) f ca :<|> hoistClientMonad pm (Proxy :: Proxy b) f cb -- | 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 hoistClientMonad _ _ _ EmptyClient = 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' mods capture a :> api) where type Client m (Capture' mods capture a :> api) = a -> Client m api clientWithRoute pm Proxy req val = clientWithRoute pm (Proxy :: Proxy api) (appendToPath p req) where p = (toUrlPiece val) hoistClientMonad pm _ f cl = \a -> hoistClientMonad pm (Proxy :: Proxy api) f (cl a) -- | 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 hoistClientMonad pm _ f cl = \as -> hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as) 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) hoistClientMonad _ _ f ma = f ma 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) hoistClientMonad _ _ f ma = f ma 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) hoistClientMonad _ _ f ma = f ma 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 } hoistClientMonad _ _ f ma = f ma instance {-# OVERLAPPABLE #-} ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method, FramingUnrender framing, FromSourceIO chunk a ) => HasClient m (Stream method status framing ct a) where type Client m (Stream method status framing ct a) = m a hoistClientMonad _ _ f ma = f ma clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' return $ fromSourceIO $ framingUnrender' $ S.fromAction BS.null (responseBody gres) where req' = req { requestAccept = fromList [contentType (Proxy :: Proxy ct)] , requestMethod = reflectMethod (Proxy :: Proxy method) } -- | 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, SBoolI (FoldRequired mods)) => HasClient m (Header' mods sym a :> api) where type Client m (Header' mods sym a :> api) = RequiredArgument mods a -> Client m api clientWithRoute pm Proxy req mval = clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument (Proxy :: Proxy mods) add (maybe req add) mval where hname = fromString $ symbolVal (Proxy :: Proxy sym) add :: a -> Request add value = addHeader hname value req hoistClientMonad pm _ f cl = \arg -> hoistClientMonad pm (Proxy :: Proxy api) f (cl arg) -- | 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) hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl -- | 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) hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl -- | 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) hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl -- | 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, SBoolI (FoldRequired mods)) => HasClient m (QueryParam' mods sym a :> api) where type Client m (QueryParam' mods sym a :> api) = RequiredArgument mods 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) $ foldRequiredArgument (Proxy :: Proxy mods) add (maybe req add) mparam where add :: a -> Request add param = appendToQueryString pname (Just $ toQueryParam param) req pname :: Text pname = pack $ symbolVal (Proxy :: Proxy sym) hoistClientMonad pm _ f cl = \arg -> hoistClientMonad pm (Proxy :: Proxy api) f (cl arg) -- | 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 hoistClientMonad pm _ f cl = \as -> hoistClientMonad pm (Proxy :: Proxy api) f (cl as) -- | 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) hoistClientMonad pm _ f cl = \b -> hoistClientMonad pm (Proxy :: Proxy api) f (cl b) -- | 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 } hoistClientMonad _ _ f cl = \meth -> f (cl meth) -- | 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' mods (ct ': cts) a :> api) where type Client m (ReqBody' mods (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 ) hoistClientMonad pm _ f cl = \a -> hoistClientMonad pm (Proxy :: Proxy api) f (cl a) instance ( HasClient m api ) => HasClient m (StreamBody' mods framing ctype a :> api) where type Client m (StreamBody' mods framing ctype a :> api) = a -> Client m api hoistClientMonad pm _ f cl = \a -> hoistClientMonad pm (Proxy :: Proxy api) f (cl a) clientWithRoute _pm Proxy _req _body = error "HasClient @StreamBody" -- | 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) hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl 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 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl 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 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl 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 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl 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) hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl 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) hoistClientMonad pm _ f cl = \authreq -> hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq) -- * 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) hoistClientMonad pm _ f cl = \bauth -> hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth) {- 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-core-0.15/src/Servant/Client/Core/Internal/Request.hs0000644000000000000000000001276307346545000023604 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} module Servant.Client.Core.Internal.Request where import Prelude () import Prelude.Compat import Control.DeepSeq (NFData (..)) import Control.Monad.Catch (Exception) import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Lazy as LBS import Data.Int (Int64) 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, mainType, parameters, subType) import Network.HTTP.Types (Header, HeaderName, HttpVersion (..), Method, QueryItem, Status (..), http11, methodGet) import Servant.API (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 instance NFData ServantError where rnf (FailureResponse res) = rnf res rnf (DecodeFailure err res) = rnf err `seq` rnf res rnf (UnsupportedContentType mt' res) = mediaTypeRnf mt' `seq` rnf res where mediaTypeRnf mt = rnf (mainType mt) `seq` rnf (subType mt) `seq` rnf (parameters mt) rnf (InvalidContentTypeHeader res) = rnf res rnf (ConnectionError err) = rnf err 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 (Generic, Typeable) type Request = RequestF Builder.Builder -- | The request body. A replica of the @http-client@ @RequestBody@. data RequestBody = RequestBodyLBS LBS.ByteString | RequestBodyBS BS.ByteString | RequestBodyBuilder Int64 Builder.Builder | RequestBodyStream Int64 ((IO BS.ByteString -> IO ()) -> IO ()) | RequestBodyStreamChunked ((IO BS.ByteString -> IO ()) -> IO ()) | RequestBodyIO (IO RequestBody) deriving (Generic, Typeable) data GenResponse a = Response { responseStatusCode :: Status , responseHeaders :: Seq.Seq Header , responseHttpVersion :: HttpVersion , responseBody :: a } deriving (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable) instance NFData a => NFData (GenResponse a) where rnf (Response sc hs hv body) = rnfStatus sc `seq` rnf hs `seq` rnfHttpVersion hv `seq` rnf body where rnfStatus (Status code msg) = rnf code `seq` rnf msg rnfHttpVersion (HttpVersion _ _) = () -- HttpVersion fields are strict type Response = GenResponse LBS.ByteString type StreamingResponse = GenResponse (IO BS.ByteString) -- 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) } servant-client-core-0.15/src/Servant/Client/Core/Internal/RunClient.hs0000644000000000000000000000472607346545000024057 0ustar0000000000000000{-# 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 Control.Monad.Free (Free (..), liftF) 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.ClientF import Servant.Client.Core.Internal.Request (GenResponse (..), Request, Response, ServantError (..), StreamingResponse) class Monad m => RunClient m where -- | How to make a request. runRequest :: Request -> m Response throwServantError :: ServantError -> m a class RunClient m => RunStreamingClient m where withStreamingRequest :: Request -> (StreamingResponse -> IO 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 instance ClientF ~ f => RunClient (Free f) where runRequest req = liftF (RunRequest req id) throwServantError = liftF . Throw {- Free and streaming? instance ClientF ~ f => RunStreamingClient (Free f) where streamingRequest req = liftF (StreamingRequest req id) -} servant-client-core-0.15/src/Servant/Client/Core/0000755000000000000000000000000007346545000020033 5ustar0000000000000000servant-client-core-0.15/src/Servant/Client/Core/Reexport.hs0000644000000000000000000000143207346545000022177 0ustar0000000000000000-- | 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 , StreamingResponse , GenResponse(..) -- * 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.Generic import Servant.Client.Core.Internal.HasClient import Servant.Client.Core.Internal.Request servant-client-core-0.15/src/Servant/Client/Free.hs0000644000000000000000000000112507346545000020357 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} module Servant.Client.Free ( client, ClientF (..), module Servant.Client.Core.Reexport, ) where import Control.Monad.Free import Data.Proxy (Proxy (..)) import Servant.Client.Core import Servant.Client.Core.Internal.ClientF import Servant.Client.Core.Reexport client :: HasClient (Free ClientF) api => Proxy api -> Client (Free ClientF) api client api = api `clientIn` (Proxy :: Proxy (Free ClientF)) servant-client-core-0.15/src/Servant/Client/Generic.hs0000644000000000000000000000305007346545000021051 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} module Servant.Client.Generic ( AsClientT, genericClient, genericClientHoist, ) where import Data.Proxy (Proxy (..)) import Servant.API.Generic import Servant.Client.Core -- | A type that specifies that an API reocrd contains a client implementation. data AsClientT (m :: * -> *) instance GenericMode (AsClientT m) where type AsClientT m :- api = Client m api -- | Generate a record of client functions. genericClient :: forall routes m. ( HasClient m (ToServantApi routes) , GenericServant routes (AsClientT m) , Client m (ToServantApi routes) ~ ToServant routes (AsClientT m) ) => routes (AsClientT m) genericClient = fromServant $ clientIn (Proxy :: Proxy (ToServantApi routes)) (Proxy :: Proxy m) -- | 'genericClient' but with 'hoistClientMonad' in between. genericClientHoist :: forall routes m n. ( HasClient m (ToServantApi routes) , GenericServant routes (AsClientT n) , Client n (ToServantApi routes) ~ ToServant routes (AsClientT n) ) => (forall x. m x -> n x) -- ^ natural transformation -> routes (AsClientT n) genericClientHoist nt = fromServant $ hoistClientMonad m api nt $ clientIn api m where m = Proxy :: Proxy m api = Proxy :: Proxy (ToServantApi routes) servant-client-core-0.15/test/Servant/Client/Core/Internal/0000755000000000000000000000000007346545000021777 5ustar0000000000000000servant-client-core-0.15/test/Servant/Client/Core/Internal/BaseUrlSpec.hs0000644000000000000000000000545107346545000024510 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.Client.Core.Internal.BaseUrlSpec (spec) where import Control.DeepSeq import Prelude () import Prelude.Compat import Test.Hspec import Test.QuickCheck import Servant.Client.Core.Internal.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 servant-client-core-0.15/test/0000755000000000000000000000000007346545000014473 5ustar0000000000000000servant-client-core-0.15/test/Spec.hs0000644000000000000000000000005407346545000015720 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-}