eeva/servant
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

extract module for http-client

Browse Source
This commit is contained in:
Arnaud Bailly 2017-08-28 18:36:05 +02:00 committed by Julian K. Arni
parent 97aa7db8b6
commit 2665693529
5 changed files with 134 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
servant-client/servant-client.cabal
View File

@ -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

1
servant-client/src/Servant/Client.hs
View File

@ -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

130
servant-client/src/Servant/Client/HttpClient.hs Normal file
View File

@ -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)

104
servant-client/src/Servant/Common/Req.hs
View File

@ -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)

1
servant-client/test/Servant/ClientSpec.hs
View File

@ -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