http-conduit 1.4.1.3 → 1.4.1.4
raw patch · 3 files changed
+58/−6 lines, 3 filesdep ~basedep ~warp
Dependency ranges changed: base, warp
Files
- Network/HTTP/Conduit/Manager.hs +26/−3
- http-conduit.cabal +2/−2
- test/main.hs +30/−1
Network/HTTP/Conduit/Manager.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-} module Network.HTTP.Conduit.Manager ( Manager , ManagerSettings (..)@@ -38,7 +39,8 @@ , 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 @@ 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,10 +191,31 @@ 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)]
http-conduit.cabal view
@@ -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 @@ , time , network , wai- , warp+ , warp >= 1.2.1 , socks , http-types , cookie
test/main.hs view
@@ -5,7 +5,8 @@ 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 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 @@ , ("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 @@ | 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