diff --git a/servant-client-core/CHANGELOG.md b/servant-client-core/CHANGELOG.md new file mode 100644 index 00000000..457587e2 --- /dev/null +++ b/servant-client-core/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for servant-client-core + +## 0.11 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/servant-client-core/LICENSE b/servant-client-core/LICENSE new file mode 100644 index 00000000..04bba964 --- /dev/null +++ b/servant-client-core/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017, Servant Contributors + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Servant Contributors nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/servant-client-core/Setup.hs b/servant-client-core/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/servant-client-core/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-client-core/include/overlapping-compat.h b/servant-client-core/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-client-core/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal new file mode 100644 index 00000000..e3083239 --- /dev/null +++ b/servant-client-core/servant-client-core.cabal @@ -0,0 +1,40 @@ +name: servant-client-core +version: 0.11 +synopsis: Core functionality and class for client function generation for servant APIs +description: + This library provides a class +license: BSD3 +license-file: LICENSE +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +homepage: http://haskell-servant.readthedocs.org/ +bug-reports: http://github.com/haskell-servant/servant/issues +-- copyright: +category: Web +build-type: Simple +extra-source-files: + include/*.h + CHANGELOG.md + README.md +source-repository head + type: git + location: http://github.com/haskell-servant/servant.git +cabal-version: >=1.10 + +library + exposed-modules: + build-depends: + base >= 4.7 && < 4.11 + , base-compat >= 0.9.1 && < 0.10 + hs-source-dirs: src + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + ghc-options: -Wall + default-language: Haskell2010 + hs-source-dirs: test + main-is: Spec.hs + other-modules: + build-depends: + base == 4.* diff --git a/servant-client/src/Servant/Client/Experimental/Auth.hs b/servant-client-core/src/Servant/Client/Core/Internal/Auth.hs similarity index 89% rename from servant-client/src/Servant/Client/Experimental/Auth.hs rename to servant-client-core/src/Servant/Client/Core/Internal/Auth.hs index a98d0b41..b9bb70e6 100644 --- a/servant-client/src/Servant/Client/Experimental/Auth.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Auth.hs @@ -10,7 +10,7 @@ module Servant.Client.Experimental.Auth ( , mkAuthenticateReq ) where -import Servant.Common.Req (Req) +import Servant.Common.Req (Request) -- | For a resource protected by authentication (e.g. AuthProtect), we need -- to provide the client with some data used to add authentication data @@ -25,12 +25,12 @@ type family AuthClientData a :: * -- -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE newtype AuthenticateReq a = - AuthenticateReq { unAuthReq :: (AuthClientData a, AuthClientData a -> Req -> Req) } + AuthenticateReq { unAuthReq :: (AuthClientData a, AuthClientData a -> Request -> Request) } -- | Handy helper to avoid wrapping datatypes in tuples everywhere. -- -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE mkAuthenticateReq :: AuthClientData a - -> (AuthClientData a -> Req -> Req) + -> (AuthClientData a -> Request -> Request) -> AuthenticateReq a mkAuthenticateReq val func = AuthenticateReq (val, func) diff --git a/servant-client/src/Servant/Common/BaseUrl.hs b/servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs similarity index 100% rename from servant-client/src/Servant/Common/BaseUrl.hs rename to servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs diff --git a/servant-client/src/Servant/Common/BasicAuth.hs b/servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hs similarity index 85% rename from servant-client/src/Servant/Common/BasicAuth.hs rename to servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hs index e2802699..df5cc66a 100644 --- a/servant-client/src/Servant/Common/BasicAuth.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hs @@ -11,11 +11,11 @@ module Servant.Common.BasicAuth ( import Data.ByteString.Base64 (encode) import Data.Monoid ((<>)) import Data.Text.Encoding (decodeUtf8) -import Servant.Common.Req (addHeader, Req) +import Servant.Common.Req (addHeader, Request) import Servant.API.BasicAuth (BasicAuthData(BasicAuthData)) -- | Authenticate a request using Basic Authentication -basicAuthReq :: BasicAuthData -> Req -> Req +basicAuthReq :: BasicAuthData -> Request -> Request basicAuthReq (BasicAuthData user pass) req = let authText = decodeUtf8 ("Basic " <> encode (user <> ":" <> pass)) in addHeader "Authorization" authText req diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Class.hs b/servant-client-core/src/Servant/Client/Core/Internal/Class.hs new file mode 100644 index 00000000..38dd3459 --- /dev/null +++ b/servant-client-core/src/Servant/Client/Core/Internal/Class.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-| Types for possible backends to run client-side `Request` queries -} +module Servant.Client.Class where + +import Data.Proxy +import Network.HTTP.Types +import Servant.Common.Req (Request, Response) + +class (Monad m) => RunClient m ct where + runRequest :: Proxy ct + -> Method + -> Request + -> m Response diff --git a/servant-client/src/Servant/Client/Generic.hs b/servant-client-core/src/Servant/Client/Core/Internal/Generic.hs similarity index 100% rename from servant-client/src/Servant/Client/Generic.hs rename to servant-client-core/src/Servant/Client/Core/Internal/Generic.hs diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs new file mode 100644 index 00000000..73b8a43f --- /dev/null +++ b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Servant.Common.Request where + +import Prelude () +import Prelude.Compat + +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Lazy as LBS +import Data.Semigroup ((<>)) +import qualified Data.Sequence as Seq +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Network.HTTP.Media (MediaType) +import Network.HTTP.Types (Header, HeaderName, HttpVersion, + Method, QueryItem, Status, http11) +import Web.HttpApiData (ToHttpApiData, toEncodedUrlPiece, + toHeader) + +data ServantError + = FailureResponse Response + | DecodeFailure Text Response + | UnsupportedContentType MediaType Response + | InvalidContentTypeHeader Response + | ConnectionError Text + deriving (Eq, Show, Generic, Typeable) + +data Request = Request + { requestPath :: Builder.Builder + , requestQueryString :: Seq.Seq QueryItem + , requestBody :: Maybe (RequestBody, MediaType) + , requestAccept :: Seq.Seq MediaType + , requestHeaders :: Seq.Seq Header + , requestHttpVersion :: HttpVersion + } deriving (Generic, Typeable) + +newtype RequestBody = RequestBodyLBS LBS.ByteString + deriving (Eq, Ord, Read, Show, Typeable) + +data Response = Response + { responseStatusCode :: Status + , responseBody :: LBS.ByteString + , responseHeaders :: Seq.Seq Header + , responseHttpVersion :: HttpVersion + } deriving (Eq, Show, Generic, Typeable) + +defaultRequest :: Request +defaultRequest = Request + { requestPath = "" + , requestQueryString = Seq.empty + , requestBody = Nothing + , requestAccept = Seq.empty + , requestHeaders = Seq.empty + , requestHttpVersion = http11 + } + +appendToPath :: Text -> Request -> Request +appendToPath p req + = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p } + +{-appendToQueryString :: Text -- ^ param name-} + {--> Maybe Text -- ^ param value-} + {--> Request-} + {--> Request-} +{-appendToQueryString pname pvalue req-} + {-= req { requestQueryString = requestQueryString req Seq.|> (pname, pvalue)}-} + +addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request +addHeader name val req + = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)} + +-- | Set body and media type of the request being constructed. +-- +-- The body is set to the given bytestring using the 'RequestBodyLBS' +-- constructor. +-- +-- @since 0.12 +-- +setRequestBodyLBS :: LBS.ByteString -> MediaType -> Request -> Request +setRequestBodyLBS b t req + = req { requestBody = Just (RequestBodyLBS b, t) } + +-- | Set body and media type of the request being constructed. +-- +-- @since 0.12 +-- +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/servant-client.cabal b/servant-client/servant-client.cabal index e2e85d45..7d52d1c5 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -44,6 +44,7 @@ library , attoparsec >= 0.12 && < 0.14 , base64-bytestring >= 1.0.0.1 && < 1.1 , bytestring >= 0.10 && < 0.11 + , containers >= 0.5 && < 0.6 , exceptions >= 0.8 && < 0.9 , generics-sop >= 0.1.0.0 && < 0.4 , http-api-data >= 0.3.6 && < 0.4 diff --git a/servant-client/src/Servant/Client/Class.hs b/servant-client/src/Servant/Client/Class.hs deleted file mode 100644 index c030486a..00000000 --- a/servant-client/src/Servant/Client/Class.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-| Types for possible backends to run client-side `Req` queries -} -module Servant.Client.Class - (RunClient(..)) -where - -import Data.Proxy -import Network.HTTP.Types -import Servant.Common.Req - -class (Monad m) => RunClient m ct result where - runRequest :: Proxy ct - -> Method - -> Req - -> m result diff --git a/servant-client/src/Servant/Client/HttpClient.hs b/servant-client/src/Servant/Client/HttpClient.hs index 0934e53e..60bab060 100644 --- a/servant-client/src/Servant/Client/HttpClient.hs +++ b/servant-client/src/Servant/Client/HttpClient.hs @@ -4,44 +4,42 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {-| http-client based client requests executor -} module Servant.Client.HttpClient where -import Prelude () -import Prelude.Compat +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.Exception +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 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 +import Network.HTTP.Types +import Servant.API.ContentTypes +import Servant.Client.Class +import Servant.Common.BaseUrl +import Servant.Common.Req -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.Client as Client import qualified Network.HTTP.Types.Header as HTTP -import Servant.API.ContentTypes -import Servant.Client.Class -import Servant.Common.BaseUrl -import Servant.Common.Req - -import qualified Network.HTTP.Client as Client instance RunClient ClientM NoContent ( Int, ByteString, MediaType , [HTTP.Header], Response ByteString) where @@ -89,8 +87,7 @@ runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm performRequest :: Method -> Req - -> ClientM ( Int, ByteString, MediaType - , [HTTP.Header], Response ByteString) + -> ClientM Response performRequest reqMethod req = do m <- asks manager reqHost <- asks baseUrl diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs deleted file mode 100644 index 94997eaf..00000000 --- a/servant-client/src/Servant/Common/Req.hs +++ /dev/null @@ -1,183 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Servant.Common.Req where - -import Prelude () -import Prelude.Compat - -import Control.Exception -import Control.Monad.Catch (MonadThrow) -import Data.Semigroup ((<>)) - -import Control.Monad.IO.Class () -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.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 Network.URI hiding (path) -import Servant.Common.BaseUrl - -import Web.HttpApiData - -data ServantError - = FailureResponse - { failingRequest :: UrlReq - , responseStatus :: Status - , responseContentType :: MediaType - , responseBody :: ByteString - } - | DecodeFailure - { decodeError :: String - , responseContentType :: MediaType - , responseBody :: ByteString - } - | UnsupportedContentType - { responseContentType :: MediaType - , responseBody :: ByteString - } - | InvalidContentTypeHeader - { responseContentTypeHeader :: ByteString - , responseBody :: ByteString - } - | ConnectionError - { connectionError :: SomeException - } - deriving (Show, Typeable) - -instance Eq ServantError where - FailureResponse _ a b c == FailureResponse _ x y z = - (a, b, c) == (x, y, z) - DecodeFailure a b c == DecodeFailure x y z = - (a, b, c) == (x, y, z) - UnsupportedContentType a b == UnsupportedContentType x y = - (a, b) == (x, y) - InvalidContentTypeHeader a b == InvalidContentTypeHeader x y = - (a, b) == (x, y) - ConnectionError a == ConnectionError x = - show a == show x - _ == _ = False - -instance Exception ServantError - -data UrlReq = UrlReq BaseUrl Req - -instance Show UrlReq where - show (UrlReq url req) = showBaseUrl url ++ path ++ "?" ++ show (qs req) - where - path = cs (BS.toLazyByteString (reqPath req)) - -data Req = Req - { reqPath :: BS.Builder - , qs :: QueryText - , reqBody :: Maybe (RequestBody, MediaType) - , reqAccept :: [MediaType] - , headers :: [(String, Text)] - } - -defReq :: Req -defReq = Req "" [] Nothing [] [] - -appendToPath :: String -> Req -> Req -appendToPath p req = - req { reqPath = reqPath req <> "/" <> toEncodedUrlPiece p } - -appendToQueryString :: Text -- ^ param name - -> Maybe Text -- ^ param value - -> Req - -> Req -appendToQueryString pname pvalue req = - req { qs = qs req ++ [(pname, pvalue)] - } - -addHeader :: ToHttpApiData a => String -> a -> Req -> Req -addHeader name val req = req { headers = headers req - ++ [(name, decodeUtf8 (toHeader val))] - } - --- | Set body and media type of the request being constructed. --- --- The body is set to the given bytestring using the 'RequestBodyLBS' --- constructor. --- -{-# DEPRECATED setRQBody "Use setReqBodyLBS instead" #-} -setRQBody :: ByteString -> MediaType -> Req -> Req -setRQBody = setReqBodyLBS - --- | Set body and media type of the request being constructed. --- --- The body is set to the given bytestring using the 'RequestBodyLBS' --- constructor. --- --- @since 0.9.2.0 --- -setReqBodyLBS :: ByteString -> MediaType -> Req -> Req -setReqBodyLBS b t req = req { reqBody = Just (RequestBodyLBS b, t) } - --- | Set body and media type of the request being constructed. --- --- @since 0.9.2.0 --- -setReqBody :: RequestBody -> MediaType -> Req -> Req -setReqBody b t req = req { reqBody = 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 (BS.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"