diff --git a/Test/Request.hs b/Test/Request.hs index 1240676..94b74b0 100644 --- a/Test/Request.hs +++ b/Test/Request.hs @@ -59,8 +59,8 @@ mkTestRequestBS method scheme path mbody = mkTestRequest method scheme path $ HC mkTestRequest :: HT.Method -> UriScheme -> String -> Maybe HC.RequestBody -> IO HC.Request mkTestRequest method scheme path mbody = do let port = show $ case scheme of - Http -> httpTestPort - Https -> httpsTestPort + Http -> httpTestPort portsDef + Https -> httpsTestPort portsDef url = map toLower (show scheme) ++ "://localhost:" ++ port ++ path req <- HC.parseUrl url return $ req diff --git a/Test/ServerDef.hs b/Test/ServerDef.hs index 043008f..1df6dd5 100644 --- a/Test/ServerDef.hs +++ b/Test/ServerDef.hs @@ -1,10 +1,48 @@ -module Test.ServerDef where ------------------------------------------------------------ -- Copyright : Erik de Castro Lopo -- License : BSD3 ------------------------------------------------------------ -httpTestPort, httpsTestPort, testProxyPort :: Int -httpTestPort = 31080 -httpsTestPort = 31443 -testProxyPort = 31088 +module Test.ServerDef + ( PortsDef (..) + , portsDef + ) where + +import Data.List (sort) +import System.IO.Unsafe (unsafePerformIO) +import System.Random + +data PortsDef = PortsDef + { httpTestPort :: Int + , httpsTestPort :: Int + , proxyTestPort :: Int + } + deriving Show + + +-- Yeah, yeah, unsafePerformIO! Worst thing that can happen is that the tests +-- fail. +portsDef :: PortsDef +portsDef = unsafePerformIO getPortsDef + + +-- Grab three unique Ints in the range (30000, 60000) and stick them in a +-- PortsDef constructor. +getPortsDef :: IO PortsDef +getPortsDef = do + vals <- randomRL [] + case sort vals of + [a, b, c] -> return $ PortsDef a b c + _ -> getPortsDef + where + randomRL :: [Int] -> IO [Int] + randomRL xs + | length xs == 3 = return $ sort xs + | otherwise = do + x <- randomRIO portRange + if x `elem` xs + then randomRL xs + else randomRL (x:xs) + +portRange :: (Int, Int) +portRange = (30000, 60000) diff --git a/Test/TestServer.hs b/Test/TestServer.hs index e1b2c9d..32662f3 100644 --- a/Test/TestServer.hs +++ b/Test/TestServer.hs @@ -39,12 +39,12 @@ import Test.Util runTestServer :: IO () runTestServer = - let settings = setPort httpTestPort $ setHost "*6" defaultSettings + let settings = setPort (httpTestPort portsDef) $ setHost "*6" defaultSettings in catchAny (runSettings settings serverApp) print runTestServerTLS :: IO () runTestServerTLS = - let settings = setPort httpsTestPort $ setHost "*6" defaultSettings + let settings = setPort (httpsTestPort portsDef) $ setHost "*6" defaultSettings tlsSettings' = tlsSettings "Test/certificate.pem" "Test/key.pem" in catchAny (runTLS tlsSettings' settings serverApp) print diff --git a/Test/Util.hs b/Test/Util.hs index 08d786e..c485222 100644 --- a/Test/Util.hs +++ b/Test/Util.hs @@ -123,7 +123,7 @@ compareResult (Result secure sa ha ba) (Result _ sb hb bb) = do testSingleUrl :: Bool -> HC.Request -> IO () testSingleUrl debug request = do direct <- httpRun request - proxy <- httpRun $ HC.addProxy "localhost" testProxyPort request + proxy <- httpRun $ HC.addProxy "localhost" (proxyTestPort portsDef) request when debug $ do printResult direct printResult proxy diff --git a/Test/testsuite.hs b/Test/testsuite.hs index 03c11ad..90def4b 100644 --- a/Test/testsuite.hs +++ b/Test/testsuite.hs @@ -137,5 +137,5 @@ withProxy settings = around_ $ defaultProxySettings :: Settings defaultProxySettings = defaultSettings { proxyHost = "*6" - , proxyPort = testProxyPort + , proxyPort = proxyTestPort portsDef } diff --git a/http-proxy.cabal b/http-proxy.cabal index 1cbaf6f..777bb15 100644 --- a/http-proxy.cabal +++ b/http-proxy.cabal @@ -69,6 +69,7 @@ Test-Suite testsuite , http-conduit , http-types , hspec >= 2.1 + , random >= 1.1 , resourcet , wai , wai-conduit diff --git a/test/proxy-test.hs b/test/proxy-test.hs deleted file mode 100644 index 69c6c22..0000000 --- a/test/proxy-test.hs +++ /dev/null @@ -1,212 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - ---------------------------------------------------------- --- --- Copyright (c) Erik de Castro Lopo --- License : BSD3 --- ---------------------------------------------------------- - -import Blaze.ByteString.Builder -import Network.HTTP.Proxy - -import Control.Applicative ((<$>)) -import Control.Concurrent (forkIO, killThread) -import Control.Concurrent.Async -import Control.Monad (unless, when) -import Data.ByteString.Lex.Integral (readDecimal_) -import Data.Char (isSpace) -import Data.Conduit (($$)) -import Data.Int (Int64) -import Data.Maybe (fromMaybe) - -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as LBS -import qualified Data.Conduit as DC -import qualified Data.Conduit.Binary as CB -import qualified Network.HTTP.Conduit as HC -import qualified Network.HTTP.Types as HT - -import Test.TestServer -import Test.HttpHttpsRewriteTest -import Test.Util - - -hugeLen :: Int64 -hugeLen = 8 * 1000 * 1000 * 1000 - - -debug :: Bool -debug = False - - -main :: IO () -main = do - basicTest - warpTlsTest - httpsConnectTest - httpToHttpsRewriteTest - streamingTest - - -basicTest :: IO () -basicTest = do - printTestMsgR "Basic tests" - withTestServerAndProxy httpTestPort testProxySettings $ do - mapM_ (testSingleUrl debug) tests - printPassR - where - testProxySettings = defaultSettings - { proxyHost = "*6" - , proxyPort = testProxyPort - } - tests = - [ ( HT.methodGet, "http://localhost:" ++ show httpTestPort ++ "/", Nothing ) - , ( HT.methodPost, "http://localhost:" ++ show httpTestPort ++ "/", Nothing ) - , ( HT.methodPost, "http://localhost:" ++ show httpTestPort ++ "/", Just "Message\n" ) - , ( HT.methodGet, "http://localhost:" ++ show httpTestPort ++ "/forbidden", Nothing ) - ] - --------------------------------------------------------------------------------- - -streamingTest :: IO () -streamingTest = - withTestServerAndProxy httpTestPort testProxySettings $ do - streamingGetTest 1000 $ "http://localhost:" ++ show httpTestPort - streamingPostTest 1000 $ "http://localhost:" ++ show httpTestPort ++ "/large-post" - streamingGetTest hugeLen $ "http://localhost:" ++ show httpTestPort - streamingPostTest hugeLen $ "http://localhost:" ++ show httpTestPort ++ "/large-post" - printPassR - where - testProxySettings = Network.HTTP.Proxy.defaultSettings - { proxyHost = "*6" - , proxyPort = testProxyPort - } - - -streamingGetTest :: Int64 -> String -> IO () -streamingGetTest size url = do - operationSizeMsgR "GET " size - request <- - (\r -> r { HC.checkStatus = \ _ _ _ -> Nothing }) - <$> HC.parseUrl (url ++ "/large-get?" ++ show size) - httpCheckGetBodySize $ HC.addProxy "localhost" testProxyPort request - printPassR - - -httpCheckGetBodySize :: HC.Request -> IO () -httpCheckGetBodySize req = HC.withManager $ \mgr -> do - resp <- HC.http req mgr - let (st, hdrs, bdyR) = (HC.responseStatus resp, HC.responseHeaders resp, HC.responseBody resp) - when (st /= HT.status200) $ - error $ "httpCheckGetBodySize : Bad status code : " ++ show st - let contentLength = readDecimal_ $ fromMaybe "0" $ lookup "content-length" hdrs - when (contentLength == (0 :: Int64)) $ - error "httpCheckGetBodySize : content-length is zero." - (bdy, finalizer) <- DC.unwrapResumable bdyR - bdy $$ byteSink contentLength - finalizer - --------------------------------------------------------------------------------- - -streamingPostTest :: Int64 -> String -> IO () -streamingPostTest size url = do - operationSizeMsgR "POST" size - request <- - (\r -> r { HC.method = "POST" - , HC.requestBody = requestBodySource size - -- Disable expecptions for non-2XX status codes. - , HC.checkStatus = \ _ _ _ -> Nothing - }) - <$> HC.parseUrl url - httpCheckPostResponse size $ HC.addProxy "localhost" testProxyPort request - printPassR - -httpCheckPostResponse :: Int64 -> HC.Request -> IO () -httpCheckPostResponse postLen req = HC.withManager $ \mgr -> do - resp <- HC.http req mgr - let (st, bodyR) = (HC.responseStatus resp, HC.responseBody resp) - when (st /= HT.status200) $ - error $ "httpCheckGetBodySize : Bad status code : " ++ show st - (bdy, finalizer) <- DC.unwrapResumable bodyR - bodyText <- bdy $$ CB.take 1024 - finalizer - let len = case BS.split ':' (BS.concat (LBS.toChunks bodyText)) of - ["Post-size", size] -> readDecimal_ $ BS.dropWhile isSpace size - _ -> error "httpCheckPostResponse : Not able to read Post-size." - when (len /= postLen) $ - error $ "httpCheckPostResponse : Post length " ++ show len ++ " should have been " ++ show postLen ++ "." - --------------------------------------------------------------------------------- - -requestBodySource :: Int64 -> HC.RequestBody -requestBodySource len = - error "requestBoddySource" len $ loop 0 - -- HC.RequestBodyStream len $ loop 0 - where - loop :: Int64 -> DC.Source IO Builder - loop count - | count >= len = return () - | len - count > blockSize64 = do - DC.yield bbytes - loop $ count + blockSize64 - | otherwise = do - let n = fromIntegral $ len - count - DC.yield $ fromByteString $ BS.take n bsbytes - return () - - blockSize = 4096 - blockSize64 = fromIntegral blockSize :: Int64 - bsbytes = BS.replicate blockSize '?' - bbytes = fromByteString bsbytes - - --------------------------------------------------------------------------------- - -warpTlsTest :: IO () -warpTlsTest = do - printTestMsgR "Test Warp with TLS" - th <- forkIO $ runTestServerTLS httpTestPort - let url = "https://localhost:" ++ show httpTestPort ++ "/" - request <- HC.parseUrl url - direct@(Result _ _ hdrs _) <- httpRun request - let isWarp = - case lookup "server" hdrs of - Just s -> BS.isPrefixOf "Warp" s - Nothing -> False - unless isWarp $ error "No 'Server: Warp' header." - when debug $ printResult direct - killThread th - printPassR - - -httpsConnectTest :: IO () -httpsConnectTest = do - printTestMsgR "HTTPS CONNECT test" - withTestServerAndProxy httpsTestPort testProxySettings $ - mapM_ (testSingleUrl debug) tests - printPassR - where - testProxySettings = defaultSettings - { proxyHost = "*6" - , proxyPort = testProxyPort - } - tests = - [ ( HT.methodGet, "https://localhost:" ++ show httpTestPort ++ "/", Nothing ) - , ( HT.methodPost, "https://localhost:" ++ show httpTestPort ++ "/", Nothing ) - , ( HT.methodPost, "https://localhost:" ++ show httpTestPort ++ "/", Just "Message\n" ) - , ( HT.methodGet, "https://localhost:" ++ show httpTestPort ++ "/forbidden", Nothing ) - ] - -withTestServerAndProxy :: Int -> Settings -> IO a -> IO a -withTestServerAndProxy port testProxySettings action = - withAsync (runTestServer port) $ \ async1 -> - withAsync (runTestProxy testProxySettings) $ \ async2 -> do - res <- action - cancel async1 - cancel async2 - return res - - -runTestProxy :: Settings -> IO () -runTestProxy settings = catchAny (runProxySettings settings) print