summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMichaelSnoyman <>2012-05-18 14:43:05 (GMT)
committerhdiff <hdiff@luite.com>2012-05-18 14:43:05 (GMT)
commit0eeff3d8b75f784c5c62c359a1c50c827a7fe413 (patch)
tree845b5a74f9b962df584e3047d97630c029bc406f
parent9769bd270608ea9aa2872c69a080d5d95f273133 (diff)
version 1.4.1.41.4.1.4
-rw-r--r--Network/HTTP/Conduit/Manager.hs29
-rw-r--r--http-conduit.cabal4
-rw-r--r--test/main.hs31
3 files changed, 58 insertions, 6 deletions
diff --git a/Network/HTTP/Conduit/Manager.hs b/Network/HTTP/Conduit/Manager.hs
index ae59e8b..8f29944 100644
--- a/Network/HTTP/Conduit/Manager.hs
+++ b/Network/HTTP/Conduit/Manager.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
module Network.HTTP.Conduit.Manager
( Manager
, ManagerSettings (..)
@@ -38,7 +39,8 @@ import Control.Monad.Trans.Resource
, MonadThrow, MonadUnsafeIO
)
import Control.Concurrent (forkIO, threadDelay)
-import Data.Time (UTCTime, getCurrentTime, addUTCTime)
+import Data.Time (UTCTime (..), Day (..), DiffTime, getCurrentTime, addUTCTime)
+import Control.DeepSeq (deepseq)
import Network (connectTo, PortID (PortNumber), HostName)
import Network.Socket (socketToHandle)
@@ -161,8 +163,8 @@ reap mapRef certCacheRef =
Nothing -> return () -- manager is closed
Just toDestroy -> do
mapM_ safeConnClose toDestroy
+ !() <- I.atomicModifyIORef certCacheRef $ \x -> let y = flushStaleCerts now x in y `seq` (y, ())
loop
- I.atomicModifyIORef certCacheRef $ \x -> (flushStaleCerts now x, ())
findStaleWrap _ Nothing = (Nothing, Nothing)
findStaleWrap isNotStale (Just m) =
let (x, y) = findStale isNotStale m
@@ -189,11 +191,32 @@ reap mapRef certCacheRef =
flushStaleCerts' (host', inner) =
case mapMaybe flushStaleCerts'' $ Map.toList inner of
[] -> Nothing
- pairs -> Just (host', Map.fromList $ take 10 pairs)
+ pairs ->
+ let x = take 10 pairs
+ in x `seqPairs` Just (host', Map.fromList x)
flushStaleCerts'' (certs, expires)
| expires > now = Just (certs, expires)
| otherwise = Nothing
+ seqPairs :: [(L.ByteString, UTCTime)] -> b -> b
+ seqPairs [] b = b
+ seqPairs (p:ps) b = p `seqPair` ps `seqPairs` b
+
+ seqPair :: (L.ByteString, UTCTime) -> b -> b
+ seqPair (lbs, utc) b = lbs `seqLBS` utc `seqUTC` b
+
+ seqLBS :: L.ByteString -> b -> b
+ seqLBS lbs b = L.length lbs `seq` b
+
+ seqUTC :: UTCTime -> b -> b
+ seqUTC (UTCTime day dt) b = day `seqDay` dt `seqDT` b
+
+ seqDay :: Day -> b -> b
+ seqDay (ModifiedJulianDay i) b = i `deepseq` b
+
+ seqDT :: DiffTime -> b -> b
+ seqDT = seq
+
neToList :: NonEmptyList a -> [(UTCTime, a)]
neToList (One a t) = [(t, a)]
neToList (Cons a _ t nelist) = (t, a) : neToList nelist
diff --git a/http-conduit.cabal b/http-conduit.cabal
index d8efbcd..f2ae8b3 100644
--- a/http-conduit.cabal
+++ b/http-conduit.cabal
@@ -1,5 +1,5 @@
name: http-conduit
-version: 1.4.1.3
+version: 1.4.1.4
license: BSD3
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@@ -105,7 +105,7 @@ test-suite test
, time
, network
, wai
- , warp
+ , warp >= 1.2.1
, socks
, http-types
, cookie
diff --git a/test/main.hs b/test/main.hs
index df5a4c8..b1f0017 100644
--- a/test/main.hs
+++ b/test/main.hs
@@ -5,7 +5,8 @@ import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Test.Hspec.HUnit ()
import Test.HUnit
-import Network.Wai
+import Network.Wai hiding (requestBody)
+import qualified Network.Wai
import Network.Wai.Handler.Warp (run)
import Network.HTTP.Conduit
import Control.Concurrent (forkIO, killThread, threadDelay)
@@ -24,6 +25,7 @@ import Data.List (partition)
import qualified Data.Conduit.List as CL
import qualified Data.Text.Encoding as TE
import qualified Data.ByteString.Lazy as L
+import Blaze.ByteString.Builder (fromByteString)
app :: Application
app req =
@@ -114,6 +116,28 @@ main = hspecX $ do
, ("hello%20world%3f%23", "hello world?#")
]
+ describe "chunked request body" $ do
+ it "works" $ do
+ tid <- forkIO echo
+ threadDelay 1000000
+ withManager $ \manager -> do
+ _ <- register $ killThread tid
+ let go bss = do
+ let Just req1 = parseUrl "http://127.0.0.1:3007"
+ src = sourceList $ map fromByteString bss
+ lbs = L.fromChunks bss
+ res <- httpLbs req1
+ { method = "POST"
+ , requestBody = RequestBodySourceChunked src
+ } manager
+ liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200
+ let ts = S.concat . L.toChunks
+ liftIO $ ts (responseBody res) @?= ts lbs
+ mapM_ go
+ [ ["hello", "world"]
+ , replicate 500 "foo\003\n\r"
+ ]
+
overLongHeaders :: IO ()
overLongHeaders = runTCPServer (ServerSettings 3004 HostAny) $ \_ sink ->
src $$ sink
@@ -160,3 +184,8 @@ redir =
| x < 16 = toEnum $ x - 10 + (fromEnum 'A')
| otherwise = error $ "Invalid argument to showHex: " ++ show x
in ['%', showHex' b, showHex' c]
+
+echo :: IO ()
+echo = run 3007 $ \req -> do
+ bss <- Network.Wai.requestBody req $$ CL.consume
+ return $ responseLBS status200 [] $ L.fromChunks bss