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

Compiling HttpClient

Browse Source
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
servant-client-core/src/Servant/Client/Core.hs
View File

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

12
servant-client-core/src/Servant/Client/Core/Internal/Request.hs
View File

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

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

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

126
servant-client/src/Servant/Client/HttpClient.hs
View File

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