From 26656935299643d6f566bae8eda74ece26388f24 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Mon, 28 Aug 2017 18:36:05 +0200 Subject: [PATCH] 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