@@ -96,6 +96,7 @@
9696{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9797{-# LANGUAGE KindSignatures #-}
9898{-# LANGUAGE OverloadedStrings #-}
99+{-# LANGUAGE RankNTypes #-}
99100{-# LANGUAGE RecordWildCards #-}
100101{-# LANGUAGE ScopedTypeVariables #-}
101102{-# LANGUAGE TypeFamilies #-}
@@ -116,6 +117,7 @@ module Network.HTTP.Req
116117 ( -- * Making a request
117118 -- $making-a-request
118119 req
120+ , req'
119121 , withReqManager
120122 -- * Embedding requests into your monad
121123 -- $embedding-requests
@@ -191,15 +193,12 @@ module Network.HTTP.Req
191193 , bsResponse
192194 , LbsResponse
193195 , lbsResponse
194− , ReturnRequest
195− , returnRequest
196196 -- ** Inspecting a response
197197 , responseBody
198198 , responseStatusCode
199199 , responseStatusMessage
200200 , responseHeader
201201 , responseCookieJar
202− , responseRequest
203202 -- ** Defining your own interpretation
204203 -- $new-response-interpretation
205204 , HttpResponse (..)
@@ -211,9 +210,10 @@ where
211210
212211import Control.Applicative
213212import Control.Arrow (first, second)
214−import Control.Exception (Exception, try, catch, throwIO)
213+import Control.Exception (Exception, try, handle, throwIO)
215214import Control.Monad
216215import Control.Monad.IO.Class
216+import Control.Retry
217217import Data.Aeson (ToJSON (..), FromJSON (..))
218218import Data.ByteString (ByteString)
219219import Data.Data (Data)
@@ -285,10 +285,8 @@ import GHC.Exts (Constraint)
285285-- * 'jsonResponse'
286286-- * 'bsResponse' (to get a strict 'ByteString')
287287-- * 'lbsResponse' (to get a lazy 'BL.ByteString')
288−-- * 'returnRequest' (makes no request, but returns the constructed
289−-- request itself, used for testing).
290288--
291−-- Finally @options@ is a 'Monoid' that holds a composite 'Option' for all
289+-- Finally, @options@ is a 'Monoid' that holds a composite 'Option' for all
292290-- other optional settings like query parameters, headers, non-standard port
293291-- number, etc. There are quite a few things you can put there, see the
294292-- corresponding section in the documentation. If you don't need anything at
@@ -388,8 +386,7 @@ import GHC.Exts (Constraint)
388386-- > print (responseBody response :: Value)
389387
390388req
391− :: forall m method body response scheme.
392− ( MonadHttp m
389+ :: ( MonadHttp m
393390 , HttpMethod method
394391 , HttpBody body
395392 , HttpResponse response
@@ -400,8 +397,40 @@ req
400397 -> Proxy response -- ^ A hint how to interpret response
401398 -> Option scheme -- ^ Collection of optional parameters
402399 -> m response -- ^ Response
403−req method url body Proxy options = do
404− config <- getHttpConfig
400+req method url body Proxy options = req' method url body options $ \request manager -> do
401+ HttpConfig {..} <- getHttpConfig
402+ let wrappingVanilla = handle (throwIO . VanillaHttpException)
403+ wrapExc = handle (throwIO . LI.toHttpException request)
404+ (liftIO . try . wrappingVanilla . wrapExc) (do
405+ response <- retrying httpConfigRetryPolicy httpConfigRetryJudge
406+ (const $ getHttpResponse request manager)
407+ httpConfigCheckResponse request response
408+ return response)
409+ >>= either handleHttpException return
410+
411+-- | Mostly like 'req' with respect to its arguments, but accepts a callback
412+-- that allows to perform a request in arbitrary fashion.
413+--
414+-- This function /does not/ perform handling\/wrapping exceptions, checking
415+-- response, and retrying. It only prepares 'L.Request' and allows you to
416+-- use it.
417+--
418+-- @since 0.3.0
419+
420+req'
421+ :: forall m method body scheme a.
422+ ( MonadHttp m
423+ , HttpMethod method
424+ , HttpBody body
425+ , HttpBodyAllowed (AllowsBody method) (ProvidesBody body) )
426+ => method -- ^ HTTP method
427+ -> Url scheme -- ^ 'Url'—location of resource
428+ -> body -- ^ Body of the request
429+ -> Option scheme -- ^ Collection of optional parameters
430+ -> (L.Request -> L.Manager -> m a) -- ^ How to perform request
431+ -> m a
432+req' method url body options m = do
433+ config@HttpConfig {..} <- getHttpConfig
405434 manager <- liftIO (readIORef globalManager)
406435 let -- NOTE First appearance of any given header wins. This allows to
407436 -- “overwrite” headers when we construct a request by cons-ing.
@@ -419,10 +448,8 @@ req method url body Proxy options = do
419448 getRequestMod (Womb body :: Womb "body" body) <>
420449 getRequestMod url <>
421450 getRequestMod (Womb method :: Womb "method" method)
422− wrappingVanilla m = catch m (throwIO . VanillaHttpException)
423451 request <- finalizeRequest options request'
424− (liftIO . try . wrappingVanilla) (getHttpResponse request manager)
425− >>= either handleHttpException return
452+ m request manager
426453
427454-- | Global 'L.Manager' that 'req' uses. Here we just go with the default
428455-- settings, so users don't need to deal with this manager stuff at all, but
@@ -470,8 +497,6 @@ withReqManager m = liftIO (readIORef globalManager) >>= m
470497
471498class MonadIO m => MonadHttp m where
472499
473− {-# MINIMAL handleHttpException #-}
474−
475500 -- | This method describes how to deal with 'HttpException' that was
476501 -- caught by the library. One option is to re-throw it if you are OK with
477502 -- exceptions, but if you prefer working with something like
@@ -505,7 +530,7 @@ data HttpConfig = HttpConfig
505530 -- ^ Alternative 'L.Manager' to use. 'Nothing' (default value) means
506531 -- that default implicit manager will be used (that's what you want in
507532 -- 99% of cases).
508− , httpConfigCheckResponse :: L.Request -> L.Response L.BodyReader -> IO ()
533+ , httpConfigCheckResponse :: forall r. HttpResponse r => L.Request -> r -> IO ()
509534 -- ^ Function to check the response immediately after receiving the
510535 -- status and headers. This is used for throwing exceptions on
511536 -- non-success status codes by default (set to @\\_ _ -> return ()@ if
@@ -514,6 +539,18 @@ data HttpConfig = HttpConfig
514539 -- something is wrong and we need a way to short-cut execution. The
515540 -- thrown exception is caught by the library though and is available in
516541 -- 'handleHttpException'.
542+ --
543+ -- @since 0.3.0
544+ , httpConfigRetryPolicy :: RetryPolicyM IO
545+ -- ^ The retry policy to use for request retrying. By default 'def' is
546+ -- used (see 'RetryPolicyM').
547+ --
548+ -- @since 0.3.0
549+ , httpConfigRetryJudge :: forall r. HttpResponse r => RetryStatus -> r -> IO Bool
550+ -- ^ The function is used to decide whether to retry a request. 'True'
551+ -- means that the request should be retried.
552+ --
553+ -- @since 0.3.0
517554 } deriving Typeable
518555
519556instance Default HttpConfig where
@@ -522,17 +559,27 @@ instance Default HttpConfig where
522559 , httpConfigRedirectCount = 10
523560 , httpConfigAltManager = Nothing
524561 , httpConfigCheckResponse = \_ response ->
525− let Y.Status statusCode _ = L.responseStatus response in
562+ let statusCode = responseStatusCode response in
526563 unless (200 <= statusCode && statusCode < 300) $ do
527− chunk <- BL.toStrict <$> L.brReadSome (L.responseBody response) 1024
528− LI.throwHttp (L.StatusCodeException (void response) chunk) }
564+ chunk <- makeResponseBodyPreview response
565+ let vresponse = toVanillaResponse response
566+ LI.throwHttp (L.StatusCodeException (void vresponse) chunk)
567+ , httpConfigRetryPolicy = def
568+ , httpConfigRetryJudge = \_ r -> return $
569+ responseStatusCode r `elem`
570+ [ 408 -- Request timeout
571+ , 504 -- Gateway timeout
572+ , 524 -- A timeout occurred
573+ , 598 -- (Informal convention) Network read timeout error
574+ , 599 -- (Informal convention) Network connect timeout error
575+ ]
576+ }
529577
530578instance RequestComponent HttpConfig where
531579 getRequestMod HttpConfig {..} = Endo $ \x ->
532580 x { L.proxy = httpConfigProxy
533581 , L.redirectCount = httpConfigRedirectCount
534− , LI.requestManagerOverride = httpConfigAltManager
535− , LI.checkResponse = httpConfigCheckResponse }
582+ , LI.requestManagerOverride = httpConfigAltManager }
536583
537584----------------------------------------------------------------------------
538585-- Request—Method
@@ -1243,6 +1290,7 @@ instance HttpResponse IgnoreResponse where
12431290 toVanillaResponse (IgnoreResponse response) = response
12441291 getHttpResponse request manager =
12451292 IgnoreResponse <$> liftIO (L.httpNoBody request manager)
1293+ makeResponseBodyPreview _ = return "<ignored response>"
12461294
12471295-- | Use this as the fourth argument of 'req' to specify that you want it to
12481296-- return the 'IgnoreResponse' interpretation.
@@ -1255,16 +1303,23 @@ ignoreResponse = Proxy
12551303-- monad in which you use 'req' will determine what to do in the case when
12561304-- parsing fails (the 'JsonHttpException' constructor will be used).
12571305
1258−newtype JsonResponse a = JsonResponse (L.Response a)
1306+data JsonResponse a = JsonResponse (L.Response a) ByteString
12591307
12601308instance FromJSON a => HttpResponse (JsonResponse a) where
12611309 type HttpResponseBody (JsonResponse a) = a
1262− toVanillaResponse (JsonResponse response) = response
1310+ toVanillaResponse (JsonResponse response _) = response
12631311 getHttpResponse request manager = do
12641312 response <- L.httpLbs request manager
12651313 case A.eitherDecode (L.responseBody response) of
12661314 Left e -> throwIO (JsonHttpException e)
1267− Right x -> return $ JsonResponse response { L.responseBody = x }
1315+ Right x -> do
1316+ let preview
1317+ = BL.toStrict
1318+ . BL.take bodyPreviewLength
1319+ . L.responseBody
1320+ $ response
1321+ return $ JsonResponse response { L.responseBody = x } preview
1322+ makeResponseBodyPreview (JsonResponse _ preview) = return preview
12681323
12691324-- | Use this as the forth argument of 'req' to specify that you want it to
12701325-- return the 'JsonResponse' interpretation.
@@ -1283,6 +1338,7 @@ instance HttpResponse BsResponse where
12831338 L.withResponse request manager $ \response -> do
12841339 chunks <- L.brConsume (L.responseBody response)
12851340 return $ BsResponse response { L.responseBody = B.concat chunks }
1341+ makeResponseBodyPreview = return . B.take bodyPreviewLength . responseBody
12861342
12871343-- | Use this as the forth argument of 'req' to specify that you want to
12881344-- interpret response body as a strict 'ByteString'.
@@ -1300,6 +1356,7 @@ instance HttpResponse LbsResponse where
13001356 toVanillaResponse (LbsResponse response) = response
13011357 getHttpResponse request manager =
13021358 LbsResponse <$> L.httpLbs request manager
1359+ makeResponseBodyPreview = return . BL.toStrict . BL.take 1027 . responseBody
13031360
13041361-- | Use this as the forth argument of 'req' to specify that you want to
13051362-- interpret response body as a lazy 'BL.ByteString'.
@@ -1307,27 +1364,6 @@ instance HttpResponse LbsResponse where
13071364lbsResponse :: Proxy LbsResponse
13081365lbsResponse = Proxy
13091366
1310−-- | This interpretation does not result in any request at all, but you can
1311−-- use the 'responseRequest' function to extract 'L.Request' that 'req' has
1312−-- prepared. This is useful primarily for testing.
1313−--
1314−-- Note that when you use this interpretation inspecting response will
1315−-- diverge (i.e. it'll blow up with an error, don't do that).
1316−
1317−newtype ReturnRequest = ReturnRequest L.Request
1318−
1319−instance HttpResponse ReturnRequest where
1320− type HttpResponseBody ReturnRequest = ()
1321− toVanillaResponse (ReturnRequest _) = error
1322− "Network.HTTP.Req.ReturnRequest interpretation does not make requests"
1323− getHttpResponse request _ = return (ReturnRequest request)
1324−
1325−-- | Use this as the forth argument of 'req' to specify that you want it to
1326−-- just return the request it consturcted without making any requests.
1327−
1328−returnRequest :: Proxy ReturnRequest
1329−returnRequest = Proxy
1330−
13311367----------------------------------------------------------------------------
13321368-- Inspecting a response
13331369
@@ -1375,11 +1411,6 @@ responseCookieJar
13751411 -> L.CookieJar
13761412responseCookieJar = L.responseCookieJar . toVanillaResponse
13771413
1378−-- | Get the original request from 'ReturnRequest' response interpretation.
1379−
1380−responseRequest :: ReturnRequest -> L.Request
1381−responseRequest (ReturnRequest request) = request
1382−
13831414----------------------------------------------------------------------------
13841415-- Response—Defining your own interpretation
13851416
@@ -1407,6 +1438,14 @@ class HttpResponse response where
14071438
14081439 getHttpResponse :: L.Request -> L.Manager -> IO response
14091440
1441+ -- | Construct a “preview” of response body. It is recommend to limit the
1442+ -- length to 1024 bytes. This is mainly useful for inclusion of response
1443+ -- body fragments in exceptions.
1444+ --
1445+ -- @since 0.3.0
1446+
1447+ makeResponseBodyPreview :: response -> IO ByteString
1448+
14101449----------------------------------------------------------------------------
14111450-- Other
14121451
@@ -1464,3 +1503,11 @@ data Scheme
14641503 = Http -- ^ HTTP
14651504 | Https -- ^ HTTPS
14661505 deriving (Eq, Ord, Show, Data, Typeable, Generic)
1506+
1507+----------------------------------------------------------------------------
1508+-- Constants
1509+
1510+-- | Max length of preview fragment of response body.
1511+
1512+bodyPreviewLength :: Num a => a
1513+bodyPreviewLength = 1024