From 26656935299643d6f566bae8eda74ece26388f24 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Mon, 28 Aug 2017 18:36:05 +0200 Subject: [PATCH 01/26] extract module for http-client --- servant-client/servant-client.cabal | 1 + servant-client/src/Servant/Client.hs | 1 + .../src/Servant/Client/HttpClient.hs | 130 ++++++++++++++++++ servant-client/src/Servant/Common/Req.hs | 104 +------------- servant-client/test/Servant/ClientSpec.hs | 1 + 5 files changed, 134 insertions(+), 103 deletions(-) create mode 100644 servant-client/src/Servant/Client/HttpClient.hs diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 6e2c6499..ba1d5f36 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -30,6 +30,7 @@ source-repository head library exposed-modules: Servant.Client + Servant.Client.HttpClient Servant.Client.Generic Servant.Client.Experimental.Auth Servant.Common.BaseUrl diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index b79fcf08..af97db54 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -42,6 +42,7 @@ import Prelude () import Prelude.Compat import Servant.API import Servant.Client.Experimental.Auth +import Servant.Client.HttpClient import Servant.Common.BaseUrl import Servant.Common.BasicAuth import Servant.Common.Req diff --git a/servant-client/src/Servant/Client/HttpClient.hs b/servant-client/src/Servant/Client/HttpClient.hs new file mode 100644 index 00000000..aead1489 --- /dev/null +++ b/servant-client/src/Servant/Client/HttpClient.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-| http-client based client requests executor -} +module Servant.Client.HttpClient 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 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 Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any) +import Data.String.Conversions (cs) +import Data.Proxy +import Network.HTTP.Media +import Network.HTTP.Types +import Network.HTTP.Client hiding (Proxy, path) +import qualified Network.HTTP.Types.Header as HTTP +import Servant.API.ContentTypes +import Servant.Common.BaseUrl +import Servant.Common.Req + +import qualified Network.HTTP.Client as Client + + +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) diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index 88d1d001..94997eaf 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -13,38 +13,23 @@ 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 Control.Monad.Catch (MonadThrow) 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 @@ -196,90 +181,3 @@ parseRequest url = liftM disableStatusCheck (parseUrl url) 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) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 14e9f917..15bc098d 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -58,6 +58,7 @@ import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Client import Servant.Client.Generic import qualified Servant.Common.Req as SCR +import qualified Servant.Client.HttpClient as SCR import Servant.Server import Servant.Server.Experimental.Auth From 175c9532f1cdb1d1325713fe25f63636c1f1c056 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Mon, 28 Aug 2017 19:27:05 +0200 Subject: [PATCH 02/26] [wip] expose client runner as a typeclass --- servant-client/src/Servant/Client.hs | 100 +++++++++--------- servant-client/src/Servant/Client/Class.hs | 15 +++ .../src/Servant/Client/HttpClient.hs | 12 +++ 3 files changed, 78 insertions(+), 49 deletions(-) create mode 100644 servant-client/src/Servant/Client/Class.hs diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index af97db54..c6e7017a 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -43,6 +44,7 @@ import Prelude.Compat import Servant.API import Servant.Client.Experimental.Auth import Servant.Client.HttpClient +import Servant.Client.Class import Servant.Common.BaseUrl import Servant.Common.BasicAuth import Servant.Common.Req @@ -60,15 +62,15 @@ import Servant.Common.Req -- > getAllBooks :: ClientM [Book] -- > postNewBook :: Book -> ClientM Book -- > (getAllBooks :<|> postNewBook) = client myApi -client :: HasClient api => Proxy api -> Client api +client :: HasClient api => Proxy api -> Client m 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 + type Client (m :: * -> *) (api :: *) :: * + clientWithRoute :: Proxy api -> Req -> Client m api -- | A client querying function for @a ':<|>' b@ will actually hand you @@ -85,7 +87,7 @@ class HasClient api where -- > 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 + type Client m (a :<|> b) = Client m a :<|> Client m b clientWithRoute Proxy req = clientWithRoute (Proxy :: Proxy a) req :<|> clientWithRoute (Proxy :: Proxy b) req @@ -104,7 +106,7 @@ data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum) -- > getAllBooks :: ClientM [Book] -- > (getAllBooks :<|> EmptyClient) = client myApi instance HasClient EmptyAPI where - type Client EmptyAPI = EmptyClient + type Client m EmptyAPI = EmptyClient clientWithRoute Proxy _ = EmptyClient -- | If you use a 'Capture' in one of your endpoints in your API, @@ -129,8 +131,8 @@ instance HasClient EmptyAPI where instance (KnownSymbol capture, ToHttpApiData a, HasClient api) => HasClient (Capture capture a :> api) where - type Client (Capture capture a :> api) = - a -> Client api + type Client m (Capture capture a :> api) = + a -> Client m api clientWithRoute Proxy req val = clientWithRoute (Proxy :: Proxy api) @@ -161,8 +163,8 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient api) instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout) => HasClient (CaptureAll capture a :> sublayout) where - type Client (CaptureAll capture a :> sublayout) = - [a] -> Client sublayout + type Client m (CaptureAll capture a :> sublayout) = + [a] -> Client m sublayout clientWithRoute Proxy req vals = clientWithRoute (Proxy :: Proxy sublayout) @@ -172,42 +174,42 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout) instance OVERLAPPABLE_ -- Note [Non-Empty Content Types] - (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) + (RunClient m ct ([H.Header], a), MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) ) => HasClient (Verb method status cts' a) where - type Client (Verb method status cts' a) = ClientM a + type Client m (Verb method status cts' a) = m a clientWithRoute Proxy req = do - snd <$> performRequestCT (Proxy :: Proxy ct) method req + snd <$> runRequest (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 + (RunClient m NoContent [H.Header], ReflectMethod method) => HasClient (Verb method status cts NoContent) where + type Client m (Verb method status cts NoContent) + = m NoContent clientWithRoute Proxy req = do - performRequestNoBody method req >> return NoContent + runRequest (Proxy :: Proxy NoContent) 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) + ( RunClient m ct ([H.Header], a), 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) + type Client m (Verb method status cts' (Headers ls a)) + = m (Headers ls a) clientWithRoute Proxy req = do let method = reflectMethod (Proxy :: Proxy method) - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req + (hdrs, resp) <- runRequest (Proxy :: Proxy ct) method req return $ Headers { getResponse = resp , getHeadersHList = buildHeadersTo hdrs } instance OVERLAPPING_ - ( BuildHeadersTo ls, ReflectMethod method + ( RunClient m NoContent [H.Header], 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) + type Client m (Verb method status cts (Headers ls NoContent)) + = m (Headers ls NoContent) clientWithRoute Proxy req = do let method = reflectMethod (Proxy :: Proxy method) - hdrs <- performRequestNoBody method req + hdrs <- runRequest method req return $ Headers { getResponse = NoContent , getHeadersHList = buildHeadersTo hdrs } @@ -241,8 +243,8 @@ instance OVERLAPPING_ instance (KnownSymbol sym, ToHttpApiData a, HasClient api) => HasClient (Header sym a :> api) where - type Client (Header sym a :> api) = - Maybe a -> Client api + type Client m (Header sym a :> api) = + Maybe a -> Client m api clientWithRoute Proxy req mval = clientWithRoute (Proxy :: Proxy api) @@ -258,21 +260,21 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient api) instance HasClient api => HasClient (HttpVersion :> api) where - type Client (HttpVersion :> api) = - Client api + type Client m (HttpVersion :> api) = + Client m api clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy api) -- | Ignore @'Summary'@ in client functions. instance HasClient api => HasClient (Summary desc :> api) where - type Client (Summary desc :> api) = Client api + type Client m (Summary desc :> api) = Client m api clientWithRoute _ = clientWithRoute (Proxy :: Proxy api) -- | Ignore @'Description'@ in client functions. instance HasClient api => HasClient (Description desc :> api) where - type Client (Description desc :> api) = Client api + type Client m (Description desc :> api) = Client m api clientWithRoute _ = clientWithRoute (Proxy :: Proxy api) @@ -304,8 +306,8 @@ instance HasClient api => HasClient (Description desc :> api) where instance (KnownSymbol sym, ToHttpApiData a, HasClient api) => HasClient (QueryParam sym a :> api) where - type Client (QueryParam sym a :> api) = - Maybe a -> Client api + type Client m (QueryParam sym a :> api) = + Maybe a -> Client m api -- if mparam = Nothing, we don't add it to the query string clientWithRoute Proxy req mparam = @@ -349,8 +351,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient api) instance (KnownSymbol sym, ToHttpApiData a, HasClient api) => HasClient (QueryParams sym a :> api) where - type Client (QueryParams sym a :> api) = - [a] -> Client api + type Client m (QueryParams sym a :> api) = + [a] -> Client m api clientWithRoute Proxy req paramlist = clientWithRoute (Proxy :: Proxy api) @@ -387,8 +389,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient api) instance (KnownSymbol sym, HasClient api) => HasClient (QueryFlag sym :> api) where - type Client (QueryFlag sym :> api) = - Bool -> Client api + type Client m (QueryFlag sym :> api) = + Bool -> Client m api clientWithRoute Proxy req flag = clientWithRoute (Proxy :: Proxy api) @@ -403,12 +405,12 @@ instance (KnownSymbol sym, HasClient api) -- | 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) + type Client m Raw + = H.Method -> m (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) clientWithRoute :: Proxy Raw -> Req -> Client Raw clientWithRoute Proxy req httpMethod = do - performRequest httpMethod req + runRequest (Proxy :: Proxy NoContent) httpMethod req -- | If you use a 'ReqBody' in one of your endpoints in your API, -- the corresponding querying function will automatically take @@ -431,8 +433,8 @@ instance HasClient Raw where instance (MimeRender ct a, HasClient api) => HasClient (ReqBody (ct ': cts) a :> api) where - type Client (ReqBody (ct ': cts) a :> api) = - a -> Client api + type Client m (ReqBody (ct ': cts) a :> api) = + a -> Client m api clientWithRoute Proxy req body = clientWithRoute (Proxy :: Proxy api) @@ -445,7 +447,7 @@ instance (MimeRender ct a, HasClient api) -- | 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 + type Client m (path :> api) = Client m api clientWithRoute Proxy req = clientWithRoute (Proxy :: Proxy api) @@ -454,19 +456,19 @@ instance (KnownSymbol path, HasClient api) => HasClient (path :> api) where where p = symbolVal (Proxy :: Proxy path) instance HasClient api => HasClient (Vault :> api) where - type Client (Vault :> api) = Client api + type Client m (Vault :> api) = Client m api clientWithRoute Proxy req = clientWithRoute (Proxy :: Proxy api) req instance HasClient api => HasClient (RemoteHost :> api) where - type Client (RemoteHost :> api) = Client api + type Client m (RemoteHost :> api) = Client m api clientWithRoute Proxy req = clientWithRoute (Proxy :: Proxy api) req instance HasClient api => HasClient (IsSecure :> api) where - type Client (IsSecure :> api) = Client api + type Client m (IsSecure :> api) = Client m api clientWithRoute Proxy req = clientWithRoute (Proxy :: Proxy api) req @@ -474,13 +476,13 @@ instance HasClient api => HasClient (IsSecure :> api) where instance HasClient subapi => HasClient (WithNamedContext name context subapi) where - type Client (WithNamedContext name context subapi) = Client subapi + type Client m (WithNamedContext name context subapi) = Client m 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 + type Client m (AuthProtect tag :> api) + = AuthenticateReq (AuthProtect tag) -> Client m api clientWithRoute Proxy req (AuthenticateReq (val,func)) = clientWithRoute (Proxy :: Proxy api) (func val req) @@ -488,7 +490,7 @@ instance ( HasClient api -- * Basic Authentication instance HasClient api => HasClient (BasicAuth realm usr :> api) where - type Client (BasicAuth realm usr :> api) = BasicAuthData -> Client api + type Client m (BasicAuth realm usr :> api) = BasicAuthData -> Client m api clientWithRoute Proxy req val = clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req) diff --git a/servant-client/src/Servant/Client/Class.hs b/servant-client/src/Servant/Client/Class.hs new file mode 100644 index 00000000..e880188f --- /dev/null +++ b/servant-client/src/Servant/Client/Class.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-| Types for possible backends to run client-side `Req` queries -} +module Servant.Client.Class + (RunClient(..)) +where + +import Data.Proxy +import Network.HTTP.Types +import Servant.API +import Servant.Common.Req + +class (Monad m) => RunClient m ct result where + runRequest :: MimeUnrender ct result + => Proxy ct + -> Method -> Req -> m result diff --git a/servant-client/src/Servant/Client/HttpClient.hs b/servant-client/src/Servant/Client/HttpClient.hs index aead1489..3d972db7 100644 --- a/servant-client/src/Servant/Client/HttpClient.hs +++ b/servant-client/src/Servant/Client/HttpClient.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} @@ -36,11 +37,22 @@ import Network.HTTP.Types import Network.HTTP.Client hiding (Proxy, path) import qualified Network.HTTP.Types.Header as HTTP import Servant.API.ContentTypes +import Servant.Client.Class import Servant.Common.BaseUrl import Servant.Common.Req import qualified Network.HTTP.Client as Client +instance RunClient ClientM NoContent ( Int, ByteString, MediaType + , [HTTP.Header], Response ByteString) where + runRequest _ meth req = performRequest meth req + +instance (MimeUnrender ct a) => + RunClient ClientM ct ([HTTP.Header], a) where + runRequest p meth req = performRequestCT p meth req + +instance RunClient ClientM NoContent [HTTP.Header] where + runRequest _ meth req = performRequestNoBody meth req data ClientEnv = ClientEnv From 5e2c48b08fd7725dd6ea4bd035c2cf8a22846a83 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Sun, 3 Sep 2017 08:49:24 +0200 Subject: [PATCH 03/26] expose client runner as a typeclass with base implementation #798 * defined a typeclass abstracting the execution of a query * provide ClientM-based instances for this typeclass * changed signature of client and clientWithRoute to add proxy for context * updated tests --- servant-client/servant-client.cabal | 1 + servant-client/src/Servant/Client.hs | 199 +++++++++++---------- servant-client/src/Servant/Client/Class.hs | 7 +- servant-client/test/Servant/ClientSpec.hs | 36 ++-- 4 files changed, 126 insertions(+), 117 deletions(-) diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index ba1d5f36..e2e85d45 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -30,6 +30,7 @@ source-repository head library exposed-modules: Servant.Client + Servant.Client.Class Servant.Client.HttpClient Servant.Client.Generic Servant.Client.Experimental.Auth diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index c6e7017a..a1a7b3ad 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -1,15 +1,16 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} #include "overlapping-compat.h" -- | This module provides 'client' which can automatically generate @@ -62,15 +63,15 @@ import Servant.Common.Req -- > getAllBooks :: ClientM [Book] -- > postNewBook :: Book -> ClientM Book -- > (getAllBooks :<|> postNewBook) = client myApi -client :: HasClient api => Proxy api -> Client m api -client p = clientWithRoute p defReq +client :: HasClient m api => Proxy m -> Proxy api -> Client m api +client pm p = clientWithRoute pm 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 +class HasClient m api where type Client (m :: * -> *) (api :: *) :: * - clientWithRoute :: Proxy api -> Req -> Client m api + clientWithRoute :: Proxy m -> Proxy api -> Req -> Client m api -- | A client querying function for @a ':<|>' b@ will actually hand you @@ -86,11 +87,11 @@ class HasClient api where -- > getAllBooks :: ClientM [Book] -- > postNewBook :: Book -> ClientM Book -- > (getAllBooks :<|> postNewBook) = client myApi -instance (HasClient a, HasClient b) => HasClient (a :<|> b) where +instance (HasClient m a, HasClient m b) => HasClient m (a :<|> b) where type Client m (a :<|> b) = Client m a :<|> Client m b - clientWithRoute Proxy req = - clientWithRoute (Proxy :: Proxy a) req :<|> - clientWithRoute (Proxy :: Proxy b) req + clientWithRoute pm Proxy req = + clientWithRoute pm (Proxy :: Proxy a) req :<|> + clientWithRoute pm (Proxy :: Proxy b) req -- | Singleton type representing a client for an empty API. data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum) @@ -105,9 +106,9 @@ data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum) -- > -- > getAllBooks :: ClientM [Book] -- > (getAllBooks :<|> EmptyClient) = client myApi -instance HasClient EmptyAPI where +instance HasClient m EmptyAPI where type Client m EmptyAPI = EmptyClient - clientWithRoute Proxy _ = EmptyClient + clientWithRoute pm Proxy _ = EmptyClient -- | If you use a 'Capture' in one of your endpoints in your API, -- the corresponding querying function will automatically take @@ -128,14 +129,14 @@ instance HasClient EmptyAPI where -- > 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 +instance (KnownSymbol capture, ToHttpApiData a, HasClient m api) + => HasClient m (Capture capture a :> api) where type Client m (Capture capture a :> api) = a -> Client m api - clientWithRoute Proxy req val = - clientWithRoute (Proxy :: Proxy api) + clientWithRoute pm Proxy req val = + clientWithRoute pm (Proxy :: Proxy api) (appendToPath p req) where p = unpack (toUrlPiece val) @@ -160,14 +161,14 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient api) -- > 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 +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 Proxy req vals = - clientWithRoute (Proxy :: Proxy sublayout) + clientWithRoute pm Proxy req vals = + clientWithRoute pm (Proxy :: Proxy sublayout) (foldl' (flip appendToPath) req ps) where ps = map (unpack . toUrlPiece) vals @@ -175,27 +176,31 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout) instance OVERLAPPABLE_ -- Note [Non-Empty Content Types] (RunClient m ct ([H.Header], a), MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) - ) => HasClient (Verb method status cts' a) where + ) => HasClient m (Verb method status cts' a) where type Client m (Verb method status cts' a) = m a - clientWithRoute Proxy req = do - snd <$> runRequest (Proxy :: Proxy ct) method req + clientWithRoute pm Proxy req = do + (_hdrs, a) :: ([H.Header], a) <- runRequest (Proxy :: Proxy ct) method req + return a where method = reflectMethod (Proxy :: Proxy method) instance OVERLAPPING_ - (RunClient m NoContent [H.Header], ReflectMethod method) => HasClient (Verb method status cts NoContent) where + ( RunClient m NoContent [HTTP.Header] + , ReflectMethod method) => HasClient m (Verb method status cts NoContent) where type Client m (Verb method status cts NoContent) = m NoContent - clientWithRoute Proxy req = do - runRequest (Proxy :: Proxy NoContent) method req >> return NoContent + clientWithRoute pm Proxy req = do + _hdrs :: [H.Header] <- runRequest (Proxy :: Proxy NoContent) method req + return NoContent where method = reflectMethod (Proxy :: Proxy method) instance OVERLAPPING_ -- Note [Non-Empty Content Types] - ( RunClient m ct ([H.Header], a), MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts) - ) => HasClient (Verb method status cts' (Headers ls a)) where + ( RunClient m ct ([H.Header], a) + , 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 Proxy req = do + clientWithRoute pm Proxy req = do let method = reflectMethod (Proxy :: Proxy method) (hdrs, resp) <- runRequest (Proxy :: Proxy ct) method req return $ Headers { getResponse = resp @@ -203,13 +208,14 @@ instance OVERLAPPING_ } instance OVERLAPPING_ - ( RunClient m NoContent [H.Header], BuildHeadersTo ls, ReflectMethod method - ) => HasClient (Verb method status cts (Headers ls NoContent)) where + ( RunClient m NoContent [H.Header] + , 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 Proxy req = do + clientWithRoute pm Proxy req = do let method = reflectMethod (Proxy :: Proxy method) - hdrs <- runRequest method req + hdrs <- runRequest (Proxy :: Proxy NoContent) method req return $ Headers { getResponse = NoContent , getHeadersHList = buildHeadersTo hdrs } @@ -240,14 +246,14 @@ instance OVERLAPPING_ -- > 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 +instance (KnownSymbol sym, ToHttpApiData a, HasClient m api) + => HasClient m (Header sym a :> api) where type Client m (Header sym a :> api) = Maybe a -> Client m api - clientWithRoute Proxy req mval = - clientWithRoute (Proxy :: Proxy api) + clientWithRoute pm Proxy req mval = + clientWithRoute pm (Proxy :: Proxy api) (maybe req (\value -> Servant.Common.Req.addHeader hname value req) mval @@ -257,26 +263,26 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient api) -- | Using a 'HttpVersion' combinator in your API doesn't affect the client -- functions. -instance HasClient api - => HasClient (HttpVersion :> api) where +instance HasClient m api + => HasClient m (HttpVersion :> api) where type Client m (HttpVersion :> api) = Client m api - clientWithRoute Proxy = - clientWithRoute (Proxy :: Proxy api) + clientWithRoute pm Proxy = + clientWithRoute pm (Proxy :: Proxy api) -- | Ignore @'Summary'@ in client functions. -instance HasClient api => HasClient (Summary desc :> api) where +instance HasClient m api => HasClient m (Summary desc :> api) where type Client m (Summary desc :> api) = Client m api - clientWithRoute _ = clientWithRoute (Proxy :: Proxy api) + clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api) -- | Ignore @'Description'@ in client functions. -instance HasClient api => HasClient (Description desc :> api) where +instance HasClient m api => HasClient m (Description desc :> api) where type Client m (Description desc :> api) = Client m api - clientWithRoute _ = clientWithRoute (Proxy :: Proxy api) + clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api) -- | If you use a 'QueryParam' in one of your endpoints in your API, -- the corresponding querying function will automatically take @@ -303,15 +309,15 @@ instance HasClient api => HasClient (Description desc :> api) where -- > -- 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 +instance (KnownSymbol sym, ToHttpApiData a, HasClient m api) + => HasClient m (QueryParam sym a :> api) where type Client m (QueryParam sym a :> api) = Maybe a -> Client m api -- if mparam = Nothing, we don't add it to the query string - clientWithRoute Proxy req mparam = - clientWithRoute (Proxy :: Proxy api) + clientWithRoute pm Proxy req mparam = + clientWithRoute pm (Proxy :: Proxy api) (maybe req (flip (appendToQueryString pname) req . Just) mparamText @@ -348,14 +354,14 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient api) -- > -- '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 +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 Proxy req paramlist = - clientWithRoute (Proxy :: Proxy api) + clientWithRoute pm Proxy req paramlist = + clientWithRoute pm (Proxy :: Proxy api) (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) req paramlist' @@ -386,14 +392,14 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient api) -- > -- 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 +instance (KnownSymbol sym, HasClient m api) + => HasClient m (QueryFlag sym :> api) where type Client m (QueryFlag sym :> api) = Bool -> Client m api - clientWithRoute Proxy req flag = - clientWithRoute (Proxy :: Proxy api) + clientWithRoute pm Proxy req flag = + clientWithRoute pm (Proxy :: Proxy api) (if flag then appendToQueryString paramname Nothing req else req @@ -404,12 +410,13 @@ instance (KnownSymbol sym, HasClient api) -- | Pick a 'Method' and specify where the server you want to query is. You get -- back the full `Response`. -instance HasClient Raw where +instance (RunClient m NoContent (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)) + => HasClient m Raw where type Client m Raw = H.Method -> m (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) - clientWithRoute :: Proxy Raw -> Req -> Client Raw - clientWithRoute Proxy req httpMethod = do + clientWithRoute :: Proxy m -> Proxy Raw -> Req -> Client m Raw + clientWithRoute pm Proxy req httpMethod = do runRequest (Proxy :: Proxy NoContent) httpMethod req -- | If you use a 'ReqBody' in one of your endpoints in your API, @@ -430,14 +437,14 @@ instance HasClient Raw where -- > 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 +instance (MimeRender ct a, HasClient m api) + => HasClient m (ReqBody (ct ': cts) a :> api) where type Client m (ReqBody (ct ': cts) a :> api) = a -> Client m api - clientWithRoute Proxy req body = - clientWithRoute (Proxy :: Proxy api) + clientWithRoute pm Proxy req body = + clientWithRoute pm (Proxy :: Proxy api) (let ctProxy = Proxy :: Proxy ct in setReqBodyLBS (mimeRender ctProxy body) -- We use first contentType from the Accept list @@ -446,54 +453,54 @@ instance (MimeRender ct a, HasClient api) ) -- | Make the querying function append @path@ to the request path. -instance (KnownSymbol path, HasClient api) => HasClient (path :> api) where +instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where type Client m (path :> api) = Client m api - clientWithRoute Proxy req = - clientWithRoute (Proxy :: Proxy api) + clientWithRoute pm Proxy req = + clientWithRoute pm (Proxy :: Proxy api) (appendToPath p req) where p = symbolVal (Proxy :: Proxy path) -instance HasClient api => HasClient (Vault :> api) where +instance HasClient m api => HasClient m (Vault :> api) where type Client m (Vault :> api) = Client m api - clientWithRoute Proxy req = - clientWithRoute (Proxy :: Proxy api) req + clientWithRoute pm Proxy req = + clientWithRoute pm (Proxy :: Proxy api) req -instance HasClient api => HasClient (RemoteHost :> api) where +instance HasClient m api => HasClient m (RemoteHost :> api) where type Client m (RemoteHost :> api) = Client m api - clientWithRoute Proxy req = - clientWithRoute (Proxy :: Proxy api) req + clientWithRoute pm Proxy req = + clientWithRoute pm (Proxy :: Proxy api) req -instance HasClient api => HasClient (IsSecure :> api) where +instance HasClient m api => HasClient m (IsSecure :> api) where type Client m (IsSecure :> api) = Client m api - clientWithRoute Proxy req = - clientWithRoute (Proxy :: Proxy api) req + clientWithRoute pm Proxy req = + clientWithRoute pm (Proxy :: Proxy api) req -instance HasClient subapi => - HasClient (WithNamedContext name context subapi) where +instance HasClient m subapi => + HasClient m (WithNamedContext name context subapi) where type Client m (WithNamedContext name context subapi) = Client m subapi - clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi) + clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi) -instance ( HasClient api - ) => HasClient (AuthProtect tag :> api) where +instance ( HasClient m api + ) => HasClient m (AuthProtect tag :> api) where type Client m (AuthProtect tag :> api) = AuthenticateReq (AuthProtect tag) -> Client m api - clientWithRoute Proxy req (AuthenticateReq (val,func)) = - clientWithRoute (Proxy :: Proxy api) (func val req) + clientWithRoute pm Proxy req (AuthenticateReq (val,func)) = + clientWithRoute pm (Proxy :: Proxy api) (func val req) -- * Basic Authentication -instance HasClient api => HasClient (BasicAuth realm usr :> api) where +instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where type Client m (BasicAuth realm usr :> api) = BasicAuthData -> Client m api - clientWithRoute Proxy req val = - clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req) + clientWithRoute pm Proxy req val = + clientWithRoute pm (Proxy :: Proxy api) (basicAuthReq val req) {- Note [Non-Empty Content Types] diff --git a/servant-client/src/Servant/Client/Class.hs b/servant-client/src/Servant/Client/Class.hs index e880188f..921352fa 100644 --- a/servant-client/src/Servant/Client/Class.hs +++ b/servant-client/src/Servant/Client/Class.hs @@ -10,6 +10,7 @@ import Servant.API import Servant.Common.Req class (Monad m) => RunClient m ct result where - runRequest :: MimeUnrender ct result - => Proxy ct - -> Method -> Req -> m result + runRequest :: Proxy ct + -> Method + -> Req + -> m result diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 15bc098d..602e1d59 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -63,7 +63,7 @@ import Servant.Server import Servant.Server.Experimental.Auth -- This declaration simply checks that all instances are in place. -_ = client comprehensiveAPI +_ = client (Proxy :: Proxy ClientM) comprehensiveAPI spec :: Spec spec = describe "Servant.Client" $ do @@ -147,7 +147,7 @@ getGet :<|> getMultiple :<|> getRespHeaders :<|> getDeleteContentType - :<|> EmptyClient = client api + :<|> EmptyClient = client (Proxy :: Proxy ClientM) api server :: Application server = serve api ( @@ -241,7 +241,7 @@ data GenericClient = GenericClient , mkNestedClient1 :: String -> NestedClient1 } deriving Generic instance SOP.Generic GenericClient -instance (Client GenericClientAPI ~ client) => ClientLike client GenericClient +instance (Client ClientM GenericClientAPI ~ client) => ClientLike client GenericClient type NestedAPI1 = QueryParam "int" Int :> NestedAPI2 @@ -252,7 +252,7 @@ data NestedClient1 = NestedClient1 , idChar :: Maybe Char -> SCR.ClientM Char } deriving Generic instance SOP.Generic NestedClient1 -instance (Client NestedAPI1 ~ client) => ClientLike client NestedClient1 +instance (Client ClientM NestedAPI1 ~ client) => ClientLike client NestedClient1 type NestedAPI2 = "sum" :> Capture "first" Int :> Capture "second" Int :> Get '[JSON] Int @@ -263,7 +263,7 @@ data NestedClient2 = NestedClient2 , doNothing :: SCR.ClientM () } deriving Generic instance SOP.Generic NestedClient2 -instance (Client NestedAPI2 ~ client) => ClientLike client NestedClient2 +instance (Client ClientM NestedAPI2 ~ client) => ClientLike client NestedClient2 genericClientServer :: Application genericClientServer = serve (Proxy :: Proxy GenericClientAPI) ( @@ -359,7 +359,7 @@ wrappedApiSpec = describe "error status codes" $ do test (WrappedApi api, desc) = it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do let getResponse :: SCR.ClientM () - getResponse = client api + getResponse = client (Proxy :: Proxy ClientM) api Left FailureResponse{..} <- runClientM getResponse (ClientEnv manager baseUrl) responseStatus `shouldBe` (HTTP.Status 500 "error message") in mapM_ test $ @@ -374,35 +374,35 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do context "client returns errors appropriately" $ do it "reports FailureResponse" $ \(_, baseUrl) -> do - let (_ :<|> getDeleteEmpty :<|> _) = client api + let (_ :<|> getDeleteEmpty :<|> _) = client (Proxy :: Proxy ClientM) 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 + let (_ :<|> _ :<|> getCapture :<|> _) = client (Proxy :: Proxy ClientM) 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 + let (getGetWrongHost :<|> _) = client (Proxy :: Proxy ClientM) 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 + let (getGet :<|> _ ) = client (Proxy :: Proxy ClientM) 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 + let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client (Proxy :: Proxy ClientM) api Left res <- runClientM (getBody alice) (ClientEnv manager baseUrl) case res of InvalidContentTypeHeader "fooooo" _ -> return () @@ -410,7 +410,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do data WrappedApi where WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a, - HasClient api, Client api ~ SCR.ClientM ()) => + HasClient ClientM api, Client ClientM api ~ SCR.ClientM ()) => Proxy api -> WrappedApi basicAuthSpec :: Spec @@ -418,14 +418,14 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d context "Authentication works when requests are properly authenticated" $ do it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do - let getBasic = client basicAuthAPI + let getBasic = client (Proxy :: Proxy ClientM) 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 getBasic = client (Proxy :: Proxy ClientM) basicAuthAPI let basicAuthData = BasicAuthData "not" "password" Left FailureResponse{..} <- runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl) responseStatus `shouldBe` HTTP.Status 403 "Forbidden" @@ -435,14 +435,14 @@ 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 getProtected = client (Proxy :: Proxy ClientM) 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 getProtected = client (Proxy :: Proxy ClientM) 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") @@ -451,11 +451,11 @@ genericClientSpec :: Spec genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWaiApp $ do describe "Servant.Client.Generic" $ do - let GenericClient{..} = mkClient (client (Proxy :: Proxy GenericClientAPI)) + let GenericClient{..} = mkClient (client (Proxy :: Proxy ClientM) (Proxy :: Proxy GenericClientAPI)) NestedClient1{..} = mkNestedClient1 "example" NestedClient2{..} = mkNestedClient2 (Just 42) - it "works for top-level client function" $ \(_, baseUrl) -> do + it "works for top-level client (Proxy :: Proxy ClientM) function" $ \(_, baseUrl) -> do (left show <$> (runClientM (getSqr (Just 5)) (ClientEnv manager baseUrl))) `shouldReturn` Right 25 it "works for nested clients" $ \(_, baseUrl) -> do From 7480076c919253bbf4da3f97ccf7d62820b9ebb3 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Mon, 4 Sep 2017 08:22:38 +0200 Subject: [PATCH 04/26] cleanup compiler's warnings --- servant-client/src/Servant/Client.hs | 12 ++++++------ servant-client/src/Servant/Client/Class.hs | 1 - 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index a1a7b3ad..25a92c7c 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -108,7 +108,7 @@ data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum) -- > (getAllBooks :<|> EmptyClient) = client myApi instance HasClient m EmptyAPI where type Client m EmptyAPI = EmptyClient - clientWithRoute pm Proxy _ = EmptyClient + clientWithRoute _pm Proxy _ = EmptyClient -- | If you use a 'Capture' in one of your endpoints in your API, -- the corresponding querying function will automatically take @@ -178,7 +178,7 @@ instance OVERLAPPABLE_ (RunClient m ct ([H.Header], a), 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 + clientWithRoute _pm Proxy req = do (_hdrs, a) :: ([H.Header], a) <- runRequest (Proxy :: Proxy ct) method req return a where method = reflectMethod (Proxy :: Proxy method) @@ -188,7 +188,7 @@ instance OVERLAPPING_ , 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 + clientWithRoute _pm Proxy req = do _hdrs :: [H.Header] <- runRequest (Proxy :: Proxy NoContent) method req return NoContent where method = reflectMethod (Proxy :: Proxy method) @@ -200,7 +200,7 @@ instance OVERLAPPING_ ) => 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 + clientWithRoute _pm Proxy req = do let method = reflectMethod (Proxy :: Proxy method) (hdrs, resp) <- runRequest (Proxy :: Proxy ct) method req return $ Headers { getResponse = resp @@ -213,7 +213,7 @@ instance OVERLAPPING_ ) => 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 + clientWithRoute _pm Proxy req = do let method = reflectMethod (Proxy :: Proxy method) hdrs <- runRequest (Proxy :: Proxy NoContent) method req return $ Headers { getResponse = NoContent @@ -416,7 +416,7 @@ instance (RunClient m NoContent (Int, ByteString, MediaType, [HTTP.Header], Resp = H.Method -> m (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) clientWithRoute :: Proxy m -> Proxy Raw -> Req -> Client m Raw - clientWithRoute pm Proxy req httpMethod = do + clientWithRoute _pm Proxy req httpMethod = do runRequest (Proxy :: Proxy NoContent) httpMethod req -- | If you use a 'ReqBody' in one of your endpoints in your API, diff --git a/servant-client/src/Servant/Client/Class.hs b/servant-client/src/Servant/Client/Class.hs index 921352fa..c030486a 100644 --- a/servant-client/src/Servant/Client/Class.hs +++ b/servant-client/src/Servant/Client/Class.hs @@ -6,7 +6,6 @@ where import Data.Proxy import Network.HTTP.Types -import Servant.API import Servant.Common.Req class (Monad m) => RunClient m ct result where From b592b51ed81654a7ee85a4aa8d85ec8286f6cf3e Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Mon, 4 Sep 2017 09:19:08 +0200 Subject: [PATCH 05/26] provide convenience functions for ClientM-based clients --- servant-client/src/Servant/Client.hs | 21 ++++++++++++-- .../src/Servant/Client/HttpClient.hs | 3 -- servant-client/test/Servant/ClientSpec.hs | 28 +++++++++---------- 3 files changed, 32 insertions(+), 20 deletions(-) diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 25a92c7c..beeb589b 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -22,7 +22,7 @@ module Servant.Client , client , HasClient(..) , ClientM - , runClientM + , runClientM, inClientM, clientM , ClientEnv (ClientEnv) , mkAuthenticateReq , ServantError(..) @@ -52,7 +52,8 @@ import Servant.Common.Req -- * Accessing APIs as a Client --- | 'client' allows you to produce operations to query an API from a client. +-- | 'client' allows you to produce operations to query an API from a client within +-- a given monadic context `m` -- -- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books -- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books @@ -60,12 +61,26 @@ import Servant.Common.Req -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > +-- > clientM :: Proxy ClientM +-- > clientM = Proxy +-- > -- > getAllBooks :: ClientM [Book] -- > postNewBook :: Book -> ClientM Book --- > (getAllBooks :<|> postNewBook) = client myApi +-- > (getAllBooks :<|> postNewBook) = client clientM myApi client :: HasClient m api => Proxy m -> Proxy api -> Client m api client pm p = clientWithRoute pm p defReq +-- | Helper proxy to simplify common case of working in `ClientM` monad +inClientM :: Proxy ClientM +inClientM = Proxy + +-- | Convenience method to declare clients running in the `ClientM` monad. +-- +-- Simply pass `inClientM` to `client`.... +clientM :: (HasClient ClientM api) => Proxy api -> Client ClientM api +clientM = client inClientM + + -- | 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'. diff --git a/servant-client/src/Servant/Client/HttpClient.hs b/servant-client/src/Servant/Client/HttpClient.hs index 3d972db7..0934e53e 100644 --- a/servant-client/src/Servant/Client/HttpClient.hs +++ b/servant-client/src/Servant/Client/HttpClient.hs @@ -63,7 +63,6 @@ data ClientEnv -- | @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 @@ -77,10 +76,8 @@ instance MonadBase IO ClientM where 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. diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 602e1d59..49b35769 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -63,7 +63,7 @@ import Servant.Server import Servant.Server.Experimental.Auth -- This declaration simply checks that all instances are in place. -_ = client (Proxy :: Proxy ClientM) comprehensiveAPI +_ = client inClientM comprehensiveAPI spec :: Spec spec = describe "Servant.Client" $ do @@ -147,7 +147,7 @@ getGet :<|> getMultiple :<|> getRespHeaders :<|> getDeleteContentType - :<|> EmptyClient = client (Proxy :: Proxy ClientM) api + :<|> EmptyClient = client inClientM api server :: Application server = serve api ( @@ -359,7 +359,7 @@ wrappedApiSpec = describe "error status codes" $ do test (WrappedApi api, desc) = it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do let getResponse :: SCR.ClientM () - getResponse = client (Proxy :: Proxy ClientM) api + getResponse = client inClientM api Left FailureResponse{..} <- runClientM getResponse (ClientEnv manager baseUrl) responseStatus `shouldBe` (HTTP.Status 500 "error message") in mapM_ test $ @@ -374,35 +374,35 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do context "client returns errors appropriately" $ do it "reports FailureResponse" $ \(_, baseUrl) -> do - let (_ :<|> getDeleteEmpty :<|> _) = client (Proxy :: Proxy ClientM) api + let (_ :<|> getDeleteEmpty :<|> _) = client inClientM 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 (Proxy :: Proxy ClientM) api + let (_ :<|> _ :<|> getCapture :<|> _) = client inClientM 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 (Proxy :: Proxy ClientM) api + let (getGetWrongHost :<|> _) = client inClientM 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 (Proxy :: Proxy ClientM) api + let (getGet :<|> _ ) = client inClientM 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 (Proxy :: Proxy ClientM) api + let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client inClientM api Left res <- runClientM (getBody alice) (ClientEnv manager baseUrl) case res of InvalidContentTypeHeader "fooooo" _ -> return () @@ -418,14 +418,14 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d context "Authentication works when requests are properly authenticated" $ do it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do - let getBasic = client (Proxy :: Proxy ClientM) basicAuthAPI + let getBasic = client inClientM 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 (Proxy :: Proxy ClientM) basicAuthAPI + let getBasic = client inClientM basicAuthAPI let basicAuthData = BasicAuthData "not" "password" Left FailureResponse{..} <- runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl) responseStatus `shouldBe` HTTP.Status 403 "Forbidden" @@ -435,14 +435,14 @@ 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 (Proxy :: Proxy ClientM) genAuthAPI + let getProtected = client inClientM 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 (Proxy :: Proxy ClientM) genAuthAPI + let getProtected = client inClientM 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") @@ -451,11 +451,11 @@ genericClientSpec :: Spec genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWaiApp $ do describe "Servant.Client.Generic" $ do - let GenericClient{..} = mkClient (client (Proxy :: Proxy ClientM) (Proxy :: Proxy GenericClientAPI)) + let GenericClient{..} = mkClient (client inClientM (Proxy :: Proxy GenericClientAPI)) NestedClient1{..} = mkNestedClient1 "example" NestedClient2{..} = mkNestedClient2 (Just 42) - it "works for top-level client (Proxy :: Proxy ClientM) function" $ \(_, baseUrl) -> do + it "works for top-level client inClientM function" $ \(_, baseUrl) -> do (left show <$> (runClientM (getSqr (Just 5)) (ClientEnv manager baseUrl))) `shouldReturn` Right 25 it "works for nested clients" $ \(_, baseUrl) -> do From 95fac329a62603c16dd2163af0dd0bc8d2bf30b4 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 6 Sep 2017 14:13:05 -0700 Subject: [PATCH 06/26] Rewrite servant-client. This commit begins the reorganization of the servant-client project so as to allow multiple backends, and also begins some much-needed refactoring of the servant-client code. --- servant-client-core/CHANGELOG.md | 5 + servant-client-core/LICENSE | 30 +++ servant-client-core/Setup.hs | 2 + .../include/overlapping-compat.h | 8 + servant-client-core/servant-client-core.cabal | 40 ++++ .../src/Servant/Client/Core/Internal}/Auth.hs | 6 +- .../Servant/Client/Core/Internal}/BaseUrl.hs | 0 .../Client/Core/Internal}/BasicAuth.hs | 4 +- .../src/Servant/Client/Core/Internal/Class.hs | 13 ++ .../Servant/Client/Core/Internal}/Generic.hs | 0 .../Servant/Client/Core/Internal/Request.hs | 146 ++++++++++++++ servant-client/servant-client.cabal | 1 + servant-client/src/Servant/Client/Class.hs | 15 -- .../src/Servant/Client/HttpClient.hs | 57 +++--- servant-client/src/Servant/Common/Req.hs | 183 ------------------ 15 files changed, 277 insertions(+), 233 deletions(-) create mode 100644 servant-client-core/CHANGELOG.md create mode 100644 servant-client-core/LICENSE create mode 100644 servant-client-core/Setup.hs create mode 100644 servant-client-core/include/overlapping-compat.h create mode 100644 servant-client-core/servant-client-core.cabal rename {servant-client/src/Servant/Client/Experimental => servant-client-core/src/Servant/Client/Core/Internal}/Auth.hs (89%) rename {servant-client/src/Servant/Common => servant-client-core/src/Servant/Client/Core/Internal}/BaseUrl.hs (100%) rename {servant-client/src/Servant/Common => servant-client-core/src/Servant/Client/Core/Internal}/BasicAuth.hs (85%) create mode 100644 servant-client-core/src/Servant/Client/Core/Internal/Class.hs rename {servant-client/src/Servant/Client => servant-client-core/src/Servant/Client/Core/Internal}/Generic.hs (100%) create mode 100644 servant-client-core/src/Servant/Client/Core/Internal/Request.hs delete mode 100644 servant-client/src/Servant/Client/Class.hs delete mode 100644 servant-client/src/Servant/Common/Req.hs diff --git a/servant-client-core/CHANGELOG.md b/servant-client-core/CHANGELOG.md new file mode 100644 index 00000000..457587e2 --- /dev/null +++ b/servant-client-core/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for servant-client-core + +## 0.11 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/servant-client-core/LICENSE b/servant-client-core/LICENSE new file mode 100644 index 00000000..04bba964 --- /dev/null +++ b/servant-client-core/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017, Servant Contributors + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Servant Contributors nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/servant-client-core/Setup.hs b/servant-client-core/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/servant-client-core/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-client-core/include/overlapping-compat.h b/servant-client-core/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-client-core/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal new file mode 100644 index 00000000..e3083239 --- /dev/null +++ b/servant-client-core/servant-client-core.cabal @@ -0,0 +1,40 @@ +name: servant-client-core +version: 0.11 +synopsis: Core functionality and class for client function generation for servant APIs +description: + This library provides a class +license: BSD3 +license-file: LICENSE +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +homepage: http://haskell-servant.readthedocs.org/ +bug-reports: http://github.com/haskell-servant/servant/issues +-- copyright: +category: Web +build-type: Simple +extra-source-files: + include/*.h + CHANGELOG.md + README.md +source-repository head + type: git + location: http://github.com/haskell-servant/servant.git +cabal-version: >=1.10 + +library + exposed-modules: + build-depends: + base >= 4.7 && < 4.11 + , base-compat >= 0.9.1 && < 0.10 + hs-source-dirs: src + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + ghc-options: -Wall + default-language: Haskell2010 + hs-source-dirs: test + main-is: Spec.hs + other-modules: + build-depends: + base == 4.* diff --git a/servant-client/src/Servant/Client/Experimental/Auth.hs b/servant-client-core/src/Servant/Client/Core/Internal/Auth.hs similarity index 89% rename from servant-client/src/Servant/Client/Experimental/Auth.hs rename to servant-client-core/src/Servant/Client/Core/Internal/Auth.hs index a98d0b41..b9bb70e6 100644 --- a/servant-client/src/Servant/Client/Experimental/Auth.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Auth.hs @@ -10,7 +10,7 @@ module Servant.Client.Experimental.Auth ( , mkAuthenticateReq ) where -import Servant.Common.Req (Req) +import Servant.Common.Req (Request) -- | For a resource protected by authentication (e.g. AuthProtect), we need -- to provide the client with some data used to add authentication data @@ -25,12 +25,12 @@ type family AuthClientData a :: * -- -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE newtype AuthenticateReq a = - AuthenticateReq { unAuthReq :: (AuthClientData a, AuthClientData a -> Req -> Req) } + AuthenticateReq { 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 mkAuthenticateReq :: AuthClientData a - -> (AuthClientData a -> Req -> Req) + -> (AuthClientData a -> Request -> Request) -> AuthenticateReq a mkAuthenticateReq val func = AuthenticateReq (val, func) diff --git a/servant-client/src/Servant/Common/BaseUrl.hs b/servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs similarity index 100% rename from servant-client/src/Servant/Common/BaseUrl.hs rename to servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs diff --git a/servant-client/src/Servant/Common/BasicAuth.hs b/servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hs similarity index 85% rename from servant-client/src/Servant/Common/BasicAuth.hs rename to servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hs index e2802699..df5cc66a 100644 --- a/servant-client/src/Servant/Common/BasicAuth.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hs @@ -11,11 +11,11 @@ module Servant.Common.BasicAuth ( import Data.ByteString.Base64 (encode) import Data.Monoid ((<>)) import Data.Text.Encoding (decodeUtf8) -import Servant.Common.Req (addHeader, Req) +import Servant.Common.Req (addHeader, Request) import Servant.API.BasicAuth (BasicAuthData(BasicAuthData)) -- | Authenticate a request using Basic Authentication -basicAuthReq :: BasicAuthData -> Req -> Req +basicAuthReq :: BasicAuthData -> Request -> Request basicAuthReq (BasicAuthData user pass) req = let authText = decodeUtf8 ("Basic " <> encode (user <> ":" <> pass)) in addHeader "Authorization" authText req diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Class.hs b/servant-client-core/src/Servant/Client/Core/Internal/Class.hs new file mode 100644 index 00000000..38dd3459 --- /dev/null +++ b/servant-client-core/src/Servant/Client/Core/Internal/Class.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-| Types for possible backends to run client-side `Request` queries -} +module Servant.Client.Class where + +import Data.Proxy +import Network.HTTP.Types +import Servant.Common.Req (Request, Response) + +class (Monad m) => RunClient m ct where + runRequest :: Proxy ct + -> Method + -> Request + -> m Response diff --git a/servant-client/src/Servant/Client/Generic.hs b/servant-client-core/src/Servant/Client/Core/Internal/Generic.hs similarity index 100% rename from servant-client/src/Servant/Client/Generic.hs rename to servant-client-core/src/Servant/Client/Core/Internal/Generic.hs diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs new file mode 100644 index 00000000..73b8a43f --- /dev/null +++ b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Servant.Common.Request where + +import Prelude () +import Prelude.Compat + +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Lazy as LBS +import Data.Semigroup ((<>)) +import qualified Data.Sequence as Seq +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Network.HTTP.Media (MediaType) +import Network.HTTP.Types (Header, HeaderName, HttpVersion, + Method, QueryItem, Status, http11) +import Web.HttpApiData (ToHttpApiData, toEncodedUrlPiece, + toHeader) + +data ServantError + = FailureResponse Response + | DecodeFailure Text Response + | UnsupportedContentType MediaType Response + | InvalidContentTypeHeader Response + | ConnectionError Text + deriving (Eq, Show, Generic, Typeable) + +data Request = Request + { requestPath :: Builder.Builder + , requestQueryString :: Seq.Seq QueryItem + , requestBody :: Maybe (RequestBody, MediaType) + , requestAccept :: Seq.Seq MediaType + , requestHeaders :: Seq.Seq Header + , requestHttpVersion :: HttpVersion + } deriving (Generic, Typeable) + +newtype RequestBody = RequestBodyLBS LBS.ByteString + deriving (Eq, Ord, Read, Show, Typeable) + +data Response = Response + { responseStatusCode :: Status + , responseBody :: LBS.ByteString + , responseHeaders :: Seq.Seq Header + , responseHttpVersion :: HttpVersion + } deriving (Eq, Show, Generic, Typeable) + +defaultRequest :: Request +defaultRequest = Request + { requestPath = "" + , requestQueryString = Seq.empty + , requestBody = Nothing + , requestAccept = Seq.empty + , requestHeaders = Seq.empty + , requestHttpVersion = http11 + } + +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.|> (pname, 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) } + +{-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 (Builder.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" diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index e2e85d45..7d52d1c5 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -44,6 +44,7 @@ library , attoparsec >= 0.12 && < 0.14 , base64-bytestring >= 1.0.0.1 && < 1.1 , bytestring >= 0.10 && < 0.11 + , containers >= 0.5 && < 0.6 , exceptions >= 0.8 && < 0.9 , generics-sop >= 0.1.0.0 && < 0.4 , http-api-data >= 0.3.6 && < 0.4 diff --git a/servant-client/src/Servant/Client/Class.hs b/servant-client/src/Servant/Client/Class.hs deleted file mode 100644 index c030486a..00000000 --- a/servant-client/src/Servant/Client/Class.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-| Types for possible backends to run client-side `Req` queries -} -module Servant.Client.Class - (RunClient(..)) -where - -import Data.Proxy -import Network.HTTP.Types -import Servant.Common.Req - -class (Monad m) => RunClient m ct result where - runRequest :: Proxy ct - -> Method - -> Req - -> m result diff --git a/servant-client/src/Servant/Client/HttpClient.hs b/servant-client/src/Servant/Client/HttpClient.hs index 0934e53e..60bab060 100644 --- a/servant-client/src/Servant/Client/HttpClient.hs +++ b/servant-client/src/Servant/Client/HttpClient.hs @@ -4,44 +4,42 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {-| http-client based client requests executor -} module Servant.Client.HttpClient where -import Prelude () -import Prelude.Compat +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 Control.Exception +import Control.Monad +import Control.Monad.Base (MonadBase (..)) +import Control.Monad.Catch (MonadCatch, MonadThrow) +import Control.Monad.Error.Class (MonadError (..)) +import Control.Monad.IO.Class () +import Control.Monad.Reader +import Control.Monad.Trans.Control (MonadBaseControl (..)) +import Control.Monad.Trans.Except +import Data.ByteString.Lazy hiding (any, elem, filter, map, + null, pack) +import Data.Foldable (toList) +import Data.Functor.Alt (Alt (..)) +import Data.Proxy +import Data.String.Conversions (cs) +import GHC.Generics +import Network.HTTP.Media +import Network.HTTP.Types +import Servant.API.ContentTypes +import Servant.Client.Class +import Servant.Common.BaseUrl +import Servant.Common.Req -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 Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any) -import Data.String.Conversions (cs) -import Data.Proxy -import Network.HTTP.Media -import Network.HTTP.Types -import Network.HTTP.Client hiding (Proxy, path) +import qualified Network.HTTP.Client as Client import qualified Network.HTTP.Types.Header as HTTP -import Servant.API.ContentTypes -import Servant.Client.Class -import Servant.Common.BaseUrl -import Servant.Common.Req - -import qualified Network.HTTP.Client as Client instance RunClient ClientM NoContent ( Int, ByteString, MediaType , [HTTP.Header], Response ByteString) where @@ -89,8 +87,7 @@ runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm performRequest :: Method -> Req - -> ClientM ( Int, ByteString, MediaType - , [HTTP.Header], Response ByteString) + -> ClientM Response performRequest reqMethod req = do m <- asks manager reqHost <- asks baseUrl diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs deleted file mode 100644 index 94997eaf..00000000 --- a/servant-client/src/Servant/Common/Req.hs +++ /dev/null @@ -1,183 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Servant.Common.Req where - -import Prelude () -import Prelude.Compat - -import Control.Exception -import Control.Monad.Catch (MonadThrow) -import Data.Semigroup ((<>)) - -import Control.Monad.IO.Class () -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.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 Network.URI hiding (path) -import Servant.Common.BaseUrl - -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" From 35599d8b38413553020765d0bd6e3af7c809742d Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 7 Sep 2017 10:05:12 -0700 Subject: [PATCH 07/26] More reorganization --- servant-client-core/servant-client-core.cabal | 22 +++++++++++- .../src/Servant/Client/Core.hs | 2 +- .../src/Servant/Client/Core/Internal/Auth.hs | 8 ++--- .../Servant/Client/Core/Internal/BaseUrl.hs | 2 +- .../Servant/Client/Core/Internal/BasicAuth.hs | 6 ++-- .../src/Servant/Client/Core/Internal/Class.hs | 4 +-- .../Servant/Client/Core/Internal/Generic.hs | 5 ++- .../Servant/Client/Core/Internal/Request.hs | 36 +++++++++---------- servant-client/servant-client.cabal | 13 ------- stack-ghc-7.10.3.yaml | 1 + stack-ghc-7.8.4.yaml | 1 + stack-ghc-8.2.1.yaml | 1 + stack.yaml | 1 + 13 files changed, 53 insertions(+), 49 deletions(-) rename servant-client/src/Servant/Client.hs => servant-client-core/src/Servant/Client/Core.hs (99%) diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index e3083239..6ea04445 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -9,6 +9,7 @@ author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com homepage: http://haskell-servant.readthedocs.org/ bug-reports: http://github.com/haskell-servant/servant/issues +cabal-version: >=1.10 -- copyright: category: Web build-type: Simple @@ -19,15 +20,34 @@ extra-source-files: source-repository head type: git location: http://github.com/haskell-servant/servant.git -cabal-version: >=1.10 library exposed-modules: + Servant.Client.Core + Servant.Client.Core.Internal.Auth + Servant.Client.Core.Internal.BaseUrl + Servant.Client.Core.Internal.BasicAuth + Servant.Client.Core.Internal.Class + Servant.Client.Core.Internal.Generic + Servant.Client.Core.Internal.Request build-depends: base >= 4.7 && < 4.11 , base-compat >= 0.9.1 && < 0.10 + , base64-bytestring >= 1.0.0.1 && < 1.1 + , bytestring >= 0.10 && < 0.11 + , containers >= 0.5 && < 0.6 + , exceptions >= 0.8 && < 0.9 + , generics-sop >= 0.1.0.0 && < 0.4 + , http-api-data >= 0.3.6 && < 0.4 + , http-media >= 0.6.2 && < 0.8 + , http-types >= 0.8.6 && < 0.10 + , network-uri >= 2.6 && < 2.7 + , safe >= 0.3.9 && < 0.4 + , servant == 0.11.* + , text >= 1.2 && < 1.3 hs-source-dirs: src default-language: Haskell2010 + include-dirs: include test-suite spec type: exitcode-stdio-1.0 diff --git a/servant-client/src/Servant/Client.hs b/servant-client-core/src/Servant/Client/Core.hs similarity index 99% rename from servant-client/src/Servant/Client.hs rename to servant-client-core/src/Servant/Client/Core.hs index beeb589b..6d1b014d 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client-core/src/Servant/Client/Core.hs @@ -16,7 +16,7 @@ -- | This module provides 'client' which can automatically generate -- querying functions for each endpoint just from the type representing your -- API. -module Servant.Client +module Servant.Client.Core ( AuthClientData , AuthenticateReq(..) , client diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Auth.hs b/servant-client-core/src/Servant/Client/Core/Internal/Auth.hs index b9bb70e6..9640bfbe 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Auth.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Auth.hs @@ -4,13 +4,9 @@ -- | Authentication for clients -module Servant.Client.Experimental.Auth ( - AuthenticateReq(AuthenticateReq, unAuthReq) - , AuthClientData - , mkAuthenticateReq - ) where +module Servant.Client.Core.Internal.Auth where -import Servant.Common.Req (Request) +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 diff --git a/servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs b/servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs index 5c3c190a..9443035d 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ViewPatterns #-} -module Servant.Common.BaseUrl ( +module Servant.Client.Core.Internal.BaseUrl ( -- * types BaseUrl (..) , InvalidBaseUrlException diff --git a/servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hs b/servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hs index df5cc66a..978ef2b3 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hs @@ -4,14 +4,12 @@ -- | Basic Authentication for clients -module Servant.Common.BasicAuth ( - basicAuthReq - ) where +module Servant.Client.Core.Internal.BasicAuth where import Data.ByteString.Base64 (encode) import Data.Monoid ((<>)) import Data.Text.Encoding (decodeUtf8) -import Servant.Common.Req (addHeader, Request) +import Servant.Client.Core.Internal.Request (addHeader, Request) import Servant.API.BasicAuth (BasicAuthData(BasicAuthData)) -- | Authenticate a request using Basic Authentication diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Class.hs b/servant-client-core/src/Servant/Client/Core/Internal/Class.hs index 38dd3459..cea567f9 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Class.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Class.hs @@ -1,10 +1,10 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-| Types for possible backends to run client-side `Request` queries -} -module Servant.Client.Class where +module Servant.Client.Core.Internal.Class where import Data.Proxy import Network.HTTP.Types -import Servant.Common.Req (Request, Response) +import Servant.Client.Core.Internal.Request (Request, Response) class (Monad m) => RunClient m ct where runRequest :: Proxy ct diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Generic.hs b/servant-client-core/src/Servant/Client/Core/Internal/Generic.hs index 425e7839..c2f5a662 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Generic.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Generic.hs @@ -10,7 +10,7 @@ #include "overlapping-compat.h" -module Servant.Client.Generic +module Servant.Client.Core.Internal.Generic ( ClientLike(..) , genericMkClientL , genericMkClientP @@ -18,7 +18,6 @@ module Servant.Client.Generic 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. @@ -111,7 +110,7 @@ instance ClientLike client custom => ClientLike (a -> client) (a -> custom) where mkClient c = mkClient . c -instance ClientLike (ClientM a) (ClientM a) where +instance ClientLike (m a) (m a) where mkClient = id -- | Match client structure with client functions, regarding left-nested API clients diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs index 73b8a43f..8cdf79b7 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs @@ -7,7 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -module Servant.Common.Request where +module Servant.Client.Core.Internal.Request where import Prelude () import Prelude.Compat @@ -16,13 +16,12 @@ import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Lazy as LBS import Data.Semigroup ((<>)) import qualified Data.Sequence as Seq -import Data.String.Conversions (cs) import Data.Text (Text) import Data.Typeable (Typeable) import GHC.Generics (Generic) import Network.HTTP.Media (MediaType) import Network.HTTP.Types (Header, HeaderName, HttpVersion, - Method, QueryItem, Status, http11) + QueryItem, Status, http11) import Web.HttpApiData (ToHttpApiData, toEncodedUrlPiece, toHeader) @@ -126,21 +125,22 @@ setRequestBody b t req = req { requestBody = Just (b, t) } {-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 + + {- #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 + {--- * performing requests-} -displayHttpRequest :: Method -> String -displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" + {-displayHttpRequest :: Method -> String-} + {-displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"-} diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 7d52d1c5..4015d683 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -42,23 +42,10 @@ library , 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 - , containers >= 0.5 && < 0.6 - , exceptions >= 0.8 && < 0.9 - , generics-sop >= 0.1.0.0 && < 0.4 - , http-api-data >= 0.3.6 && < 0.4 , http-client >= 0.4.18.1 && < 0.6 , http-client-tls >= 0.2.2 && < 0.4 - , http-media >= 0.6.2 && < 0.8 - , 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 diff --git a/stack-ghc-7.10.3.yaml b/stack-ghc-7.10.3.yaml index fb18aac7..e1f14b91 100644 --- a/stack-ghc-7.10.3.yaml +++ b/stack-ghc-7.10.3.yaml @@ -2,6 +2,7 @@ flags: {} packages: - servant/ - servant-client/ +- servant-client-core/ - servant-docs/ - servant-foreign/ - servant-server/ diff --git a/stack-ghc-7.8.4.yaml b/stack-ghc-7.8.4.yaml index 01bb6420..479a6d20 100644 --- a/stack-ghc-7.8.4.yaml +++ b/stack-ghc-7.8.4.yaml @@ -2,6 +2,7 @@ flags: {} packages: - servant/ - servant-client/ +- servant-client-core/ - servant-docs/ - servant-foreign/ - servant-server/ diff --git a/stack-ghc-8.2.1.yaml b/stack-ghc-8.2.1.yaml index c1a64f37..926f72cf 100644 --- a/stack-ghc-8.2.1.yaml +++ b/stack-ghc-8.2.1.yaml @@ -1,6 +1,7 @@ resolver: nightly-2017-09-01 packages: - servant-client/ +- servant-client-core/ - servant-docs/ - servant-foreign/ - servant-server/ diff --git a/stack.yaml b/stack.yaml index 62ff4f2b..e283f7fd 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,6 +2,7 @@ resolver: nightly-2017-04-01 packages: - servant/ - servant-client/ +- servant-client-core/ - servant-docs/ - servant-foreign/ - servant-server/ From 01f344dfbb7e4cdf81fc90033f6e4a130c15b866 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 7 Sep 2017 13:38:31 -0700 Subject: [PATCH 08/26] Compiling servant-client-core --- servant-client-core/servant-client-core.cabal | 1 + .../src/Servant/Client/Core.hs | 161 ++++++++++-------- .../Servant/Client/Core/Internal/BasicAuth.hs | 14 +- .../src/Servant/Client/Core/Internal/Class.hs | 14 +- .../Servant/Client/Core/Internal/Request.hs | 19 ++- servant-client/servant-client.cabal | 1 - 6 files changed, 115 insertions(+), 95 deletions(-) diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index 6ea04445..779c09ee 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -41,6 +41,7 @@ library , http-api-data >= 0.3.6 && < 0.4 , http-media >= 0.6.2 && < 0.8 , http-types >= 0.8.6 && < 0.10 + , mtl >= 2.2 && < 2.3 , network-uri >= 2.6 && < 2.7 , safe >= 0.3.9 && < 0.4 , servant == 0.11.* diff --git a/servant-client-core/src/Servant/Client/Core.hs b/servant-client-core/src/Servant/Client/Core.hs index 6d1b014d..42323d40 100644 --- a/servant-client-core/src/Servant/Client/Core.hs +++ b/servant-client-core/src/Servant/Client/Core.hs @@ -21,34 +21,52 @@ module Servant.Client.Core , AuthenticateReq(..) , client , HasClient(..) - , ClientM - , runClientM, inClientM, clientM - , ClientEnv (ClientEnv) , mkAuthenticateReq , ServantError(..) , EmptyClient(..) - , module Servant.Common.BaseUrl + , module Servant.Client.Core.Internal.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 Control.Monad.Error.Class (throwError) +import Data.List (foldl') +import Data.Proxy (Proxy (Proxy)) +import Data.String (fromString) +import Data.Text (pack) +import GHC.Exts (fromList, toList) +import GHC.TypeLits (KnownSymbol, symbolVal) +import qualified Network.HTTP.Types as H +import Prelude () import Prelude.Compat -import Servant.API -import Servant.Client.Experimental.Auth -import Servant.Client.HttpClient -import Servant.Client.Class -import Servant.Common.BaseUrl -import Servant.Common.BasicAuth -import Servant.Common.Req +import Servant.API ((:<|>) ((:<|>)), (:>), + AuthProtect, BasicAuth, + BasicAuthData, + BuildHeadersTo (..), + Capture, CaptureAll, + Description, EmptyAPI, + Header, Headers (..), + HttpVersion, IsSecure, + MimeRender (mimeRender), + MimeUnrender (mimeUnrender), + NoContent (NoContent), + QueryFlag, QueryParam, + QueryParams, Raw, + ReflectMethod (..), + RemoteHost, ReqBody, + Summary, ToHttpApiData, + Vault, Verb, + WithNamedContext, + contentType, + getHeadersHList, + getResponse, + toQueryParam, + toUrlPiece) +import Servant.API.ContentTypes (contentTypes) + +import Servant.Client.Core.Internal.Auth +import Servant.Client.Core.Internal.BaseUrl +import Servant.Client.Core.Internal.BasicAuth +import Servant.Client.Core.Internal.Class +import Servant.Client.Core.Internal.Request -- * Accessing APIs as a Client @@ -68,25 +86,15 @@ import Servant.Common.Req -- > postNewBook :: Book -> ClientM Book -- > (getAllBooks :<|> postNewBook) = client clientM myApi client :: HasClient m api => Proxy m -> Proxy api -> Client m api -client pm p = clientWithRoute pm p defReq - --- | Helper proxy to simplify common case of working in `ClientM` monad -inClientM :: Proxy ClientM -inClientM = Proxy - --- | Convenience method to declare clients running in the `ClientM` monad. --- --- Simply pass `inClientM` to `client`.... -clientM :: (HasClient ClientM api) => Proxy api -> Client ClientM api -clientM = client inClientM +client pm p = clientWithRoute pm p defaultRequest -- | 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 m api where +class RunClient m => HasClient m api where type Client (m :: * -> *) (api :: *) :: * - clientWithRoute :: Proxy m -> Proxy api -> Req -> Client m api + clientWithRoute :: Proxy m -> Proxy api -> Request -> Client m api -- | A client querying function for @a ':<|>' b@ will actually hand you @@ -121,7 +129,7 @@ data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum) -- > -- > getAllBooks :: ClientM [Book] -- > (getAllBooks :<|> EmptyClient) = client myApi -instance HasClient m EmptyAPI where +instance RunClient m => HasClient m EmptyAPI where type Client m EmptyAPI = EmptyClient clientWithRoute _pm Proxy _ = EmptyClient @@ -154,7 +162,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m api) clientWithRoute pm (Proxy :: Proxy api) (appendToPath p req) - where p = unpack (toUrlPiece val) + where p = (toUrlPiece val) -- | If you use a 'CaptureAll' in one of your endpoints in your API, -- the corresponding querying function will automatically take an @@ -186,53 +194,65 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout) clientWithRoute pm (Proxy :: Proxy sublayout) (foldl' (flip appendToPath) req ps) - where ps = map (unpack . toUrlPiece) vals + where ps = map (toUrlPiece) vals instance OVERLAPPABLE_ -- Note [Non-Empty Content Types] - (RunClient m ct ([H.Header], a), MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) + ( 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 - (_hdrs, a) :: ([H.Header], a) <- runRequest (Proxy :: Proxy ct) method req - return a + response <- runRequest req + { requestAccept = fromList $ toList accept + , requestMethod = method + } + case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of + Left err -> throwError $ DecodeFailure (pack err) response + Right val -> return val where method = reflectMethod (Proxy :: Proxy method) + accept = contentTypes (Proxy :: Proxy ct) instance OVERLAPPING_ - ( RunClient m NoContent [HTTP.Header] - , ReflectMethod method) => HasClient m (Verb method status cts NoContent) where + ( 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 - _hdrs :: [H.Header] <- runRequest (Proxy :: Proxy NoContent) method req + _response <- runRequest req { requestMethod = method } return NoContent where method = reflectMethod (Proxy :: Proxy method) instance OVERLAPPING_ -- Note [Non-Empty Content Types] - ( RunClient m ct ([H.Header], a) - , MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts) + ( 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 - let method = reflectMethod (Proxy :: Proxy method) - (hdrs, resp) <- runRequest (Proxy :: Proxy ct) method req - return $ Headers { getResponse = resp - , getHeadersHList = buildHeadersTo hdrs - } + response <- runRequest req + { requestMethod = method + , requestAccept = fromList $ toList accept + } + case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of + Left err -> throwError $ DecodeFailure (pack err) response + Right val -> return $ Headers + { getResponse = val + , getHeadersHList = buildHeadersTo . toList $ responseHeaders response + } + where method = reflectMethod (Proxy :: Proxy method) + accept = contentTypes (Proxy :: Proxy ct) instance OVERLAPPING_ - ( RunClient m NoContent [H.Header] - , BuildHeadersTo ls, ReflectMethod method + ( 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) - hdrs <- runRequest (Proxy :: Proxy NoContent) method req + response <- runRequest req { requestMethod = method } return $ Headers { getResponse = NoContent - , getHeadersHList = buildHeadersTo hdrs + , getHeadersHList = buildHeadersTo . toList $ responseHeaders response } @@ -270,11 +290,11 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api) clientWithRoute pm Proxy req mval = clientWithRoute pm (Proxy :: Proxy api) (maybe req - (\value -> Servant.Common.Req.addHeader hname value req) + (\value -> addHeader hname value req) mval ) - where hname = symbolVal (Proxy :: Proxy sym) + where hname = fromString $ symbolVal (Proxy :: Proxy sym) -- | Using a 'HttpVersion' combinator in your API doesn't affect the client -- functions. @@ -338,8 +358,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api) mparamText ) - where pname = cs pname' - pname' = symbolVal (Proxy :: Proxy sym) + where pname = pack $ symbolVal (Proxy :: Proxy sym) mparamText = fmap toQueryParam mparam -- | If you use a 'QueryParams' in one of your endpoints in your API, @@ -382,8 +401,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api) paramlist' ) - where pname = cs pname' - pname' = symbolVal (Proxy :: Proxy sym) + where pname = pack $ symbolVal (Proxy :: Proxy sym) paramlist' = map (Just . toQueryParam) paramlist -- | If you use a 'QueryFlag' in one of your endpoints in your API, @@ -420,19 +438,18 @@ instance (KnownSymbol sym, HasClient m api) else req ) - where paramname = cs $ symbolVal (Proxy :: Proxy sym) + where paramname = pack $ symbolVal (Proxy :: Proxy sym) -- | Pick a 'Method' and specify where the server you want to query is. You get -- back the full `Response`. -instance (RunClient m NoContent (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)) - => HasClient m Raw where +instance RunClient m => HasClient m Raw where type Client m Raw - = H.Method -> m (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) + = H.Method -> m Response - clientWithRoute :: Proxy m -> Proxy Raw -> Req -> Client m Raw + clientWithRoute :: Proxy m -> Proxy Raw -> Request -> Client m Raw clientWithRoute _pm Proxy req httpMethod = do - runRequest (Proxy :: Proxy NoContent) httpMethod req + runRequest req { requestMethod = httpMethod } -- | If you use a 'ReqBody' in one of your endpoints in your API, -- the corresponding querying function will automatically take @@ -461,10 +478,10 @@ instance (MimeRender ct a, HasClient m api) clientWithRoute pm Proxy req body = clientWithRoute pm (Proxy :: Proxy api) (let ctProxy = Proxy :: Proxy ct - in setReqBodyLBS (mimeRender ctProxy body) - -- We use first contentType from the Accept list - (contentType ctProxy) - req + in setRequestBodyLBS (mimeRender ctProxy body) + -- We use first contentType from the Accept list + (contentType ctProxy) + req ) -- | Make the querying function append @path@ to the request path. @@ -475,7 +492,7 @@ instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where clientWithRoute pm (Proxy :: Proxy api) (appendToPath p req) - where p = symbolVal (Proxy :: Proxy path) + where p = pack $ symbolVal (Proxy :: Proxy path) instance HasClient m api => HasClient m (Vault :> api) where type Client m (Vault :> api) = Client m api diff --git a/servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hs b/servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hs index 978ef2b3..64dc8433 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeFamilies #-} -- | 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.Client.Core.Internal.Request (addHeader, Request) -import Servant.API.BasicAuth (BasicAuthData(BasicAuthData)) +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 diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Class.hs b/servant-client-core/src/Servant/Client/Core/Internal/Class.hs index cea567f9..0428fcb8 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Class.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Class.hs @@ -1,13 +1,11 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-| Types for possible backends to run client-side `Request` queries -} module Servant.Client.Core.Internal.Class where -import Data.Proxy -import Network.HTTP.Types -import Servant.Client.Core.Internal.Request (Request, Response) +import Control.Monad.Error.Class (MonadError) +import Servant.Client.Core.Internal.Request (Request, Response, + ServantError) -class (Monad m) => RunClient m ct where - runRequest :: Proxy ct - -> Method - -> Request - -> m Response +class (MonadError ServantError m) => RunClient m where + runRequest :: Request -> m Response diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs index 8cdf79b7..3072aa08 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs @@ -17,11 +17,13 @@ import qualified Data.ByteString.Lazy as LBS import Data.Semigroup ((<>)) import qualified Data.Sequence as Seq import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) import Data.Typeable (Typeable) import GHC.Generics (Generic) import Network.HTTP.Media (MediaType) import Network.HTTP.Types (Header, HeaderName, HttpVersion, - QueryItem, Status, http11) + Method, QueryItem, Status, http11, + methodGet) import Web.HttpApiData (ToHttpApiData, toEncodedUrlPiece, toHeader) @@ -40,6 +42,7 @@ data Request = Request , requestAccept :: Seq.Seq MediaType , requestHeaders :: Seq.Seq Header , requestHttpVersion :: HttpVersion + , requestMethod :: Method } deriving (Generic, Typeable) newtype RequestBody = RequestBodyLBS LBS.ByteString @@ -60,18 +63,20 @@ defaultRequest = Request , 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.|> (pname, pvalue)}-} +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 diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 4015d683..cbed6f55 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -49,7 +49,6 @@ library , 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 From 05db359296371488cbc658209055e1af3cf2d626 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 7 Sep 2017 16:07:18 -0700 Subject: [PATCH 09/26] Compiling HttpClient --- .../src/Servant/Client/Core.hs | 4 + .../Servant/Client/Core/Internal/Request.hs | 12 +- servant-client/servant-client.cabal | 14 +- .../src/Servant/Client/HttpClient.hs | 126 +++++++++++------- 4 files changed, 96 insertions(+), 60 deletions(-) diff --git a/servant-client-core/src/Servant/Client/Core.hs b/servant-client-core/src/Servant/Client/Core.hs index 42323d40..5701e8c2 100644 --- a/servant-client-core/src/Servant/Client/Core.hs +++ b/servant-client-core/src/Servant/Client/Core.hs @@ -24,6 +24,10 @@ module Servant.Client.Core , mkAuthenticateReq , ServantError(..) , EmptyClient(..) + , RunClient(..) + , Request(..) + , Response(..) + , RequestBody(..) , module Servant.Client.Core.Internal.BaseUrl ) where diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs index 3072aa08..bfcd1d70 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs @@ -27,11 +27,17 @@ import Network.HTTP.Types (Header, HeaderName, HttpVersion, import Web.HttpApiData (ToHttpApiData, toEncodedUrlPiece, toHeader) -data ServantError - = FailureResponse Response +-- | A type representing possible errors in a request +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) @@ -45,6 +51,7 @@ data Request = Request , requestMethod :: Method } deriving (Generic, Typeable) +-- | The request body. Currently only lazy ByteStrings are supported. newtype RequestBody = RequestBodyLBS LBS.ByteString deriving (Eq, Ord, Read, Show, Typeable) @@ -55,6 +62,7 @@ data Response = Response , responseHttpVersion :: HttpVersion } deriving (Eq, Show, Generic, Typeable) +-- A GET request to the top-level path defaultRequest :: Request defaultRequest = Request { requestPath = "" diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index cbed6f55..d56ad33d 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -29,23 +29,23 @@ source-repository head library exposed-modules: - Servant.Client - Servant.Client.Class Servant.Client.HttpClient - Servant.Client.Generic - Servant.Client.Experimental.Auth - Servant.Common.BaseUrl - Servant.Common.BasicAuth - Servant.Common.Req build-depends: base >= 4.7 && < 4.11 , base-compat >= 0.9.1 && < 0.10 + , bytestring >= 0.10 && < 0.11 , aeson >= 0.7 && < 1.3 , attoparsec >= 0.12 && < 0.14 , http-client >= 0.4.18.1 && < 0.6 , http-client-tls >= 0.2.2 && < 0.4 + , http-media >= 0.6.2 && < 0.8 + , http-types >= 0.8.6 && < 0.10 + , exceptions >= 0.8 && < 0.9 , monad-control >= 1.0.0.4 && < 1.1 + , mtl >= 2.2 && < 2.3 , semigroupoids >= 4.3 && < 5.3 + , servant-client-core == 0.11.* + , text >= 1.2 && < 1.3 , transformers >= 0.3 && < 0.6 , transformers-base >= 0.4.4 && < 0.5 , transformers-compat >= 0.4 && < 0.6 diff --git a/servant-client/src/Servant/Client/HttpClient.hs b/servant-client/src/Servant/Client/HttpClient.hs index 60bab060..5dd84c30 100644 --- a/servant-client/src/Servant/Client/HttpClient.hs +++ b/servant-client/src/Servant/Client/HttpClient.hs @@ -20,41 +20,37 @@ import Control.Monad import Control.Monad.Base (MonadBase (..)) import Control.Monad.Catch (MonadCatch, MonadThrow) import Control.Monad.Error.Class (MonadError (..)) -import Control.Monad.IO.Class () +import Data.ByteString.Builder (toLazyByteString) +import qualified Data.ByteString.Lazy as BSL +import Data.Monoid ((<>)) +import Data.String (fromString) +import qualified Data.Text as T +import GHC.Exts (fromList) +{-import Control.Monad.IO.Class ()-} import Control.Monad.Reader import Control.Monad.Trans.Control (MonadBaseControl (..)) import Control.Monad.Trans.Except -import Data.ByteString.Lazy hiding (any, elem, filter, map, - null, pack) +{-import Data.ByteString.Lazy hiding (any, elem, filter, map,-} + {-null, pack)-} import Data.Foldable (toList) import Data.Functor.Alt (Alt (..)) import Data.Proxy -import Data.String.Conversions (cs) +{-import Data.String.Conversions (cs)-} import GHC.Generics -import Network.HTTP.Media -import Network.HTTP.Types -import Servant.API.ContentTypes -import Servant.Client.Class -import Servant.Common.BaseUrl -import Servant.Common.Req +import Network.HTTP.Media (parseAccept, renderHeader, (//)) +import Network.HTTP.Types (hContentType, renderQuery, + statusCode) +{-import Servant.API.ContentTypes-} +import Servant.Client.Core +{-import Servant.Common.BaseUrl-} +{-import Servant.Common.Req-} import qualified Network.HTTP.Client as Client -import qualified Network.HTTP.Types.Header as HTTP - -instance RunClient ClientM NoContent ( Int, ByteString, MediaType - , [HTTP.Header], Response ByteString) where - runRequest _ meth req = performRequest meth req - -instance (MimeUnrender ct a) => - RunClient ClientM ct ([HTTP.Header], a) where - runRequest p meth req = performRequestCT p meth req - -instance RunClient ClientM NoContent [HTTP.Header] where - runRequest _ meth req = performRequestNoBody meth req +{-import qualified Network.HTTP.Types.Header as HTTP-} data ClientEnv = ClientEnv - { manager :: Manager + { manager :: Client.Manager , baseUrl :: BaseUrl } @@ -82,55 +78,83 @@ instance MonadBaseControl IO ClientM where instance Alt ClientM where a b = a `catchError` \_ -> b +instance RunClient ClientM where + runRequest = performRequest + runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a) runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm -performRequest :: Method -> Req - -> ClientM Response -performRequest reqMethod req = do - m <- asks manager - reqHost <- asks baseUrl - partialRequest <- liftIO $ reqToRequest req reqHost - let request = partialRequest { Client.method = reqMethod } +performRequest :: Request -> ClientM Response +performRequest req = do + m <- asks manager + burl <- asks baseUrl + let request = requestToClientRequest burl req eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m case eResponse of - Left err -> - throwError . ConnectionError $ SomeException err - + Left err -> throwError $ err Right response -> do let status = Client.responseStatus response body = Client.responseBody response hdrs = Client.responseHeaders response status_code = statusCode status + ourResponse = clientResponseToReponse response 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 + Nothing -> throwError $ InvalidContentTypeHeader ourResponse 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) + throwError $ FailureResponse ourResponse + return ourResponse -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) +clientResponseToReponse :: Client.Response BSL.ByteString -> Response +clientResponseToReponse r = Response + { responseStatusCode = Client.responseStatus r + , responseBody = Client.responseBody r + , responseHeaders = fromList $ Client.responseHeaders r + , responseHttpVersion = Client.responseVersion r + } -performRequestNoBody :: Method -> Req -> ClientM [HTTP.Header] -performRequestNoBody reqMethod req = do - (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req - return hdrs +requestToClientRequest :: BaseUrl -> Request -> Client.Request +requestToClientRequest burl r = Client.defaultRequest + { Client.method = requestMethod r + , Client.host = fromString $ baseUrlHost burl + , Client.port = baseUrlPort burl + , Client.path = BSL.toStrict + $ fromString (baseUrlPath burl) + <> toLazyByteString (requestPath r) + , Client.queryString = renderQuery True . toList $ requestQueryString r + , Client.requestHeaders = + let orig = toList $ requestHeaders r + in maybe orig (: orig) contentTypeHdr + , Client.requestBody = body + } + where + (body, contentTypeHdr) = case requestBody r of + Nothing -> (Client.RequestBodyLBS "", Nothing) + Just (RequestBodyLBS body, typ) + -> (Client.RequestBodyLBS body, Just (hContentType, renderHeader typ)) + +{-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) + pure . Left . ConnectionError . T.pack $ show (e :: Client.HttpException) From f44ab3d083c66828b73ed837f830fedc268e4008 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 7 Sep 2017 16:11:20 -0700 Subject: [PATCH 10/26] Cleanup --- .../Servant/Client/Core/Internal/Request.hs | 50 ------------------- .../src/Servant/Client/HttpClient.hs | 48 +++--------------- 2 files changed, 8 insertions(+), 90 deletions(-) diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs index bfcd1d70..8b9306d3 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs @@ -107,53 +107,3 @@ setRequestBodyLBS b t req -- setRequestBody :: RequestBody -> MediaType -> Request -> Request setRequestBody b t req = req { requestBody = 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 (Builder.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"-} diff --git a/servant-client/src/Servant/Client/HttpClient.hs b/servant-client/src/Servant/Client/HttpClient.hs index 5dd84c30..a54574f6 100644 --- a/servant-client/src/Servant/Client/HttpClient.hs +++ b/servant-client/src/Servant/Client/HttpClient.hs @@ -20,33 +20,24 @@ import Control.Monad import Control.Monad.Base (MonadBase (..)) import Control.Monad.Catch (MonadCatch, MonadThrow) import Control.Monad.Error.Class (MonadError (..)) +import Control.Monad.Reader +import Control.Monad.Trans.Control (MonadBaseControl (..)) +import Control.Monad.Trans.Except import Data.ByteString.Builder (toLazyByteString) import qualified Data.ByteString.Lazy as BSL +import Data.Foldable (toList) +import Data.Functor.Alt (Alt (..)) import Data.Monoid ((<>)) import Data.String (fromString) import qualified Data.Text as T import GHC.Exts (fromList) -{-import Control.Monad.IO.Class ()-} -import Control.Monad.Reader -import Control.Monad.Trans.Control (MonadBaseControl (..)) -import Control.Monad.Trans.Except -{-import Data.ByteString.Lazy hiding (any, elem, filter, map,-} - {-null, pack)-} -import Data.Foldable (toList) -import Data.Functor.Alt (Alt (..)) -import Data.Proxy -{-import Data.String.Conversions (cs)-} import GHC.Generics -import Network.HTTP.Media (parseAccept, renderHeader, (//)) +import Network.HTTP.Media (renderHeader) import Network.HTTP.Types (hContentType, renderQuery, statusCode) -{-import Servant.API.ContentTypes-} import Servant.Client.Core -{-import Servant.Common.BaseUrl-} -{-import Servant.Common.Req-} import qualified Network.HTTP.Client as Client -{-import qualified Network.HTTP.Types.Header as HTTP-} data ClientEnv = ClientEnv @@ -97,15 +88,8 @@ performRequest req = do Left err -> throwError $ err Right response -> do let status = Client.responseStatus response - body = Client.responseBody response - hdrs = Client.responseHeaders response status_code = statusCode status ourResponse = clientResponseToReponse response - ct <- case lookup "Content-Type" $ Client.responseHeaders response of - Nothing -> pure $ "application"//"octet-stream" - Just t -> case parseAccept t of - Nothing -> throwError $ InvalidContentTypeHeader ourResponse - Just t' -> pure t' unless (status_code >= 200 && status_code < 300) $ throwError $ FailureResponse ourResponse return ourResponse @@ -135,24 +119,8 @@ requestToClientRequest burl r = Client.defaultRequest where (body, contentTypeHdr) = case requestBody r of Nothing -> (Client.RequestBodyLBS "", Nothing) - Just (RequestBodyLBS body, typ) - -> (Client.RequestBodyLBS body, Just (hContentType, renderHeader typ)) - -{-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-} + Just (RequestBodyLBS body', typ) + -> (Client.RequestBodyLBS body', Just (hContentType, renderHeader typ)) catchConnectionError :: IO a -> IO (Either ServantError a) catchConnectionError action = From 6995e39427c6e4ef1a9f206a4404796c3736e656 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 7 Sep 2017 16:17:53 -0700 Subject: [PATCH 11/26] Move BaseUrlSpec --- servant-client-core/servant-client-core.cabal | 8 ++++++++ .../test/Servant/Client/Core/Internal}/BaseUrlSpec.hs | 8 +++----- servant-client-core/test/Spec.hs | 1 + 3 files changed, 12 insertions(+), 5 deletions(-) rename {servant-client/test/Servant/Common => servant-client-core/test/Servant/Client/Core/Internal}/BaseUrlSpec.hs (94%) create mode 100644 servant-client-core/test/Spec.hs diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index 779c09ee..0e9411b7 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -56,6 +56,14 @@ test-suite spec default-language: Haskell2010 hs-source-dirs: test main-is: Spec.hs + build-depends: + base + , base-compat + , deepseq + , servant-client-core + , hspec == 2.* + , QuickCheck >= 2.7 && < 2.10 other-modules: + Servant.Client.Core.Internal.BaseUrlSpec build-depends: base == 4.* diff --git a/servant-client/test/Servant/Common/BaseUrlSpec.hs b/servant-client-core/test/Servant/Client/Core/Internal/BaseUrlSpec.hs similarity index 94% rename from servant-client/test/Servant/Common/BaseUrlSpec.hs rename to servant-client-core/test/Servant/Client/Core/Internal/BaseUrlSpec.hs index e25da65d..09ece081 100644 --- a/servant-client/test/Servant/Common/BaseUrlSpec.hs +++ b/servant-client-core/test/Servant/Client/Core/Internal/BaseUrlSpec.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -module Servant.Common.BaseUrlSpec where +module Servant.Client.Core.Internal.BaseUrlSpec (spec) where + import Control.DeepSeq import Prelude () @@ -7,7 +8,7 @@ import Prelude.Compat import Test.Hspec import Test.QuickCheck -import Servant.Common.BaseUrl +import Servant.Client.Core.Internal.BaseUrl spec :: Spec spec = do @@ -78,6 +79,3 @@ instance Arbitrary BaseUrl where (1, choose (1, 20000)) : [] pathGen = listOf1 . elements $ letters - -isLeft :: Either a b -> Bool -isLeft = either (const True) (const False) diff --git a/servant-client-core/test/Spec.hs b/servant-client-core/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/servant-client-core/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} From 75ea91c34d06f9e645ee2f4c001d6eb61e23da7d Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 12 Sep 2017 12:38:52 -0400 Subject: [PATCH 12/26] Fix some tests --- servant-client-core/README.md | 5 + servant-client-core/servant-client-core.cabal | 2 - .../src/Servant/Client/Core.hs | 24 +- .../src/Servant/Client/Core/Internal/Auth.hs | 6 +- .../Servant/Client/Core/Internal/BaseUrl.hs | 12 +- .../Servant/Client/Core/Internal/Generic.hs | 6 +- servant-client/servant-client.cabal | 6 +- servant-client/src/Servant/Client.hs | 10 + .../Client/{ => Internal}/HttpClient.hs | 6 +- servant-client/test/Servant/ClientSpec.hs | 233 ++++++++++-------- 10 files changed, 173 insertions(+), 137 deletions(-) create mode 100644 servant-client-core/README.md create mode 100644 servant-client/src/Servant/Client.hs rename servant-client/src/Servant/Client/{ => Internal}/HttpClient.hs (94%) diff --git a/servant-client-core/README.md b/servant-client-core/README.md new file mode 100644 index 00000000..601a1d55 --- /dev/null +++ b/servant-client-core/README.md @@ -0,0 +1,5 @@ +# servant-client-core + +![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) + +HTTP-client-agnostic client functions for servant APIs. diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index 0e9411b7..d5716be5 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -65,5 +65,3 @@ test-suite spec , QuickCheck >= 2.7 && < 2.10 other-modules: Servant.Client.Core.Internal.BaseUrlSpec - build-depends: - base == 4.* diff --git a/servant-client-core/src/Servant/Client/Core.hs b/servant-client-core/src/Servant/Client/Core.hs index 5701e8c2..5de52556 100644 --- a/servant-client-core/src/Servant/Client/Core.hs +++ b/servant-client-core/src/Servant/Client/Core.hs @@ -19,7 +19,7 @@ module Servant.Client.Core ( AuthClientData , AuthenticateReq(..) - , client + , clientIn , HasClient(..) , mkAuthenticateReq , ServantError(..) @@ -29,6 +29,15 @@ module Servant.Client.Core , Response(..) , RequestBody(..) , module Servant.Client.Core.Internal.BaseUrl + , ClientLike(..) + , genericMkClientL + , genericMkClientP + -- * Writing instances + , addHeader + , appendToQueryString + , appendToPath + , setRequestBodyLBS + , setRequestBody ) where import Control.Monad.Error.Class (throwError) @@ -67,10 +76,15 @@ import Servant.API ((:<|>) ((:<|>)), (:>), import Servant.API.ContentTypes (contentTypes) import Servant.Client.Core.Internal.Auth -import Servant.Client.Core.Internal.BaseUrl +import Servant.Client.Core.Internal.BaseUrl (BaseUrl (..), + InvalidBaseUrlException, + Scheme (..), + parseBaseUrl, + showBaseUrl) import Servant.Client.Core.Internal.BasicAuth import Servant.Client.Core.Internal.Class import Servant.Client.Core.Internal.Request +import Servant.Client.Core.Internal.Generic -- * Accessing APIs as a Client @@ -88,9 +102,9 @@ import Servant.Client.Core.Internal.Request -- > -- > getAllBooks :: ClientM [Book] -- > postNewBook :: Book -> ClientM Book --- > (getAllBooks :<|> postNewBook) = client clientM myApi -client :: HasClient m api => Proxy m -> Proxy api -> Client m api -client pm p = clientWithRoute pm p defaultRequest +-- > (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 diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Auth.hs b/servant-client-core/src/Servant/Client/Core/Internal/Auth.hs index 9640bfbe..cf9eb596 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Auth.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Auth.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeFamilies #-} -- | Authentication for clients module Servant.Client.Core.Internal.Auth where -import Servant.Client.Core.Internal.Request (Request) +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 diff --git a/servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs b/servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs index 9443035d..b95f57bd 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs @@ -1,21 +1,13 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ViewPatterns #-} -module Servant.Client.Core.Internal.BaseUrl ( - -- * types - BaseUrl (..) - , InvalidBaseUrlException - , Scheme (..) - -- * functions - , parseBaseUrl - , showBaseUrl -) where +module Servant.Client.Core.Internal.BaseUrl where import Control.Monad.Catch (Exception, MonadThrow, throwM) import Data.List import Data.Typeable import GHC.Generics -import Network.URI hiding (path) +import Network.URI hiding (path) import Safe import Text.Read diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Generic.hs b/servant-client-core/src/Servant/Client/Core/Internal/Generic.hs index c2f5a662..fa3a94bf 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Generic.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Generic.hs @@ -10,11 +10,7 @@ #include "overlapping-compat.h" -module Servant.Client.Core.Internal.Generic - ( ClientLike(..) - , genericMkClientL - , genericMkClientP - ) where +module Servant.Client.Core.Internal.Generic where import Generics.SOP (Code, Generic, I(..), NP(..), NS(Z), SOP(..), to) import Servant.API ((:<|>)(..)) diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index d56ad33d..116d92cd 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -12,7 +12,7 @@ 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 +copyright: 2014-2017 Zalora South East Asia Pte Ltd, Servant Contributors category: Servant, Web build-type: Simple cabal-version: >=1.10 @@ -29,7 +29,8 @@ source-repository head library exposed-modules: - Servant.Client.HttpClient + Servant.Client + Servant.Client.Internal.HttpClient build-depends: base >= 4.7 && < 4.11 , base-compat >= 0.9.1 && < 0.10 @@ -67,7 +68,6 @@ test-suite spec main-is: Spec.hs other-modules: Servant.ClientSpec - , Servant.Common.BaseUrlSpec build-depends: base == 4.* , aeson diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs new file mode 100644 index 00000000..bf03817f --- /dev/null +++ b/servant-client/src/Servant/Client.hs @@ -0,0 +1,10 @@ +module Servant.Client + ( ClientEnv(..) + , ClientM + , runClientM + , client + , module X + ) where + +import Servant.Client.Internal.HttpClient +import Servant.Client.Core as X diff --git a/servant-client/src/Servant/Client/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs similarity index 94% rename from servant-client/src/Servant/Client/HttpClient.hs rename to servant-client/src/Servant/Client/Internal/HttpClient.hs index a54574f6..dcf72dc3 100644 --- a/servant-client/src/Servant/Client/HttpClient.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -9,7 +10,7 @@ {-# LANGUAGE TypeFamilies #-} {-| http-client based client requests executor -} -module Servant.Client.HttpClient where +module Servant.Client.Internal.HttpClient where import Prelude () @@ -28,6 +29,7 @@ import qualified Data.ByteString.Lazy as BSL import Data.Foldable (toList) import Data.Functor.Alt (Alt (..)) import Data.Monoid ((<>)) +import Data.Proxy (Proxy (..)) import Data.String (fromString) import qualified Data.Text as T import GHC.Exts (fromList) @@ -45,6 +47,8 @@ data ClientEnv , baseUrl :: BaseUrl } +client :: HasClient ClientM api => Proxy api -> Client ClientM api +client api = api `clientIn` (Proxy :: Proxy ClientM) -- | @ClientM@ is the monad in which client functions run. Contains the -- 'Manager' and 'BaseUrl' used for requests in the reader environment. diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 49b35769..1a37cc3f 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -26,44 +26,59 @@ #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 Control.Arrow (left) +import Control.Concurrent (ThreadId, forkIO, + killThread) +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 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 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 qualified Network.HTTP.Types as HTTP import Network.Socket -import Network.Wai (Request, requestHeaders, responseLBS) +import qualified Network.Wai as Wai import Network.Wai.Handler.Warp -import Prelude () +import Prelude () import Prelude.Compat -import System.IO.Unsafe (unsafePerformIO) -import Test.HUnit +import System.IO.Unsafe (unsafePerformIO) import Test.Hspec import Test.Hspec.QuickCheck +import Test.HUnit import Test.QuickCheck -import Web.FormUrlEncoded (FromForm, ToForm) +import Web.FormUrlEncoded (FromForm, ToForm) -import Servant.API +import Servant.API ((:<|>) ((:<|>)), + (:>), AuthProtect, + BasicAuth, + BasicAuthData (..), + Capture, + CaptureAll, Delete, + DeleteNoContent, + EmptyAPI, + FormUrlEncoded, + Get, Header, + Headers, JSON, + NoContent, Post, + Put, QueryFlag, + QueryParam, + QueryParams, + ReqBody) import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Client -import Servant.Client.Generic -import qualified Servant.Common.Req as SCR -import qualified Servant.Client.HttpClient as SCR +{-import qualified Servant.Common.Req as SCR-} +{-import qualified Servant.Client.HttpClient as SCR-} import Servant.Server import Servant.Server.Experimental.Auth -- This declaration simply checks that all instances are in place. -_ = client inClientM comprehensiveAPI +_ = client comprehensiveAPI spec :: Spec spec = describe "Servant.Client" $ do @@ -76,17 +91,16 @@ spec = describe "Servant.Client" $ do -- * test data types -data Person = Person { - name :: String, - age :: Integer - } - deriving (Eq, Show, Generic) +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 +instance ToForm Person +instance FromForm Person alice :: Person alice = Person "Alice" 42 @@ -117,22 +131,22 @@ type Api = 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 +getGet :: ClientM Person +getDeleteEmpty :: ClientM NoContent +getCapture :: String -> ClientM Person +getCaptureAll :: [String] -> ClientM [Person] +getBody :: Person -> ClientM Person +getQueryParam :: Maybe String -> ClientM Person +getQueryParams :: [String] -> ClientM [Person] +getQueryFlag :: Bool -> ClientM Bool getRawSuccess :: HTTP.Method - -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString) + -> ClientM Response getRawFailure :: HTTP.Method - -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString) + -> 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 + -> ClientM (String, Maybe Int, Bool, [(String, [Rational])]) +getRespHeaders :: ClientM (Headers TestHeaders Bool) +getDeleteContentType :: ClientM NoContent getGet :<|> getDeleteEmpty @@ -147,7 +161,7 @@ getGet :<|> getMultiple :<|> getRespHeaders :<|> getDeleteContentType - :<|> EmptyClient = client inClientM api + :<|> EmptyClient = client api server :: Application server = serve api ( @@ -162,8 +176,8 @@ server = serve api ( 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") + :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess") + :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure") :<|> (\ a b c d -> return (a, b, c, d)) :<|> (return $ addHeader 1729 $ addHeader "eg2" True) :<|> return NoContent @@ -179,9 +193,9 @@ 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")] "") + (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "") + :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "") + :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "") ) -- * basic auth stuff @@ -237,7 +251,7 @@ type GenericClientAPI :<|> Capture "foo" String :> NestedAPI1 data GenericClient = GenericClient - { getSqr :: Maybe Int -> SCR.ClientM Int + { getSqr :: Maybe Int -> ClientM Int , mkNestedClient1 :: String -> NestedClient1 } deriving Generic instance SOP.Generic GenericClient @@ -249,7 +263,7 @@ type NestedAPI1 data NestedClient1 = NestedClient1 { mkNestedClient2 :: Maybe Int -> NestedClient2 - , idChar :: Maybe Char -> SCR.ClientM Char + , idChar :: Maybe Char -> ClientM Char } deriving Generic instance SOP.Generic NestedClient1 instance (Client ClientM NestedAPI1 ~ client) => ClientLike client NestedClient1 @@ -259,8 +273,8 @@ type NestedAPI2 :<|> "void" :> Post '[JSON] () data NestedClient2 = NestedClient2 - { getSum :: Int -> Int -> SCR.ClientM Int - , doNothing :: SCR.ClientM () + { getSum :: Int -> Int -> ClientM Int + , doNothing :: ClientM () } deriving Generic instance SOP.Generic NestedClient2 instance (Client ClientM NestedAPI2 ~ client) => ClientLike client NestedClient2 @@ -277,50 +291,52 @@ genericClientServer = serve (Proxy :: Proxy GenericClientAPI) ( 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 +{-# NOINLINE manager' #-} +manager' :: C.Manager +manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings + +runClient x = runClientM x (ClientEnv manager' baseUrl) 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 + (left show <$> runClient getGet) `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 + (left show <$> (runClient getDeleteEmpty)) `shouldReturn` Right NoContent it "allows content type" $ \(_, baseUrl) -> do - (left show <$> (runClientM getDeleteContentType (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent + (left show <$> (runClient getDeleteContentType)) `shouldReturn` Right NoContent it "Servant.API.Capture" $ \(_, baseUrl) -> do - (left show <$> (runClientM (getCapture "Paula") (ClientEnv manager baseUrl))) `shouldReturn` Right (Person "Paula" 0) + (left show <$> (runClient (getCapture "Paula"))) `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 + (left show <$> (runClient (getCaptureAll ["Paula", "Peta"]))) `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 + (left show <$> runClient (getBody p)) `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" + left show <$> runClient (getQueryParam (Just "alice")) `shouldReturn` Right alice + Left (FailureResponse r) <- runClient (getQueryParam (Just "bob")) + responseStatusCode r `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)) + (left show <$> runClient (getQueryParams [])) `shouldReturn` Right [] + (left show <$> runClient (getQueryParams ["alice", "bob"])) `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 + (left show <$> runClient (getQueryFlag flag)) `shouldReturn` Right flag it "Servant.API.Raw on success" $ \(_, baseUrl) -> do - res <- runClientM (getRawSuccess HTTP.methodGet) (ClientEnv manager baseUrl) + res <- runClient (getRawSuccess HTTP.methodGet) case res of Left e -> assertFailure $ show e Right (code, body, ct, _, response) -> do @@ -329,15 +345,16 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do 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) + res <- runClient (getRawFailure HTTP.methodGet) 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" + Left (FailureResponse r) -> do + responseStatusCode r `shouldBe` HTTP.status400 + responseBody r `shouldBe` "rawFailure" + Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e it "Returns headers appropriately" $ \(_, baseUrl) -> do - res <- runClientM getRespHeaders (ClientEnv manager baseUrl) + res <- runClient getRespHeaders case res of Left e -> assertFailure $ show e Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] @@ -346,7 +363,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ 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) + result <- left show <$> runClient (getMultiple cap num flag body) return $ result === Right (cap, num, flag, body) @@ -358,10 +375,10 @@ wrappedApiSpec = describe "error status codes" $ do let test :: (WrappedApi, String) -> Spec test (WrappedApi api, desc) = it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do - let getResponse :: SCR.ClientM () - getResponse = client inClientM api - Left FailureResponse{..} <- runClientM getResponse (ClientEnv manager baseUrl) - responseStatus `shouldBe` (HTTP.Status 500 "error message") + let getResponse :: ClientM () + getResponse = client api + Left (FailureResponse r) <- runClient getResponse + responseStatusCode r `shouldBe` (HTTP.Status 500 "error message") in mapM_ test $ (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") : (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") : @@ -374,43 +391,43 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do context "client returns errors appropriately" $ do it "reports FailureResponse" $ \(_, baseUrl) -> do - let (_ :<|> getDeleteEmpty :<|> _) = client inClientM api - Left res <- runClientM getDeleteEmpty (ClientEnv manager baseUrl) + let (_ :<|> getDeleteEmpty :<|> _) = client api + Left res <- runClient getDeleteEmpty case res of - FailureResponse _ (HTTP.Status 404 "Not Found") _ _ -> return () + FailureResponse r | responseStatusCode r == 404 -> return () _ -> fail $ "expected 404 response, but got " <> show res it "reports DecodeFailure" $ \(_, baseUrl) -> do - let (_ :<|> _ :<|> getCapture :<|> _) = client inClientM api - Left res <- runClientM (getCapture "foo") (ClientEnv manager baseUrl) + let (_ :<|> _ :<|> getCapture :<|> _) = client api + Left res <- runClient (getCapture "foo") (ClientEnv manager baseUrl) case res of - DecodeFailure _ ("application/json") _ -> return () + DecodeFailure _ _ -> return () _ -> fail $ "expected DecodeFailure, but got " <> show res it "reports ConnectionError" $ \_ -> do - let (getGetWrongHost :<|> _) = client inClientM api + 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 inClientM api - Left res <- runClientM getGet (ClientEnv manager baseUrl) + let (getGet :<|> _ ) = client api + Left res <- runClient getGet case res of UnsupportedContentType ("application/octet-stream") _ -> return () _ -> fail $ "expected UnsupportedContentType, but got " <> show res it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do - let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client inClientM api - Left res <- runClientM (getBody alice) (ClientEnv manager baseUrl) + let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api + Left res <- runClient (getBody alice) case res of - InvalidContentTypeHeader "fooooo" _ -> return () + InvalidContentTypeHeader _ -> return () _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res data WrappedApi where WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a, - HasClient ClientM api, Client ClientM api ~ SCR.ClientM ()) => + HasClient ClientM api, Client ClientM api ~ ClientM ()) => Proxy api -> WrappedApi basicAuthSpec :: Spec @@ -418,50 +435,50 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d context "Authentication works when requests are properly authenticated" $ do it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do - let getBasic = client inClientM basicAuthAPI + let getBasic = client basicAuthAPI let basicAuthData = BasicAuthData "servant" "server" - (left show <$> runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)) `shouldReturn` Right alice + (left show <$> runClient (getBasic basicAuthData)) `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 inClientM basicAuthAPI + let getBasic = client basicAuthAPI let basicAuthData = BasicAuthData "not" "password" - Left FailureResponse{..} <- runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl) - responseStatus `shouldBe` HTTP.Status 403 "Forbidden" + Left (FailureResponse r) <- runClient (getBasic basicAuthData) + responseStatusCode r `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 inClientM genAuthAPI - let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req) - (left show <$> runClientM (getProtected authRequest) (ClientEnv manager baseUrl)) `shouldReturn` Right alice + let getProtected = client genAuthAPI + let authRequest = mkAuthenticateReq () (\_ req -> addHeader "AuthHeader" ("cool" :: String) req) + (left show <$> runClient (getProtected authRequest) ) `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 inClientM 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") + let getProtected = client genAuthAPI + let authRequest = mkAuthenticateReq () (\_ req -> addHeader "Wrong" ("header" :: String) req) + Left (FailureResponse r) <- runClient (getProtected authRequest) + responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized") genericClientSpec :: Spec genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWaiApp $ do describe "Servant.Client.Generic" $ do - let GenericClient{..} = mkClient (client inClientM (Proxy :: Proxy GenericClientAPI)) + let GenericClient{..} = mkClient (client (Proxy :: Proxy GenericClientAPI)) NestedClient1{..} = mkNestedClient1 "example" NestedClient2{..} = mkNestedClient2 (Just 42) it "works for top-level client inClientM function" $ \(_, baseUrl) -> do - (left show <$> (runClientM (getSqr (Just 5)) (ClientEnv manager baseUrl))) `shouldReturn` Right 25 + (left show <$> (runClient (getSqr (Just 5)))) `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 () + (left show <$> (runClient (idChar (Just 'c')))) `shouldReturn` Right 'c' + (left show <$> (runClient (getSum 3 4))) `shouldReturn` Right 7 + (left show <$> (runClient doNothing )) `shouldReturn` Right () -- * utils From 5bd9d253cebfd32d33a12c90ba04a403d193ce02 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 12 Sep 2017 14:43:16 -0400 Subject: [PATCH 13/26] Almost compiling test --- .../src/Servant/Client/Core.hs | 1 + .../Servant/Client/Core/Internal/Generic.hs | 3 - servant-client/servant-client.cabal | 1 + .../src/Servant/Client/Internal/HttpClient.hs | 3 + servant-client/test/Servant/ClientSpec.hs | 105 +++++++++--------- 5 files changed, 59 insertions(+), 54 deletions(-) diff --git a/servant-client-core/src/Servant/Client/Core.hs b/servant-client-core/src/Servant/Client/Core.hs index 5de52556..6d216d1f 100644 --- a/servant-client-core/src/Servant/Client/Core.hs +++ b/servant-client-core/src/Servant/Client/Core.hs @@ -26,6 +26,7 @@ module Servant.Client.Core , EmptyClient(..) , RunClient(..) , Request(..) + , defaultRequest , Response(..) , RequestBody(..) , module Servant.Client.Core.Internal.BaseUrl diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Generic.hs b/servant-client-core/src/Servant/Client/Core/Internal/Generic.hs index fa3a94bf..4bc1bda8 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Generic.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Generic.hs @@ -106,9 +106,6 @@ instance ClientLike client custom => ClientLike (a -> client) (a -> custom) where mkClient c = mkClient . c -instance ClientLike (m a) (m a) where - mkClient = id - -- | Match client structure with client functions, regarding left-nested API clients -- as separate data structures. class GClientLikeP client xs where diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 116d92cd..de9d0287 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -73,6 +73,7 @@ test-suite spec , aeson , base-compat , bytestring + , containers , deepseq , hspec == 2.* , http-api-data diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index dcf72dc3..93d831b9 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient.hs @@ -76,6 +76,9 @@ instance Alt ClientM where instance RunClient ClientM where runRequest = performRequest +instance ClientLike (ClientM a) (ClientM a) where + mkClient = id + runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a) runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 1a37cc3f..46835495 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -26,6 +26,9 @@ #include "overlapping-compat.h" module Servant.ClientSpec where +import Prelude () +import Prelude.Compat + import Control.Arrow (left) import Control.Concurrent (ThreadId, forkIO, killThread) @@ -34,9 +37,12 @@ import Control.Monad.Error.Class (throwError) import Data.Aeson import qualified Data.ByteString.Lazy as BS import Data.Char (chr, isPrint) +import Data.Foldable (toList) import Data.Foldable (forM_) +import Data.Maybe (isJust) import Data.Monoid hiding (getLast) import Data.Proxy +import Data.Sequence (findIndexL) import qualified Generics.SOP as SOP import GHC.Generics (Generic) import qualified Network.HTTP.Client as C @@ -45,8 +51,6 @@ import qualified Network.HTTP.Types as HTTP import Network.Socket import qualified Network.Wai as Wai import Network.Wai.Handler.Warp -import Prelude () -import Prelude.Compat import System.IO.Unsafe (unsafePerformIO) import Test.Hspec import Test.Hspec.QuickCheck @@ -61,19 +65,19 @@ import Servant.API ((:<|>) ((:<|>)), Capture, CaptureAll, Delete, DeleteNoContent, - EmptyAPI, + EmptyAPI, addHeader, FormUrlEncoded, Get, Header, Headers, JSON, - NoContent, Post, - Put, QueryFlag, + NoContent (NoContent), + Post, Put, Raw, + QueryFlag, QueryParam, QueryParams, - ReqBody) + ReqBody, + getHeaders) import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Client -{-import qualified Servant.Common.Req as SCR-} -{-import qualified Servant.Client.HttpClient as SCR-} import Servant.Server import Servant.Server.Experimental.Auth @@ -139,10 +143,8 @@ getBody :: Person -> ClientM Person getQueryParam :: Maybe String -> ClientM Person getQueryParams :: [String] -> ClientM [Person] getQueryFlag :: Bool -> ClientM Bool -getRawSuccess :: HTTP.Method - -> ClientM Response -getRawFailure :: HTTP.Method - -> ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString) +getRawSuccess :: HTTP.Method -> ClientM Response +getRawFailure :: HTTP.Method -> ClientM Response getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> ClientM (String, Maybe Int, Bool, [(String, [Rational])]) getRespHeaders :: ClientM (Headers TestHeaders Bool) @@ -179,7 +181,7 @@ server = serve api ( :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess") :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure") :<|> (\ a b c d -> return (a, b, c, d)) - :<|> (return $ addHeader 1729 $ addHeader "eg2" True) + :<|> (return $ Servant.API.addHeader 1729 $ Servant.API.addHeader "eg2" True) :<|> return NoContent :<|> emptyServer) @@ -233,7 +235,7 @@ type instance AuthClientData (AuthProtect "auth-tag") = () genAuthHandler :: AuthHandler Request () genAuthHandler = - let handler req = case lookup "AuthHeader" (requestHeaders req) of + let handler req = case lookup "AuthHeader" (toList $ requestHeaders req) of Nothing -> throwError (err401 { errBody = "Missing auth header" }) Just _ -> return () in mkAuthHandler handler @@ -295,57 +297,58 @@ genericClientServer = serve (Proxy :: Proxy GenericClientAPI) ( manager' :: C.Manager manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings -runClient x = runClientM x (ClientEnv manager' baseUrl) +runClient x baseUrl' = runClientM x (ClientEnv manager' baseUrl') sucessSpec :: Spec sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do it "Servant.API.Get" $ \(_, baseUrl) -> do - (left show <$> runClient getGet) `shouldReturn` Right alice + left show <$> runClient getGet baseUrl `shouldReturn` Right alice describe "Servant.API.Delete" $ do it "allows empty content type" $ \(_, baseUrl) -> do - (left show <$> (runClient getDeleteEmpty)) `shouldReturn` Right NoContent + left show <$> runClient getDeleteEmpty baseUrl `shouldReturn` Right NoContent it "allows content type" $ \(_, baseUrl) -> do - (left show <$> (runClient getDeleteContentType)) `shouldReturn` Right NoContent + left show <$> runClient getDeleteContentType baseUrl `shouldReturn` Right NoContent it "Servant.API.Capture" $ \(_, baseUrl) -> do - (left show <$> (runClient (getCapture "Paula"))) `shouldReturn` Right (Person "Paula" 0) + left show <$> runClient (getCapture "Paula") baseUrl `shouldReturn` Right (Person "Paula" 0) it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do let expected = [(Person "Paula" 0), (Person "Peta" 1)] - (left show <$> (runClient (getCaptureAll ["Paula", "Peta"]))) `shouldReturn` Right expected + left show <$> runClient (getCaptureAll ["Paula", "Peta"]) baseUrl `shouldReturn` Right expected it "Servant.API.ReqBody" $ \(_, baseUrl) -> do let p = Person "Clara" 42 - (left show <$> runClient (getBody p)) `shouldReturn` Right p + left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p it "Servant.API.QueryParam" $ \(_, baseUrl) -> do - left show <$> runClient (getQueryParam (Just "alice")) `shouldReturn` Right alice - Left (FailureResponse r) <- runClient (getQueryParam (Just "bob")) + left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice + Left (FailureResponse r) <- runClient (getQueryParam (Just "bob")) baseUrl responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found" it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do - (left show <$> runClient (getQueryParams [])) `shouldReturn` Right [] - (left show <$> runClient (getQueryParams ["alice", "bob"])) + left show <$> runClient (getQueryParams []) baseUrl `shouldReturn` Right [] + left show <$> runClient (getQueryParams ["alice", "bob"]) 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 <$> runClient (getQueryFlag flag)) `shouldReturn` Right flag + left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag it "Servant.API.Raw on success" $ \(_, baseUrl) -> do - res <- runClient (getRawSuccess HTTP.methodGet) + res <- runClient (getRawSuccess HTTP.methodGet) 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 + Right r -> do + responseStatusCode r `shouldBe` HTTP.status200 + responseBody r `shouldBe` "rawSuccess" + findIndexL (\x -> fst x == HTTP.hContentType) (responseHeaders r) + `shouldSatisfy` isJust it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do - res <- runClient (getRawFailure HTTP.methodGet) + res <- runClient (getRawFailure HTTP.methodGet) baseUrl case res of Right _ -> assertFailure "expected Left, but got Right" Left (FailureResponse r) -> do @@ -354,7 +357,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e it "Returns headers appropriately" $ \(_, baseUrl) -> do - res <- runClient getRespHeaders + res <- runClient getRespHeaders baseUrl case res of Left e -> assertFailure $ show e Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] @@ -363,7 +366,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ 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 <$> runClient (getMultiple cap num flag body) + result <- left show <$> runClient (getMultiple cap num flag body) baseUrl return $ result === Right (cap, num, flag, body) @@ -377,7 +380,7 @@ wrappedApiSpec = describe "error status codes" $ do it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do let getResponse :: ClientM () getResponse = client api - Left (FailureResponse r) <- runClient getResponse + Left (FailureResponse r) <- runClient getResponse baseUrl responseStatusCode r `shouldBe` (HTTP.Status 500 "error message") in mapM_ test $ (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") : @@ -392,35 +395,35 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do context "client returns errors appropriately" $ do it "reports FailureResponse" $ \(_, baseUrl) -> do let (_ :<|> getDeleteEmpty :<|> _) = client api - Left res <- runClient getDeleteEmpty + Left res <- runClient getDeleteEmpty baseUrl case res of - FailureResponse r | responseStatusCode r == 404 -> return () + FailureResponse r | responseStatusCode r == HTTP.status404 -> return () _ -> fail $ "expected 404 response, but got " <> show res it "reports DecodeFailure" $ \(_, baseUrl) -> do let (_ :<|> _ :<|> getCapture :<|> _) = client api - Left res <- runClient (getCapture "foo") (ClientEnv manager baseUrl) + Left res <- runClient (getCapture "foo") baseUrl case res of DecodeFailure _ _ -> 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 "")) + Left res <- runClient getGetWrongHost (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 <- runClient getGet + Left res <- runClient getGet 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 <- runClient (getBody alice) + Left res <- runClient (getBody alice) baseUrl case res of InvalidContentTypeHeader _ -> return () _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res @@ -437,14 +440,14 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do let getBasic = client basicAuthAPI let basicAuthData = BasicAuthData "servant" "server" - (left show <$> runClient (getBasic basicAuthData)) `shouldReturn` Right alice + left show <$> runClient (getBasic basicAuthData) 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 r) <- runClient (getBasic basicAuthData) + Left (FailureResponse r) <- runClient (getBasic basicAuthData) baseUrl responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden" genAuthSpec :: Spec @@ -453,15 +456,15 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do let getProtected = client genAuthAPI - let authRequest = mkAuthenticateReq () (\_ req -> addHeader "AuthHeader" ("cool" :: String) req) - (left show <$> runClient (getProtected authRequest) ) `shouldReturn` Right alice + let authRequest = mkAuthenticateReq () (\_ req -> Servant.Client.addHeader "AuthHeader" ("cool" :: String) req) + left show <$> runClient (getProtected authRequest) 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 -> addHeader "Wrong" ("header" :: String) req) - Left (FailureResponse r) <- runClient (getProtected authRequest) + let authRequest = mkAuthenticateReq () (\_ req -> Servant.Client.addHeader "Wrong" ("header" :: String) req) + Left (FailureResponse r) <- runClient (getProtected authRequest) baseUrl responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized") genericClientSpec :: Spec @@ -473,12 +476,12 @@ genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWa NestedClient2{..} = mkNestedClient2 (Just 42) it "works for top-level client inClientM function" $ \(_, baseUrl) -> do - (left show <$> (runClient (getSqr (Just 5)))) `shouldReturn` Right 25 + left show <$> runClient (getSqr (Just 5)) baseUrl `shouldReturn` Right 25 it "works for nested clients" $ \(_, baseUrl) -> do - (left show <$> (runClient (idChar (Just 'c')))) `shouldReturn` Right 'c' - (left show <$> (runClient (getSum 3 4))) `shouldReturn` Right 7 - (left show <$> (runClient doNothing )) `shouldReturn` Right () + left show <$> runClient (idChar (Just 'c')) baseUrl `shouldReturn` Right 'c' + left show <$> runClient (getSum 3 4) baseUrl `shouldReturn` Right 7 + left show <$> runClient doNothing baseUrl `shouldReturn` Right () -- * utils From ffbfa42a14b4bd922784b3a21f67e3148fb9421d Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 12 Sep 2017 19:49:55 -0400 Subject: [PATCH 14/26] Tests now pass --- .../src/Servant/Client/Core.hs | 9 ++--- .../src/Servant/Client/Core/Internal/Class.hs | 39 +++++++++++++++++-- servant-client/test/Servant/ClientSpec.hs | 20 ++++------ 3 files changed, 47 insertions(+), 21 deletions(-) diff --git a/servant-client-core/src/Servant/Client/Core.hs b/servant-client-core/src/Servant/Client/Core.hs index 6d216d1f..822df161 100644 --- a/servant-client-core/src/Servant/Client/Core.hs +++ b/servant-client-core/src/Servant/Client/Core.hs @@ -225,11 +225,10 @@ instance OVERLAPPABLE_ { requestAccept = fromList $ toList accept , requestMethod = method } - case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of - Left err -> throwError $ DecodeFailure (pack err) response - Right val -> return val - where method = reflectMethod (Proxy :: Proxy method) - accept = contentTypes (Proxy :: Proxy ct) + response `decodedAs` (Proxy :: Proxy ct) + where + accept = contentTypes (Proxy :: Proxy ct) + method = reflectMethod (Proxy :: Proxy method) instance OVERLAPPING_ ( RunClient m, ReflectMethod method diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Class.hs b/servant-client-core/src/Servant/Client/Core/Internal/Class.hs index 0428fcb8..37287fd9 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Class.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Class.hs @@ -1,11 +1,44 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} {-| Types for possible backends to run client-side `Request` queries -} module Servant.Client.Core.Internal.Class where -import Control.Monad.Error.Class (MonadError) -import Servant.Client.Core.Internal.Request (Request, Response, - ServantError) +import Control.Monad (unless) +import Control.Monad.Error.Class (MonadError, throwError) +import Data.Proxy (Proxy) +import qualified Data.Text as T +import Network.HTTP.Media (MediaType, matches, + parseAccept, (//)) +import Servant.API (MimeUnrender, + contentTypes, + mimeUnrender) +import Servant.Client.Core.Internal.Request (Request, Response (..), + ServantError (..)) +import Data.Foldable (toList) class (MonadError ServantError m) => RunClient m where + -- | How to make a request. runRequest :: Request -> m Response + +checkContentTypeHeader :: RunClient m => Response -> m MediaType +checkContentTypeHeader response = + case lookup "Content-Type" $ toList $ responseHeaders response of + Nothing -> pure $ "application"//"octet-stream" + Just t -> case parseAccept t of + Nothing -> throwError $ InvalidContentTypeHeader response + Just t' -> pure 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) $ + throwError $ UnsupportedContentType responseContentType response + case mimeUnrender contentType $ responseBody response of + Left err -> throwError $ DecodeFailure (T.pack err) response + Right val -> return val + where + accept = toList $ contentTypes contentType diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 46835495..3a5ef1f6 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -24,7 +24,7 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} #include "overlapping-compat.h" -module Servant.ClientSpec where +module Servant.ClientSpec (spec) where import Prelude () import Prelude.Compat @@ -35,18 +35,13 @@ import Control.Concurrent (ThreadId, forkIO, 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 (toList) import Data.Foldable (forM_) -import Data.Maybe (isJust) import Data.Monoid hiding (getLast) import Data.Proxy -import Data.Sequence (findIndexL) 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 qualified Network.Wai as Wai @@ -96,8 +91,8 @@ spec = describe "Servant.Client" $ do -- * test data types data Person = Person - { name :: String - , age :: Integer + { _name :: String + , _age :: Integer } deriving (Eq, Show, Generic) instance ToJSON Person @@ -233,14 +228,14 @@ genAuthAPI = Proxy type instance AuthServerData (AuthProtect "auth-tag") = () type instance AuthClientData (AuthProtect "auth-tag") = () -genAuthHandler :: AuthHandler Request () +genAuthHandler :: AuthHandler Wai.Request () genAuthHandler = - let handler req = case lookup "AuthHeader" (toList $ requestHeaders req) of + let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of Nothing -> throwError (err401 { errBody = "Missing auth header" }) Just _ -> return () in mkAuthHandler handler -genAuthServerContext :: Context '[ AuthHandler Request () ] +genAuthServerContext :: Context '[ AuthHandler Wai.Request () ] genAuthServerContext = genAuthHandler :. EmptyContext genAuthServer :: Application @@ -297,6 +292,7 @@ genericClientServer = serve (Proxy :: Proxy GenericClientAPI) ( manager' :: C.Manager manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings +runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a) runClient x baseUrl' = runClientM x (ClientEnv manager' baseUrl') sucessSpec :: Spec @@ -344,8 +340,6 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do Right r -> do responseStatusCode r `shouldBe` HTTP.status200 responseBody r `shouldBe` "rawSuccess" - findIndexL (\x -> fst x == HTTP.hContentType) (responseHeaders r) - `shouldSatisfy` isJust it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do res <- runClient (getRawFailure HTTP.methodGet) baseUrl From 6be78e0b387f44277ee9339fd49472e603a2e23e Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 13 Sep 2017 11:05:48 -0400 Subject: [PATCH 15/26] Documentation --- .../src/Servant/Client/Core.hs | 51 ++++++++++++------- .../src/Servant/Client/Core/Internal/Class.hs | 2 +- .../Servant/Client/Core/Internal/Request.hs | 2 + servant-client/src/Servant/Client.hs | 11 ++-- .../src/Servant/Client/Internal/HttpClient.hs | 25 ++++++--- 5 files changed, 61 insertions(+), 30 deletions(-) diff --git a/servant-client-core/src/Servant/Client/Core.hs b/servant-client-core/src/Servant/Client/Core.hs index 822df161..bb078ee4 100644 --- a/servant-client-core/src/Servant/Client/Core.hs +++ b/servant-client-core/src/Servant/Client/Core.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -17,23 +16,34 @@ -- querying functions for each endpoint just from the type representing your -- API. module Servant.Client.Core - ( AuthClientData - , AuthenticateReq(..) - , clientIn + ( + -- * Client generation + clientIn , HasClient(..) + + -- * Authentication , mkAuthenticateReq - , ServantError(..) - , EmptyClient(..) - , RunClient(..) - , Request(..) - , defaultRequest - , Response(..) - , RequestBody(..) - , module Servant.Client.Core.Internal.BaseUrl + , AuthenticateReq(..) + , AuthClientData + + -- * Generic Client , ClientLike(..) , genericMkClientL , genericMkClientP - -- * Writing instances + , ServantError(..) + , EmptyClient(..) + + -- * Request + , Request(..) + , defaultRequest + , RequestBody(..) + + -- * Response + , Response(..) + , RunClient(..) + , module Servant.Client.Core.Internal.BaseUrl + + -- * Writing HasClient instances , addHeader , appendToQueryString , appendToPath @@ -84,13 +94,13 @@ import Servant.Client.Core.Internal.BaseUrl (BaseUrl (..), showBaseUrl) import Servant.Client.Core.Internal.BasicAuth import Servant.Client.Core.Internal.Class -import Servant.Client.Core.Internal.Request import Servant.Client.Core.Internal.Generic +import Servant.Client.Core.Internal.Request -- * Accessing APIs as a Client --- | 'client' allows you to produce operations to query an API from a client within --- a given monadic context `m` +-- | '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 @@ -108,9 +118,12 @@ 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. It's mostly --- an internal class, you can just use 'client'. +-- | 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 diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Class.hs b/servant-client-core/src/Servant/Client/Core/Internal/Class.hs index 37287fd9..5cf5ce1e 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Class.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Class.hs @@ -3,7 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} -{-| Types for possible backends to run client-side `Request` queries -} +-- | Types for possible backends to run client-side `Request` queries module Servant.Client.Core.Internal.Class where import Control.Monad (unless) diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs index 8b9306d3..4d9475d1 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs @@ -28,6 +28,8 @@ import Web.HttpApiData (ToHttpApiData, toEncodedUrlPiece, toHeader) -- | A type representing possible errors in a request +-- +-- Note that this type substially change in 0.12 data ServantError = -- | The server returned an error response FailureResponse Response diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index bf03817f..5e2189c8 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -1,10 +1,13 @@ +-- | This module provides 'client' which can automatically generate +-- querying functions for each endpoint just from the type representing your +-- API. module Servant.Client - ( ClientEnv(..) + ( client , ClientM , runClientM - , client - , module X + , ClientEnv(..) + , module Servant.Client.Core ) where import Servant.Client.Internal.HttpClient -import Servant.Client.Core as X +import Servant.Client.Core diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index 93d831b9..b869290f 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient.hs @@ -41,23 +41,36 @@ import Servant.Client.Core import qualified Network.HTTP.Client as Client +-- | The environment in which a request is run. data ClientEnv = ClientEnv { manager :: Client.Manager , baseUrl :: BaseUrl } +-- | Generates a set of client functions for an API. +-- +-- Example: +-- +-- > type API = Capture "no" Int :> Get '[JSON] Int +-- > :<|> Get '[JSON] [Bool] +-- > +-- > api :: Proxy API +-- > api = Proxy +-- > +-- > getInt :: Int -> ClientM Int +-- > getBools :: ClientM [Bool] +-- > getInt :<|> getBools = client api client :: HasClient ClientM api => Proxy api -> Client ClientM api client api = api `clientIn` (Proxy :: Proxy ClientM) -- | @ClientM@ is the monad in which client functions run. Contains the -- '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 - ) +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 From e8b9814168432237ec293f4b320703e5fd1625df Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 13 Sep 2017 12:36:20 -0400 Subject: [PATCH 16/26] Documentation and Reexport module --- servant-client-core/servant-client-core.cabal | 4 +- .../src/Servant/Client/Core.hs | 60 +- .../src/Servant/Client/Core/Internal/Auth.hs | 10 +- .../Servant/Client/Core/Internal/HasClient.hs | 541 ++++++++++++++++++ .../Core/Internal/{Class.hs => RunClient.hs} | 2 +- .../src/Servant/Client/Core/Reexport.hs | 30 + servant-client/servant-client.cabal | 1 + servant-client/src/Servant/Client.hs | 4 +- .../src/Servant/Client/Internal/HttpClient.hs | 3 +- servant-client/test/Servant/ClientSpec.hs | 10 +- 10 files changed, 627 insertions(+), 38 deletions(-) create mode 100644 servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs rename servant-client-core/src/Servant/Client/Core/Internal/{Class.hs => RunClient.hs} (97%) create mode 100644 servant-client-core/src/Servant/Client/Core/Reexport.hs diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index d5716be5..8f16b11e 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -24,12 +24,14 @@ source-repository head library exposed-modules: Servant.Client.Core + Servant.Client.Core.Reexport Servant.Client.Core.Internal.Auth Servant.Client.Core.Internal.BaseUrl Servant.Client.Core.Internal.BasicAuth - Servant.Client.Core.Internal.Class Servant.Client.Core.Internal.Generic + Servant.Client.Core.Internal.HasClient Servant.Client.Core.Internal.Request + Servant.Client.Core.Internal.RunClient build-depends: base >= 4.7 && < 4.11 , base-compat >= 0.9.1 && < 0.10 diff --git a/servant-client-core/src/Servant/Client/Core.hs b/servant-client-core/src/Servant/Client/Core.hs index bb078ee4..8a5cd6dd 100644 --- a/servant-client-core/src/Servant/Client/Core.hs +++ b/servant-client-core/src/Servant/Client/Core.hs @@ -1,29 +1,33 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -#include "overlapping-compat.h" --- | This module provides 'client' which can automatically generate --- querying functions for each endpoint just from the type representing your --- API. +-- | 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, who are encouraged +-- to re-export the parts of the module Servant.Client.Core ( -- * Client generation clientIn , HasClient(..) + -- * Request + , Request(..) + , defaultRequest + , RequestBody(..) + -- * Authentication - , mkAuthenticateReq - , AuthenticateReq(..) + , mkAuthenticatedRequest + , basicAuthReq + , AuthenticatedRequest(..) , AuthClientData -- * Generic Client @@ -33,10 +37,6 @@ module Servant.Client.Core , ServantError(..) , EmptyClient(..) - -- * Request - , Request(..) - , defaultRequest - , RequestBody(..) -- * Response , Response(..) @@ -44,13 +44,26 @@ module Servant.Client.Core , module Servant.Client.Core.Internal.BaseUrl -- * Writing HasClient instances + -- | These functions need not be re-exported by backend libraries. , addHeader , appendToQueryString , appendToPath , setRequestBodyLBS , setRequestBody ) where +import Servant.Client.Core.Internal.Auth +import Servant.Client.Core.Internal.BaseUrl (BaseUrl (..), + InvalidBaseUrlException, + Scheme (..), + parseBaseUrl, + showBaseUrl) +import Servant.Client.Core.Internal.BasicAuth +import Servant.Client.Core.Internal.HasClient +import Servant.Client.Core.Internal.Generic +import Servant.Client.Core.Internal.Request +import Servant.Client.Core.Internal.RunClient +{- import Control.Monad.Error.Class (throwError) import Data.List (foldl') import Data.Proxy (Proxy (Proxy)) @@ -581,3 +594,4 @@ 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). -} +-} diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Auth.hs b/servant-client-core/src/Servant/Client/Core/Internal/Auth.hs index cf9eb596..7e10f054 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Auth.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Auth.hs @@ -20,13 +20,13 @@ type family AuthClientData a :: * -- data to a request -- -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE -newtype AuthenticateReq a = - AuthenticateReq { unAuthReq :: (AuthClientData a, AuthClientData a -> Request -> Request) } +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 -mkAuthenticateReq :: AuthClientData a +mkAuthenticatedRequest :: AuthClientData a -> (AuthClientData a -> Request -> Request) - -> AuthenticateReq a -mkAuthenticateReq val func = AuthenticateReq (val, func) + -> AuthenticatedRequest a +mkAuthenticatedRequest val func = AuthenticatedRequest (val, func) diff --git a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs new file mode 100644 index 00000000..2d619236 --- /dev/null +++ b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs @@ -0,0 +1,541 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +#include "overlapping-compat.h" +module Servant.Client.Core.Internal.HasClient where + + +import Control.Monad.Error.Class (throwError) +import Data.List (foldl') +import Data.Proxy (Proxy (Proxy)) +import Data.String (fromString) +import Data.Text (pack) +import GHC.Exts (fromList, toList) +import GHC.TypeLits (KnownSymbol, symbolVal) +import qualified Network.HTTP.Types as H +import Prelude () +import Prelude.Compat +import Servant.API ((:<|>) ((:<|>)), (:>), + AuthProtect, BasicAuth, + BasicAuthData, + BuildHeadersTo (..), + Capture, CaptureAll, + Description, EmptyAPI, + Header, Headers (..), + HttpVersion, IsSecure, + MimeRender (mimeRender), + MimeUnrender (mimeUnrender), + NoContent (NoContent), + QueryFlag, QueryParam, + QueryParams, Raw, + ReflectMethod (..), + RemoteHost, ReqBody, + Summary, ToHttpApiData, + Vault, Verb, + WithNamedContext, + contentType, + getHeadersHList, + getResponse, + toQueryParam, + toUrlPiece) +import Servant.API.ContentTypes (contentTypes) + +import Servant.Client.Core.Internal.Auth +import Servant.Client.Core.Internal.BasicAuth +import Servant.Client.Core.Internal.Request +import Servant.Client.Core.Internal.RunClient + +-- * Accessing APIs as a Client + +-- | 'clientIn' allows you to produce operations to query an API from a client +-- within a 'RunClient' monad. +-- +-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books +-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > clientM :: Proxy ClientM +-- > clientM = Proxy +-- > +-- > getAllBooks :: ClientM [Book] +-- > postNewBook :: Book -> ClientM Book +-- > (getAllBooks :<|> postNewBook) = myApi `clientIn` clientM +clientIn :: HasClient m api => Proxy api -> Proxy m -> Client m api +clientIn p pm = clientWithRoute pm p defaultRequest + + +-- | This class lets us define how each API combinator influences the creation +-- of an HTTP request. +-- +-- Unless you are writing a new backend for @servant-client-core@ or new +-- combinators that you want to support client-generation, you can ignore this +-- class. +class RunClient m => HasClient m api where + type Client (m :: * -> *) (api :: *) :: * + clientWithRoute :: Proxy m -> Proxy api -> Request -> Client m api + + +-- | A client querying function for @a ':<|>' b@ will actually hand you +-- one function for querying @a@ and another one for querying @b@, +-- stitching them together with ':<|>', which really is just like a pair. +-- +-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books +-- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getAllBooks :: ClientM [Book] +-- > postNewBook :: Book -> ClientM Book +-- > (getAllBooks :<|> postNewBook) = client myApi +instance (HasClient m a, HasClient m b) => HasClient m (a :<|> b) where + type Client m (a :<|> b) = Client m a :<|> Client m b + clientWithRoute pm Proxy req = + clientWithRoute pm (Proxy :: Proxy a) req :<|> + clientWithRoute pm (Proxy :: Proxy b) req + +-- | Singleton type representing a client for an empty API. +data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum) + +-- | The client for 'EmptyAPI' is simply 'EmptyClient'. +-- +-- > type MyAPI = "books" :> Get '[JSON] [Book] -- GET /books +-- > :<|> "nothing" :> EmptyAPI +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getAllBooks :: ClientM [Book] +-- > (getAllBooks :<|> EmptyClient) = client myApi +instance RunClient m => HasClient m EmptyAPI where + type Client m EmptyAPI = EmptyClient + clientWithRoute _pm Proxy _ = EmptyClient + +-- | If you use a 'Capture' in one of your endpoints in your API, +-- the corresponding querying function will automatically take +-- an additional argument of the type specified by your 'Capture'. +-- That function will take care of inserting a textual representation +-- of this value at the right place in the request path. +-- +-- You can control how values for this type are turned into +-- text by specifying a 'ToHttpApiData' instance for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBook :: Text -> ClientM Book +-- > getBook = client myApi +-- > -- then you can just use "getBook" to query that endpoint +instance (KnownSymbol capture, ToHttpApiData a, HasClient m api) + => HasClient m (Capture capture a :> api) where + + type Client m (Capture capture a :> api) = + a -> Client m api + + clientWithRoute pm Proxy req val = + clientWithRoute pm (Proxy :: Proxy api) + (appendToPath p req) + + where p = (toUrlPiece val) + +-- | If you use a 'CaptureAll' in one of your endpoints in your API, +-- the corresponding querying function will automatically take an +-- additional argument of a list of the type specified by your +-- 'CaptureAll'. That function will take care of inserting a textual +-- representation of this value at the right place in the request +-- path. +-- +-- You can control how these values are turned into text by specifying +-- a 'ToHttpApiData' instance of your type. +-- +-- Example: +-- +-- > type MyAPI = "src" :> CaptureAll Text -> Get '[JSON] SourceFile +-- > +-- > myApi :: Proxy +-- > myApi = Proxy +-- +-- > getSourceFile :: [Text] -> ClientM SourceFile +-- > getSourceFile = client myApi +-- > -- then you can use "getSourceFile" to query that endpoint +instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout) + => HasClient m (CaptureAll capture a :> sublayout) where + + type Client m (CaptureAll capture a :> sublayout) = + [a] -> Client m sublayout + + clientWithRoute pm Proxy req vals = + clientWithRoute pm (Proxy :: Proxy sublayout) + (foldl' (flip appendToPath) req ps) + + where ps = map (toUrlPiece) vals + +instance OVERLAPPABLE_ + -- Note [Non-Empty Content Types] + ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) + ) => HasClient m (Verb method status cts' a) where + type Client m (Verb method status cts' a) = m a + clientWithRoute _pm Proxy req = do + response <- runRequest req + { requestAccept = fromList $ toList accept + , requestMethod = method + } + response `decodedAs` (Proxy :: Proxy ct) + where + accept = contentTypes (Proxy :: Proxy ct) + method = reflectMethod (Proxy :: Proxy method) + +instance OVERLAPPING_ + ( RunClient m, ReflectMethod method + ) => HasClient m (Verb method status cts NoContent) where + type Client m (Verb method status cts NoContent) + = m NoContent + clientWithRoute _pm Proxy req = do + _response <- runRequest req { requestMethod = method } + return NoContent + where method = reflectMethod (Proxy :: Proxy method) + +instance OVERLAPPING_ + -- Note [Non-Empty Content Types] + ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls + , ReflectMethod method, cts' ~ (ct ': cts) + ) => HasClient m (Verb method status cts' (Headers ls a)) where + type Client m (Verb method status cts' (Headers ls a)) + = m (Headers ls a) + clientWithRoute _pm Proxy req = do + response <- runRequest req + { requestMethod = method + , requestAccept = fromList $ toList accept + } + case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of + Left err -> throwError $ DecodeFailure (pack err) response + Right val -> return $ Headers + { getResponse = val + , getHeadersHList = buildHeadersTo . toList $ responseHeaders response + } + where method = reflectMethod (Proxy :: Proxy method) + accept = contentTypes (Proxy :: Proxy ct) + +instance OVERLAPPING_ + ( RunClient m, BuildHeadersTo ls, ReflectMethod method + ) => HasClient m (Verb method status cts (Headers ls NoContent)) where + type Client m (Verb method status cts (Headers ls NoContent)) + = m (Headers ls NoContent) + clientWithRoute _pm Proxy req = do + let method = reflectMethod (Proxy :: Proxy method) + response <- runRequest req { requestMethod = method } + return $ Headers { getResponse = NoContent + , getHeadersHList = buildHeadersTo . toList $ responseHeaders response + } + + +-- | If you use a 'Header' in one of your endpoints in your API, +-- the corresponding querying function will automatically take +-- an additional argument of the type specified by your 'Header', +-- wrapped in Maybe. +-- +-- That function will take care of encoding this argument as Text +-- in the request headers. +-- +-- All you need is for your type to have a 'ToHttpApiData' instance. +-- +-- Example: +-- +-- > newtype Referer = Referer { referrer :: Text } +-- > deriving (Eq, Show, Generic, ToHttpApiData) +-- > +-- > -- GET /view-my-referer +-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > viewReferer :: Maybe Referer -> ClientM Book +-- > viewReferer = client myApi +-- > -- then you can just use "viewRefer" to query that endpoint +-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments +instance (KnownSymbol sym, ToHttpApiData a, HasClient m api) + => HasClient m (Header sym a :> api) where + + type Client m (Header sym a :> api) = + Maybe a -> Client m api + + clientWithRoute pm Proxy req mval = + clientWithRoute pm (Proxy :: Proxy api) + (maybe req + (\value -> addHeader hname value req) + mval + ) + + where hname = fromString $ symbolVal (Proxy :: Proxy sym) + +-- | Using a 'HttpVersion' combinator in your API doesn't affect the client +-- functions. +instance HasClient m api + => HasClient m (HttpVersion :> api) where + + type Client m (HttpVersion :> api) = + Client m api + + clientWithRoute pm Proxy = + clientWithRoute pm (Proxy :: Proxy api) + +-- | Ignore @'Summary'@ in client functions. +instance HasClient m api => HasClient m (Summary desc :> api) where + type Client m (Summary desc :> api) = Client m api + + clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api) + +-- | Ignore @'Description'@ in client functions. +instance HasClient m api => HasClient m (Description desc :> api) where + type Client m (Description desc :> api) = Client m api + + clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api) + +-- | If you use a 'QueryParam' in one of your endpoints in your API, +-- the corresponding querying function will automatically take +-- an additional argument of the type specified by your 'QueryParam', +-- enclosed in Maybe. +-- +-- If you give Nothing, nothing will be added to the query string. +-- +-- If you give a non-'Nothing' value, this function will take care +-- of inserting a textual representation of this value in the query string. +-- +-- You can control how values for your type are turned into +-- text by specifying a 'ToHttpApiData' instance for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooksBy :: Maybe Text -> ClientM [Book] +-- > getBooksBy = client myApi +-- > -- then you can just use "getBooksBy" to query that endpoint. +-- > -- 'getBooksBy Nothing' for all books +-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov +instance (KnownSymbol sym, ToHttpApiData a, HasClient m api) + => HasClient m (QueryParam sym a :> api) where + + type Client m (QueryParam sym a :> api) = + Maybe a -> Client m api + + -- if mparam = Nothing, we don't add it to the query string + clientWithRoute pm Proxy req mparam = + clientWithRoute pm (Proxy :: Proxy api) + (maybe req + (flip (appendToQueryString pname) req . Just) + mparamText + ) + + where pname = pack $ symbolVal (Proxy :: Proxy sym) + mparamText = fmap toQueryParam mparam + +-- | If you use a 'QueryParams' in one of your endpoints in your API, +-- the corresponding querying function will automatically take +-- an additional argument, a list of values of the type specified +-- by your 'QueryParams'. +-- +-- If you give an empty list, nothing will be added to the query string. +-- +-- Otherwise, this function will take care +-- of inserting a textual representation of your values in the query string, +-- under the same query string parameter name. +-- +-- You can control how values for your type are turned into +-- text by specifying a 'ToHttpApiData' instance for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooksBy :: [Text] -> ClientM [Book] +-- > getBooksBy = client myApi +-- > -- then you can just use "getBooksBy" to query that endpoint. +-- > -- 'getBooksBy []' for all books +-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]' +-- > -- to get all books by Asimov and Heinlein +instance (KnownSymbol sym, ToHttpApiData a, HasClient m api) + => HasClient m (QueryParams sym a :> api) where + + type Client m (QueryParams sym a :> api) = + [a] -> Client m api + + clientWithRoute pm Proxy req paramlist = + clientWithRoute pm (Proxy :: Proxy api) + (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) + req + paramlist' + ) + + where pname = pack $ symbolVal (Proxy :: Proxy sym) + paramlist' = map (Just . toQueryParam) paramlist + +-- | If you use a 'QueryFlag' in one of your endpoints in your API, +-- the corresponding querying function will automatically take +-- an additional 'Bool' argument. +-- +-- If you give 'False', nothing will be added to the query string. +-- +-- Otherwise, this function will insert a value-less query string +-- parameter under the name associated to your 'QueryFlag'. +-- +-- Example: +-- +-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooks :: Bool -> ClientM [Book] +-- > getBooks = client myApi +-- > -- then you can just use "getBooks" to query that endpoint. +-- > -- 'getBooksBy False' for all books +-- > -- 'getBooksBy True' to only get _already published_ books +instance (KnownSymbol sym, HasClient m api) + => HasClient m (QueryFlag sym :> api) where + + type Client m (QueryFlag sym :> api) = + Bool -> Client m api + + clientWithRoute pm Proxy req flag = + clientWithRoute pm (Proxy :: Proxy api) + (if flag + then appendToQueryString paramname Nothing req + else req + ) + + where paramname = pack $ symbolVal (Proxy :: Proxy sym) + + +-- | Pick a 'Method' and specify where the server you want to query is. You get +-- back the full `Response`. +instance RunClient m => HasClient m Raw where + type Client m Raw + = H.Method -> m Response + + clientWithRoute :: Proxy m -> Proxy Raw -> Request -> Client m Raw + clientWithRoute _pm Proxy req httpMethod = do + runRequest req { requestMethod = httpMethod } + +-- | If you use a 'ReqBody' in one of your endpoints in your API, +-- the corresponding querying function will automatically take +-- an additional argument of the type specified by your 'ReqBody'. +-- That function will take care of encoding this argument as JSON and +-- of using it as the request body. +-- +-- All you need is for your type to have a 'ToJSON' instance. +-- +-- Example: +-- +-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > addBook :: Book -> ClientM Book +-- > addBook = client myApi +-- > -- then you can just use "addBook" to query that endpoint +instance (MimeRender ct a, HasClient m api) + => HasClient m (ReqBody (ct ': cts) a :> api) where + + type Client m (ReqBody (ct ': cts) a :> api) = + a -> Client m api + + clientWithRoute pm Proxy req body = + clientWithRoute pm (Proxy :: Proxy api) + (let ctProxy = Proxy :: Proxy ct + in setRequestBodyLBS (mimeRender ctProxy body) + -- We use first contentType from the Accept list + (contentType ctProxy) + req + ) + +-- | Make the querying function append @path@ to the request path. +instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where + type Client m (path :> api) = Client m api + + clientWithRoute pm Proxy req = + clientWithRoute pm (Proxy :: Proxy api) + (appendToPath p req) + + where p = pack $ symbolVal (Proxy :: Proxy path) + +instance HasClient m api => HasClient m (Vault :> api) where + type Client m (Vault :> api) = Client m api + + clientWithRoute pm Proxy req = + clientWithRoute pm (Proxy :: Proxy api) req + +instance HasClient m api => HasClient m (RemoteHost :> api) where + type Client m (RemoteHost :> api) = Client m api + + clientWithRoute pm Proxy req = + clientWithRoute pm (Proxy :: Proxy api) req + +instance HasClient m api => HasClient m (IsSecure :> api) where + type Client m (IsSecure :> api) = Client m api + + clientWithRoute pm Proxy req = + clientWithRoute pm (Proxy :: Proxy api) req + +instance HasClient m subapi => + HasClient m (WithNamedContext name context subapi) where + + type Client m (WithNamedContext name context subapi) = Client m subapi + clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi) + +instance ( HasClient m api + ) => HasClient m (AuthProtect tag :> api) where + type Client m (AuthProtect tag :> api) + = AuthenticatedRequest (AuthProtect tag) -> Client m api + + clientWithRoute pm Proxy req (AuthenticatedRequest (val,func)) = + clientWithRoute pm (Proxy :: Proxy api) (func val req) + +-- * Basic Authentication + +instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where + type Client m (BasicAuth realm usr :> api) = BasicAuthData -> Client m api + + clientWithRoute pm Proxy req val = + clientWithRoute pm (Proxy :: Proxy api) (basicAuthReq val req) + + +{- Note [Non-Empty Content Types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Rather than have + + instance (..., cts' ~ (ct ': cts)) => ... cts' ... + +It may seem to make more sense to have: + + instance (...) => ... (ct ': cts) ... + +But this means that if another instance exists that does *not* require +non-empty lists, but is otherwise more specific, no instance will be overall +more specific. This in turn generally means adding yet another instance (one +for empty and one for non-empty lists). +-} diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Class.hs b/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs similarity index 97% rename from servant-client-core/src/Servant/Client/Core/Internal/Class.hs rename to servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs index 5cf5ce1e..fef4ac6b 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Class.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs @@ -4,7 +4,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} -- | Types for possible backends to run client-side `Request` queries -module Servant.Client.Core.Internal.Class where +module Servant.Client.Core.Internal.RunClient where import Control.Monad (unless) import Control.Monad.Error.Class (MonadError, throwError) diff --git a/servant-client-core/src/Servant/Client/Core/Reexport.hs b/servant-client-core/src/Servant/Client/Core/Reexport.hs new file mode 100644 index 00000000..a7b67d2d --- /dev/null +++ b/servant-client-core/src/Servant/Client/Core/Reexport.hs @@ -0,0 +1,30 @@ +-- | This module is a utility for @servant-client-core@ backend writers. It +-- contains all the functionality fron @servant-client-core@ that should be +-- re-exported. +module Servant.Client.Core.Reexport + ( + -- * HasClient + HasClient(..) + -- * Response (for @Raw@) + , Response(..) + + -- * Generic Client + , ClientLike(..) + , genericMkClientL + , genericMkClientP + , ServantError(..) + , EmptyClient(..) + + -- * BaseUrl + , BaseUrl(..) + , Scheme(..) + , showBaseUrl + , parseBaseUrl + , InvalidBaseUrlException + ) where + + +import Servant.Client.Core.Internal.BaseUrl +import Servant.Client.Core.Internal.HasClient +import Servant.Client.Core.Internal.Generic +import Servant.Client.Core.Internal.Request diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index de9d0287..690b74f1 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -86,6 +86,7 @@ test-suite spec , QuickCheck >= 2.7 , servant , servant-client + , servant-client-core , servant-server == 0.11.* , text , transformers diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 5e2189c8..0eb33907 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -6,8 +6,8 @@ module Servant.Client , ClientM , runClientM , ClientEnv(..) - , module Servant.Client.Core + , module X ) where import Servant.Client.Internal.HttpClient -import Servant.Client.Core +import Servant.Client.Core.Reexport as X diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index b869290f..a1a74bb0 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient.hs @@ -9,7 +9,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-| http-client based client requests executor -} +-- | @http-client@-based client requests executor module Servant.Client.Internal.HttpClient where @@ -96,7 +96,6 @@ runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a) runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm - performRequest :: Request -> ClientM Response performRequest req = do m <- asks manager diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 3a5ef1f6..fda25428 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -73,6 +73,8 @@ import Servant.API ((:<|>) ((:<|>)), getHeaders) import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Client +import qualified Servant.Client.Core.Internal.Request as Req +import qualified Servant.Client.Core.Internal.Auth as Auth import Servant.Server import Servant.Server.Experimental.Auth @@ -176,7 +178,7 @@ server = serve api ( :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess") :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure") :<|> (\ a b c d -> return (a, b, c, d)) - :<|> (return $ Servant.API.addHeader 1729 $ Servant.API.addHeader "eg2" True) + :<|> (return $ addHeader 1729 $ addHeader "eg2" True) :<|> return NoContent :<|> emptyServer) @@ -226,7 +228,7 @@ genAuthAPI :: Proxy GenAuthAPI genAuthAPI = Proxy type instance AuthServerData (AuthProtect "auth-tag") = () -type instance AuthClientData (AuthProtect "auth-tag") = () +type instance Auth.AuthClientData (AuthProtect "auth-tag") = () genAuthHandler :: AuthHandler Wai.Request () genAuthHandler = @@ -450,14 +452,14 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do let getProtected = client genAuthAPI - let authRequest = mkAuthenticateReq () (\_ req -> Servant.Client.addHeader "AuthHeader" ("cool" :: String) req) + let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "AuthHeader" ("cool" :: String) req) left show <$> runClient (getProtected authRequest) 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 -> Servant.Client.addHeader "Wrong" ("header" :: String) req) + let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req) Left (FailureResponse r) <- runClient (getProtected authRequest) baseUrl responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized") From 257c3d4081ccafab3dea551acc2871899a383be2 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 13 Sep 2017 12:50:37 -0400 Subject: [PATCH 17/26] Readme for servant-client-core --- servant-client-core/README.md | 25 +++++++++++++++++++ servant-client-core/servant-client-core.cabal | 3 ++- 2 files changed, 27 insertions(+), 1 deletion(-) diff --git a/servant-client-core/README.md b/servant-client-core/README.md index 601a1d55..180063a9 100644 --- a/servant-client-core/README.md +++ b/servant-client-core/README.md @@ -3,3 +3,28 @@ ![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'l 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. diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index 8f16b11e..59d02870 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -2,7 +2,8 @@ name: servant-client-core version: 0.11 synopsis: Core functionality and class for client function generation for servant APIs description: - This library provides a class + This library provides backend-agnostic generation of client functions. For + more information, see the README. license: BSD3 license-file: LICENSE author: Servant Contributors From d6aee29be1e9f89d75c4bc6b921de69be38b3fd4 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 13 Sep 2017 12:57:18 -0400 Subject: [PATCH 18/26] Fix readme list --- servant-client-core/README.md | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/servant-client-core/README.md b/servant-client-core/README.md index 180063a9..6391bb52 100644 --- a/servant-client-core/README.md +++ b/servant-client-core/README.md @@ -10,18 +10,18 @@ This library should mainly be of interest to backend- and combinator-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: +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. +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 From da8337809b3e148a64e0c093960870d1c6a5304c Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 13 Sep 2017 16:01:31 -0400 Subject: [PATCH 19/26] Documentation fixes --- doc/tutorial/Client.lhs | 8 ++++---- servant-client-core/CHANGELOG.md | 5 +++-- servant-client-core/README.md | 2 +- servant-client-core/servant-client-core.cabal | 13 +++++++------ servant-client/src/Servant/Client.hs | 4 ++-- .../src/Servant/Client/Internal/HttpClient.hs | 2 +- 6 files changed, 18 insertions(+), 16 deletions(-) diff --git a/doc/tutorial/Client.lhs b/doc/tutorial/Client.lhs index 94aee690..b2279849 100644 --- a/doc/tutorial/Client.lhs +++ b/doc/tutorial/Client.lhs @@ -128,15 +128,15 @@ That's it. Let's now write some code that uses our client functions. ``` haskell queries :: ClientM (Position, HelloMessage, Email) queries = do - pos <- position 10 10 - message <- hello (Just "servant") + pos <- position 10 10 + message <- hello (Just "servant") em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]) return (pos, message, em) run :: IO () run = do - manager <- newManager defaultManagerSettings - res <- runClientM queries (ClientEnv manager (BaseUrl Http "localhost" 8081 "")) + manager' <- newManager defaultManagerSettings + res <- runClientM queries (ClientEnv manager' (BaseUrl Http "localhost" 8081 "")) case res of Left err -> putStrLn $ "Error: " ++ show err Right (pos, message, em) -> do diff --git a/servant-client-core/CHANGELOG.md b/servant-client-core/CHANGELOG.md index 457587e2..10b2cd74 100644 --- a/servant-client-core/CHANGELOG.md +++ b/servant-client-core/CHANGELOG.md @@ -1,5 +1,6 @@ # Revision history for servant-client-core -## 0.11 -- YYYY-mm-dd +## 0.12 -- YYYY-mm-dd -* First version. Released on an unsuspecting world. +* First version. Factored out of servant-client all the functionality that was +independent of the http-client backend. diff --git a/servant-client-core/README.md b/servant-client-core/README.md index 6391bb52..2602c82d 100644 --- a/servant-client-core/README.md +++ b/servant-client-core/README.md @@ -10,7 +10,7 @@ This library should mainly be of interest to backend- and combinator-writers. If you are creating a new backend, you'll need to: -1. Define a `RunClient` instance for your datatype (call it 'MyMonad') +1. Define a `RunClient` instance for your datatype (call it `MyMonad`) 2. Define a `ClientLike` instance. This will look like: ``` haskell diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index 59d02870..987ccddf 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -51,14 +51,15 @@ library , text >= 1.2 && < 1.3 hs-source-dirs: src default-language: Haskell2010 - include-dirs: include + ghc-options: -Wall + include-dirs: include test-suite spec - type: exitcode-stdio-1.0 - ghc-options: -Wall - default-language: Haskell2010 - hs-source-dirs: test - main-is: Spec.hs + type: exitcode-stdio-1.0 + ghc-options: -Wall + default-language: Haskell2010 + hs-source-dirs: test + main-is: Spec.hs build-depends: base , base-compat diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 0eb33907..ac35a669 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -6,8 +6,8 @@ module Servant.Client , ClientM , runClientM , ClientEnv(..) - , module X + , module Servant.Client.Core.Reexport ) where import Servant.Client.Internal.HttpClient -import Servant.Client.Core.Reexport as X +import Servant.Client.Core.Reexport diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index a1a74bb0..0236b492 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient.hs @@ -65,7 +65,7 @@ client :: HasClient ClientM api => Proxy api -> Client ClientM api client api = api `clientIn` (Proxy :: Proxy ClientM) -- | @ClientM@ is the monad in which client functions run. Contains the --- 'Manager' and 'BaseUrl' used for requests in the reader environment. +-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment. newtype ClientM a = ClientM { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a } deriving ( Functor, Applicative, Monad, MonadIO, Generic From 39ad4656956eb7ffd4f192965a2d6844495df629 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 14 Sep 2017 09:53:51 -0400 Subject: [PATCH 20/26] Ghc 8.2 fixes --- servant-client-core/servant-client-core.cabal | 7 +++++-- .../src/Servant/Client/Core/Internal/HasClient.hs | 4 ++-- .../src/Servant/Client/Core/Internal/RunClient.hs | 11 +++++++---- servant-client/servant-client.cabal | 5 +---- servant/servant.cabal | 2 ++ stack-ghc-8.2.1.yaml | 2 +- 6 files changed, 18 insertions(+), 13 deletions(-) diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index 987ccddf..ce9fea02 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -44,11 +44,14 @@ library , http-api-data >= 0.3.6 && < 0.4 , http-media >= 0.6.2 && < 0.8 , http-types >= 0.8.6 && < 0.10 - , mtl >= 2.2 && < 2.3 + , mtl >= 2.1 && < 2.3 , network-uri >= 2.6 && < 2.7 , safe >= 0.3.9 && < 0.4 , servant == 0.11.* , text >= 1.2 && < 1.3 + if !impl(ghc >= 8.0) + build-depends: + semigroups >=0.16.2.2 && <0.19 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -66,6 +69,6 @@ test-suite spec , deepseq , servant-client-core , hspec == 2.* - , QuickCheck >= 2.7 && < 2.10 + , QuickCheck >= 2.7 && < 2.11 other-modules: Servant.Client.Core.Internal.BaseUrlSpec diff --git a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs index 2d619236..fe65b05f 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs @@ -14,6 +14,8 @@ #include "overlapping-compat.h" module Servant.Client.Core.Internal.HasClient where +import Prelude.Compat +import Prelude () import Control.Monad.Error.Class (throwError) import Data.List (foldl') @@ -23,8 +25,6 @@ import Data.Text (pack) import GHC.Exts (fromList, toList) import GHC.TypeLits (KnownSymbol, symbolVal) import qualified Network.HTTP.Types as H -import Prelude () -import Prelude.Compat import Servant.API ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData, diff --git a/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs b/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs index fef4ac6b..a441a8b8 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs @@ -1,13 +1,17 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} -- | Types for possible backends to run client-side `Request` queries module Servant.Client.Core.Internal.RunClient where +import Prelude.Compat +import Prelude () + import Control.Monad (unless) import Control.Monad.Error.Class (MonadError, throwError) +import Data.Foldable (toList) import Data.Proxy (Proxy) import qualified Data.Text as T import Network.HTTP.Media (MediaType, matches, @@ -17,7 +21,6 @@ import Servant.API (MimeUnrender, mimeUnrender) import Servant.Client.Core.Internal.Request (Request, Response (..), ServantError (..)) -import Data.Foldable (toList) class (MonadError ServantError m) => RunClient m where -- | How to make a request. @@ -26,10 +29,10 @@ class (MonadError ServantError m) => RunClient m where checkContentTypeHeader :: RunClient m => Response -> m MediaType checkContentTypeHeader response = case lookup "Content-Type" $ toList $ responseHeaders response of - Nothing -> pure $ "application"//"octet-stream" + Nothing -> return $ "application"//"octet-stream" Just t -> case parseAccept t of Nothing -> throwError $ InvalidContentTypeHeader response - Just t' -> pure t' + Just t' -> return t' decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m) => Response -> Proxy ct -> m a diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 690b74f1..535a80d0 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -43,16 +43,13 @@ library , http-types >= 0.8.6 && < 0.10 , exceptions >= 0.8 && < 0.9 , monad-control >= 1.0.0.4 && < 1.1 - , mtl >= 2.2 && < 2.3 + , mtl >= 2.1 && < 2.3 , semigroupoids >= 4.3 && < 5.3 , servant-client-core == 0.11.* , text >= 1.2 && < 1.3 , transformers >= 0.3 && < 0.6 , transformers-base >= 0.4.4 && < 0.5 , transformers-compat >= 0.4 && < 0.6 - if !impl(ghc >= 8.0) - build-depends: - semigroups >=0.16.2.2 && <0.19 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/servant/servant.cabal b/servant/servant.cabal index fbd4d714..58985321 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -155,3 +155,5 @@ test-suite doctests include-dirs: include x-doctest-source-dirs: test x-doctest-modules: Servant.Utils.LinksSpec + other-modules: + Build_doctests diff --git a/stack-ghc-8.2.1.yaml b/stack-ghc-8.2.1.yaml index 926f72cf..5af842b0 100644 --- a/stack-ghc-8.2.1.yaml +++ b/stack-ghc-8.2.1.yaml @@ -1,4 +1,4 @@ -resolver: nightly-2017-09-01 +resolver: nightly-2017-09-13 packages: - servant-client/ - servant-client-core/ From 83fd4acf2164c0ff82f8b3e21fd4f40cdfbcb278 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 14 Sep 2017 10:02:32 -0400 Subject: [PATCH 21/26] Add Build_doctests to servant-server --- servant-server/servant-server.cabal | 2 ++ 1 file changed, 2 insertions(+) diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index efb8f29b..c9210354 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -164,3 +164,5 @@ test-suite doctests if impl(ghc >= 8.2) x-doctest-options: -fdiagnostics-color=never include-dirs: include + other-modules: + Build_doctests From 65c2cbb6a96d24a5c50b93e5132cfbd76bd96289 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 14 Sep 2017 10:43:57 -0400 Subject: [PATCH 22/26] Fix 7.8.4 IsList Sequence issue And other minor 7.8.4 issues. --- .../src/Servant/Client/Core/Internal/HasClient.hs | 5 +++-- servant-client/servant-client.cabal | 3 ++- servant-client/src/Servant/Client/Internal/HttpClient.hs | 2 +- servant-server/servant-server.cabal | 2 -- stack-ghc-7.8.4.yaml | 1 + 5 files changed, 7 insertions(+), 6 deletions(-) diff --git a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs index fe65b05f..bd407ed6 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs @@ -14,15 +14,16 @@ #include "overlapping-compat.h" module Servant.Client.Core.Internal.HasClient where +import Prelude () import Prelude.Compat -import Prelude () import Control.Monad.Error.Class (throwError) +import Data.Foldable (toList) import Data.List (foldl') import Data.Proxy (Proxy (Proxy)) +import Data.Sequence (fromList) import Data.String (fromString) import Data.Text (pack) -import GHC.Exts (fromList, toList) import GHC.TypeLits (KnownSymbol, symbolVal) import qualified Network.HTTP.Types as H import Servant.API ((:<|>) ((:<|>)), (:>), diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 535a80d0..36edb205 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -37,7 +37,8 @@ library , bytestring >= 0.10 && < 0.11 , aeson >= 0.7 && < 1.3 , attoparsec >= 0.12 && < 0.14 - , http-client >= 0.4.18.1 && < 0.6 + , containers >= 0.5 && < 0.6 + , http-client >= 0.4.30 && < 0.6 , http-client-tls >= 0.2.2 && < 0.4 , http-media >= 0.6.2 && < 0.8 , http-types >= 0.8.6 && < 0.10 diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index 0236b492..5595c039 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient.hs @@ -30,9 +30,9 @@ import Data.Foldable (toList) import Data.Functor.Alt (Alt (..)) import Data.Monoid ((<>)) import Data.Proxy (Proxy (..)) +import Data.Sequence (fromList) import Data.String (fromString) import qualified Data.Text as T -import GHC.Exts (fromList) import GHC.Generics import Network.HTTP.Media (renderHeader) import Network.HTTP.Types (hContentType, renderQuery, diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index c9210354..efb8f29b 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -164,5 +164,3 @@ test-suite doctests if impl(ghc >= 8.2) x-doctest-options: -fdiagnostics-color=never include-dirs: include - other-modules: - Build_doctests diff --git a/stack-ghc-7.8.4.yaml b/stack-ghc-7.8.4.yaml index 479a6d20..97049725 100644 --- a/stack-ghc-7.8.4.yaml +++ b/stack-ghc-7.8.4.yaml @@ -20,6 +20,7 @@ extra-deps: - hspec-expectations-0.8.2 - hspec-wai-0.8.0 - http-api-data-0.3.6 +- http-client-0.4.30 - natural-transformation-0.4 - primitive-0.6.1.0 - servant-js-0.9.3 From 30528a8198f961a95be4dd95c8a0d810050f5f5d Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 14 Sep 2017 13:17:19 -0400 Subject: [PATCH 23/26] Parametrize Request --- servant-client-core/src/Servant/Client/Core.hs | 3 ++- .../src/Servant/Client/Core/Internal/Request.hs | 9 ++++++--- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/servant-client-core/src/Servant/Client/Core.hs b/servant-client-core/src/Servant/Client/Core.hs index 8a5cd6dd..84ae9660 100644 --- a/servant-client-core/src/Servant/Client/Core.hs +++ b/servant-client-core/src/Servant/Client/Core.hs @@ -20,7 +20,8 @@ module Servant.Client.Core , HasClient(..) -- * Request - , Request(..) + , Request + , RequestF(..) , defaultRequest , RequestBody(..) diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs index 4d9475d1..3f5bc0a0 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -43,15 +44,17 @@ data ServantError = | ConnectionError Text deriving (Eq, Show, Generic, Typeable) -data Request = Request - { requestPath :: Builder.Builder +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) + } deriving (Eq, Show, Functor, Generic, Typeable) + +type Request = RequestF Builder.Builder -- | The request body. Currently only lazy ByteStrings are supported. newtype RequestBody = RequestBodyLBS LBS.ByteString From 4e9c342c4e43c6ff9ca2ceb4e571b9e0ca6e4d0b Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 14 Sep 2017 13:21:53 -0400 Subject: [PATCH 24/26] Review fixes --- .../src/Servant/Client/Core.hs | 541 +----------------- .../src/Servant/Client/Core/Reexport.hs | 2 +- stack-ghc-8.2.1.yaml | 2 +- 3 files changed, 6 insertions(+), 539 deletions(-) diff --git a/servant-client-core/src/Servant/Client/Core.hs b/servant-client-core/src/Servant/Client/Core.hs index 84ae9660..a926c169 100644 --- a/servant-client-core/src/Servant/Client/Core.hs +++ b/servant-client-core/src/Servant/Client/Core.hs @@ -2,8 +2,8 @@ -- from @servant@ APIs. By "backend," we mean something that concretely -- executes the request, such as: -- --- * The 'http-client' library --- * The 'haxl' library +-- * The @http-client@ library +-- * The @haxl@ library -- * GHCJS via FFI -- -- etc. @@ -11,8 +11,8 @@ -- Each backend is encapsulated in a monad that is an instance of the -- 'RunClient' class. -- --- This library is primarily of interest to backend-writers, who are encouraged --- to re-export the parts of the +-- 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 @@ -63,536 +63,3 @@ import Servant.Client.Core.Internal.HasClient import Servant.Client.Core.Internal.Generic import Servant.Client.Core.Internal.Request import Servant.Client.Core.Internal.RunClient - -{- -import Control.Monad.Error.Class (throwError) -import Data.List (foldl') -import Data.Proxy (Proxy (Proxy)) -import Data.String (fromString) -import Data.Text (pack) -import GHC.Exts (fromList, toList) -import GHC.TypeLits (KnownSymbol, symbolVal) -import qualified Network.HTTP.Types as H -import Prelude () -import Prelude.Compat -import Servant.API ((:<|>) ((:<|>)), (:>), - AuthProtect, BasicAuth, - BasicAuthData, - BuildHeadersTo (..), - Capture, CaptureAll, - Description, EmptyAPI, - Header, Headers (..), - HttpVersion, IsSecure, - MimeRender (mimeRender), - MimeUnrender (mimeUnrender), - NoContent (NoContent), - QueryFlag, QueryParam, - QueryParams, Raw, - ReflectMethod (..), - RemoteHost, ReqBody, - Summary, ToHttpApiData, - Vault, Verb, - WithNamedContext, - contentType, - getHeadersHList, - getResponse, - toQueryParam, - toUrlPiece) -import Servant.API.ContentTypes (contentTypes) - -import Servant.Client.Core.Internal.Auth -import Servant.Client.Core.Internal.BaseUrl (BaseUrl (..), - InvalidBaseUrlException, - Scheme (..), - parseBaseUrl, - showBaseUrl) -import Servant.Client.Core.Internal.BasicAuth -import Servant.Client.Core.Internal.Class -import Servant.Client.Core.Internal.Generic -import Servant.Client.Core.Internal.Request - --- * Accessing APIs as a Client - --- | 'clientIn' allows you to produce operations to query an API from a client --- within a 'RunClient' monad. --- --- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books --- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > clientM :: Proxy ClientM --- > clientM = Proxy --- > --- > getAllBooks :: ClientM [Book] --- > postNewBook :: Book -> ClientM Book --- > (getAllBooks :<|> postNewBook) = myApi `clientIn` clientM -clientIn :: HasClient m api => Proxy api -> Proxy m -> Client m api -clientIn p pm = clientWithRoute pm p defaultRequest - - --- | This class lets us define how each API combinator influences the creation --- of an HTTP request. --- --- Unless you are writing a new backend for @servant-client-core@ or new --- combinators that you want to support client-generation, you can ignore this --- class. -class RunClient m => HasClient m api where - type Client (m :: * -> *) (api :: *) :: * - clientWithRoute :: Proxy m -> Proxy api -> Request -> Client m api - - --- | A client querying function for @a ':<|>' b@ will actually hand you --- one function for querying @a@ and another one for querying @b@, --- stitching them together with ':<|>', which really is just like a pair. --- --- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books --- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getAllBooks :: ClientM [Book] --- > postNewBook :: Book -> ClientM Book --- > (getAllBooks :<|> postNewBook) = client myApi -instance (HasClient m a, HasClient m b) => HasClient m (a :<|> b) where - type Client m (a :<|> b) = Client m a :<|> Client m b - clientWithRoute pm Proxy req = - clientWithRoute pm (Proxy :: Proxy a) req :<|> - clientWithRoute pm (Proxy :: Proxy b) req - --- | Singleton type representing a client for an empty API. -data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum) - --- | The client for 'EmptyAPI' is simply 'EmptyClient'. --- --- > type MyAPI = "books" :> Get '[JSON] [Book] -- GET /books --- > :<|> "nothing" :> EmptyAPI --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getAllBooks :: ClientM [Book] --- > (getAllBooks :<|> EmptyClient) = client myApi -instance RunClient m => HasClient m EmptyAPI where - type Client m EmptyAPI = EmptyClient - clientWithRoute _pm Proxy _ = EmptyClient - --- | If you use a 'Capture' in one of your endpoints in your API, --- the corresponding querying function will automatically take --- an additional argument of the type specified by your 'Capture'. --- That function will take care of inserting a textual representation --- of this value at the right place in the request path. --- --- You can control how values for this type are turned into --- text by specifying a 'ToHttpApiData' instance for your type. --- --- Example: --- --- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getBook :: Text -> ClientM Book --- > getBook = client myApi --- > -- then you can just use "getBook" to query that endpoint -instance (KnownSymbol capture, ToHttpApiData a, HasClient m api) - => HasClient m (Capture capture a :> api) where - - type Client m (Capture capture a :> api) = - a -> Client m api - - clientWithRoute pm Proxy req val = - clientWithRoute pm (Proxy :: Proxy api) - (appendToPath p req) - - where p = (toUrlPiece val) - --- | If you use a 'CaptureAll' in one of your endpoints in your API, --- the corresponding querying function will automatically take an --- additional argument of a list of the type specified by your --- 'CaptureAll'. That function will take care of inserting a textual --- representation of this value at the right place in the request --- path. --- --- You can control how these values are turned into text by specifying --- a 'ToHttpApiData' instance of your type. --- --- Example: --- --- > type MyAPI = "src" :> CaptureAll Text -> Get '[JSON] SourceFile --- > --- > myApi :: Proxy --- > myApi = Proxy --- --- > getSourceFile :: [Text] -> ClientM SourceFile --- > getSourceFile = client myApi --- > -- then you can use "getSourceFile" to query that endpoint -instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout) - => HasClient m (CaptureAll capture a :> sublayout) where - - type Client m (CaptureAll capture a :> sublayout) = - [a] -> Client m sublayout - - clientWithRoute pm Proxy req vals = - clientWithRoute pm (Proxy :: Proxy sublayout) - (foldl' (flip appendToPath) req ps) - - where ps = map (toUrlPiece) vals - -instance OVERLAPPABLE_ - -- Note [Non-Empty Content Types] - ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) - ) => HasClient m (Verb method status cts' a) where - type Client m (Verb method status cts' a) = m a - clientWithRoute _pm Proxy req = do - response <- runRequest req - { requestAccept = fromList $ toList accept - , requestMethod = method - } - response `decodedAs` (Proxy :: Proxy ct) - where - accept = contentTypes (Proxy :: Proxy ct) - method = reflectMethod (Proxy :: Proxy method) - -instance OVERLAPPING_ - ( RunClient m, ReflectMethod method - ) => HasClient m (Verb method status cts NoContent) where - type Client m (Verb method status cts NoContent) - = m NoContent - clientWithRoute _pm Proxy req = do - _response <- runRequest req { requestMethod = method } - return NoContent - where method = reflectMethod (Proxy :: Proxy method) - -instance OVERLAPPING_ - -- Note [Non-Empty Content Types] - ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls - , ReflectMethod method, cts' ~ (ct ': cts) - ) => HasClient m (Verb method status cts' (Headers ls a)) where - type Client m (Verb method status cts' (Headers ls a)) - = m (Headers ls a) - clientWithRoute _pm Proxy req = do - response <- runRequest req - { requestMethod = method - , requestAccept = fromList $ toList accept - } - case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of - Left err -> throwError $ DecodeFailure (pack err) response - Right val -> return $ Headers - { getResponse = val - , getHeadersHList = buildHeadersTo . toList $ responseHeaders response - } - where method = reflectMethod (Proxy :: Proxy method) - accept = contentTypes (Proxy :: Proxy ct) - -instance OVERLAPPING_ - ( RunClient m, BuildHeadersTo ls, ReflectMethod method - ) => HasClient m (Verb method status cts (Headers ls NoContent)) where - type Client m (Verb method status cts (Headers ls NoContent)) - = m (Headers ls NoContent) - clientWithRoute _pm Proxy req = do - let method = reflectMethod (Proxy :: Proxy method) - response <- runRequest req { requestMethod = method } - return $ Headers { getResponse = NoContent - , getHeadersHList = buildHeadersTo . toList $ responseHeaders response - } - - --- | If you use a 'Header' in one of your endpoints in your API, --- the corresponding querying function will automatically take --- an additional argument of the type specified by your 'Header', --- wrapped in Maybe. --- --- That function will take care of encoding this argument as Text --- in the request headers. --- --- All you need is for your type to have a 'ToHttpApiData' instance. --- --- Example: --- --- > newtype Referer = Referer { referrer :: Text } --- > deriving (Eq, Show, Generic, ToHttpApiData) --- > --- > -- GET /view-my-referer --- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > viewReferer :: Maybe Referer -> ClientM Book --- > viewReferer = client myApi --- > -- then you can just use "viewRefer" to query that endpoint --- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments -instance (KnownSymbol sym, ToHttpApiData a, HasClient m api) - => HasClient m (Header sym a :> api) where - - type Client m (Header sym a :> api) = - Maybe a -> Client m api - - clientWithRoute pm Proxy req mval = - clientWithRoute pm (Proxy :: Proxy api) - (maybe req - (\value -> addHeader hname value req) - mval - ) - - where hname = fromString $ symbolVal (Proxy :: Proxy sym) - --- | Using a 'HttpVersion' combinator in your API doesn't affect the client --- functions. -instance HasClient m api - => HasClient m (HttpVersion :> api) where - - type Client m (HttpVersion :> api) = - Client m api - - clientWithRoute pm Proxy = - clientWithRoute pm (Proxy :: Proxy api) - --- | Ignore @'Summary'@ in client functions. -instance HasClient m api => HasClient m (Summary desc :> api) where - type Client m (Summary desc :> api) = Client m api - - clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api) - --- | Ignore @'Description'@ in client functions. -instance HasClient m api => HasClient m (Description desc :> api) where - type Client m (Description desc :> api) = Client m api - - clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api) - --- | If you use a 'QueryParam' in one of your endpoints in your API, --- the corresponding querying function will automatically take --- an additional argument of the type specified by your 'QueryParam', --- enclosed in Maybe. --- --- If you give Nothing, nothing will be added to the query string. --- --- If you give a non-'Nothing' value, this function will take care --- of inserting a textual representation of this value in the query string. --- --- You can control how values for your type are turned into --- text by specifying a 'ToHttpApiData' instance for your type. --- --- Example: --- --- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book] --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getBooksBy :: Maybe Text -> ClientM [Book] --- > getBooksBy = client myApi --- > -- then you can just use "getBooksBy" to query that endpoint. --- > -- 'getBooksBy Nothing' for all books --- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov -instance (KnownSymbol sym, ToHttpApiData a, HasClient m api) - => HasClient m (QueryParam sym a :> api) where - - type Client m (QueryParam sym a :> api) = - Maybe a -> Client m api - - -- if mparam = Nothing, we don't add it to the query string - clientWithRoute pm Proxy req mparam = - clientWithRoute pm (Proxy :: Proxy api) - (maybe req - (flip (appendToQueryString pname) req . Just) - mparamText - ) - - where pname = pack $ symbolVal (Proxy :: Proxy sym) - mparamText = fmap toQueryParam mparam - --- | If you use a 'QueryParams' in one of your endpoints in your API, --- the corresponding querying function will automatically take --- an additional argument, a list of values of the type specified --- by your 'QueryParams'. --- --- If you give an empty list, nothing will be added to the query string. --- --- Otherwise, this function will take care --- of inserting a textual representation of your values in the query string, --- under the same query string parameter name. --- --- You can control how values for your type are turned into --- text by specifying a 'ToHttpApiData' instance for your type. --- --- Example: --- --- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book] --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getBooksBy :: [Text] -> ClientM [Book] --- > getBooksBy = client myApi --- > -- then you can just use "getBooksBy" to query that endpoint. --- > -- 'getBooksBy []' for all books --- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]' --- > -- to get all books by Asimov and Heinlein -instance (KnownSymbol sym, ToHttpApiData a, HasClient m api) - => HasClient m (QueryParams sym a :> api) where - - type Client m (QueryParams sym a :> api) = - [a] -> Client m api - - clientWithRoute pm Proxy req paramlist = - clientWithRoute pm (Proxy :: Proxy api) - (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) - req - paramlist' - ) - - where pname = pack $ symbolVal (Proxy :: Proxy sym) - paramlist' = map (Just . toQueryParam) paramlist - --- | If you use a 'QueryFlag' in one of your endpoints in your API, --- the corresponding querying function will automatically take --- an additional 'Bool' argument. --- --- If you give 'False', nothing will be added to the query string. --- --- Otherwise, this function will insert a value-less query string --- parameter under the name associated to your 'QueryFlag'. --- --- Example: --- --- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book] --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getBooks :: Bool -> ClientM [Book] --- > getBooks = client myApi --- > -- then you can just use "getBooks" to query that endpoint. --- > -- 'getBooksBy False' for all books --- > -- 'getBooksBy True' to only get _already published_ books -instance (KnownSymbol sym, HasClient m api) - => HasClient m (QueryFlag sym :> api) where - - type Client m (QueryFlag sym :> api) = - Bool -> Client m api - - clientWithRoute pm Proxy req flag = - clientWithRoute pm (Proxy :: Proxy api) - (if flag - then appendToQueryString paramname Nothing req - else req - ) - - where paramname = pack $ symbolVal (Proxy :: Proxy sym) - - --- | Pick a 'Method' and specify where the server you want to query is. You get --- back the full `Response`. -instance RunClient m => HasClient m Raw where - type Client m Raw - = H.Method -> m Response - - clientWithRoute :: Proxy m -> Proxy Raw -> Request -> Client m Raw - clientWithRoute _pm Proxy req httpMethod = do - runRequest req { requestMethod = httpMethod } - --- | If you use a 'ReqBody' in one of your endpoints in your API, --- the corresponding querying function will automatically take --- an additional argument of the type specified by your 'ReqBody'. --- That function will take care of encoding this argument as JSON and --- of using it as the request body. --- --- All you need is for your type to have a 'ToJSON' instance. --- --- Example: --- --- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > addBook :: Book -> ClientM Book --- > addBook = client myApi --- > -- then you can just use "addBook" to query that endpoint -instance (MimeRender ct a, HasClient m api) - => HasClient m (ReqBody (ct ': cts) a :> api) where - - type Client m (ReqBody (ct ': cts) a :> api) = - a -> Client m api - - clientWithRoute pm Proxy req body = - clientWithRoute pm (Proxy :: Proxy api) - (let ctProxy = Proxy :: Proxy ct - in setRequestBodyLBS (mimeRender ctProxy body) - -- We use first contentType from the Accept list - (contentType ctProxy) - req - ) - --- | Make the querying function append @path@ to the request path. -instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where - type Client m (path :> api) = Client m api - - clientWithRoute pm Proxy req = - clientWithRoute pm (Proxy :: Proxy api) - (appendToPath p req) - - where p = pack $ symbolVal (Proxy :: Proxy path) - -instance HasClient m api => HasClient m (Vault :> api) where - type Client m (Vault :> api) = Client m api - - clientWithRoute pm Proxy req = - clientWithRoute pm (Proxy :: Proxy api) req - -instance HasClient m api => HasClient m (RemoteHost :> api) where - type Client m (RemoteHost :> api) = Client m api - - clientWithRoute pm Proxy req = - clientWithRoute pm (Proxy :: Proxy api) req - -instance HasClient m api => HasClient m (IsSecure :> api) where - type Client m (IsSecure :> api) = Client m api - - clientWithRoute pm Proxy req = - clientWithRoute pm (Proxy :: Proxy api) req - -instance HasClient m subapi => - HasClient m (WithNamedContext name context subapi) where - - type Client m (WithNamedContext name context subapi) = Client m subapi - clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi) - -instance ( HasClient m api - ) => HasClient m (AuthProtect tag :> api) where - type Client m (AuthProtect tag :> api) - = AuthenticateReq (AuthProtect tag) -> Client m api - - clientWithRoute pm Proxy req (AuthenticateReq (val,func)) = - clientWithRoute pm (Proxy :: Proxy api) (func val req) - --- * Basic Authentication - -instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where - type Client m (BasicAuth realm usr :> api) = BasicAuthData -> Client m api - - clientWithRoute pm Proxy req val = - clientWithRoute pm (Proxy :: Proxy api) (basicAuthReq val req) - - -{- Note [Non-Empty Content Types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Rather than have - - instance (..., cts' ~ (ct ': cts)) => ... cts' ... - -It may seem to make more sense to have: - - instance (...) => ... (ct ': cts) ... - -But this means that if another instance exists that does *not* require -non-empty lists, but is otherwise more specific, no instance will be overall -more specific. This in turn generally means adding yet another instance (one -for empty and one for non-empty lists). --} --} diff --git a/servant-client-core/src/Servant/Client/Core/Reexport.hs b/servant-client-core/src/Servant/Client/Core/Reexport.hs index a7b67d2d..4c90a6f2 100644 --- a/servant-client-core/src/Servant/Client/Core/Reexport.hs +++ b/servant-client-core/src/Servant/Client/Core/Reexport.hs @@ -1,5 +1,5 @@ -- | This module is a utility for @servant-client-core@ backend writers. It --- contains all the functionality fron @servant-client-core@ that should be +-- contains all the functionality from @servant-client-core@ that should be -- re-exported. module Servant.Client.Core.Reexport ( diff --git a/stack-ghc-8.2.1.yaml b/stack-ghc-8.2.1.yaml index 5af842b0..926f72cf 100644 --- a/stack-ghc-8.2.1.yaml +++ b/stack-ghc-8.2.1.yaml @@ -1,4 +1,4 @@ -resolver: nightly-2017-09-13 +resolver: nightly-2017-09-01 packages: - servant-client/ - servant-client-core/ From 49d5067e22dcd98f3ad68da3b4e7d099b48f9855 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Fri, 15 Sep 2017 09:02:50 -0400 Subject: [PATCH 25/26] Review fixes --- servant-client-core/README.md | 2 +- servant-client-core/servant-client-core.cabal | 2 +- servant-client-core/src/Servant/Client/Core/Internal/Request.hs | 2 +- servant-client/servant-client.cabal | 2 +- servant/servant.cabal | 2 -- 5 files changed, 4 insertions(+), 6 deletions(-) diff --git a/servant-client-core/README.md b/servant-client-core/README.md index 2602c82d..59681225 100644 --- a/servant-client-core/README.md +++ b/servant-client-core/README.md @@ -25,6 +25,6 @@ instance ClientLike (MyMonad a) (MyMonad a) where ## For combinator-writers -You'l need to define a new `HasClient` instance for your combinator. There are +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. diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index ce9fea02..b8c52753 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -11,7 +11,7 @@ maintainer: haskell-servant-maintainers@googlegroups.com homepage: http://haskell-servant.readthedocs.org/ bug-reports: http://github.com/haskell-servant/servant/issues cabal-version: >=1.10 --- copyright: +copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant Contributors category: Web build-type: Simple extra-source-files: diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs index 3f5bc0a0..af204f01 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs @@ -30,7 +30,7 @@ import Web.HttpApiData (ToHttpApiData, toEncodedUrlPiece, -- | A type representing possible errors in a request -- --- Note that this type substially change in 0.12 +-- Note that this type substantially changed in 0.12. data ServantError = -- | The server returned an error response FailureResponse Response diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 36edb205..14ea3ad2 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -12,7 +12,7 @@ license: BSD3 license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com -copyright: 2014-2017 Zalora South East Asia Pte Ltd, Servant Contributors +copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant Contributors category: Servant, Web build-type: Simple cabal-version: >=1.10 diff --git a/servant/servant.cabal b/servant/servant.cabal index 58985321..fbd4d714 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -155,5 +155,3 @@ test-suite doctests include-dirs: include x-doctest-source-dirs: test x-doctest-modules: Servant.Utils.LinksSpec - other-modules: - Build_doctests From 1a67d93c609555e97299d947b18b7b8f25a9259e Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Fri, 15 Sep 2017 14:57:03 -0400 Subject: [PATCH 26/26] Use own throw/catch --- .../src/Servant/Client/Core/Internal/HasClient.hs | 3 +-- .../src/Servant/Client/Core/Internal/Request.hs | 5 ++++- .../src/Servant/Client/Core/Internal/RunClient.hs | 13 +++++++------ .../src/Servant/Client/Internal/HttpClient.hs | 2 ++ 4 files changed, 14 insertions(+), 9 deletions(-) diff --git a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs index bd407ed6..42d61d58 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs @@ -17,7 +17,6 @@ module Servant.Client.Core.Internal.HasClient where import Prelude () import Prelude.Compat -import Control.Monad.Error.Class (throwError) import Data.Foldable (toList) import Data.List (foldl') import Data.Proxy (Proxy (Proxy)) @@ -225,7 +224,7 @@ instance OVERLAPPING_ , requestAccept = fromList $ toList accept } case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of - Left err -> throwError $ DecodeFailure (pack err) response + Left err -> throwServantError $ DecodeFailure (pack err) response Right val -> return $ Headers { getResponse = val , getHeadersHList = buildHeadersTo . toList $ responseHeaders response diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs index af204f01..458219b9 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -13,6 +13,7 @@ module Servant.Client.Core.Internal.Request where import Prelude () import Prelude.Compat +import Control.Monad.Catch (Exception) import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Lazy as LBS import Data.Semigroup ((<>)) @@ -44,6 +45,8 @@ data ServantError = | ConnectionError Text deriving (Eq, Show, Generic, Typeable) +instance Exception ServantError + data RequestF a = Request { requestPath :: a , requestQueryString :: Seq.Seq QueryItem diff --git a/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs b/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs index a441a8b8..564cbb39 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs @@ -6,11 +6,10 @@ -- | Types for possible backends to run client-side `Request` queries module Servant.Client.Core.Internal.RunClient where -import Prelude.Compat import Prelude () +import Prelude.Compat import Control.Monad (unless) -import Control.Monad.Error.Class (MonadError, throwError) import Data.Foldable (toList) import Data.Proxy (Proxy) import qualified Data.Text as T @@ -22,16 +21,18 @@ import Servant.API (MimeUnrender, import Servant.Client.Core.Internal.Request (Request, Response (..), ServantError (..)) -class (MonadError ServantError m) => RunClient m where +class (Monad m) => RunClient m where -- | How to make a request. runRequest :: Request -> m Response + throwServantError :: ServantError -> m a + catchServantError :: m a -> (ServantError -> m a) -> m a checkContentTypeHeader :: RunClient m => Response -> m MediaType checkContentTypeHeader response = case lookup "Content-Type" $ toList $ responseHeaders response of Nothing -> return $ "application"//"octet-stream" Just t -> case parseAccept t of - Nothing -> throwError $ InvalidContentTypeHeader response + Nothing -> throwServantError $ InvalidContentTypeHeader response Just t' -> return t' decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m) @@ -39,9 +40,9 @@ decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m) decodedAs response contentType = do responseContentType <- checkContentTypeHeader response unless (any (matches responseContentType) accept) $ - throwError $ UnsupportedContentType responseContentType response + throwServantError $ UnsupportedContentType responseContentType response case mimeUnrender contentType $ responseBody response of - Left err -> throwError $ DecodeFailure (T.pack err) response + Left err -> throwServantError $ DecodeFailure (T.pack err) response Right val -> return val where accept = toList $ contentTypes contentType diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index 5595c039..e61b29e3 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient.hs @@ -88,6 +88,8 @@ instance Alt ClientM where instance RunClient ClientM where runRequest = performRequest + throwServantError = throwError + catchServantError = catchError instance ClientLike (ClientM a) (ClientM a) where mkClient = id