diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,15 @@ +## Req 3.4.0 + +* Requests using `DELETE` method can now have a body. [Issue + 89](https://github.com/mrkkrp/req/issues/89). + +* Added the `httpConfigRetryJudgeException` field to `HttpConfig` so that + requests that result in exceptions can be retried. [Issue + 93](https://github.com/mrkkrp/req/issues/93). + +* Added the function `renderUrl`. [Issue + 83](https://github.com/mrkkrp/req/issues/83). + ## Req 3.3.0 * Derived `Show` instances for response types `IgnoreResponse`, diff --git a/Network/HTTP/Req.hs b/Network/HTTP/Req.hs --- a/Network/HTTP/Req.hs +++ b/Network/HTTP/Req.hs @@ -149,6 +149,7 @@ useHttpsURI, useURI, urlQ, + renderUrl, -- ** Body -- $body @@ -232,8 +233,9 @@ import qualified Blaze.ByteString.Builder as BB import Control.Applicative import Control.Arrow (first, second) -import Control.Exception hiding (TypeError) +import Control.Exception hiding (Handler (..), TypeError) import Control.Monad.Base +import Control.Monad.Catch (Handler (..)) import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.Trans.Control @@ -472,11 +474,22 @@ r' <- L.responseOpen request manager writeIORef rref (Just r') return r' + exceptionRetryPolicies = + skipAsyncExceptions + ++ [ \retryStatus -> Handler $ \e -> + return $ httpConfigRetryJudgeException retryStatus e + ] r <- retrying httpConfigRetryPolicy - (\st r -> return $ httpConfigRetryJudge st r) - (const openResponse) + (\retryStatus r -> return $ httpConfigRetryJudge retryStatus r) + ( const + ( recovering + httpConfigRetryPolicy + exceptionRetryPolicies + (const openResponse) + ) + ) (preview, r') <- grabPreview bodyPreviewLength r mapM_ LI.throwHttp (httpConfigCheckResponse request r' preview) consume r' @@ -652,7 +665,12 @@ -- /1.0.0/. -- -- @since 0.3.0 - httpConfigRetryJudge :: forall b. RetryStatus -> L.Response b -> Bool + httpConfigRetryJudge :: forall b. RetryStatus -> L.Response b -> Bool, + -- | Similar to 'httpConfigRetryJudge', but is used to decide when to + -- retry requests that resulted in an exception. + -- + -- @since 3.4.0 + httpConfigRetryJudgeException :: RetryStatus -> SomeException -> Bool } deriving (Typeable) @@ -678,7 +696,8 @@ 524, -- A timeout occurred 598, -- (Informal convention) Network read timeout error 599 -- (Informal convention) Network connect timeout error - ] + ], + httpConfigRetryJudgeException = \_ _ -> False } where statusCode = Y.statusCode . L.responseStatus @@ -770,14 +789,15 @@ type AllowsBody PUT = 'CanHaveBody httpMethodName Proxy = Y.methodPut --- | 'DELETE' method. This data type does not allow having request body with --- 'DELETE' requests, as it should be. However some APIs may expect 'DELETE' --- requests to have bodies, in that case define your own variation of --- 'DELETE' method and allow it to have a body. +-- | 'DELETE' method. RFC 7231 allows a payload in DELETE but without +-- semantics. +-- +-- __Note__: before version /3.4.0/ this method did not allow request +-- bodies. data DELETE = DELETE instance HttpMethod DELETE where - type AllowsBody DELETE = 'NoBody + type AllowsBody DELETE = 'CanHaveBody httpMethodName Proxy = Y.methodDelete -- | 'TRACE' method. @@ -909,6 +929,19 @@ (/:) :: Url scheme -> Text -> Url scheme (/:) = (/~) + +-- | Render a 'Url' as 'Text'. +-- +-- @since 3.4.0 +renderUrl :: Url scheme -> Text +renderUrl = \case + Url Https parts -> + "https://" <> renderParts parts + Url Http parts -> + "http://" <> renderParts parts + where + renderParts parts = + T.intercalate "/" (reverse $ NE.toList parts) -- | The 'useHttpURI' function provides an alternative method to get 'Url' -- (possibly with some 'Option's) from a 'URI'. This is useful when you are diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,7 +4,7 @@ [![Hackage](https://img.shields.io/hackage/v/req.svg?style=flat)](https://hackage.haskell.org/package/req) [![Stackage Nightly](http://stackage.org/package/req/badge/nightly)](http://stackage.org/nightly/package/req) [![Stackage LTS](http://stackage.org/package/req/badge/lts)](http://stackage.org/lts/package/req) -[![Build Status](https://travis-ci.org/mrkkrp/req.svg?branch=master)](https://travis-ci.org/mrkkrp/req) +![CI](https://github.com/mrkkrp/req/workflows/CI/badge.svg?branch=master) * [Motivation and Req vs other libraries](#motivation-and-req-vs-other-libraries) * [Unsolved problems](#unsolved-problems) diff --git a/httpbin-tests/Network/HTTP/ReqSpec.hs b/httpbin-tests/Network/HTTP/ReqSpec.hs --- a/httpbin-tests/Network/HTTP/ReqSpec.hs +++ b/httpbin-tests/Network/HTTP/ReqSpec.hs @@ -10,7 +10,7 @@ import Control.Exception import Control.Monad.Reader import Control.Monad.Trans.Control -import Data.Aeson ((.=), ToJSON (..), Value (..), object) +import Data.Aeson (ToJSON (..), Value (..), object, (.=)) import qualified Data.Aeson as A import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL @@ -33,28 +33,26 @@ spec :: Spec spec = do - describe "exception throwing on non-2xx status codes" - $ it "throws indeed for non-2xx" - $ req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty - `shouldThrow` selector404 - - describe "exception throwing on non-2xx status codes (Req monad)" - $ it "throws indeed for non-2xx" - $ asIO . runReq defaultHttpConfig - $ liftBaseWith - $ \run -> - run (req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty) + describe "exception throwing on non-2xx status codes" $ + it "throws indeed for non-2xx" $ + req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty `shouldThrow` selector404 - describe "response check via httpConfigCheckResponse" - $ context "if it's set to always throw" - $ it "throws indeed" - $ blindlyThrowing (req GET httpbin NoReqBody ignoreResponse mempty) - `shouldThrow` anyException + describe "exception throwing on non-2xx status codes (Req monad)" $ + it "throws indeed for non-2xx" $ + asIO . runReq defaultHttpConfig $ + liftBaseWith $ \run -> + run (req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty) + `shouldThrow` selector404 - describe "receiving user-agent header back" - $ it "works" - $ do + describe "response check via httpConfigCheckResponse" $ + context "if it's set to always throw" $ + it "throws indeed" $ + blindlyThrowing (req GET httpbin NoReqBody ignoreResponse mempty) + `shouldThrow` anyException + + describe "receiving user-agent header back" $ + it "works" $ do r <- req GET @@ -68,9 +66,8 @@ responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" - describe "receiving request headers back" - $ it "works" - $ do + describe "receiving request headers back" $ + it "works" $ do r <- req GET @@ -91,9 +88,8 @@ responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" - describe "receiving GET data back" - $ it "works" - $ do + describe "receiving GET data back" $ + it "works" $ do r <- req GET (httpbin /: "get") NoReqBody jsonResponse mempty (stripFunnyHeaders . stripOrigin) (responseBody r) `shouldBe` object @@ -109,9 +105,8 @@ responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" - describe "receiving POST JSON data back" - $ it "works" - $ do + describe "receiving POST JSON data back" $ + it "works" $ do let text = "foo" :: Text reflected = reflectJSON text r <- req POST (httpbin /: "post") (ReqBodyJson text) jsonResponse mempty @@ -135,9 +130,8 @@ responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" - describe "receiving POST data back (multipart form data)" - $ it "works" - $ do + describe "receiving POST data back (multipart form data)" $ + it "works" $ do body <- reqBodyMultipart [ LM.partBS "foo" "foo data!", @@ -169,9 +163,8 @@ responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" - describe "receiving PATCHed file back" - $ it "works" - $ do + describe "receiving PATCHed file back" $ + it "works" $ do let file :: FilePath file = "httpbin-data/robots.txt" contents <- TIO.readFile file @@ -195,9 +188,8 @@ responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" - describe "receiving PUT form URL-encoded data back" - $ it "works" - $ do + describe "receiving PUT form URL-encoded data back" $ + it "works" $ do let params = "foo" =: ("bar" :: Text) <> "baz" =: (5 :: Int) @@ -230,9 +222,8 @@ -- TODO /delete - describe "receiving UTF-8 encoded Unicode data" - $ it "works" - $ do + describe "receiving UTF-8 encoded Unicode data" $ + it "works" $ do r <- req GET @@ -248,9 +239,8 @@ -- TODO /gzip -- TODO /deflate - describe "retrying" - $ it "retries as many times as specified" - $ do + describe "retrying" $ + it "retries as many times as specified" $ do -- FIXME We no longer can count retries because all the functions -- responsible for controlling retrying are pure now. let status = 408 :: Int @@ -273,19 +263,22 @@ -- TODO /response-headers -- TODO /redirect - describe "redirects" - $ it "follows redirects" - $ do - r <- - req - GET - (httpbin /: "redirect-to") - NoReqBody - ignoreResponse - ("url" =: ("https://httpbin.org" :: Text)) - responseStatusCode r `shouldBe` 200 - responseStatusMessage r `shouldBe` "OK" + -- FIXME Redirects test is temporarily disabled due to + -- + -- https://github.com/postmanlabs/httpbin/issues/617 + -- describe "redirects" $ + -- it "follows redirects" $ do + -- r <- + -- req + -- GET + -- (httpbin /: "redirect-to") + -- NoReqBody + -- ignoreResponse + -- ("url" =: ("https://httpbin.org" :: Text)) + -- responseStatusCode r `shouldBe` 200 + -- responseStatusMessage r `shouldBe` "OK" + -- TODO /relative-redicet -- TODO /absolute-redirect -- TODO /cookies @@ -294,9 +287,8 @@ let user, password :: Text user = "Scooby" password = "Doo" - context "when we do not send appropriate basic auth data" - $ it "fails with 401" - $ do + context "when we do not send appropriate basic auth data" $ + it "fails with 401" $ do r <- prepareForShit $ req @@ -307,9 +299,8 @@ mempty responseStatusCode r `shouldBe` 401 responseStatusMessage r `shouldBe` "UNAUTHORIZED" - context "when we provide appropriate basic auth data" - $ it "succeeds" - $ do + context "when we provide appropriate basic auth data" $ + it "succeeds" $ do r <- req GET @@ -328,9 +319,8 @@ -- TODO /range -- TODO /html - describe "robots.txt" - $ it "works" - $ do + describe "robots.txt" $ + it "works" $ do r <- req GET (httpbin /: "robots.txt") NoReqBody bsResponse mempty robots <- B.readFile "httpbin-data/robots.txt" responseBody r `shouldBe` robots @@ -341,9 +331,8 @@ -- TODO /cache describe "getting random bytes" $ do - it "works" - $ property - $ \n' -> do + it "works" $ + property $ \n' -> do let n :: Word n = getSmall n' r <- @@ -356,9 +345,8 @@ responseBody r `shouldSatisfy` ((== n) . fromIntegral . BL.length) responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" - context "when we try to interpret 1000 random bytes as JSON" - $ it "throws correct exception" - $ do + context "when we try to interpret 1000 random bytes as JSON" $ + it "throws correct exception" $ do let selector :: HttpException -> Bool selector (JsonHttpException _) = True selector _ = False @@ -372,22 +360,21 @@ mempty `shouldThrow` selector - describe "streaming random bytes" - $ it "works" - $ property - $ \n' -> do - let n :: Word - n = getSmall n' - r <- - req - GET - (httpbin /: "stream-bytes" /~ n) - NoReqBody - bsResponse - mempty - responseBody r `shouldSatisfy` ((== n) . fromIntegral . B.length) - responseStatusCode r `shouldBe` 200 - responseStatusMessage r `shouldBe` "OK" + describe "streaming random bytes" $ + it "works" $ + property $ \n' -> do + let n :: Word + n = getSmall n' + r <- + req + GET + (httpbin /: "stream-bytes" /~ n) + NoReqBody + bsResponse + mempty + responseBody r `shouldSatisfy` ((== n) . fromIntegral . B.length) + responseStatusCode r `shouldBe` 200 + responseStatusMessage r `shouldBe` "OK" -- TODO /links -- TODO /image @@ -450,9 +437,8 @@ -- get various response status codes. checkStatusCode :: Int -> SpecWith () checkStatusCode code = - describe ("receiving status code " ++ show code) - $ it "works" - $ do + describe ("receiving status code " ++ show code) $ + it "works" $ do r <- prepareForShit $ req diff --git a/pure-tests/Network/HTTP/ReqSpec.hs b/pure-tests/Network/HTTP/ReqSpec.hs --- a/pure-tests/Network/HTTP/ReqSpec.hs +++ b/pure-tests/Network/HTTP/ReqSpec.hs @@ -54,13 +54,12 @@ spec :: Spec spec = do - describe "config" - $ it "getHttpConfig has effect on resulting request" - $ property - $ \config -> do - request <- runReq config (req_ GET url NoReqBody mempty) - L.proxy request `shouldBe` httpConfigProxy config - L.redirectCount request `shouldBe` httpConfigRedirectCount config + describe "config" $ + it "getHttpConfig has effect on resulting request" $ + property $ \config -> do + request <- runReq config (req_ GET url NoReqBody mempty) + L.proxy request `shouldBe` httpConfigProxy config + L.redirectCount request `shouldBe` httpConfigRedirectCount config describe "methods" $ do let mnth :: @@ -72,9 +71,8 @@ SpecM () () mnth method = do let name = httpMethodName (Proxy :: Proxy method) - describe (B8.unpack name) - $ it "affects name of HTTP method" - $ do + describe (B8.unpack name) $ + it "affects name of HTTP method" $ do request <- req_ method url NoReqBody mempty L.method request `shouldBe` name mnth GET @@ -88,48 +86,42 @@ mnth PATCH describe "urls" $ do - describe "http" - $ it "sets all the params correctly" - $ property - $ \host -> do - request <- req_ GET (http host) NoReqBody mempty - L.secure request `shouldBe` False - L.port request `shouldBe` 80 - L.host request `shouldBe` urlEncode host - describe "https" - $ it "sets all the params correctly" - $ property - $ \host -> do - request <- req_ GET (https host) NoReqBody mempty - L.secure request `shouldBe` True - L.port request `shouldBe` 443 - L.host request `shouldBe` urlEncode host - describe "(/~)" - $ it "attaches a path piece that is URL-encoded" - $ property - $ \host pieces -> do - let url' = foldl (/~) (https host) pieces - request <- req_ GET url' NoReqBody mempty - L.host request `shouldBe` urlEncode host - L.path request `shouldBe` encodePathPieces pieces - describe "(/:)" - $ it "attaches a path piece that is URL-encoded" - $ property - $ \host pieces -> do - let url' = foldl (/:) (https host) pieces - request <- req_ GET url' NoReqBody mempty - L.host request `shouldBe` urlEncode host - L.path request `shouldBe` encodePathPieces pieces + describe "http" $ + it "sets all the params correctly" $ + property $ \host -> do + request <- req_ GET (http host) NoReqBody mempty + L.secure request `shouldBe` False + L.port request `shouldBe` 80 + L.host request `shouldBe` urlEncode host + describe "https" $ + it "sets all the params correctly" $ + property $ \host -> do + request <- req_ GET (https host) NoReqBody mempty + L.secure request `shouldBe` True + L.port request `shouldBe` 443 + L.host request `shouldBe` urlEncode host + describe "(/~)" $ + it "attaches a path piece that is URL-encoded" $ + property $ \host pieces -> do + let url' = foldl (/~) (https host) pieces + request <- req_ GET url' NoReqBody mempty + L.host request `shouldBe` urlEncode host + L.path request `shouldBe` encodePathPieces pieces + describe "(/:)" $ + it "attaches a path piece that is URL-encoded" $ + property $ \host pieces -> do + let url' = foldl (/:) (https host) pieces + request <- req_ GET url' NoReqBody mempty + L.host request `shouldBe` urlEncode host + L.path request `shouldBe` encodePathPieces pieces describe "useHttpURI" $ do - it "does not recognize non-http schemes" - $ property - $ \uri -> + it "does not recognize non-http schemes" $ + property $ \uri -> when (URI.uriScheme uri /= Just [QQ.scheme|http|]) $ useHttpURI uri `shouldSatisfy` isNothing - it "accepts correct URLs" - $ property - $ \uri' -> do + it "accepts correct URLs" $ + property $ \uri' -> do unless (isRight (URI.uriAuthority uri')) discard let uri = uri' {URI.uriScheme = Just [QQ.scheme|http|]} (url', options) = fromJust (useHttpURI uri) @@ -141,14 +133,12 @@ lookup "Authorization" (L.requestHeaders request) `shouldBe` uriBasicAuth uri describe "useHttpsURI" $ do - it "does not recognize non-https schemes" - $ property - $ \uri -> + it "does not recognize non-https schemes" $ + property $ \uri -> when (URI.uriScheme uri /= Just [QQ.scheme|https|]) $ useHttpsURI uri `shouldSatisfy` isNothing - it "parses correct URLs" - $ property - $ \uri' -> do + it "parses correct URLs" $ + property $ \uri' -> do unless (isRight (URI.uriAuthority uri')) discard let uri = uri' {URI.uriScheme = Just [QQ.scheme|https|]} (url', options) = fromJust (useHttpsURI uri) @@ -160,18 +150,16 @@ lookup "Authorization" (L.requestHeaders request) `shouldBe` uriBasicAuth uri describe "useURI" $ do - it "does not recognize non-http and non-https schemes" - $ property - $ \uri -> + it "does not recognize non-http and non-https schemes" $ + property $ \uri -> when ( ( URI.uriScheme uri /= Just [QQ.scheme|http|] && (URI.uriScheme uri /= Just [QQ.scheme|https|]) ) ) $ useURI uri `shouldSatisfy` isNothing - it "parses correct URLs" - $ property - $ \uri' -> do + it "parses correct URLs" $ + property $ \uri' -> do unless (isRight (URI.uriAuthority uri')) discard let uriHttp = uri' {URI.uriScheme = Just [QQ.scheme|http|]} uriHttps = uri' {URI.uriScheme = Just [QQ.scheme|https|]} @@ -194,57 +182,70 @@ lookup "Authorization" (L.requestHeaders requestHttps) `shouldBe` uriBasicAuth uriHttps + describe "renderUrl" $ do + context "http" $ do + context "empty path" $ + it "renders correctly" $ do + let (uriHttp, _) = [urlQ|http://httpbin.org|] + renderUrl uriHttp `shouldBe` "http://httpbin.org" + context "non-empty path" $ + it "renders correctly" $ do + let (uriHttp, _) = [urlQ|http://httpbin.org/here/we/go|] + renderUrl uriHttp `shouldBe` "http://httpbin.org/here/we/go" + context "http" $ do + context "empty path" $ + it "renders correctly" $ do + let (uriHttp, _) = [urlQ|https://httpbin.org|] + renderUrl uriHttp `shouldBe` "https://httpbin.org" + context "non-empty path" $ + it "renders correctly" $ do + let (uriHttp, _) = [urlQ|https://httpbin.org/here/we/go|] + renderUrl uriHttp `shouldBe` "https://httpbin.org/here/we/go" + describe "bodies" $ do - describe "NoReqBody" - $ it "sets body to empty byte string" - $ do + describe "NoReqBody" $ + it "sets body to empty byte string" $ do request <- req_ POST url NoReqBody mempty case L.requestBody request of L.RequestBodyBS x -> x `shouldBe` B.empty _ -> expectationFailure "Wrong request body constructor." - describe "ReqBodyJson" - $ it "sets body to correct lazy byte string" - $ property - $ \thing -> do - request <- req_ POST url (ReqBodyJson thing) mempty - case L.requestBody request of - L.RequestBodyLBS x -> x `shouldBe` A.encode (thing :: Thing) - _ -> expectationFailure "Wrong request body constructor." - describe "ReqBodyBs" - $ it "sets body to specified strict byte string" - $ property - $ \bs -> do - request <- req_ POST url (ReqBodyBs bs) mempty - case L.requestBody request of - L.RequestBodyBS x -> x `shouldBe` bs - _ -> expectationFailure "Wrong request body constructor." - describe "ReqBodyLbs" - $ it "sets body to specified lazy byte string" - $ property - $ \lbs -> do - request <- req_ POST url (ReqBodyLbs lbs) mempty - case L.requestBody request of - L.RequestBodyLBS x -> x `shouldBe` lbs - _ -> expectationFailure "Wrong request body constructor." - describe "ReqBodyUrlEnc" - $ it "sets body to correct lazy byte string" - $ property - $ \params -> do - request <- req_ POST url (ReqBodyUrlEnc (formUrlEnc params)) mempty - case L.requestBody request of - L.RequestBodyLBS x -> x `shouldBe` renderQuery params - _ -> expectationFailure "Wrong request body constructor." + describe "ReqBodyJson" $ + it "sets body to correct lazy byte string" $ + property $ \thing -> do + request <- req_ POST url (ReqBodyJson thing) mempty + case L.requestBody request of + L.RequestBodyLBS x -> x `shouldBe` A.encode (thing :: Thing) + _ -> expectationFailure "Wrong request body constructor." + describe "ReqBodyBs" $ + it "sets body to specified strict byte string" $ + property $ \bs -> do + request <- req_ POST url (ReqBodyBs bs) mempty + case L.requestBody request of + L.RequestBodyBS x -> x `shouldBe` bs + _ -> expectationFailure "Wrong request body constructor." + describe "ReqBodyLbs" $ + it "sets body to specified lazy byte string" $ + property $ \lbs -> do + request <- req_ POST url (ReqBodyLbs lbs) mempty + case L.requestBody request of + L.RequestBodyLBS x -> x `shouldBe` lbs + _ -> expectationFailure "Wrong request body constructor." + describe "ReqBodyUrlEnc" $ + it "sets body to correct lazy byte string" $ + property $ \params -> do + request <- req_ POST url (ReqBodyUrlEnc (formUrlEnc params)) mempty + case L.requestBody request of + L.RequestBodyLBS x -> x `shouldBe` renderQuery params + _ -> expectationFailure "Wrong request body constructor." describe "optional parameters" $ do describe "header" $ do - it "sets specified header value" - $ property - $ \name value -> do + it "sets specified header value" $ + property $ \name value -> do request <- req_ GET url NoReqBody (header name value) lookup (CI.mk name) (L.requestHeaders request) `shouldBe` pure value - it "left header wins" - $ property - $ \name value0 value1 -> do + it "left header wins" $ + property $ \name value0 value1 -> do request <- req_ GET @@ -252,9 +253,8 @@ NoReqBody (header name value0 <> header name value1) lookup (CI.mk name) (L.requestHeaders request) `shouldBe` pure value0 - it "overwrites headers set by other parts of the lib" - $ property - $ \value -> do + it "overwrites headers set by other parts of the lib" $ + property $ \value -> do request <- req_ POST @@ -262,26 +262,23 @@ (ReqBodyUrlEnc mempty) (header "Content-Type" value) lookup "Content-Type" (L.requestHeaders request) `shouldBe` pure value - describe "cookieJar" - $ it "cookie jar is set without modifications" - $ property - $ \cjar -> do - request <- req_ GET url NoReqBody (cookieJar cjar) + describe "cookieJar" $ + it "cookie jar is set without modifications" $ + property $ \cjar -> do + request <- req_ GET url NoReqBody (cookieJar cjar) #if MIN_VERSION_http_client(0,7,0) - L.cookieJar request `shouldSatisfy` (maybe False (L.equalCookieJar cjar)) + L.cookieJar request `shouldSatisfy` (maybe False (L.equalCookieJar cjar)) #else - L.cookieJar request `shouldBe` Just cjar + L.cookieJar request `shouldBe` Just cjar #endif describe "basicAuth" $ do - it "sets Authorization header to correct value" - $ property - $ \username password -> do + it "sets Authorization header to correct value" $ + property $ \username password -> do request <- req_ GET url NoReqBody (basicAuth username password) lookup "Authorization" (L.requestHeaders request) `shouldBe` Just (basicAuthHeader username password) - it "overwrites manual setting of header" - $ property - $ \username password value -> do + it "overwrites manual setting of header" $ + property $ \username password value -> do request0 <- req_ GET @@ -297,9 +294,8 @@ let result = Just (basicAuthHeader username password) lookup "Authorization" (L.requestHeaders request0) `shouldBe` result lookup "Authorization" (L.requestHeaders request1) `shouldBe` result - it "left auth option wins" - $ property - $ \username0 password0 username1 password1 -> do + it "left auth option wins" $ + property $ \username0 password0 username1 password1 -> do request <- req_ GET @@ -309,15 +305,13 @@ lookup "Authorization" (L.requestHeaders request) `shouldBe` Just (basicAuthHeader username0 password0) describe "oAuth2Bearer" $ do - it "sets Authorization header to correct value" - $ property - $ \token -> do + it "sets Authorization header to correct value" $ + property $ \token -> do request <- req_ GET url NoReqBody (oAuth2Bearer token) lookup "Authorization" (L.requestHeaders request) `shouldBe` pure ("Bearer " <> token) - it "overwrites manual setting of header" - $ property - $ \token value -> do + it "overwrites manual setting of header" $ + property $ \token value -> do request0 <- req_ GET @@ -335,9 +329,8 @@ `shouldBe` pure result lookup "Authorization" (L.requestHeaders request1) `shouldBe` pure result - it "left auth option wins" - $ property - $ \token0 token1 -> do + it "left auth option wins" $ + property $ \token0 token1 -> do request <- req_ GET @@ -346,23 +339,20 @@ (oAuth2Bearer token0 <> oAuth2Bearer token1) lookup "Authorization" (L.requestHeaders request) `shouldBe` pure ("Bearer " <> token0) - describe "ProxyAuthorization" - $ it "sets Authorization header to correct value" - $ property - $ \username password -> do - request <- req_ GET url NoReqBody (basicProxyAuth username password) - lookup "Proxy-Authorization" (L.requestHeaders request) - `shouldBe` pure (basicProxyAuthHeader username password) + describe "ProxyAuthorization" $ + it "sets Authorization header to correct value" $ + property $ \username password -> do + request <- req_ GET url NoReqBody (basicProxyAuth username password) + lookup "Proxy-Authorization" (L.requestHeaders request) + `shouldBe` pure (basicProxyAuthHeader username password) describe "oAuth2Token" $ do - it "sets Authorization header to correct value" - $ property - $ \token -> do + it "sets Authorization header to correct value" $ + property $ \token -> do request <- req_ GET url NoReqBody (oAuth2Token token) lookup "Authorization" (L.requestHeaders request) `shouldBe` pure ("token " <> token) - it "overwrites manual setting of header" - $ property - $ \token value -> do + it "overwrites manual setting of header" $ + property $ \token value -> do request0 <- req_ GET @@ -380,9 +370,8 @@ `shouldBe` pure result lookup "Authorization" (L.requestHeaders request1) `shouldBe` pure result - it "left auth option wins" - $ property - $ \token0 token1 -> do + it "left auth option wins" $ + property $ \token0 token1 -> do request <- req_ GET @@ -391,27 +380,24 @@ (oAuth2Token token0 <> oAuth2Token token1) lookup "Authorization" (L.requestHeaders request) `shouldBe` pure ("token " <> token0) - describe "port" - $ it "sets port overwriting the defaults" - $ property - $ \n -> do - request <- req_ GET url NoReqBody (port n) - L.port request `shouldBe` n - describe "decompress" - $ it "sets decompress function overwriting the defaults" - $ property - $ \token -> do - request <- req_ GET url NoReqBody (decompress (/= token)) - L.decompress request token `shouldBe` False + describe "port" $ + it "sets port overwriting the defaults" $ + property $ \n -> do + request <- req_ GET url NoReqBody (port n) + L.port request `shouldBe` n + describe "decompress" $ + it "sets decompress function overwriting the defaults" $ + property $ \token -> do + request <- req_ GET url NoReqBody (decompress (/= token)) + L.decompress request token `shouldBe` False -- FIXME Can't really test responseTimeout right new because the -- ResponseTimeout data type does not implement Eq and its constructors -- are also not exported. Sent a PR. - describe "httpVersion" - $ it "sets HTTP version overwriting the defaults" - $ property - $ \major minor -> do - request <- req_ GET url NoReqBody (httpVersion major minor) - L.requestVersion request `shouldBe` Y.HttpVersion major minor + describe "httpVersion" $ + it "sets HTTP version overwriting the defaults" $ + property $ \major minor -> do + request <- req_ GET url NoReqBody (httpVersion major minor) + L.requestVersion request `shouldBe` Y.HttpVersion major minor describe "quasiquoter" $ do it "works for valid urls" $ @@ -422,9 +408,9 @@ forall a s. Typeable a => (a, Option s) -> Bool testTypeOfQuoterResult _ = isJust $ eqT @a @(Url 'Https) in property $ testTypeOfQuoterResult [urlQ|https://example.org/|] - it "doesn't work for invalid urls" - $ property - $ TH.runQ (TH.quoteExp urlQ "not a url") `shouldThrow` anyIOException + it "doesn't work for invalid urls" $ + property $ + TH.runQ (TH.quoteExp urlQ "not a url") `shouldThrow` anyIOException ---------------------------------------------------------------------------- -- Instances @@ -440,6 +426,7 @@ httpConfigCheckResponse _ _ _ = Nothing httpConfigRetryPolicy = retryPolicyDefault httpConfigRetryJudge _ _ = False + httpConfigRetryJudgeException _ _ = False return HttpConfig {..} instance Show HttpConfig where diff --git a/req.cabal b/req.cabal --- a/req.cabal +++ b/req.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: req -version: 3.3.0 +version: 3.4.0 license: BSD3 license-file: LICENSE.md maintainer: Mark Karpov @@ -44,6 +44,7 @@ bytestring >=0.10.8 && <0.11, case-insensitive >=0.2 && <1.3, connection >=0.2.2 && <0.4, + exceptions >=0.6 && <0.11, http-api-data >=0.2 && <0.5, http-client >=0.5 && <0.8, http-client-tls >=0.3.2 && <0.4, @@ -120,7 +121,7 @@ mtl >=2.0 && <3.0, req -any, text >=0.2 && <1.3, - unordered-containers >=0.2.5 && <0.2.11 + unordered-containers >=0.2.5 && <0.2.12 if flag(dev) ghc-options: -O0 -Wall -Werror