summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMichaelSnoyman <>2012-12-11 17:04:11 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2012-12-11 17:04:11 (GMT)
commit40d0b47eea4297721cd755f47d706e522684dd62 (patch)
treefb6898e45bbff74dd79585bfbe0561131ca3adba
parent22e161ee5683475798621f7fb0ad9b62886fdb36 (diff)
version 1.8.5.11.8.5.1
-rw-r--r--Network/HTTP/Conduit/Request.hs4
-rw-r--r--http-conduit.cabal4
-rw-r--r--test/main.hs191
3 files changed, 103 insertions, 96 deletions
diff --git a/Network/HTTP/Conduit/Request.hs b/Network/HTTP/Conduit/Request.hs
index be530d5..2d4a8a0 100644
--- a/Network/HTTP/Conduit/Request.hs
+++ b/Network/HTTP/Conduit/Request.hs
@@ -179,7 +179,7 @@ applyBasicAuth user passwd req =
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 @@ addProxy hst prt req =
-- 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.
diff --git a/http-conduit.cabal b/http-conduit.cabal
index 89c6c0a..e5fa97e 100644
--- a/http-conduit.cabal
+++ b/http-conduit.cabal
@@ -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 @@ test-suite test
, time
, network
, wai
- , warp >= 1.2.1
+ , warp >= 1.3.6
, socks
, http-types
, cookie
diff --git a/test/main.hs b/test/main.hs
index 9ea57af..4f8c4bc 100644
--- a/test/main.hs
+++ b/test/main.hs
@@ -7,25 +7,27 @@ import qualified Data.ByteString.Lazy.Char8 as L8
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 @@ app req =
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 @@ main = withSocketsDo $ hspec $ do
, ("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 @@ main = withSocketsDo $ hspec $ do
, 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 @@ main = withSocketsDo $ hspec $ do
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 @@ redir =
| 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"