http-conduit 1.8.5 → 1.8.5.1
raw patch · 3 files changed
+103/−96 lines, 3 filesdep ~warpPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: warp
API changes (from Hackage documentation)
Files
- Network/HTTP/Conduit/Request.hs +2/−2
- http-conduit.cabal +2/−2
- test/main.hs +99/−92
Network/HTTP/Conduit/Request.hs view
@@ -179,7 +179,7 @@ basic = S8.append "Basic " (B64.encode $ S8.concat [ user, ":", passwd ]) --- | Add a proxy to the the Request so that the Request when executed will use+-- | Add a proxy to the Request so that the Request when executed will use -- the provided proxy. addProxy :: S.ByteString -> Int -> Request m -> Request m addProxy hst prt req =@@ -187,7 +187,7 @@ -- FIXME add a helper for generating POST bodies --- | Add url-encoded paramters to the 'Request'.+-- | Add url-encoded parameters to the 'Request'. -- -- This sets a new 'requestBody', adds a content-type request header and -- changes the 'method' to POST.
http-conduit.cabal view
@@ -1,5 +1,5 @@ name: http-conduit-version: 1.8.5+version: 1.8.5.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -108,7 +108,7 @@ , time , network , wai- , warp >= 1.2.1+ , warp >= 1.3.6 , socks , http-types , cookie
test/main.hs view
@@ -7,25 +7,27 @@ import Test.HUnit import Network.Wai hiding (requestBody) import qualified Network.Wai as Wai-import Network.Wai.Handler.Warp (run)-import Network.HTTP.Conduit-import Data.ByteString.Base64 (encode)-import Control.Concurrent (forkIO, killThread, threadDelay)+import Network.Wai.Handler.Warp (runSettings, defaultSettings, settingsPort, settingsBeforeMainLoop)+import Network.HTTP.Conduit hiding (port)+import Control.Concurrent (forkIO, killThread, putMVar, takeMVar, newEmptyMVar) import Network.HTTP.Types-import Control.Exception.Lifted (try, SomeException)+import Control.Exception.Lifted (try, SomeException, bracket, onException, IOException)+import qualified Data.IORef as I import qualified Control.Exception as E (catch) import Network.HTTP.Conduit.ConnInfo import Network (withSocketsDo)+import Network.Socket (sClose) import CookieTest (cookieTest)-import Data.Conduit.Network (runTCPServer, serverSettings, HostPreference (HostAny), appSink, appSource)+import Data.Conduit.Network (runTCPServer, serverSettings, HostPreference (..), appSink, appSource, bindPort, serverAfterBind, ServerSettings)+import qualified Data.Conduit.Network+import System.IO.Unsafe (unsafePerformIO) import Data.Conduit (($$), yield, Flush (Chunk)) import Control.Monad (void, forever)-import Control.Monad.Trans.Resource (register) import Control.Monad.IO.Class (liftIO) import Data.ByteString.UTF8 (fromString) import Data.Conduit.List (sourceList) import Data.CaseInsensitive (mk)-import Data.List (partition, lookup)+import Data.List (partition) import qualified Data.Conduit.List as CL import qualified Data.Text as T import qualified Data.Text.Encoding as TE@@ -42,99 +44,102 @@ Just "flavor=chocolate-chip" -> responseLBS status200 [] "nom-nom-nom" _ -> responseLBS status412 [] "Baaaw where's my chocolate?" ["infredir", i'] ->- let i = read $ T.unpack i'+ let i = read $ T.unpack i' :: Int in return $ responseLBS status303 [(hLocation, S.append "/infredir/" $ S8.pack $ show $ i+1)] (L8.pack $ show i) ["infredirrepeat", i'] ->- let i = read $ T.unpack i'+ let i = read $ T.unpack i' :: Int in return $ responseLBS status303- [(hLocation, S.append "/infredirrepeat/" $ S8.pack $ show $ i+1)+ [(hLocation, S.append "/infredirrepeat/" $ S8.pack $ show $ i + 1) ,(hContentLength, "2048")] (L8.pack $ take 2048 $ unwords $ repeat $ show i) _ -> return $ responseLBS status404 [] "not found" where tastyCookie = (mk (fromString "Set-Cookie"), fromString "flavor=chocolate-chip;") +nextPort :: I.IORef Int+nextPort = unsafePerformIO $ I.newIORef 15452++getPort :: IO Int+getPort = do+ port <- I.atomicModifyIORef nextPort $ \p -> (p + 1, p)+ esocket <- try $ bindPort port HostIPv4+ case esocket of+ Left (_ :: IOException) -> getPort+ Right socket -> do+ sClose socket+ return port++withApp :: Application -> (Int -> IO ()) -> IO ()+withApp app' f = withApp' (const app') f++withApp' :: (Int -> Application) -> (Int -> IO ()) -> IO ()+withApp' app' f = do+ port <- getPort+ baton <- newEmptyMVar+ bracket+ (forkIO $ runSettings defaultSettings+ { settingsPort = port+ , settingsBeforeMainLoop = putMVar baton ()+ } (app' port) `onException` putMVar baton ())+ killThread+ (const $ takeMVar baton >> f port)+ main :: IO () main = withSocketsDo $ hspec $ do cookieTest describe "simpleHttp" $ do- it "gets homepage" $ do- tid <- forkIO $ run 13000 app- threadDelay 10000- lbs <- simpleHttp "http://127.0.0.1:13000/"- killThread tid+ it "gets homepage" $ withApp app $ \port -> do+ lbs <- simpleHttp $ "http://127.0.0.1:" ++ show port lbs @?= "homepage"- it "throws exception on 404" $ do- tid <- forkIO $ run 13001 app- threadDelay 10000- elbs <- try $ simpleHttp "http://127.0.0.1:13001/404"- killThread tid+ it "throws exception on 404" $ withApp app $ \port -> do+ elbs <- try $ simpleHttp $ concat ["http://127.0.0.1:", show port, "/404"] case elbs of Left (_ :: SomeException) -> return () Right _ -> error "Expected an exception" describe "httpLbs" $ do- it "preserves 'set-cookie' headers" $ do- tid <- forkIO $ run 13010 app- threadDelay 10000- request <- parseUrl "http://127.0.0.1:13010/cookies"+ it "preserves 'set-cookie' headers" $ withApp app $ \port -> do+ request <- parseUrl $ concat ["http://127.0.0.1:", show port, "/cookies"] withManager $ \manager -> do Response _ _ headers _ <- httpLbs request manager let setCookie = mk (fromString "Set-Cookie") (setCookieHeaders, _) = partition ((== setCookie) . fst) headers liftIO $ assertBool "response contains a 'set-cookie' header" $ length setCookieHeaders > 0- killThread tid- it "redirects set cookies" $ do- tid <- forkIO $ run 13010 app- request <- parseUrl "http://127.0.0.1:13010/cookie_redir1"+ it "redirects set cookies" $ withApp app $ \port -> do+ request <- parseUrl $ concat ["http://127.0.0.1:", show port, "/cookie_redir1"] withManager $ \manager -> do- _ <- register $ killThread tid Response _ _ _ body <- httpLbs request manager liftIO $ body @?= "nom-nom-nom" describe "manager" $ do- it "closes all connections" $ do+ it "closes all connections" $ withApp app $ \port1 -> withApp app $ \port2 -> do clearSocketsList- tid1 <- forkIO $ run 13002 app- tid2 <- forkIO $ run 13003 app- threadDelay 1000 withManager $ \manager -> do- let Just req1 = parseUrl "http://127.0.0.1:13002/"- let Just req2 = parseUrl "http://127.0.0.1:13003/"+ let Just req1 = parseUrl $ "http://127.0.0.1:" ++ show port1+ let Just req2 = parseUrl $ "http://127.0.0.1:" ++ show port2 _res1a <- http req1 manager _res1b <- http req1 manager _res2 <- http req2 manager return () requireAllSocketsClosed- killThread tid2- killThread tid1 describe "DOS protection" $ do- it "overlong headers" $ do- tid1 <- forkIO overLongHeaders- threadDelay 1000+ it "overlong headers" $ overLongHeaders $ \port -> do withManager $ \manager -> do- _ <- register $ killThread tid1- let Just req1 = parseUrl "http://127.0.0.1:13004/"+ let Just req1 = parseUrl $ "http://127.0.0.1:" ++ show port res1 <- try $ http req1 manager case res1 of Left e -> liftIO $ show (e :: SomeException) @?= show OverlongHeaders _ -> error "Shouldn't have worked"- it "not overlong headers" $ do- tid1 <- forkIO notOverLongHeaders- threadDelay 1000+ it "not overlong headers" $ notOverLongHeaders $ \port -> do withManager $ \manager -> do- _ <- register $ killThread tid1- let Just req1 = parseUrl "http://127.0.0.1:13005/"+ let Just req1 = parseUrl $ "http://127.0.0.1:" ++ show port _ <- httpLbs req1 manager return () describe "redirects" $ do- it "doesn't double escape" $ do- tid <- forkIO redir- threadDelay 1000000+ it "doesn't double escape" $ redir $ \port -> do withManager $ \manager -> do- _ <- register $ killThread tid let go (encoded, final) = do- let Just req1 = parseUrl $ "http://127.0.0.1:13006/redir/" ++ encoded+ let Just req1 = parseUrl $ concat ["http://127.0.0.1:", show port, "/redir/", encoded] res <- httpLbs req1 manager liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200 liftIO $ responseBody res @?= L.fromChunks [TE.encodeUtf8 final]@@ -145,22 +150,17 @@ , ("hello%20world", "hello world") , ("hello%20world%3f%23", "hello world?#") ]- it "TooManyRedirects: redirect request body is preserved" $ do- tid <- forkIO $ run 13009 app- let Just req = parseUrl "http://127.0.0.1:13009/infredir/0"+ it "TooManyRedirects: redirect request body is preserved" $ withApp app $ \port -> do+ let Just req = parseUrl $ concat ["http://127.0.0.1:", show port, "/infredir/0"] let go (res, i) = liftIO $ responseBody res @?= (L8.pack $ show i) E.catch (withManager $ \manager -> do- void $ register $ killThread tid void $ http req{redirectCount=5} manager) $- \(TooManyRedirects redirs) -> mapM_ go (zip redirs [5,4..0])+ \(TooManyRedirects redirs) -> mapM_ go (zip redirs [5,4..0 :: Int]) describe "chunked request body" $ do- it "works" $ do- tid <- forkIO echo- threadDelay 1000000+ it "works" $ echo $ \port -> do withManager $ \manager -> do- _ <- register $ killThread tid let go bss = do- let Just req1 = parseUrl "http://127.0.0.1:13007"+ let Just req1 = parseUrl $ "http://127.0.0.1:" ++ show port src = sourceList $ map fromByteString bss lbs = L.fromChunks bss res <- httpLbs req1@@ -175,12 +175,9 @@ , replicate 500 "foo\003\n\r" ] describe "no status message" $ do- it "works" $ do- tid <- forkIO noStatusMessage- threadDelay 1000000+ it "works" $ noStatusMessage $ \port -> do+ req <- parseUrl $ "http://127.0.0.1:" ++ show port withManager $ \manager -> do- _ <- register $ killThread tid- req <- parseUrl "http://127.0.0.1:13008" res <- httpLbs req manager liftIO $ do Network.HTTP.Conduit.responseStatus res `shouldBe` status200@@ -188,40 +185,50 @@ describe "redirect" $ do it "ignores large response bodies" $ do- tid <- forkIO $ run 13100 $ \req ->- case pathInfo req of- ["foo"] -> return $ responseLBS status200 [] "Hello World!"- _ -> return $ ResponseSource status301 [("location", "http://localhost:13100/foo")] $ forever $ yield $ Chunk $ fromByteString "hello\n"- threadDelay 1000000- withManager $ \manager -> do- _ <- register $ killThread tid- req <- parseUrl "http://127.0.0.1:13100"+ let app' port req =+ case pathInfo req of+ ["foo"] -> return $ responseLBS status200 [] "Hello World!"+ _ -> return $ ResponseSource status301 [("location", S8.pack $ "http://localhost:" ++ show port ++ "/foo")] $ forever $ yield $ Chunk $ fromByteString "hello\n"+ withApp' app' $ \port -> withManager $ \manager -> do+ req <- parseUrl $ "http://127.0.0.1:" ++ show port res <- httpLbs req manager liftIO $ do Network.HTTP.Conduit.responseStatus res `shouldBe` status200 responseBody res `shouldBe` "Hello World!" -overLongHeaders :: IO ()-overLongHeaders = runTCPServer (serverSettings 13004 HostAny) $ \app ->- src $$ appSink app+withCApp :: Data.Conduit.Network.Application IO -> (Int -> IO ()) -> IO ()+withCApp app' f = do+ port <- getPort+ baton <- newEmptyMVar+ let start = putMVar baton ()+ settings :: ServerSettings IO+ settings = (serverSettings port HostAny :: ServerSettings IO) { serverAfterBind = const start }+ bracket+ (forkIO $ runTCPServer settings app' `onException` start)+ killThread+ (const $ takeMVar baton >> f port)++overLongHeaders :: (Int -> IO ()) -> IO ()+overLongHeaders =+ withCApp $ \app' -> src $$ appSink app' where src = sourceList $ "HTTP/1.0 200 OK\r\nfoo: " : repeat "bar" -notOverLongHeaders :: IO ()-notOverLongHeaders = runTCPServer (serverSettings 13005 HostAny) $ \app -> do- appSource app $$ CL.drop 1- src $$ appSink app+notOverLongHeaders :: (Int -> IO ()) -> IO ()+notOverLongHeaders = withCApp $ \app' -> do+ appSource app' $$ CL.drop 1+ src $$ appSink app' where src = sourceList $ [S.concat $ "HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\nContent-Length: 16384\r\n\r\n" : ( take 16384 $ repeat "x")] -redir :: IO ()+redir :: (Int -> IO ()) -> IO () redir =- run 13006 redirApp+ withApp' redirApp where- redirApp req =+ redirApp port req = case pathInfo req of ["redir", foo] -> return $ responseLBS status301- [ ("Location", "http://127.0.0.1:13006/content/" `S.append` escape foo)+ [ ("Location", S8.pack (concat ["http://127.0.0.1:", show port, "/content/"]) `S.append` escape foo) ] "" ["content", foo] -> return $ responseLBS status200 [] $ L.fromChunks [TE.encodeUtf8 foo]@@ -248,13 +255,13 @@ | otherwise = error $ "Invalid argument to showHex: " ++ show x in ['%', showHex' b, showHex' c] -echo :: IO ()-echo = run 13007 $ \req -> do+echo :: (Int -> IO ()) -> IO ()+echo = withApp $ \req -> do bss <- Wai.requestBody req $$ CL.consume return $ responseLBS status200 [] $ L.fromChunks bss -noStatusMessage :: IO ()-noStatusMessage = runTCPServer (serverSettings 13008 HostAny) $ \app ->- src $$ appSink app+noStatusMessage :: (Int -> IO ()) -> IO ()+noStatusMessage =+ withCApp $ \app' -> src $$ appSink app' where src = yield "HTTP/1.0 200\r\nContent-Length: 3\r\n\r\nfoo: barbazbin"