Merge 6ed8715 into 9c79ac4

Network/HTTP/Req.hs

@@ -88,6 +88,7 @@
 -- machinery for performing requests is the same as with @http-conduit@ and
 -- @wreq@. The only difference is the API.
 
+{-# LANGUAGE BangPatterns               #-}
 {-# LANGUAGE CPP                        #-}
 {-# LANGUAGE DataKinds                  #-}
 {-# LANGUAGE DeriveDataTypeable         #-}
@@ -214,7 +215,6 @@ where
 
 import Control.Applicative
 import Control.Arrow (first, second)
-import Control.Exception (Exception, try, handle, throwIO)
 import Control.Monad
 import Control.Monad.Base
 import Control.Monad.IO.Class
@@ -256,8 +256,10 @@ import qualified Network.HTTP.Types           as Y
 import qualified Web.Authenticate.OAuth       as OAuth
 
 #if MIN_VERSION_base(4,9,0)
+import Control.Exception hiding (TypeError)
 import Data.Kind (Constraint)
 #else
+import Control.Exception
 import GHC.Exts (Constraint)
 #endif
 
@@ -406,13 +408,25 @@ req
   -> m response        -- ^ Response
 req method url body Proxy options = req' method url body options $ \request manager -> do
   HttpConfig {..}  <- getHttpConfig
-  let wrappingVanilla = handle (throwIO . VanillaHttpException)
-      wrapExc         = handle (throwIO . LI.toHttpException request)
-  (liftIO . try . wrappingVanilla . wrapExc) (do
-    response <- retrying httpConfigRetryPolicy httpConfigRetryJudge
-      (const $ getHttpResponse request manager)
-    httpConfigCheckResponse request response
-    return response)
+  let wrapVanilla = handle (throwIO . VanillaHttpException)
+      wrapExc     = handle (throwIO . LI.toHttpException request)
+      withRRef    = bracket
+        (newIORef Nothing)
+        (readIORef >=> mapM_ L.responseClose)
+  (liftIO . try . wrapVanilla . wrapExc) (withRRef $ \rref -> do
+    let openResponse = mask_ $ do
+          r  <- readIORef rref
+          mapM_ L.responseClose r
+          r' <- L.responseOpen request manager
+          writeIORef rref (Just r')
+          return r'
+    r <- retrying
+      httpConfigRetryPolicy
+      (\st r -> return $ httpConfigRetryJudge st r)
+      (const openResponse)
+    (preview, getResponse) <- getHttpResponse r
+    mapM_ LI.throwHttp (httpConfigCheckResponse request r preview)
+    getResponse)
     >>= either handleHttpException return
 
 -- | Mostly like 'req' with respect to its arguments, but accepts a callback
@@ -526,37 +540,60 @@ class MonadIO m => MonadHttp m where
 -- making HTTP requests.
 
 data HttpConfig = HttpConfig
-  { httpConfigProxy         :: Maybe L.Proxy
+  { httpConfigProxy :: Maybe L.Proxy
     -- ^ Proxy to use. By default values of @HTTP_PROXY@ and @HTTPS_PROXY@
     -- environment variables are respected, this setting overwrites them.
     -- Default value: 'Nothing'.
   , httpConfigRedirectCount :: Int
     -- ^ How many redirects to follow when getting a resource. Default
     -- value: 10.
-  , httpConfigAltManager    :: Maybe L.Manager
+  , httpConfigAltManager :: Maybe L.Manager
     -- ^ Alternative 'L.Manager' to use. 'Nothing' (default value) means
     -- that the default implicit manager will be used (that's what you want
     -- in 99% of cases).
-  , httpConfigCheckResponse :: forall r. HttpResponse r => L.Request -> r -> IO ()
+  , httpConfigCheckResponse
+    :: forall b.
+       L.Request
+    -> L.Response b
+    -> ByteString
+    -> Maybe L.HttpExceptionContent
     -- ^ Function to check the response immediately after receiving the
-    -- status and headers. This is used for throwing exceptions on
-    -- non-success status codes by default (set to @\\_ _ -> return ()@ if
-    -- this behavior is not desirable). Throwing is better then just
-    -- returning a request with non-2xx status code because in that case
-    -- something is wrong and we need a way to short-cut execution. The
-    -- thrown exception is caught by the library though and is available in
-    -- 'handleHttpException'.
+    -- status and headers, before streaming of response body. The third
+    -- argument is the beginning of response body (typically first 1024
+    -- bytes). This is used for throwing exceptions on non-success status
+    -- codes by default (set to @\\_ _ _ -> Nothing@ if this behavior is not
+    -- desirable).
+    --
+    -- When the value this function returns is 'Nothing', nothing will
+    -- happen. When it there is 'L.HttpExceptionContent' inside 'Just', it
+    -- will be thrown.
+    --
+    -- Throwing is better then just returning a request with non-2xx status
+    -- code because in that case something is wrong and we need a way to
+    -- short-cut execution (also remember that Req retries automatically on
+    -- request timeouts and such, so when your request fails, it's certainly
+    -- something exceptional). The thrown exception is caught by the library
+    -- though and is available in 'handleHttpException'.
+    --
+    -- __Note__: signature of this function was changed in the version
+    -- /1.0.0/.
     --
     -- @since 0.3.0
-  , httpConfigRetryPolicy :: RetryPolicyM IO
+  , httpConfigRetryPolicy :: RetryPolicy
     -- ^ The retry policy to use for request retrying. By default 'def' is
     -- used (see 'RetryPolicyM').
     --
+    -- __Note__: signature of this function was changed in the version
+    -- /1.0.0/.
+    --
     -- @since 0.3.0
-  , httpConfigRetryJudge :: forall r. HttpResponse r => RetryStatus -> r -> IO Bool
+  , httpConfigRetryJudge :: forall b. RetryStatus -> L.Response b -> Bool
     -- ^ The function is used to decide whether to retry a request. 'True'
     -- means that the request should be retried.
     --
+    -- __Note__: signature of this function was changed in the version
+    -- /1.0.0/.
+    --
     -- @since 0.3.0
   } deriving Typeable
 
@@ -565,22 +602,23 @@ instance Default HttpConfig where
     { httpConfigProxy         = Nothing
     , httpConfigRedirectCount = 10
     , httpConfigAltManager    = Nothing
-    , httpConfigCheckResponse = \_ response ->
-        let statusCode = responseStatusCode response in
-          unless (200 <= statusCode && statusCode < 300) $
-            let chunk = makeResponseBodyPreview response
-                vresponse = toVanillaResponse response
-            in LI.throwHttp (L.StatusCodeException (void vresponse) chunk)
+    , httpConfigCheckResponse = \_ response preview ->
+        let scode = statusCode response
+        in if 200 <= scode && scode < 300
+             then Nothing
+             else Just (L.StatusCodeException (void response) preview)
     , httpConfigRetryPolicy  = def
-    , httpConfigRetryJudge   = \_ r -> return $
-        responseStatusCode r `elem`
+    , httpConfigRetryJudge   = \_ response ->
+        statusCode response `elem`
           [ 408 -- Request timeout
           , 504 -- Gateway timeout
           , 524 -- A timeout occurred
           , 598 -- (Informal convention) Network read timeout error
           , 599 -- (Informal convention) Network connect timeout error
           ]
     }
+    where
+      statusCode = Y.statusCode . L.responseStatus
 
 instance RequestComponent HttpConfig where
   getRequestMod HttpConfig {..} = Endo $ \x ->
@@ -1338,14 +1376,14 @@ httpVersion major minor = withRequest $ \x ->
 
 -- | Make a request and ignore the body of the response.
 
-data IgnoreResponse = IgnoreResponse (L.Response ())
+newtype IgnoreResponse = IgnoreResponse (L.Response ())
 
 instance HttpResponse IgnoreResponse where
   type HttpResponseBody IgnoreResponse = ()
-  toVanillaResponse (IgnoreResponse response) = response
-  getHttpResponse request manager =
-    IgnoreResponse <$> liftIO (L.httpNoBody request manager)
-  makeResponseBodyPreview _ = "<ignored response>"
+  toVanillaResponse (IgnoreResponse r) = r
+  getHttpResponse r = do
+    (preview, _, _) <- brReadN (L.responseBody r) bodyPreviewLength
+    return (preview, return $ IgnoreResponse (void r))
 
 -- | Use this as the fourth argument of 'req' to specify that you want it to
 -- ignore the response body.
@@ -1358,23 +1396,16 @@ ignoreResponse = Proxy
 -- monad in which you use 'req' will determine what to do in the case when
 -- parsing fails (the 'JsonHttpException' constructor will be used).
 
-data JsonResponse a = JsonResponse (L.Response a) ByteString
+newtype JsonResponse a = JsonResponse (L.Response a)
 
 instance FromJSON a => HttpResponse (JsonResponse a) where
   type HttpResponseBody (JsonResponse a) = a
-  toVanillaResponse (JsonResponse response _) = response
-  getHttpResponse request manager = do
-    response <- L.httpLbs request manager
-    case A.eitherDecode (L.responseBody response) of
-      Left e -> throwIO (JsonHttpException e)
-      Right x -> do
-        let preview
-              = BL.toStrict
-              . BL.take bodyPreviewLength
-              . L.responseBody
-              $ response
-        return $ JsonResponse response { L.responseBody = x } preview
-  makeResponseBodyPreview (JsonResponse _ preview) = preview
+  toVanillaResponse (JsonResponse r) = r
+  getHttpResponse = withPreview $ \r -> do
+    let chunks = L.responseBody r
+    case A.eitherDecode (BL.fromChunks chunks) of
+      Left  e -> throwIO (JsonHttpException e)
+      Right x -> return (JsonResponse r { L.responseBody = x })
 
 -- | Use this as the fourth argument of 'req' to specify that you want it to
 -- return the 'JsonResponse' interpretation.
@@ -1389,11 +1420,10 @@ newtype BsResponse = BsResponse (L.Response ByteString)
 
 instance HttpResponse BsResponse where
   type HttpResponseBody BsResponse = ByteString
-  toVanillaResponse (BsResponse response) = response
-  getHttpResponse request manager =
-    BsResponse <$> httpBs request manager
-  makeResponseBodyPreview =
-    B.take bodyPreviewLength . responseBody
+  toVanillaResponse (BsResponse r) = r
+  getHttpResponse = withPreview $ \r -> do
+    let chunks = L.responseBody r
+    return (BsResponse r { L.responseBody = B.concat chunks })
 
 -- | Use this as the fourth argument of 'req' to specify that you want to
 -- interpret the response body as a strict 'ByteString'.
@@ -1408,25 +1438,70 @@ newtype LbsResponse = LbsResponse (L.Response BL.ByteString)
 
 instance HttpResponse LbsResponse where
   type HttpResponseBody LbsResponse = BL.ByteString
-  toVanillaResponse (LbsResponse response) = response
-  getHttpResponse request manager =
-    LbsResponse <$> L.httpLbs request manager
-  makeResponseBodyPreview =
-    BL.toStrict . BL.take bodyPreviewLength . responseBody
+  toVanillaResponse (LbsResponse r) = r
+  getHttpResponse = withPreview $ \r -> do
+    let chunks = L.responseBody r
+    return (LbsResponse r { L.responseBody = BL.fromChunks chunks })
 
 -- | Use this as the fourth argument of 'req' to specify that you want to
 -- interpret the response body as a lazy 'BL.ByteString'.
 
 lbsResponse :: Proxy LbsResponse
 lbsResponse = Proxy
 
--- | Perform a 'L.Request' using given 'L.Manager' and return the response
--- as a strict 'ByteString'.
-
-httpBs :: L.Request -> L.Manager -> IO (L.Response ByteString)
-httpBs request manager = L.withResponse request manager $ \response -> do
-  chunks <- L.brConsume (L.responseBody response)
-  return response { L.responseBody = B.concat chunks }
+----------------------------------------------------------------------------
+-- Helpers for response interpretations
+
+-- | A helper that is useful for implementing the 'getHttpResponse' method
+-- of the 'HttpResponse' type class.
+
+withPreview
+  :: (L.Response [ByteString] -> IO r)
+     -- ^ How to transform a response with response body chunks inside into
+     -- the final result
+  -> L.Response L.BodyReader
+     -- ^ Response with body reader inside
+  -> IO (ByteString, IO r)
+     -- ^ Preview 'ByteString' and action that consumes the whole response
+     -- body and produces the actual result
+withPreview f r = do
+  let br = L.responseBody r
+  (target, leftover, done) <- brReadN br bodyPreviewLength
+  let consume = do
+        chunks <-
+          if done
+            then return [target,leftover]
+            else do
+              xs <- L.brConsume br
+              return (target:leftover:xs)
+        f (r { L.responseBody = chunks })
+  return (target, consume)
+
+-- | Consume N bytes from 'L.BodyReader', return the target chunk and the
+-- leftover (may be empty), and whether we're done consuming the body.
+
+brReadN
+  :: L.BodyReader
+     -- ^ Body reader to stream from
+  -> Int
+     -- ^ How many bytes to consume
+  -> IO (ByteString, ByteString, Bool)
+     -- ^ Target chunk, the leftover, whether we're done
+brReadN br n = go 0 id id
+  where
+    go !tlen t l = do
+      chunk <- br
+      if B.null chunk
+        then return (r t, r l, True)
+        else do
+          let (target, leftover) = B.splitAt (n - tlen) chunk
+              tlen'              = B.length target
+              t'                 = t . (target:)
+              l'                 = l . (leftover:)
+          if tlen + tlen' < n
+            then go (tlen + tlen') t' l'
+            else return (r t', r l', False)
+    r f = B.concat (f [])
 
 ----------------------------------------------------------------------------
 -- Inspecting a response
@@ -1497,21 +1572,31 @@ class HttpResponse response where
 
   toVanillaResponse :: response -> L.Response (HttpResponseBody response)
 
-  -- | This method describes how to make an HTTP request given 'L.Request'
-  -- (prepared by the library) and 'L.Manager'.
-
-  getHttpResponse :: L.Request -> L.Manager -> IO response
-
-  -- | Construct a “preview” of response body. It is recommend to limit the
-  -- length to 1024 bytes. This is mainly used for inclusion of response
-  -- body fragments in exceptions.
+  -- | This method describes how to consume response body and, more
+  -- generally, obtain @response@ value from @'L.Response' 'L.BodyReader'@
+  -- as well as a preview of the body in the form of plain 'ByteString'. The
+  -- recommended length of the preview 'ByteString' is 1024 bytes.
   --
-  -- __Note__: in versions 0.3.0–0.4.0 this function returned @'IO'
-  -- 'ByteString'@.
+  -- A good implementation should consume just enough bytes to put together
+  -- the preview string without streaming the entire response body. The
+  -- action returned as the second component of the tuple should perform
+  -- full streaming and produce the final result.
   --
-  -- @since 0.5.0
-
-  makeResponseBodyPreview :: response -> ByteString
+  -- __Note__: 'L.BodyReader' is nothing but @'IO' 'ByteString'@. You should
+  -- call this action repeatedly until it yields the empty 'ByteString'. In
+  -- that case streaming of response is finished and you can concatenate the
+  -- chunks to obtain the final result. (Of course you could as well stream
+  -- the contents to a file or do whatever you want.)
+  --
+  -- __Note__: signature of this function was changed in the version
+  -- /1.0.0/.
+
+  getHttpResponse
+    :: L.Response L.BodyReader
+       -- ^ Response with body reader inside
+    -> IO (ByteString, IO response)
+       -- ^ Preview 'ByteString' and the action that produces the whole
+       -- @response@
 
 ----------------------------------------------------------------------------
 -- Other