http-client 0.4.7.1 → 0.4.7.2

raw patch · 5 files changed

+96/−4 lines, 5 filesdep +clockPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependencies added: clock

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• Network/HTTP/Client/Request.hs +1/−1
• Network/HTTP/Client/Response.hs +0/−2
• Network/HTTP/Client/Util.hs +89/−0
• http-client.cabal +2/−1

@@ -1,3 +1,7 @@+## 0.4.7.2++* Improved `timeout` implementation for high contention cases [#98](https://github.com/snoyberg/http-client/issues/98)+ ## 0.4.7.1  * Fix for shared connections in proxy servers [#103](https://github.com/snoyberg/http-client/issues/103)

@@ -49,10 +49,10 @@ import qualified Data.ByteString.Base64 as B64  import Network.HTTP.Client.Types+import Network.HTTP.Client.Util import Network.HTTP.Client.Connection  import Network.HTTP.Client.Util (readDec, (<>))-import System.Timeout (timeout) import Data.Time.Clock import Control.Monad.Catch (MonadThrow, throwM) import Data.IORef

@@ -27,8 +27,6 @@ import Network.HTTP.Client.Body import Network.HTTP.Client.Headers -import System.Timeout (timeout)- -- | If a request is a redirection (status code 3xx) this function will create -- a new request from the old request, the server headers returned with the -- redirection, and the redirection code itself. This function returns 'Nothing'

@@ -1,12 +1,18 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} module Network.HTTP.Client.Util     ( hGetSome     , (<>)     , readDec     , hasNoBody     , fromStrict+    , timeout+    , newTimeoutManager+    , TimeoutManager     ) where  import Data.Monoid (Monoid, mappend)@@ -21,7 +27,17 @@  import qualified Data.Text as T import qualified Data.Text.Read+--import System.Timeout (timeout) +import System.Clock+import System.IO.Unsafe (unsafePerformIO)+import Control.Exception (mask_, Exception, throwTo, try, finally, SomeException, assert)+import Control.Monad (join, when, void)+import Control.Concurrent (myThreadId, threadDelay, forkIO)+import Data.IORef+import Data.Function (fix)+import Data.Typeable (Typeable)+ #if MIN_VERSION_base(4,3,0) import Data.ByteString (hGetSome) #else@@ -82,3 +98,76 @@ fromStrict :: S.ByteString -> L.ByteString fromStrict x = L.fromChunks [x] #endif++data TimeoutHandler = TimeoutHandler {-# UNPACK #-} !TimeSpec (IO ())+newtype TimeoutManager = TimeoutManager (IORef ([TimeoutHandler], Bool))++newTimeoutManager :: IO TimeoutManager+newTimeoutManager = fmap TimeoutManager $ newIORef ([], False)++timeoutManager :: TimeoutManager+timeoutManager = unsafePerformIO newTimeoutManager+{-# NOINLINE timeoutManager #-}++spawnWorker :: TimeoutManager -> IO ()+spawnWorker (TimeoutManager ref) = void $ forkIO $ fix $ \loop -> do+    threadDelay 500000+    join $ atomicModifyIORef ref $ \(hs, isCleaning) -> assert (not isCleaning) $+        if null hs+            then (([], False), return ())+            else (([], True), ) $ do+                now <- getTime Monotonic+                front <- go now id hs+                atomicModifyIORef ref $ \(hs', isCleaning') ->+                    assert isCleaning' $ ((front hs', False), ())+                loop+  where+    go now =+        go'+      where+        go' front [] = return front+        go' front (h@(TimeoutHandler time action):hs)+            | time < now = do+                _ :: Either SomeException () <- try action+                go' front hs+            | otherwise = go' (front . (h:)) hs++addHandler :: TimeoutManager -> TimeoutHandler -> IO ()+addHandler man@(TimeoutManager ref) h = mask_ $ join $ atomicModifyIORef ref+    $ \(hs, isCleaning) ->+        let hs' = h : hs+            action+                | isCleaning || not (null hs) = return ()+                | otherwise = spawnWorker man+         in ((hs', isCleaning), action)++-- | Has same semantics as @System.Timeout.timeout@, but implemented in such a+-- way to avoid high-concurrency contention issues. See:+--+-- https://github.com/snoyberg/http-client/issues/98+timeout :: Int -> IO a -> IO (Maybe a)+timeout delayU inner = do+    TimeSpec nowS nowN <- getTime Monotonic+    let (delayS, delayU') = delayU `quotRem` 1000000+        delayN = delayU' * 1000+        stopN' = nowN + delayN+        stopS' = nowS + delayS+        (stopN, stopS)+            | stopN' > 1000000000 = (stopN' - 1000000000, stopS' + 1)+            | otherwise = (stopN', stopS')+        toStop = TimeSpec stopS stopN+    toThrow <- newIORef True+    tid <- myThreadId+    let handler = TimeoutHandler toStop $ do+            toThrow' <- readIORef toThrow+            when toThrow' $ throwTo tid TimeoutTriggered+    eres <- try $ do+        addHandler timeoutManager handler+        inner `finally` writeIORef toThrow False+    return $ case eres of+        Left TimeoutTriggered -> Nothing+        Right x -> Just x++data TimeoutTriggered = TimeoutTriggered+    deriving (Show, Typeable)+instance Exception TimeoutTriggered

@@ -1,5 +1,5 @@ name:                http-client-version:             0.4.7.1+version:             0.4.7.2 synopsis:            An HTTP client engine, intended as a base layer for more user-friendly packages. description:         Hackage documentation generation is not reliable. For up to date documentation, please see: <http://www.stackage.org/package/http-client>. homepage:            https://github.com/snoyberg/http-client@@ -52,6 +52,7 @@                      , filepath                      , mime-types                      , ghc-prim+                     , clock             >= 0.4.1.3   if flag(network-uri)     build-depends: network >= 2.6, network-uri >= 2.6   else