Compiling HttpClient

This commit is contained in:
Julian K. Arni 2017-09-07 16:07:18 -07:00
parent 01f344dfbb
commit 05db359296
4 changed files with 96 additions and 60 deletions

View file

@ -24,6 +24,10 @@ module Servant.Client.Core
, mkAuthenticateReq , mkAuthenticateReq
, ServantError(..) , ServantError(..)
, EmptyClient(..) , EmptyClient(..)
, RunClient(..)
, Request(..)
, Response(..)
, RequestBody(..)
, module Servant.Client.Core.Internal.BaseUrl , module Servant.Client.Core.Internal.BaseUrl
) where ) where

View file

@ -27,11 +27,17 @@ import Network.HTTP.Types (Header, HeaderName, HttpVersion,
import Web.HttpApiData (ToHttpApiData, toEncodedUrlPiece, import Web.HttpApiData (ToHttpApiData, toEncodedUrlPiece,
toHeader) toHeader)
data ServantError -- | A type representing possible errors in a request
= FailureResponse Response data ServantError =
-- | The server returned an error response
FailureResponse Response
-- | The body could not be decoded at the expected type
| DecodeFailure Text Response | DecodeFailure Text Response
-- | The content-type of the response is not supported
| UnsupportedContentType MediaType Response | UnsupportedContentType MediaType Response
-- | The content-type header is invalid
| InvalidContentTypeHeader Response | InvalidContentTypeHeader Response
-- | There was a connection error, and no response was received
| ConnectionError Text | ConnectionError Text
deriving (Eq, Show, Generic, Typeable) deriving (Eq, Show, Generic, Typeable)
@ -45,6 +51,7 @@ data Request = Request
, requestMethod :: Method , requestMethod :: Method
} deriving (Generic, Typeable) } deriving (Generic, Typeable)
-- | The request body. Currently only lazy ByteStrings are supported.
newtype RequestBody = RequestBodyLBS LBS.ByteString newtype RequestBody = RequestBodyLBS LBS.ByteString
deriving (Eq, Ord, Read, Show, Typeable) deriving (Eq, Ord, Read, Show, Typeable)
@ -55,6 +62,7 @@ data Response = Response
, responseHttpVersion :: HttpVersion , responseHttpVersion :: HttpVersion
} deriving (Eq, Show, Generic, Typeable) } deriving (Eq, Show, Generic, Typeable)
-- A GET request to the top-level path
defaultRequest :: Request defaultRequest :: Request
defaultRequest = Request defaultRequest = Request
{ requestPath = "" { requestPath = ""

View file

@ -29,23 +29,23 @@ source-repository head
library library
exposed-modules: exposed-modules:
Servant.Client
Servant.Client.Class
Servant.Client.HttpClient Servant.Client.HttpClient
Servant.Client.Generic
Servant.Client.Experimental.Auth
Servant.Common.BaseUrl
Servant.Common.BasicAuth
Servant.Common.Req
build-depends: build-depends:
base >= 4.7 && < 4.11 base >= 4.7 && < 4.11
, base-compat >= 0.9.1 && < 0.10 , base-compat >= 0.9.1 && < 0.10
, bytestring >= 0.10 && < 0.11
, aeson >= 0.7 && < 1.3 , aeson >= 0.7 && < 1.3
, attoparsec >= 0.12 && < 0.14 , attoparsec >= 0.12 && < 0.14
, http-client >= 0.4.18.1 && < 0.6 , http-client >= 0.4.18.1 && < 0.6
, http-client-tls >= 0.2.2 && < 0.4 , 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 , monad-control >= 1.0.0.4 && < 1.1
, mtl >= 2.2 && < 2.3
, semigroupoids >= 4.3 && < 5.3 , semigroupoids >= 4.3 && < 5.3
, servant-client-core == 0.11.*
, text >= 1.2 && < 1.3
, transformers >= 0.3 && < 0.6 , transformers >= 0.3 && < 0.6
, transformers-base >= 0.4.4 && < 0.5 , transformers-base >= 0.4.4 && < 0.5
, transformers-compat >= 0.4 && < 0.6 , transformers-compat >= 0.4 && < 0.6

View file

@ -20,41 +20,37 @@ import Control.Monad
import Control.Monad.Base (MonadBase (..)) import Control.Monad.Base (MonadBase (..))
import Control.Monad.Catch (MonadCatch, MonadThrow) import Control.Monad.Catch (MonadCatch, MonadThrow)
import Control.Monad.Error.Class (MonadError (..)) 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.Reader
import Control.Monad.Trans.Control (MonadBaseControl (..)) import Control.Monad.Trans.Control (MonadBaseControl (..))
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Data.ByteString.Lazy hiding (any, elem, filter, map, {-import Data.ByteString.Lazy hiding (any, elem, filter, map,-}
null, pack) {-null, pack)-}
import Data.Foldable (toList) import Data.Foldable (toList)
import Data.Functor.Alt (Alt (..)) import Data.Functor.Alt (Alt (..))
import Data.Proxy import Data.Proxy
import Data.String.Conversions (cs) {-import Data.String.Conversions (cs)-}
import GHC.Generics import GHC.Generics
import Network.HTTP.Media import Network.HTTP.Media (parseAccept, renderHeader, (//))
import Network.HTTP.Types import Network.HTTP.Types (hContentType, renderQuery,
import Servant.API.ContentTypes statusCode)
import Servant.Client.Class {-import Servant.API.ContentTypes-}
import Servant.Common.BaseUrl import Servant.Client.Core
import Servant.Common.Req {-import Servant.Common.BaseUrl-}
{-import Servant.Common.Req-}
import qualified Network.HTTP.Client as Client import qualified Network.HTTP.Client as Client
import qualified Network.HTTP.Types.Header as HTTP {-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
data ClientEnv data ClientEnv
= ClientEnv = ClientEnv
{ manager :: Manager { manager :: Client.Manager
, baseUrl :: BaseUrl , baseUrl :: BaseUrl
} }
@ -82,55 +78,83 @@ instance MonadBaseControl IO ClientM where
instance Alt ClientM where instance Alt ClientM where
a <!> b = a `catchError` \_ -> b a <!> b = a `catchError` \_ -> b
instance RunClient ClientM where
runRequest = performRequest
runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a) runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm 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 eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m
case eResponse of case eResponse of
Left err -> Left err -> throwError $ err
throwError . ConnectionError $ SomeException err
Right response -> do Right response -> do
let status = Client.responseStatus response let status = Client.responseStatus response
body = Client.responseBody response body = Client.responseBody response
hdrs = Client.responseHeaders response hdrs = Client.responseHeaders response
status_code = statusCode status status_code = statusCode status
ourResponse = clientResponseToReponse response
ct <- case lookup "Content-Type" $ Client.responseHeaders response of ct <- case lookup "Content-Type" $ Client.responseHeaders response of
Nothing -> pure $ "application"//"octet-stream" Nothing -> pure $ "application"//"octet-stream"
Just t -> case parseAccept t of Just t -> case parseAccept t of
Nothing -> throwError $ InvalidContentTypeHeader (cs t) body Nothing -> throwError $ InvalidContentTypeHeader ourResponse
Just t' -> pure t' Just t' -> pure t'
unless (status_code >= 200 && status_code < 300) $ unless (status_code >= 200 && status_code < 300) $
throwError $ FailureResponse (UrlReq reqHost req) status ct body throwError $ FailureResponse ourResponse
return (status_code, body, ct, hdrs, response) return ourResponse
performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req clientResponseToReponse :: Client.Response BSL.ByteString -> Response
-> ClientM ([HTTP.Header], result) clientResponseToReponse r = Response
performRequestCT ct reqMethod req = do { responseStatusCode = Client.responseStatus r
let acceptCTS = contentTypes ct , responseBody = Client.responseBody r
(_status, respBody, respCT, hdrs, _response) <- , responseHeaders = fromList $ Client.responseHeaders r
performRequest reqMethod (req { reqAccept = toList acceptCTS }) , responseHttpVersion = Client.responseVersion r
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] requestToClientRequest :: BaseUrl -> Request -> Client.Request
performRequestNoBody reqMethod req = do requestToClientRequest burl r = Client.defaultRequest
(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req { Client.method = requestMethod r
return hdrs , 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 :: IO a -> IO (Either ServantError a)
catchConnectionError action = catchConnectionError action =
catch (Right <$> action) $ \e -> catch (Right <$> action) $ \e ->
pure . Left . ConnectionError $ SomeException (e :: HttpException) pure . Left . ConnectionError . T.pack $ show (e :: Client.HttpException)