diff --git a/Network/HTTP/Proxy.hs b/Network/HTTP/Proxy.hs --- a/Network/HTTP/Proxy.hs +++ b/Network/HTTP/Proxy.hs @@ -32,6 +32,7 @@ , UpstreamProxy (..) , httpProxyApp + , warpSettings , runProxy , runProxySettings @@ -105,7 +106,7 @@ , proxyHost :: HostPreference -- ^ Default value: HostIPv4 , proxyOnException :: SomeException -> Wai.Response -- ^ What to do with exceptions thrown by either the application or server. Default: ignore server-generated exceptions (see 'InvalidRequest') and print application-generated applications to stderr. , proxyTimeout :: Int -- ^ Timeout value in seconds. Default value: 30 - , proxyRequestModifier :: Request -> IO (Either Response Request) -- ^ A function that allows the the request to be modified before being run. Default: 'return . Right'. + , proxyRequestModifier :: Request -> IO (Either Response Request) -- ^ A function that allows the request to be modified before being run. Default: 'return . Right'. , proxyLogger :: ByteString -> IO () -- ^ A function for logging proxy internal state. Default: 'return ()'. , proxyUpstream :: Maybe UpstreamProxy -- ^ Optional upstream proxy. } @@ -173,7 +174,9 @@ HC.requestBodySourceChunkedIO (sourceRequestBody mwreq) Wai.KnownLength l -> HC.requestBodySourceIO (fromIntegral l) (sourceRequestBody mwreq) - , HC.decompress = const True + -- Do not touch response body. Otherwise there may be discrepancy + -- between response headers and the response content. + , HC.decompress = const False } handle (respond . errorResponse) $ HC.withResponse hreq mgr $ \res -> do diff --git a/Test/Gen.hs b/Test/Gen.hs deleted file mode 100644 --- a/Test/Gen.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------- --- Copyright : Ambiata Pty Ltd --- Author : Sharif Olorin --- License : BSD3 ------------------------------------------------------------- - -module Test.Gen - ( genWaiRequest - ) where - -import Control.Applicative -import Data.ByteString.Char8 (ByteString) -import Data.CaseInsensitive (CI) -import Data.List (intersperse) -import Data.Monoid ((<>)) -import Network.HTTP.Types -import Network.Socket (SockAddr (..), PortNumber) -import Test.QuickCheck - -import qualified Data.ByteString.Char8 as BS -import qualified Data.CaseInsensitive as CI -import qualified Data.Text.Encoding as T -import qualified Data.Vault.Lazy as Vault -import qualified Network.Wai.Internal as Wai - -genWaiRequest :: Gen Wai.Request -genWaiRequest = do - method <- genHttpMethod - version <- genHttpVersion - pathList <- listOf genAscii - secure <- elements [ False, True ] - query <- genQuery - port <- genPort - sockAddr <- SockAddrInet port <$> arbitrary - host <- genHostname - headers <- genHeaderList - (bodylen, body) <- genRequestBody - return $ Wai.Request method version - (BS.concat $ "/" : intersperse "/" pathList) - (renderQueryBS query) - headers secure sockAddr - (map T.decodeUtf8 pathList) - query - (return body) -- requestBody - Vault.empty - bodylen -- requestBodyLength - (Just host) -- requestHeaderHost - Nothing -- requestHeaderRange - Nothing -- requestHeaderReferer - Nothing -- requestHeaderUserAgent - - -genRequestBody :: Gen (Wai.RequestBodyLength, ByteString) -genRequestBody = - let mkResult body = (Wai.KnownLength (fromIntegral $ BS.length body), body) - in mkResult <$> genAscii - - -genHttpMethod :: Gen ByteString -genHttpMethod = elements - [ "GET", "POST", "HEAD", "PUT", "DELETE", "TRACE", "CONNECT" - , "OPTIONS", "PATCH" - ] - -genHttpVersion :: Gen HttpVersion -genHttpVersion = elements [ http09, http10, http11 ] - -genHostname :: Gen ByteString -genHostname = BS.intercalate "." <$> listOf1 genAscii - -genPort :: Gen PortNumber -genPort = fromIntegral <$> arbitrary `suchThat` (\x -> x > 1024 && x < (65536 :: Int)) - -genHeaderList :: Gen [Header] -genHeaderList = listOf genHeader - -genHeader :: Gen Header -genHeader = (,) <$> genHeaderName <*> genAscii - -genHeaderName :: Gen (CI ByteString) -genHeaderName = CI.mk <$> genAscii - -renderQueryBS :: Query -> ByteString -renderQueryBS [] = "" -renderQueryBS ql = - let mkPair (name, value) = name <> maybe "" ("=" <>) value - in "?" <> BS.intercalate "&" (map mkPair ql) - -genQuery :: Gen Query -genQuery = listOf genQueryItem - -genQueryItem :: Gen QueryItem -genQueryItem = (,) <$> genAscii <*> oneof [Just <$> genAscii, pure Nothing] - -genAscii :: Gen ByteString -genAscii = BS.pack <$> do - srange <- choose (3, 10) - vectorOf srange $ oneof [choose ('a', 'z'), choose ('0', '9')] diff --git a/Test/Request.hs b/Test/Request.hs deleted file mode 100644 --- a/Test/Request.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------- --- Copyright (c) Erik de Castro Lopo --- License : BSD3 ------------------------------------------------------------- - -module Test.Request - ( UriScheme (..) - , mkGetRequest - , mkGetRequestWithBody - , mkPostRequest - , mkPostRequestBS - , mkPostRequestBody - ) where - -import Control.Applicative -import Data.ByteString (ByteString) -import Data.Char -import Data.Maybe - -import qualified Network.HTTP.Client as HC -import qualified Network.HTTP.Types as HT - -import Test.ServerDef - - -data UriScheme - = Http | Https - -instance Show UriScheme where - show Http = "HTTP" - show Https = "HTTPS" - - -mkGetRequest :: UriScheme -> String -> IO HC.Request -mkGetRequest scheme path = mkTestRequest get scheme path Nothing - - -mkGetRequestWithBody :: UriScheme -> String -> ByteString -> IO HC.Request -mkGetRequestWithBody scheme path body = mkTestRequestBS get scheme path (Just body) - - -mkPostRequest :: UriScheme -> String -> IO HC.Request -mkPostRequest scheme path = mkTestRequest post scheme path Nothing - - -mkPostRequestBS :: UriScheme -> String -> ByteString -> IO HC.Request -mkPostRequestBS scheme path body = mkTestRequestBS post scheme path (Just body) - - -mkPostRequestBody :: UriScheme -> String -> HC.RequestBody -> IO HC.Request -mkPostRequestBody scheme path body = mkTestRequest post scheme path (Just body) - - -mkTestRequestBS :: HT.Method -> UriScheme -> String -> Maybe ByteString -> IO HC.Request -mkTestRequestBS method scheme path mbody = mkTestRequest method scheme path $ HC.RequestBodyBS <$> mbody - - -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 portsDef - Https -> httpsTestPort portsDef - url = map toLower (show scheme) ++ "://localhost:" ++ port ++ path - req <- HC.parseRequest url - return $ req - { HC.method = if HC.method req /= method then method else HC.method req - , HC.requestBody = fromMaybe (HC.requestBody req) mbody - } - - -get, post :: HT.Method -get = HT.methodGet -post = HT.methodPost - diff --git a/Test/ServerDef.hs b/Test/ServerDef.hs deleted file mode 100644 --- a/Test/ServerDef.hs +++ /dev/null @@ -1,48 +0,0 @@ ------------------------------------------------------------- --- Copyright : Erik de Castro Lopo --- License : BSD3 ------------------------------------------------------------- - -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 - } - deriving Show - - --- Yeah, yeah, unsafePerformIO! Worst thing that can happen is that the tests --- fail. -{-# NOINLINE portsDef #-} -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] -> return $ PortsDef a b - _ -> getPortsDef - where - randomRL :: [Int] -> IO [Int] - randomRL xs - | length xs == 2 = 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 deleted file mode 100644 --- a/Test/TestServer.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------- --- Copyright : Erik de Castro Lopo --- License : BSD3 ------------------------------------------------------------- - -module Test.TestServer - ( runTestServer - , runTestServerTLS - ) where - -import Control.Applicative -import Data.ByteString (ByteString) -import Data.List (sort) -import Data.Monoid -import Data.String -import Network.HTTP.Types -import Network.Wai -import Network.Wai.Conduit -import Network.Wai.Handler.Warp -import Network.Wai.Handler.WarpTLS - -import Data.ByteString.Lex.Integral (readDecimal_) -import Data.Conduit (($$)) -import Data.Int (Int64) - -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as LBS -import qualified Data.Conduit as DC - -import qualified Network.HTTP.Proxy.Request as HPR - -import Test.ServerDef -import Test.Util - - -runTestServer :: IO () -runTestServer = - let settings = setPort (httpTestPort portsDef) $ setHost "*6" defaultSettings - in catchAny (runSettings settings serverApp) print - -runTestServerTLS :: IO () -runTestServerTLS = - let settings = setPort (httpsTestPort portsDef) $ setHost "*6" defaultSettings - tlsSettings' = tlsSettings "Test/certificate.pem" "Test/key.pem" - in catchAny (runTLS tlsSettings' settings serverApp) print - --------------------------------------------------------------------------------- - -serverApp :: Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived -serverApp req respond - | rawPathInfo req == "/forbidden" = - respond $ simpleResponse status403 "This is the forbidden message.\n" - - | rawPathInfo req == "/301" = do - let respHeaders = [ (hLocation, "http://other-server" <> rawPathInfo req) ] - respond $ responseLBS status301 respHeaders mempty - - | rawPathInfo req == "/large-get" = do - let len = readDecimal_ $ BS.drop 1 $ rawQueryString req - let respHeaders = - [ (hContentType, "text/plain") - , (hContentLength, fromString $ show len) - ] - respond . responseSource status200 respHeaders $ builderSource len - - | rawPathInfo req == "/secure" = do - let body = "Using SSL: " <> BS.pack (show $ isSecure req) - let respHeaders = - [ (hContentType, "text/plain") - , (hContentLength, fromString . show $ BS.length body) - ] - respond $ responseBS status200 respHeaders body - - | rawPathInfo req == "/large-post" && requestMethod req == "POST" = do - let len = maybe 0 readDecimal_ (lookup "content-length" $ requestHeaders req) :: Int64 - if len == 0 - then respond $ simpleResponse status400 "Error : POST Content-Length was either missing or zero.\n" - else respond =<< largePostCheck len (sourceRequestBody req) - - | otherwise = do - let text = "This is the not-found message.\n\n" : responseBody req - respHeaders = [ (hContentType, "text/plain") ] - respond . responseLBS status404 respHeaders $ LBS.fromChunks text - - -responseBody :: Request -> [ByteString] -responseBody req = - [ " Method : " , requestMethod req , "\n" - , " HTTP Version : " , fromString (show (httpVersion req)) , "\n" - , " Path Info : " , rawPathInfo req , "\n" - , " Query String : " , rawQueryString req , "\n" - , " Server : " , HPR.waiRequestHost req , "\n" - , " Secure (SSL) : " , fromString (show (isSecure req)), "\n" - , " Request Headers :\n" - , headerShow (sort $ requestHeaders req) - , "\n" - ] - - -largePostCheck :: Int64 -> DC.Source IO ByteString -> IO Response -largePostCheck len rbody = - maybe success failure <$> (rbody $$ byteSink len) - where - success = simpleResponse status200 . BS.pack $ "Post-size: " ++ show len - failure = simpleResponse status500 diff --git a/Test/Util.hs b/Test/Util.hs deleted file mode 100644 --- a/Test/Util.hs +++ /dev/null @@ -1,232 +0,0 @@ -{-# LANGUAGE BangPatterns, OverloadedStrings #-} ------------------------------------------------------------- --- Copyright : Erik de Castro Lopo --- License : BSD3 ------------------------------------------------------------- - -module Test.Util where - -import Blaze.ByteString.Builder -import Control.Applicative -import Control.Concurrent.Async -import Control.Exception hiding (assert) -import Control.Monad (forM_, when, unless) -import Control.Monad.Trans.Resource -import Data.ByteString (ByteString) -import Data.Int (Int64) -import Data.Maybe -import Data.String (fromString) -import Network.Socket -import Network.Connection - -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as LBS -import qualified Data.CaseInsensitive as CI -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 qualified Network.Wai as Wai - -import Network.HTTP.Proxy.Request - - -dumpWaiRequest :: Wai.Request -> IO () -dumpWaiRequest req = - mapM_ BS.putStrLn - [ "------- Wai Request --------------------------------------------------------------" - , "Method : " , Wai.requestMethod req - , "HTTP Version : " , fromString (show (Wai.httpVersion req)) - , "Path Info : " , Wai.rawPathInfo req - , "Query String : " , Wai.rawQueryString req - , "Server : " , waiRequestHost req - , "Secure (SSL) : " , fromString (show (Wai.isSecure req)) - , "Remote Host : " , fromString (show (Wai.remoteHost req)) - , "Request Headers :" - , headerShow (Wai.requestHeaders req) - ] - - -dumpHttpConduitRequest :: HC.Request -> IO () -dumpHttpConduitRequest req = - mapM_ BS.putStrLn - [ "------- HttpConduit Request ------------------------------------------------------" - , "Method : " , HC.method req - , "Secure (SSL) : " , fromString (show (HC.secure req)) - , "Host Name : " , HC.host req - , "Host Port : " , fromString (show (HC.port req)) - , "Path : " , HC.path req - , "Query String : " , HT.urlDecode False (HC.queryString req) - , "Request Headers :" - , headerShow (HC.requestHeaders req) - ] - - -dumpHttpResponse :: HT.Status -> HT.ResponseHeaders -> IO () -dumpHttpResponse s rh = do - mapM_ BS.putStrLn - [ "------- Response from upsteam ----------------------------------------------------" - , "HTTP/1.0 ", BS.pack (show (HT.statusCode s)), " ", HT.statusMessage s - ] - BS.putStr . BS.concat $ map (\ (f, v) -> BS.concat [ " ", CI.original f, ": ", v, "\n" ]) rh - - -headerShow :: [HT.Header] -> ByteString -headerShow headers = - BS.concat $ map hdrShow headers - where - hdrShow (f, v) = BS.concat [ " ", CI.original f , ": " , v, "\n" ] - - --------------------------------------------------------------------------------- - -simpleResponse :: HT.Status -> ByteString -> Wai.Response -simpleResponse status text = do - let respHeaders = - [ (HT.hContentType, "text/plain") - , (HT.hContentLength, fromString . show $ BS.length text) - ] - responseBS status respHeaders text - - -responseBS :: HT.Status -> HT.ResponseHeaders -> ByteString -> Wai.Response -responseBS status headers text = - Wai.responseLBS status headers$ LBS.fromChunks [text] - --------------------------------------------------------------------------------- - -data Result = Result - { resultSecure :: Bool - , resultStatus :: Int - , resultHeaders :: [HT.Header] - , resultBS :: ByteString - } - - -printResult :: Result -> IO () -printResult (Result _ status headers body) = do - putStrLn $ "Response status : " ++ show status - putStrLn "Response headers :" - BS.putStr $ headerShow headers - putStrLn "Response body :" - BS.putStrLn body - --------------------------------------------------------------------------------- - --- | Compare results and error out if they're different. -compareResult :: Result -> Result -> IO () -compareResult (Result secure sa ha ba) (Result _ sb hb bb) = do - assert (sa == sb) $ "HTTP status codes don't match : " ++ show sa ++ " /= " ++ show sb - forM_ [ "server", "content-type", "content-length" ] $ \v -> - assertMaybe (lookup v ha) (lookup v hb) $ \ ja jb -> - "Header field '" ++ show v ++ "' doesn't match : '" ++ show ja ++ "' /= '" ++ show jb - assert (ba == bb) $ "HTTP response bodies are different :\n" ++ BS.unpack ba ++ "\n-----------\n" ++ BS.unpack bb - when (not secure && isJust (lookup "X-Via-Proxy" ha)) $ - error "Error: Direct connection should not contain 'X-Via-Proxy' header." - when (not secure && isNothing (lookup "X-Via-Proxy" hb)) $ - error "Error: Direct connection should not contain 'X-Via-Proxy' header." - where - assert :: Bool -> String -> IO () - assert b = unless b . error - - assertMaybe :: Eq a => Maybe a -> Maybe a -> (a -> a -> String) -> IO () - assertMaybe Nothing _ _ = return () - assertMaybe _ Nothing _ = return () - assertMaybe (Just a) (Just b) fmsg = unless (a == b) . error $ fmsg a b - - -testSingleUrl :: Bool -> Int -> HC.Request -> IO () -testSingleUrl debug testProxyPort request = do - direct <- httpRun request - proxy <- httpRun $ addTestProxy testProxyPort request - when debug $ do - printResult direct - printResult proxy - compareResult direct proxy - - -addTestProxy :: Int -> HC.Request -> HC.Request -addTestProxy = HC.addProxy "localhost" - - --- | Use HC.http to fullfil a HC.Request. We need to wrap it because the --- Response contains a Source which we need to read to generate our result. -httpRun :: HC.Request -> IO Result -httpRun req = do - mgr <- HC.newManager $ HC.mkManagerSettings (TLSSettingsSimple True False False) Nothing - runResourceT $ do - resp <- HC.http (modifyRequest req) mgr - let contentLen = readInt64 <$> lookup HT.hContentLength (HC.responseHeaders resp) - bodyText <- checkBodySize (HC.responseBody resp) contentLen - return $ Result (HC.secure req) (HT.statusCode $ HC.responseStatus resp) - (HC.responseHeaders resp) bodyText - where - modifyRequest r = r { HC.redirectCount = 0 } - - -checkBodySize :: (Monad f, Functor f) => DC.ResumableSource f ByteString -> Maybe Int64 -> f ByteString -checkBodySize bodySrc Nothing = fmap (BS.concat . LBS.toChunks) $ bodySrc DC.$$+- CB.take 1000 -checkBodySize bodySrc (Just len) = do - let blockSize = 1000 - if len <= blockSize - then checkBodySize bodySrc Nothing - else fromMaybe "Success" <$> (bodySrc DC.$$+- byteSink len) - - -byteSink :: Monad m => Int64 -> DC.Sink ByteString m (Maybe ByteString) -byteSink bytes = sink 0 - where - sink :: Monad m => Int64 -> DC.Sink ByteString m (Maybe ByteString) - sink !count = DC.await >>= maybe (closeSink count) (sinkBlock count) - - sinkBlock :: Monad m => Int64 -> ByteString -> DC.Sink ByteString m (Maybe ByteString) - sinkBlock !count bs = sink (count + fromIntegral (BS.length bs)) - - closeSink :: Monad m => Int64 -> m (Maybe ByteString) - closeSink !count = return $ - if count == bytes - then Nothing - else Just . BS.pack $ "Error : Body length " ++ show count - ++ " should have been " ++ show bytes ++ "." - - -builderSource :: Monad m => Int64 -> DC.Source m (DC.Flush Builder) -builderSource = DC.mapOutput (DC.Chunk . fromByteString) . byteSource - - -byteSource :: Monad m => Int64 -> DC.Source m ByteString -byteSource bytes = loop 0 - where - loop :: Monad m => Int64 -> DC.Source m ByteString - loop !count - | count >= bytes = return () - | count + blockSize64 < bytes = do - DC.yield bsbytes - loop $ count + blockSize64 - | otherwise = do - let n = fromIntegral $ bytes - count - DC.yield $ BS.take n bsbytes - return () - - blockSize = 8192 :: Int - blockSize64 = fromIntegral blockSize :: Int64 - bsbytes = BS.replicate blockSize '?' - - -readInt64 :: ByteString -> Int64 -readInt64 = read . BS.unpack - - -catchAny :: IO a -> (SomeException -> IO a) -> IO a -catchAny action onE = - withAsync action waitCatch >>= either onE return - - -openLocalhostListenSocket :: IO (Socket, Port) -openLocalhostListenSocket = do - sock <- socket AF_INET Stream defaultProtocol - addr <- inet_addr "127.0.0.1" - bind sock (SockAddrInet aNY_PORT addr) - listen sock 10 - port <- fromIntegral <$> socketPort sock - return (sock, port) diff --git a/Test/Wai.hs b/Test/Wai.hs deleted file mode 100644 --- a/Test/Wai.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------- --- Copyright : Erik de Castro Lopo --- License : BSD3 ------------------------------------------------------------- - -module Test.Wai where - -import Network.Wai.Internal -import Test.Hspec - -waiShouldBe :: Request -> Request -> Expectation -waiShouldBe a b = do - requestMethod a `shouldBe` requestMethod b - httpVersion a `shouldBe` httpVersion b - rawPathInfo a `shouldBe` rawPathInfo b - rawQueryString a `shouldBe` rawQueryString b - requestHeaders a `shouldBe` requestHeaders b - isSecure a `shouldBe` isSecure b - remoteHost a `shouldBe` remoteHost b - pathInfo a `shouldBe` pathInfo b - queryString a `shouldBe` queryString b - -- requestBody a - -- vault a `shouldBe` vault b - -- requestBodyLength a `shouldBe` requestBodyLength b - requestHeaderHost a `shouldBe` requestHeaderHost b - requestHeaderRange a `shouldBe` requestHeaderRange b - - diff --git a/Test/testsuite.hs b/Test/testsuite.hs deleted file mode 100644 --- a/Test/testsuite.hs +++ /dev/null @@ -1,208 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------- --- Copyright : Erik de Castro Lopo --- License : BSD3 ------------------------------------------------------------- - -import Control.Applicative -import Control.Concurrent.Async -import Control.Exception -import Control.Monad -import Control.Monad.Trans.Resource -import Data.Conduit -import Data.Int (Int64) -import Data.Monoid -import System.Environment -import Test.Hspec -import Test.Hspec.QuickCheck - -import qualified Data.ByteString.Char8 as BS -import qualified Data.CaseInsensitive as CI -import qualified Network.HTTP.Conduit as HC -import qualified Network.HTTP.Types as HT -import qualified Network.Wai as Wai - -import Network.HTTP.Proxy -import Network.HTTP.Proxy.Request - -import Test.Gen -import Test.QuickCheck -import Test.TestServer -import Test.Util -import Test.Wai -import Test.Request -import Test.ServerDef - - -proxyTestDebug :: Bool -proxyTestDebug = False - -main :: IO () -main = do -#if __GLASGOW_HASKELL__ > 706 - -- Clear the `http_proxy` enviroment variable. We can't use `unsetEnv` if - -- we want to support ghc 7.6. - unsetEnv "http_proxy" -#endif - bracket - (mapM async [ runTestServer, runTestServerTLS ]) - (mapM_ cancel) - (const $ runProxyTests proxyTestDebug) - -runProxyTests :: Bool -> IO () -runProxyTests dbg = hspec $ do - testHelpersTest - proxyTest Http dbg - protocolTest - proxyTest Https dbg - streamingTest dbg - requestTest - --- ----------------------------------------------------------------------------- - -testHelpersTest :: Spec -testHelpersTest = - -- Test the HTTP and HTTPS servers directly (ie bypassing the Proxy). - describe "Test helper functionality:" $ do - it "Byte Sink catches short response bodies." $ - runResourceT (byteSource 80 $$ byteSink 100) - `shouldReturn` Just "Error : Body length 80 should have been 100." - it "Byte Source and Sink work in constant memory." $ - runResourceT (byteSource oneBillion $$ byteSink oneBillion) `shouldReturn` Nothing - it "Byte Sink catches long response bodies." $ - runResourceT (byteSource 110 $$ byteSink 100) - `shouldReturn` Just "Error : Body length 110 should have been 100." - it "Client and server can stream GET response." $ do - let size = oneBillion - sizeStr = show size - result <- httpRun =<< mkGetRequest Http ("/large-get?" ++ sizeStr) - resultStatus result `shouldBe` 200 - lookup HT.hContentLength (resultHeaders result) `shouldBe` Just (BS.pack sizeStr) - it "Client and server can stream POST request." $ do - let size = oneMillion - sizeStr = show size - body = HC.requestBodySourceIO size $ byteSource size - result <- httpRun =<< mkPostRequestBody Http ("/large-post?" ++ sizeStr) body - resultStatus result `shouldBe` 200 - resultBS result `shouldBe` BS.pack ("Post-size: " ++ sizeStr) - - -proxyTest :: UriScheme -> Bool -> Spec -proxyTest uris dbg = around withDefaultTestProxy $ - describe ("Simple " ++ show uris ++ " proxying:") $ do - let tname = show uris - it (tname ++ " GET.") $ \ testProxyPort -> - testSingleUrl dbg testProxyPort =<< mkGetRequest uris "/" - it (tname ++ " GET with query.") $ \ testProxyPort -> - testSingleUrl dbg testProxyPort =<< mkGetRequest uris "/a?b=1&c=2" - it (tname ++ " GET with request body.") $ \ testProxyPort -> - testSingleUrl dbg testProxyPort =<< mkGetRequestWithBody uris "/" "Hello server!" - it (tname ++ " GET /forbidden returns 403.") $ \ testProxyPort -> - testSingleUrl dbg testProxyPort =<< mkGetRequest uris "/forbidden" - it (tname ++ " GET /not-found returns 404.") $ \ testProxyPort -> - testSingleUrl dbg testProxyPort =<< mkGetRequest uris "/not-found" - it (tname ++ " POST.") $ \ testProxyPort -> - testSingleUrl dbg testProxyPort =<< mkPostRequest uris "/" - it (tname ++ " POST with request body.") $ \ testProxyPort -> - testSingleUrl dbg testProxyPort =<< mkPostRequestBS uris "/" "Hello server!" - it (tname ++ " POST /forbidden returns 403.") $ \ testProxyPort -> - testSingleUrl dbg testProxyPort =<< mkPostRequest uris "/forbidden" - it (tname ++ " POST /not-found returns 404.") $ \ testProxyPort -> - testSingleUrl dbg testProxyPort =<< mkPostRequest uris "/not-found" - - -protocolTest :: Spec -protocolTest = around withDefaultTestProxy $ - describe "HTTP protocol:" $ - it "Passes re-directs through to client." $ \ testProxyPort -> do - req <- addTestProxy testProxyPort <$> mkGetRequest Http "/301" - result <- httpRun req - resultStatus result `shouldBe` 301 - lookup HT.hLocation (resultHeaders result) `shouldBe` Just "http://other-server/301" - - --- Only need to do this test for HTTP not HTTPS (because it just streams bytes --- back and forth). -streamingTest :: Bool -> Spec -streamingTest dbg = around withDefaultTestProxy $ - describe "HTTP streaming via proxy:" $ do - forM_ [ 100, oneThousand, oneMillion, oneBillion ] $ \ size -> - it ("Http GET " ++ show (size :: Int64) ++ " bytes.") $ \ testProxyPort -> - testSingleUrl dbg testProxyPort =<< mkGetRequest Http ("/large-get?" ++ show size) - forM_ [ 100, oneThousand, oneMillion, oneBillion ] $ \ size -> - it ("Http POST " ++ show (size :: Int64) ++ " bytes.") $ \ testProxyPort -> do - let body = HC.requestBodySourceIO size $ byteSource size - testSingleUrl dbg testProxyPort =<< mkPostRequestBody Http ("/large-post?" ++ show size) body - - --- Test that a Request can be pulled apart and reconstructed without losing --- anything. -requestTest :: Spec -requestTest = describe "Request:" $ do - prop "Roundtrips with waiRequest." $ forAll genWaiRequest $ \wreq -> - wreq `waiShouldBe` (waiRequest wreq . proxyRequest) wreq - it "Can add a request header." $ - withTestProxy proxySettingsAddHeader $ \ testProxyPort -> do - req <- addTestProxy testProxyPort <$> mkGetRequest Http "/whatever" - result <- httpRun req - "X-Test-Header: Blah" `BS.isInfixOf` resultBS result `shouldBe` True - it "Can rewrite HTTP to HTTPS." $ - withTestProxy proxySettingsHttpsUpgrade $ \ testProxyPort -> do - req <- addTestProxy testProxyPort <$> mkGetRequest Http "/secure" - result <- httpRun req - -- Getting a TlsException shows that we have successfully upgraded - -- from HTTP to HTTPS. Its not possible to ignore this failure - -- because its made by the http-conduit inside the proxy. - BS.take 13 (resultBS result) `shouldBe` "HttpException" - it "Can provide a proxy Response." $ - withTestProxy proxySettingsProxyResponse $ \ testProxyPort -> do - req <- addTestProxy testProxyPort <$> mkGetRequest Http "/whatever" - result <- httpRun req - resultBS result `shouldBe` "This is the proxy reqponse" - --- ----------------------------------------------------------------------------- - -oneThousand, oneMillion, oneBillion :: Int64 -oneThousand = 1000 -oneMillion = oneThousand * oneThousand -oneBillion = oneThousand * oneMillion - - -withDefaultTestProxy :: (Int -> IO ()) -> IO () -withDefaultTestProxy action = do - (sock, portnum) <- openLocalhostListenSocket - bracket (async $ runProxySettingsSocket defaultProxySettings sock) cancel (const $ action portnum) - - -withTestProxy :: Settings -> (Int -> Expectation) -> Expectation -withTestProxy settings expectation = do - (sock, portnum) <- openLocalhostListenSocket - bracket (async $ runProxySettingsSocket settings sock) cancel (const $ expectation portnum) - - -proxySettingsAddHeader :: Settings -proxySettingsAddHeader = defaultProxySettings - { proxyRequestModifier = \ req -> return . Right $ req - { requestHeaders = (CI.mk "X-Test-Header", "Blah") : requestHeaders req - } - } - -proxySettingsHttpsUpgrade :: Settings -proxySettingsHttpsUpgrade = defaultProxySettings - { proxyRequestModifier = \ req -> return . Right $ req { requestPath = httpsUpgrade $ requestPath req } - } - where - httpsUpgrade bs = - let (start, end) = BS.breakSubstring (bsShow $ httpTestPort portsDef) bs - https = bsShow $ httpsTestPort portsDef - in "https" <> BS.drop 4 start <> https <> BS.drop 5 end - bsShow = BS.pack . show - -proxySettingsProxyResponse :: Settings -proxySettingsProxyResponse = defaultProxySettings - { proxyRequestModifier = const . return $ Left proxyResponse - } - where - proxyResponse :: Wai.Response - proxyResponse = simpleResponse HT.status200 "This is the proxy reqponse" diff --git a/http-proxy.cabal b/http-proxy.cabal --- a/http-proxy.cabal +++ b/http-proxy.cabal @@ -1,19 +1,19 @@ -Name: http-proxy -Version: 0.1.0.5 -License: BSD3 -License-file: LICENSE -Author: Michael Snoyman, Erik de Castro Lopo -Maintainer: erikd@mega-nerd.com -Homepage: https://github.com/erikd/http-proxy -Bug-reports: https://github.com/erikd/http-proxy/issues -Category: Web -Build-Type: Simple -Cabal-Version: >=1.8 -Stability: Experimental +name: http-proxy +version: 0.1.0.6 +license: BSD3 +license-file: LICENSE +author: Michael Snoyman, Erik de Castro Lopo +maintainer: erikd@mega-nerd.com +homepage: https://github.com/erikd/http-proxy +bug-reports: https://github.com/erikd/http-proxy/issues +category: Web +build-type: Simple +cabal-version: >= 1.10 +stability: Experimental -Synopsis: A library for writing HTTP and HTTPS proxies +synopsis: A library for writing HTTP and HTTPS proxies -Description: +description: http-proxy is a library for writing HTTP and HTTPS proxies. . Use of the Conduit library provides file streaming via the proxy in both @@ -25,73 +25,125 @@ a functions for exception reporting and request re-writing. Eventually, this capability will be expanded to allow optional logging, disk caching etc. -Library - Build-Depends: base >= 4 && < 5 - , async >= 2.0 - , blaze-builder >= 0.4 - , bytestring >= 0.10 - , bytestring-lexing >= 0.4 - , case-insensitive >= 1.2 - , conduit >= 1.2 - , conduit-extra >= 1.1 - , http-client >= 0.5 && < 0.6 - , http-conduit >= 2.2 && < 2.3 - , http-types >= 0.8 - , mtl >= 2.1 - , network >= 2.6 - , resourcet >= 1.1 - , tls >= 1.2 - , text >= 1.2 - , transformers >= 0.3 - , wai >= 3.2 - , wai-conduit >= 3.0 - , warp >= 3.0 - , warp-tls >= 3.0 +library + default-language: Haskell2010 + ghc-options: -Wall -fwarn-tabs + if os(windows) + cpp-options: -DWINDOWS - Exposed-modules: Network.HTTP.Proxy - Other-modules: Network.HTTP.Proxy.Request + exposed-modules: Network.HTTP.Proxy + Network.HTTP.Proxy.Request - ghc-options: -Wall -fwarn-tabs + build-depends: base >= 4 && < 5 + , async >= 2.0 + , blaze-builder >= 0.4 + , bytestring >= 0.10 + , bytestring-lexing >= 0.4 + , case-insensitive >= 1.2 + , conduit >= 1.2 + , conduit-extra >= 1.1 && < 1.3 + , http-client + -- More recent versions seem to have broken proxy support. + , http-conduit >= 2.1.11 && < 2.2 + , http-types >= 0.8 + , mtl >= 2.1 + , network >= 2.6 + , resourcet >= 1.1 + -- Not used directly but necessary to enforce < 0.2 + , streaming-commons >= 0.1 && < 0.2 + , tls >= 1.2 + , text >= 1.2 + , transformers >= 0.3 + , wai >= 3.2 + , wai-conduit >= 3.0 + , warp >= 3.0 + , warp-tls >= 3.0 + + + +test-suite test + type: exitcode-stdio-1.0 + ghc-options: -Wall -fwarn-tabs -threaded if os(windows) - Cpp-options: -DWINDOWS + cpp-options: -DWINDOWS + default-language: Haskell2010 + hs-source-dirs: test + main-is: test.hs -Test-Suite testsuite - Type: exitcode-stdio-1.0 - Main-is: Test/testsuite.hs - build-depends: base - , async - , blaze-builder - , bytestring - , bytestring-lexing - , case-insensitive - , conduit - , connection >= 0.2 - , conduit-extra - , http-client - , http-conduit - , http-types - , hspec >= 2.1 - , network - , QuickCheck >= 2.7 - , random >= 1.1 - , resourcet - , text - , vault - , wai - , wai-conduit - , warp - , warp-tls + other-modules: Test.Gen + , Test.Request + , Test.ServerDef + , Test.TestServer + , Test.Util + , Test.Wai - Other-modules: Test.Gen - , Test.Request - , Test.ServerDef - , Test.TestServer - , Test.Util - , Test.Wai + build-depends: base + , async + , blaze-builder + , bytestring + , bytestring-lexing + , case-insensitive + , conduit + , connection >= 0.2 + , conduit-extra + , http-client + , http-conduit + , http-proxy + , http-types + , hspec >= 2.1 + , network + , QuickCheck >= 2.7 + , random >= 1.1 + , resourcet + , text + , vault + , wai + , wai-conduit + , warp + , warp-tls - ghc-options: -Wall -fwarn-tabs +test-suite test-io + type: exitcode-stdio-1.0 + ghc-options: -Wall -fwarn-tabs -threaded if os(windows) - Cpp-options: -DWINDOWS + cpp-options: -DWINDOWS + default-language: Haskell2010 + hs-source-dirs: test + main-is: test-io.hs + + other-modules: Test.Gen + , Test.Request + , Test.ServerDef + , Test.TestServer + , Test.Util + , Test.Wai + + build-depends: base + , async + , blaze-builder + , bytestring + , bytestring-lexing + , case-insensitive + , conduit + , connection >= 0.2 + , conduit-extra + , http-client + , http-conduit + , http-proxy + , http-types + , hspec >= 2.1 + , network + , QuickCheck >= 2.7 + , random >= 1.1 + , resourcet + , text + , vault + , wai + , wai-conduit + , warp + , warp-tls + + source-repository head type: git diff --git a/test/Test/Gen.hs b/test/Test/Gen.hs new file mode 100644 --- /dev/null +++ b/test/Test/Gen.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE OverloadedStrings #-} +------------------------------------------------------------ +-- Copyright : Ambiata Pty Ltd +-- Author : Sharif Olorin +-- License : BSD3 +------------------------------------------------------------ + +module Test.Gen + ( genWaiRequest + ) where + +import Data.ByteString.Char8 (ByteString) +import Data.CaseInsensitive (CI) +import Data.List (intersperse) +import Data.Monoid ((<>)) +import Network.HTTP.Types +import Network.Socket (SockAddr (..), PortNumber) +import Test.QuickCheck + +import qualified Data.ByteString.Char8 as BS +import qualified Data.CaseInsensitive as CI +import qualified Data.Text.Encoding as T +import qualified Data.Vault.Lazy as Vault +import qualified Network.Wai.Internal as Wai + +genWaiRequest :: Gen Wai.Request +genWaiRequest = do + method <- genHttpMethod + version <- genHttpVersion + pathList <- listOf genAscii + secure <- elements [ False, True ] + query <- genQuery + port <- genPort + sockAddr <- SockAddrInet port <$> arbitrary + host <- genHostname + headers <- genHeaderList + (bodylen, body) <- genRequestBody + return $ Wai.Request method version + (BS.concat $ "/" : intersperse "/" pathList) + (renderQueryBS query) + headers secure sockAddr + (map T.decodeUtf8 pathList) + query + (return body) -- requestBody + Vault.empty + bodylen -- requestBodyLength + (Just host) -- requestHeaderHost + Nothing -- requestHeaderRange + Nothing -- requestHeaderReferer + Nothing -- requestHeaderUserAgent + + +genRequestBody :: Gen (Wai.RequestBodyLength, ByteString) +genRequestBody = + let mkResult body = (Wai.KnownLength (fromIntegral $ BS.length body), body) + in mkResult <$> genAscii + + +genHttpMethod :: Gen ByteString +genHttpMethod = elements + [ "GET", "POST", "HEAD", "PUT", "DELETE", "TRACE", "CONNECT" + , "OPTIONS", "PATCH" + ] + +genHttpVersion :: Gen HttpVersion +genHttpVersion = elements [ http09, http10, http11 ] + +genHostname :: Gen ByteString +genHostname = BS.intercalate "." <$> listOf1 genAscii + +genPort :: Gen PortNumber +genPort = fromIntegral <$> arbitrary `suchThat` (\x -> x > 1024 && x < (65536 :: Int)) + +genHeaderList :: Gen [Header] +genHeaderList = listOf genHeader + +genHeader :: Gen Header +genHeader = (,) <$> genHeaderName <*> genAscii + +genHeaderName :: Gen (CI ByteString) +genHeaderName = CI.mk <$> genAscii + +renderQueryBS :: Query -> ByteString +renderQueryBS [] = "" +renderQueryBS ql = + let mkPair (name, value) = name <> maybe "" ("=" <>) value + in "?" <> BS.intercalate "&" (map mkPair ql) + +genQuery :: Gen Query +genQuery = listOf genQueryItem + +genQueryItem :: Gen QueryItem +genQueryItem = (,) <$> genAscii <*> oneof [Just <$> genAscii, pure Nothing] + +genAscii :: Gen ByteString +genAscii = BS.pack <$> do + srange <- choose (3, 10) + vectorOf srange $ oneof [choose ('a', 'z'), choose ('0', '9')] diff --git a/test/Test/Request.hs b/test/Test/Request.hs new file mode 100644 --- /dev/null +++ b/test/Test/Request.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +------------------------------------------------------------ +-- Copyright (c) Erik de Castro Lopo +-- License : BSD3 +------------------------------------------------------------ + +module Test.Request + ( UriScheme (..) + , mkGetRequest + , mkGetRequestWithBody + , mkPostRequest + , mkPostRequestBS + , mkPostRequestBody + ) where + +import Data.ByteString (ByteString) +import Data.Char +import Data.Maybe + +import qualified Network.HTTP.Client as HC +import qualified Network.HTTP.Types as HT + +import Test.ServerDef + + +data UriScheme + = Http | Https + +instance Show UriScheme where + show Http = "HTTP" + show Https = "HTTPS" + + +mkGetRequest :: UriScheme -> String -> IO HC.Request +mkGetRequest scheme path = mkTestRequest get scheme path Nothing + + +mkGetRequestWithBody :: UriScheme -> String -> ByteString -> IO HC.Request +mkGetRequestWithBody scheme path body = mkTestRequestBS get scheme path (Just body) + + +mkPostRequest :: UriScheme -> String -> IO HC.Request +mkPostRequest scheme path = mkTestRequest post scheme path Nothing + + +mkPostRequestBS :: UriScheme -> String -> ByteString -> IO HC.Request +mkPostRequestBS scheme path body = mkTestRequestBS post scheme path (Just body) + + +mkPostRequestBody :: UriScheme -> String -> HC.RequestBody -> IO HC.Request +mkPostRequestBody scheme path body = mkTestRequest post scheme path (Just body) + + +mkTestRequestBS :: HT.Method -> UriScheme -> String -> Maybe ByteString -> IO HC.Request +mkTestRequestBS method scheme path mbody = mkTestRequest method scheme path $ HC.RequestBodyBS <$> mbody + + +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 portsDef + Https -> httpsTestPort portsDef + url = map toLower (show scheme) ++ "://localhost:" ++ port ++ path + req <- HC.parseRequest url + return $ req + { HC.method = if HC.method req /= method then method else HC.method req + , HC.requestBody = fromMaybe (HC.requestBody req) mbody + } + + +get, post :: HT.Method +get = HT.methodGet +post = HT.methodPost + diff --git a/test/Test/ServerDef.hs b/test/Test/ServerDef.hs new file mode 100644 --- /dev/null +++ b/test/Test/ServerDef.hs @@ -0,0 +1,48 @@ +------------------------------------------------------------ +-- Copyright : Erik de Castro Lopo +-- License : BSD3 +------------------------------------------------------------ + +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 + } + deriving Show + + +-- Yeah, yeah, unsafePerformIO! Worst thing that can happen is that the tests +-- fail. +{-# NOINLINE portsDef #-} +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] -> return $ PortsDef a b + _ -> getPortsDef + where + randomRL :: [Int] -> IO [Int] + randomRL xs + | length xs == 2 = 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/Test/TestServer.hs b/test/Test/TestServer.hs new file mode 100644 --- /dev/null +++ b/test/Test/TestServer.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE OverloadedStrings #-} +------------------------------------------------------------ +-- Copyright : Erik de Castro Lopo +-- License : BSD3 +------------------------------------------------------------ + +module Test.TestServer + ( runTestServer + , runTestServerTLS + ) where + +import Data.ByteString (ByteString) +import Data.List (sort) +import Data.Monoid +import Data.String +import Network.HTTP.Types +import Network.Wai +import Network.Wai.Conduit +import Network.Wai.Handler.Warp +import Network.Wai.Handler.WarpTLS + +import Data.ByteString.Lex.Integral (readDecimal_) +import Data.Conduit (($$)) +import Data.Int (Int64) + +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.Conduit as DC + +import qualified Network.HTTP.Proxy.Request as HPR + +import Test.ServerDef +import Test.Util + + +runTestServer :: IO () +runTestServer = + let settings = setPort (httpTestPort portsDef) $ setHost "*6" defaultSettings + in catchAny (runSettings settings serverApp) print + +runTestServerTLS :: IO () +runTestServerTLS = + let settings = setPort (httpsTestPort portsDef) $ setHost "*6" defaultSettings + tlsSettings' = tlsSettings "test/certificate.pem" "test/key.pem" + in catchAny (runTLS tlsSettings' settings serverApp) print + +-------------------------------------------------------------------------------- + +serverApp :: Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived +serverApp req respond + | rawPathInfo req == "/forbidden" = + respond $ simpleResponse status403 "This is the forbidden message.\n" + + | rawPathInfo req == "/301" = do + let respHeaders = [ (hLocation, "http://other-server" <> rawPathInfo req) ] + respond $ responseLBS status301 respHeaders mempty + + | rawPathInfo req == "/large-get" = do + let len = readDecimal_ $ BS.drop 1 $ rawQueryString req + let respHeaders = + [ (hContentType, "text/plain") + , (hContentLength, fromString $ show len) + ] + respond . responseSource status200 respHeaders $ builderSource len + + | rawPathInfo req == "/secure" = do + let body = "Using SSL: " <> BS.pack (show $ isSecure req) + let respHeaders = + [ (hContentType, "text/plain") + , (hContentLength, fromString . show $ BS.length body) + ] + respond $ responseBS status200 respHeaders body + + | rawPathInfo req == "/large-post" && requestMethod req == "POST" = do + let len = maybe 0 readDecimal_ (lookup "content-length" $ requestHeaders req) :: Int64 + if len == 0 + then respond $ simpleResponse status400 "Error : POST Content-Length was either missing or zero.\n" + else respond =<< largePostCheck len (sourceRequestBody req) + + | otherwise = do + let text = "This is the not-found message.\n\n" : responseBody req + respHeaders = [ (hContentType, "text/plain") ] + respond . responseLBS status404 respHeaders $ LBS.fromChunks text + + +responseBody :: Request -> [ByteString] +responseBody req = + [ " Method : " , requestMethod req , "\n" + , " HTTP Version : " , fromString (show (httpVersion req)) , "\n" + , " Path Info : " , rawPathInfo req , "\n" + , " Query String : " , rawQueryString req , "\n" + , " Server : " , HPR.waiRequestHost req , "\n" + , " Secure (SSL) : " , fromString (show (isSecure req)), "\n" + , " Request Headers :\n" + , headerShow (sort $ requestHeaders req) + , "\n" + ] + + +largePostCheck :: Int64 -> DC.Source IO ByteString -> IO Response +largePostCheck len rbody = + maybe success failure <$> (rbody $$ byteSink len) + where + success = simpleResponse status200 . BS.pack $ "Post-size: " ++ show len + failure = simpleResponse status500 diff --git a/test/Test/Util.hs b/test/Test/Util.hs new file mode 100644 --- /dev/null +++ b/test/Test/Util.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE BangPatterns, OverloadedStrings #-} +------------------------------------------------------------ +-- Copyright : Erik de Castro Lopo +-- License : BSD3 +------------------------------------------------------------ + +module Test.Util where + +import Blaze.ByteString.Builder +import Control.Concurrent.Async +import Control.Exception hiding (assert) +import Control.Monad (forM_, when, unless) +import Control.Monad.Trans.Resource +import Data.ByteString (ByteString) +import Data.Int (Int64) +import Data.Maybe +import Data.String (fromString) +import Network.Socket +import Network.Connection + +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.CaseInsensitive as CI +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 qualified Network.Wai as Wai + +import Network.HTTP.Proxy.Request + + +dumpWaiRequest :: Wai.Request -> IO () +dumpWaiRequest req = + mapM_ BS.putStrLn + [ "------- Wai Request --------------------------------------------------------------" + , "Method : " , Wai.requestMethod req + , "HTTP Version : " , fromString (show (Wai.httpVersion req)) + , "Path Info : " , Wai.rawPathInfo req + , "Query String : " , Wai.rawQueryString req + , "Server : " , waiRequestHost req + , "Secure (SSL) : " , fromString (show (Wai.isSecure req)) + , "Remote Host : " , fromString (show (Wai.remoteHost req)) + , "Request Headers :" + , headerShow (Wai.requestHeaders req) + ] + + +dumpHttpConduitRequest :: HC.Request -> IO () +dumpHttpConduitRequest req = + mapM_ BS.putStrLn + [ "------- HttpConduit Request ------------------------------------------------------" + , "Method : " , HC.method req + , "Secure (SSL) : " , fromString (show (HC.secure req)) + , "Host Name : " , HC.host req + , "Host Port : " , fromString (show (HC.port req)) + , "Path : " , HC.path req + , "Query String : " , HT.urlDecode False (HC.queryString req) + , "Request Headers :" + , headerShow (HC.requestHeaders req) + ] + + +dumpHttpResponse :: HT.Status -> HT.ResponseHeaders -> IO () +dumpHttpResponse s rh = do + mapM_ BS.putStrLn + [ "------- Response from upsteam ----------------------------------------------------" + , "HTTP/1.0 ", BS.pack (show (HT.statusCode s)), " ", HT.statusMessage s + ] + BS.putStr . BS.concat $ map (\ (f, v) -> BS.concat [ " ", CI.original f, ": ", v, "\n" ]) rh + + +headerShow :: [HT.Header] -> ByteString +headerShow headers = + BS.concat $ map hdrShow headers + where + hdrShow (f, v) = BS.concat [ " ", CI.original f , ": " , v, "\n" ] + + +-------------------------------------------------------------------------------- + +simpleResponse :: HT.Status -> ByteString -> Wai.Response +simpleResponse status text = do + let respHeaders = + [ (HT.hContentType, "text/plain") + , (HT.hContentLength, fromString . show $ BS.length text) + ] + responseBS status respHeaders text + + +responseBS :: HT.Status -> HT.ResponseHeaders -> ByteString -> Wai.Response +responseBS status headers text = + Wai.responseLBS status headers$ LBS.fromChunks [text] + +-------------------------------------------------------------------------------- + +data Result = Result + { resultSecure :: Bool + , resultStatus :: Int + , resultHeaders :: [HT.Header] + , resultBS :: ByteString + } + + +printResult :: Result -> IO () +printResult (Result _ status headers body) = do + putStrLn $ "Response status : " ++ show status + putStrLn "Response headers :" + BS.putStr $ headerShow headers + putStrLn "Response body :" + BS.putStrLn body + +-------------------------------------------------------------------------------- + +-- | Compare results and error out if they're different. +compareResult :: Result -> Result -> IO () +compareResult (Result secure sa ha ba) (Result _ sb hb bb) = do + assert (sa == sb) $ "HTTP status codes don't match : " ++ show sa ++ " /= " ++ show sb + forM_ [ "server", "content-type", "content-length" ] $ \v -> + assertMaybe (lookup v ha) (lookup v hb) $ \ ja jb -> + "Header field '" ++ show v ++ "' doesn't match : '" ++ show ja ++ "' /= '" ++ show jb + assert (ba == bb) $ "HTTP response bodies are different :\n" ++ BS.unpack ba ++ "\n-----------\n" ++ BS.unpack bb + when (not secure && isJust (lookup "X-Via-Proxy" ha)) $ + error "Error: Direct connection should not contain 'X-Via-Proxy' header." + when (not secure && isNothing (lookup "X-Via-Proxy" hb)) $ + error "Error: Direct connection should not contain 'X-Via-Proxy' header." + where + assert :: Bool -> String -> IO () + assert b = unless b . error + + assertMaybe :: Eq a => Maybe a -> Maybe a -> (a -> a -> String) -> IO () + assertMaybe Nothing _ _ = return () + assertMaybe _ Nothing _ = return () + assertMaybe (Just a) (Just b) fmsg = unless (a == b) . error $ fmsg a b + + +testSingleUrl :: Bool -> Int -> HC.Request -> IO () +testSingleUrl debug testProxyPort request = do + direct <- httpRun request + proxy <- httpRun $ addTestProxy testProxyPort request + when debug $ do + printResult direct + printResult proxy + compareResult direct proxy + + +addTestProxy :: Int -> HC.Request -> HC.Request +addTestProxy = HC.addProxy "localhost" + + +-- | Use HC.http to fullfil a HC.Request. We need to wrap it because the +-- Response contains a Source which we need to read to generate our result. +httpRun :: HC.Request -> IO Result +httpRun req = do + mgr <- HC.newManager $ HC.mkManagerSettings (TLSSettingsSimple True False False) Nothing + runResourceT $ do + resp <- HC.http (modifyRequest req) mgr + let contentLen = readInt64 <$> lookup HT.hContentLength (HC.responseHeaders resp) + bodyText <- checkBodySize (HC.responseBody resp) contentLen + return $ Result (HC.secure req) (HT.statusCode $ HC.responseStatus resp) + (HC.responseHeaders resp) bodyText + where + modifyRequest r = r { HC.redirectCount = 0 } + + +checkBodySize :: (Monad f, Functor f) => DC.ResumableSource f ByteString -> Maybe Int64 -> f ByteString +checkBodySize bodySrc Nothing = fmap (BS.concat . LBS.toChunks) $ bodySrc DC.$$+- CB.take 1000 +checkBodySize bodySrc (Just len) = do + let blockSize = 1000 + if len <= blockSize + then checkBodySize bodySrc Nothing + else fromMaybe "Success" <$> (bodySrc DC.$$+- byteSink len) + + +byteSink :: Monad m => Int64 -> DC.Sink ByteString m (Maybe ByteString) +byteSink bytes = sink 0 + where + sink :: Monad m => Int64 -> DC.Sink ByteString m (Maybe ByteString) + sink !count = DC.await >>= maybe (closeSink count) (sinkBlock count) + + sinkBlock :: Monad m => Int64 -> ByteString -> DC.Sink ByteString m (Maybe ByteString) + sinkBlock !count bs = sink (count + fromIntegral (BS.length bs)) + + closeSink :: Monad m => Int64 -> m (Maybe ByteString) + closeSink !count = return $ + if count == bytes + then Nothing + else Just . BS.pack $ "Error : Body length " ++ show count + ++ " should have been " ++ show bytes ++ "." + + +builderSource :: Monad m => Int64 -> DC.Source m (DC.Flush Builder) +builderSource = DC.mapOutput (DC.Chunk . fromByteString) . byteSource + + +byteSource :: Monad m => Int64 -> DC.Source m ByteString +byteSource bytes = loop 0 + where + loop :: Monad m => Int64 -> DC.Source m ByteString + loop !count + | count >= bytes = return () + | count + blockSize64 < bytes = do + DC.yield bsbytes + loop $ count + blockSize64 + | otherwise = do + let n = fromIntegral $ bytes - count + DC.yield $ BS.take n bsbytes + return () + + blockSize = 8192 :: Int + blockSize64 = fromIntegral blockSize :: Int64 + bsbytes = BS.replicate blockSize '?' + + +readInt64 :: ByteString -> Int64 +readInt64 = read . BS.unpack + + +catchAny :: IO a -> (SomeException -> IO a) -> IO a +catchAny action onE = + withAsync action waitCatch >>= either onE return + + +openLocalhostListenSocket :: IO (Socket, Port) +openLocalhostListenSocket = do + sock <- socket AF_INET Stream defaultProtocol + addr <- inet_addr "127.0.0.1" + bind sock (SockAddrInet aNY_PORT addr) + listen sock 10 + port <- fromIntegral <$> socketPort sock + return (sock, port) diff --git a/test/Test/Wai.hs b/test/Test/Wai.hs new file mode 100644 --- /dev/null +++ b/test/Test/Wai.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} +------------------------------------------------------------ +-- Copyright : Erik de Castro Lopo +-- License : BSD3 +------------------------------------------------------------ + +module Test.Wai where + +import Network.Wai.Internal +import Test.Hspec + +waiShouldBe :: Request -> Request -> Expectation +waiShouldBe a b = do + requestMethod a `shouldBe` requestMethod b + httpVersion a `shouldBe` httpVersion b + rawPathInfo a `shouldBe` rawPathInfo b + rawQueryString a `shouldBe` rawQueryString b + requestHeaders a `shouldBe` requestHeaders b + isSecure a `shouldBe` isSecure b + remoteHost a `shouldBe` remoteHost b + pathInfo a `shouldBe` pathInfo b + queryString a `shouldBe` queryString b + -- requestBody a + -- vault a `shouldBe` vault b + -- requestBodyLength a `shouldBe` requestBodyLength b + requestHeaderHost a `shouldBe` requestHeaderHost b + requestHeaderRange a `shouldBe` requestHeaderRange b + + diff --git a/test/test-io.hs b/test/test-io.hs new file mode 100644 --- /dev/null +++ b/test/test-io.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +------------------------------------------------------------ +-- Copyright : Erik de Castro Lopo +-- License : BSD3 +------------------------------------------------------------ + +import Control.Concurrent.Async +import Control.Exception +import Control.Monad +import Control.Monad.Trans.Resource +import Data.Conduit +import Data.Int (Int64) +import Data.Monoid +import System.Environment +import Test.Hspec + +import qualified Data.ByteString.Char8 as BS +import qualified Data.CaseInsensitive as CI +import qualified Network.HTTP.Conduit as HC +import qualified Network.HTTP.Types as HT +import qualified Network.Wai as Wai + +import Network.HTTP.Proxy + +import Test.TestServer +import Test.Util +import Test.Request +import Test.ServerDef + + +proxyTestDebug :: Bool +proxyTestDebug = False + +main :: IO () +main = do + -- Clear the `http_proxy` enviroment variable. + unsetEnv "http_proxy" + bracket + (mapM async [ runTestServer, runTestServerTLS ]) + (mapM_ cancel) + (const $ runProxyTests proxyTestDebug) + +runProxyTests :: Bool -> IO () +runProxyTests dbg = hspec $ do + testHelpersTest + proxyTest Http dbg + protocolTest + proxyTest Https dbg + streamingTest dbg + requestTest + +-- ----------------------------------------------------------------------------- + +testHelpersTest :: Spec +testHelpersTest = + -- Test the HTTP and HTTPS servers directly (ie bypassing the Proxy). + describe "Test helper functionality:" $ do + it "Byte Sink catches short response bodies." $ + runResourceT (byteSource 80 $$ byteSink 100) + `shouldReturn` Just "Error : Body length 80 should have been 100." + it "Byte Source and Sink work in constant memory." $ + runResourceT (byteSource oneBillion $$ byteSink oneBillion) `shouldReturn` Nothing + it "Byte Sink catches long response bodies." $ + runResourceT (byteSource 110 $$ byteSink 100) + `shouldReturn` Just "Error : Body length 110 should have been 100." + it "Client and server can stream GET response." $ do + let size = oneBillion + sizeStr = show size + result <- httpRun =<< mkGetRequest Http ("/large-get?" ++ sizeStr) + resultStatus result `shouldBe` 200 + lookup HT.hContentLength (resultHeaders result) `shouldBe` Just (BS.pack sizeStr) + it "Client and server can stream POST request." $ do + let size = oneMillion + sizeStr = show size + body = HC.requestBodySourceIO size $ byteSource size + result <- httpRun =<< mkPostRequestBody Http ("/large-post?" ++ sizeStr) body + resultStatus result `shouldBe` 200 + resultBS result `shouldBe` BS.pack ("Post-size: " ++ sizeStr) + + +proxyTest :: UriScheme -> Bool -> Spec +proxyTest uris dbg = around withDefaultTestProxy $ + describe ("Simple " ++ show uris ++ " proxying:") $ do + let tname = show uris + it (tname ++ " GET.") $ \ testProxyPort -> + testSingleUrl dbg testProxyPort =<< mkGetRequest uris "/" + it (tname ++ " GET with query.") $ \ testProxyPort -> + testSingleUrl dbg testProxyPort =<< mkGetRequest uris "/a?b=1&c=2" + it (tname ++ " GET with request body.") $ \ testProxyPort -> + testSingleUrl dbg testProxyPort =<< mkGetRequestWithBody uris "/" "Hello server!" + it (tname ++ " GET /forbidden returns 403.") $ \ testProxyPort -> + testSingleUrl dbg testProxyPort =<< mkGetRequest uris "/forbidden" + it (tname ++ " GET /not-found returns 404.") $ \ testProxyPort -> + testSingleUrl dbg testProxyPort =<< mkGetRequest uris "/not-found" + it (tname ++ " POST.") $ \ testProxyPort -> + testSingleUrl dbg testProxyPort =<< mkPostRequest uris "/" + it (tname ++ " POST with request body.") $ \ testProxyPort -> + testSingleUrl dbg testProxyPort =<< mkPostRequestBS uris "/" "Hello server!" + it (tname ++ " POST /forbidden returns 403.") $ \ testProxyPort -> + testSingleUrl dbg testProxyPort =<< mkPostRequest uris "/forbidden" + it (tname ++ " POST /not-found returns 404.") $ \ testProxyPort -> + testSingleUrl dbg testProxyPort =<< mkPostRequest uris "/not-found" + + +protocolTest :: Spec +protocolTest = around withDefaultTestProxy $ + describe "HTTP protocol:" $ + it "Passes re-directs through to client." $ \ testProxyPort -> do + req <- addTestProxy testProxyPort <$> mkGetRequest Http "/301" + result <- httpRun req + resultStatus result `shouldBe` 301 + lookup HT.hLocation (resultHeaders result) `shouldBe` Just "http://other-server/301" + + +-- Only need to do this test for HTTP not HTTPS (because it just streams bytes +-- back and forth). +streamingTest :: Bool -> Spec +streamingTest dbg = around withDefaultTestProxy $ + describe "HTTP streaming via proxy:" $ do + forM_ [ 100, oneThousand, oneMillion, oneBillion ] $ \ size -> + it ("Http GET " ++ show (size :: Int64) ++ " bytes.") $ \ testProxyPort -> + testSingleUrl dbg testProxyPort =<< mkGetRequest Http ("/large-get?" ++ show size) + forM_ [ 100, oneThousand, oneMillion, oneBillion ] $ \ size -> + it ("Http POST " ++ show (size :: Int64) ++ " bytes.") $ \ testProxyPort -> do + let body = HC.requestBodySourceIO size $ byteSource size + testSingleUrl dbg testProxyPort =<< mkPostRequestBody Http ("/large-post?" ++ show size) body + + +-- Test that a Request can be pulled apart and reconstructed without losing +-- anything. +requestTest :: Spec +requestTest = describe "Request:" $ do + it "Can add a request header." $ + withTestProxy proxySettingsAddHeader $ \ testProxyPort -> do + req <- addTestProxy testProxyPort <$> mkGetRequest Http "/whatever" + result <- httpRun req + "X-Test-Header: Blah" `BS.isInfixOf` resultBS result `shouldBe` True + it "Can rewrite HTTP to HTTPS." $ + withTestProxy proxySettingsHttpsUpgrade $ \ testProxyPort -> do + req <- addTestProxy testProxyPort <$> mkGetRequest Http "/secure" + result <- httpRun req + -- Getting a TlsException shows that we have successfully upgraded + -- from HTTP to HTTPS. Its not possible to ignore this failure + -- because its made by the http-conduit inside the proxy. + BS.takeWhile (/= ' ') (resultBS result) `shouldBe` "TlsExceptionHostPort" + it "Can provide a proxy Response." $ + withTestProxy proxySettingsProxyResponse $ \ testProxyPort -> do + req <- addTestProxy testProxyPort <$> mkGetRequest Http "/whatever" + result <- httpRun req + resultBS result `shouldBe` "This is the proxy reqponse" + +-- ----------------------------------------------------------------------------- + +oneThousand, oneMillion, oneBillion :: Int64 +oneThousand = 1000 +oneMillion = oneThousand * oneThousand +oneBillion = oneThousand * oneMillion + + +withDefaultTestProxy :: (Int -> IO ()) -> IO () +withDefaultTestProxy action = do + (sock, portnum) <- openLocalhostListenSocket + bracket (async $ runProxySettingsSocket defaultProxySettings sock) cancel (const $ action portnum) + + +withTestProxy :: Settings -> (Int -> Expectation) -> Expectation +withTestProxy settings expectation = do + (sock, portnum) <- openLocalhostListenSocket + bracket (async $ runProxySettingsSocket settings sock) cancel (const $ expectation portnum) + + +proxySettingsAddHeader :: Settings +proxySettingsAddHeader = defaultProxySettings + { proxyRequestModifier = \ req -> return . Right $ req + { requestHeaders = (CI.mk "X-Test-Header", "Blah") : requestHeaders req + } + } + +proxySettingsHttpsUpgrade :: Settings +proxySettingsHttpsUpgrade = defaultProxySettings + { proxyRequestModifier = \ req -> return . Right $ req { requestPath = httpsUpgrade $ requestPath req } + } + where + httpsUpgrade bs = + let (start, end) = BS.breakSubstring (bsShow $ httpTestPort portsDef) bs + https = bsShow $ httpsTestPort portsDef + in "https" <> BS.drop 4 start <> https <> BS.drop 5 end + bsShow = BS.pack . show + +proxySettingsProxyResponse :: Settings +proxySettingsProxyResponse = defaultProxySettings + { proxyRequestModifier = const . return $ Left proxyResponse + } + where + proxyResponse :: Wai.Response + proxyResponse = simpleResponse HT.status200 "This is the proxy reqponse" diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +------------------------------------------------------------ +-- Copyright : Erik de Castro Lopo +-- License : BSD3 +------------------------------------------------------------ + +import Test.Hspec (Spec, describe, hspec) +import Test.Hspec.QuickCheck (prop) + +import Network.HTTP.Proxy.Request + +import Test.Gen +import Test.QuickCheck + +import Test.Wai + + + +main :: IO () +main = + hspec requestTest + +-- Test that a Request can be pulled apart and reconstructed without losing +-- anything. +requestTest :: Spec +requestTest = describe "Request:" $ + prop "Roundtrips with waiRequest." $ forAll genWaiRequest $ \wreq -> + wreq `waiShouldBe` (waiRequest wreq . proxyRequest) wreq