req 3.3.0 → 3.4.0
raw patch · 6 files changed
+288/−269 lines, 6 filesdep +exceptionsdep ~unordered-containers
Dependencies added: exceptions
Dependency ranges changed: unordered-containers
Files
- CHANGELOG.md +12/−0
- Network/HTTP/Req.hs +43/−10
- README.md +1/−1
- httpbin-tests/Network/HTTP/ReqSpec.hs +76/−90
- pure-tests/Network/HTTP/ReqSpec.hs +153/−166
- req.cabal +3/−2
CHANGELOG.md view
@@ -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`,
Network/HTTP/Req.hs view
@@ -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
README.md view
@@ -4,7 +4,7 @@ [](https://hackage.haskell.org/package/req) [](http://stackage.org/nightly/package/req) [](http://stackage.org/lts/package/req)-[](https://travis-ci.org/mrkkrp/req)+ * [Motivation and Req vs other libraries](#motivation-and-req-vs-other-libraries) * [Unsolved problems](#unsolved-problems)
httpbin-tests/Network/HTTP/ReqSpec.hs view
@@ -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
pure-tests/Network/HTTP/ReqSpec.hs view
@@ -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
req.cabal view
@@ -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 <markkarpov92@gmail.com>@@ -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