extract module for http-client

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

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

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)

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)

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