From f44ab3d083c66828b73ed837f830fedc268e4008 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 7 Sep 2017 16:11:20 -0700 Subject: [PATCH] Cleanup --- .../Servant/Client/Core/Internal/Request.hs | 50 ------------------- .../src/Servant/Client/HttpClient.hs | 48 +++--------------- 2 files changed, 8 insertions(+), 90 deletions(-) diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs index bfcd1d70..8b9306d3 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs @@ -107,53 +107,3 @@ setRequestBodyLBS b t req -- setRequestBody :: RequestBody -> MediaType -> Request -> Request setRequestBody b t req = req { requestBody = Just (b, t) } - -{-reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request-} -{-reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =-} - {-setheaders . setAccept . setrqb . setQS <$> parseRequest url-} - - {-where url = show $ nullURI { uriScheme = case reqScheme of-} - {-Http -> "http:"-} - {-Https -> "https:"-} - {-, uriAuthority = Just $-} - {-URIAuth { uriUserInfo = ""-} - {-, uriRegName = reqHost-} - {-, uriPort = ":" ++ show reqPort-} - {-}-} - {-, uriPath = fullPath-} - {-}-} - {-fullPath = path ++ cs (Builder.toLazyByteString (reqPath req))-} - - {-setrqb r = case reqBody req of-} - {-Nothing -> r-} - {-Just (b,t) -> r { requestBody = b-} - {-, requestHeaders = requestHeaders r-} - {-++ [(hContentType, cs . show $ t)] }-} - {-setQS = setQueryString $ queryTextToQuery (qs req)-} - {-setheaders r = r { requestHeaders = requestHeaders r-} - {-<> fmap toProperHeader (headers req) }-} - {-setAccept r = r { requestHeaders = filter ((/= "Accept") . fst) (requestHeaders r)-} - {-<> [("Accept", renderHeader $ reqAccept req)-} - {-| not . null . reqAccept $ req] }-} - {-toProperHeader (name, val) =-} - {-(fromString name, encodeUtf8 val)-} - - - {- #if !MIN_VERSION_http_client(0,4,30)-} - {--- 'parseRequest' is introduced in http-client-0.4.30-} - {--- it differs from 'parseUrl', by not throwing exceptions on non-2xx http statuses-} - {----} - {--- See for implementations:-} - {--- http://hackage.haskell.org/package/http-client-0.4.30/docs/src/Network-HTTP-Client-Request.html#parseRequest-} - {--- http://hackage.haskell.org/package/http-client-0.5.0/docs/src/Network-HTTP-Client-Request.html#parseRequest-} - {-parseRequest :: MonadThrow m => String -> m Request-} - {-parseRequest url = liftM disableStatusCheck (parseUrl url)-} - {-where-} - {-disableStatusCheck req = req { checkStatus = \ _status _headers _cookies -> Nothing }-} - {- #endif-} - - - {--- * performing requests-} - - {-displayHttpRequest :: Method -> String-} - {-displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"-} diff --git a/servant-client/src/Servant/Client/HttpClient.hs b/servant-client/src/Servant/Client/HttpClient.hs index 5dd84c30..a54574f6 100644 --- a/servant-client/src/Servant/Client/HttpClient.hs +++ b/servant-client/src/Servant/Client/HttpClient.hs @@ -20,33 +20,24 @@ import Control.Monad import Control.Monad.Base (MonadBase (..)) import Control.Monad.Catch (MonadCatch, MonadThrow) import Control.Monad.Error.Class (MonadError (..)) +import Control.Monad.Reader +import Control.Monad.Trans.Control (MonadBaseControl (..)) +import Control.Monad.Trans.Except import Data.ByteString.Builder (toLazyByteString) import qualified Data.ByteString.Lazy as BSL +import Data.Foldable (toList) +import Data.Functor.Alt (Alt (..)) 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.Foldable (toList) -import Data.Functor.Alt (Alt (..)) -import Data.Proxy -{-import Data.String.Conversions (cs)-} import GHC.Generics -import Network.HTTP.Media (parseAccept, renderHeader, (//)) +import Network.HTTP.Media (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-} data ClientEnv = ClientEnv @@ -97,15 +88,8 @@ performRequest req = do 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 ourResponse - Just t' -> pure t' unless (status_code >= 200 && status_code < 300) $ throwError $ FailureResponse ourResponse return ourResponse @@ -135,24 +119,8 @@ requestToClientRequest burl r = Client.defaultRequest 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-} + Just (RequestBodyLBS body', typ) + -> (Client.RequestBodyLBS body', Just (hContentType, renderHeader typ)) catchConnectionError :: IO a -> IO (Either ServantError a) catchConnectionError action =