{-# LANGUAGE NumDecimals #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Network.HTTP.Client.BrReadWithTimeout
-- Copyright   :  (c) Alexey Radkov 2022
-- License     :  BSD-style
--
-- Maintainer  :  alexey.radkov@gmail.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Http client with timeouts applied in between body read events.
--
-- Note that the response timeout in /http-client/ is applied only when
-- receiving the response headers which is not always satisfactory given
-- that a slow server may send the rest of the response very slowly.
-----------------------------------------------------------------------------


module Network.HTTP.Client.BrReadWithTimeout (
                                              fromResponseTimeout
                                             ,brReadWithTimeout
                                             ,httpLbsBrReadWithTimeout
                                             ) where

import           Network.HTTP.Client hiding (HttpExceptionContent (..))
import qualified Network.HTTP.Client as E (HttpExceptionContent (..))
import qualified Network.HTTP.Client.Internal as I (ResponseTimeout (..)
                                                   ,mResponseTimeout
                                                   )
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as L
import           Control.Exception
import           System.Timeout

-- | Converts 'ResponseTimeout' of the request into the number of microseconds.
fromResponseTimeout :: Request -> Manager -> Int
fromResponseTimeout :: Request -> Manager -> Int
fromResponseTimeout Request
req Manager
man =
    case Request -> ResponseTimeout
responseTimeout Request
req of
        ResponseTimeout
I.ResponseTimeoutDefault ->
            case Manager -> ResponseTimeout
I.mResponseTimeout Manager
man of
                ResponseTimeout
I.ResponseTimeoutDefault -> Int
30e6
                ResponseTimeout
I.ResponseTimeoutNone -> -Int
1
                I.ResponseTimeoutMicro Int
u -> Int
u
        ResponseTimeout
I.ResponseTimeoutNone -> -Int
1
        I.ResponseTimeoutMicro Int
u -> Int
u

-- | Reads the next chunk of the response body with the specified timeout.
--
-- Note that 'brRead' and 'httpLbs' do not apply any timeouts after reading
-- response headers. This may hang the client if the server implementation is
-- buggy, for instance, when it sends a body of a lesser size than the value of
-- the /Content-Length/ response header. This function solves this problem by
-- applying a timeout passed in the first parameter as a number of microseconds
-- between body read events.
--
-- Throws 'E.ResponseTimeout' if reading of the next chunk of the response body
-- timed out.
brReadWithTimeout :: Int -> Request -> BodyReader -> IO ByteString
brReadWithTimeout :: Int -> Request -> BodyReader -> BodyReader
brReadWithTimeout Int
tmo Request
req BodyReader
br = do
    Maybe ByteString
x <- Int -> BodyReader -> IO (Maybe ByteString)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
tmo BodyReader
br
    case Maybe ByteString
x of
        Maybe ByteString
Nothing -> HttpException -> BodyReader
forall e a. Exception e => e -> IO a
throwIO (HttpException -> BodyReader) -> HttpException -> BodyReader
forall a b. (a -> b) -> a -> b
$ Request -> HttpExceptionContent -> HttpException
HttpExceptionRequest
            Request
req { responseTimeout :: ResponseTimeout
responseTimeout = Int -> ResponseTimeout
I.ResponseTimeoutMicro Int
tmo }
                HttpExceptionContent
E.ResponseTimeout
        Just ByteString
bs -> ByteString -> BodyReader
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs

-- | This is like 'httpLbs' but with a timeout between body read events.
--
-- The value of the timeout is retrieved from the 'ResponseTimeout' of the
-- request.
httpLbsBrReadWithTimeout :: Request -> Manager -> IO (Response L.ByteString)
httpLbsBrReadWithTimeout :: Request -> Manager -> IO (Response ByteString)
httpLbsBrReadWithTimeout Request
req Manager
man = Request
-> Manager
-> (Response BodyReader -> IO (Response ByteString))
-> IO (Response ByteString)
forall a.
Request -> Manager -> (Response BodyReader -> IO a) -> IO a
withResponse Request
req Manager
man ((Response BodyReader -> IO (Response ByteString))
 -> IO (Response ByteString))
-> (Response BodyReader -> IO (Response ByteString))
-> IO (Response ByteString)
forall a b. (a -> b) -> a -> b
$ \Response BodyReader
res -> do
    let tmo :: Int
tmo = Request -> Manager -> Int
fromResponseTimeout Request
req Manager
man
    [ByteString]
bss <- BodyReader -> IO [ByteString]
brConsume (BodyReader -> IO [ByteString]) -> BodyReader -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ Int -> Request -> BodyReader -> BodyReader
brReadWithTimeout Int
tmo Request
req (BodyReader -> BodyReader) -> BodyReader -> BodyReader
forall a b. (a -> b) -> a -> b
$ Response BodyReader -> BodyReader
forall body. Response body -> body
responseBody Response BodyReader
res
    Response ByteString -> IO (Response ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Response BodyReader
res { responseBody :: ByteString
responseBody = [ByteString] -> ByteString
L.fromChunks [ByteString]
bss }