http-proxy 0.1.0.5 → 0.1.0.6
raw patch · 17 files changed
+943/−873 lines, 17 filesdep +http-proxydep +streaming-commonsdep ~asyncdep ~basedep ~blaze-builderPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
Dependencies added: http-proxy, streaming-commons
Dependency ranges changed: async, base, blaze-builder, bytestring, bytestring-lexing, case-insensitive, conduit, conduit-extra, http-client, http-conduit, http-types, network, resourcet, text, wai, wai-conduit, warp, warp-tls
API changes (from Hackage documentation)
+ Network.HTTP.Proxy: warpSettings :: Settings -> Settings
+ Network.HTTP.Proxy.Request: Request :: Method -> HttpVersion -> RequestHeaders -> ByteString -> ByteString -> Request
+ Network.HTTP.Proxy.Request: [httpVersion] :: Request -> HttpVersion
+ Network.HTTP.Proxy.Request: [queryString] :: Request -> ByteString
+ Network.HTTP.Proxy.Request: [requestHeaders] :: Request -> RequestHeaders
+ Network.HTTP.Proxy.Request: [requestMethod] :: Request -> Method
+ Network.HTTP.Proxy.Request: [requestPath] :: Request -> ByteString
+ Network.HTTP.Proxy.Request: data Request
+ Network.HTTP.Proxy.Request: instance GHC.Classes.Eq Network.HTTP.Proxy.Request.Request
+ Network.HTTP.Proxy.Request: instance GHC.Show.Show Network.HTTP.Proxy.Request.Request
+ Network.HTTP.Proxy.Request: proxyRequest :: Request -> Request
+ Network.HTTP.Proxy.Request: type Port = Int
+ Network.HTTP.Proxy.Request: waiRequest :: Request -> Request -> Request
+ Network.HTTP.Proxy.Request: waiRequestHost :: Request -> ByteString
Files
- Network/HTTP/Proxy.hs +5/−2
- Test/Gen.hs +0/−99
- Test/Request.hs +0/−75
- Test/ServerDef.hs +0/−48
- Test/TestServer.hs +0/−106
- Test/Util.hs +0/−232
- Test/Wai.hs +0/−29
- Test/testsuite.hs +0/−208
- http-proxy.cabal +126/−74
- test/Test/Gen.hs +98/−0
- test/Test/Request.hs +75/−0
- test/Test/ServerDef.hs +48/−0
- test/Test/TestServer.hs +105/−0
- test/Test/Util.hs +231/−0
- test/Test/Wai.hs +29/−0
- test/test-io.hs +197/−0
- test/test.hs +29/−0
Network/HTTP/Proxy.hs view
@@ -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
− Test/Gen.hs
@@ -1,99 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---------------------------------------------------------------- Copyright : Ambiata Pty Ltd--- Author : Sharif Olorin <sio@tesser.org>--- 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')]
− Test/Request.hs
@@ -1,75 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---------------------------------------------------------------- Copyright (c) Erik de Castro Lopo <erikd@mega-nerd.com>--- 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-
− Test/ServerDef.hs
@@ -1,48 +0,0 @@---------------------------------------------------------------- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com>--- 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)
− Test/TestServer.hs
@@ -1,106 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---------------------------------------------------------------- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com>--- 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
− Test/Util.hs
@@ -1,232 +0,0 @@-{-# LANGUAGE BangPatterns, OverloadedStrings #-}---------------------------------------------------------------- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com>--- 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)
− Test/Wai.hs
@@ -1,29 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---------------------------------------------------------------- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com>--- 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--
− Test/testsuite.hs
@@ -1,208 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}---------------------------------------------------------------- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com>--- 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"
http-proxy.cabal view
@@ -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
+ test/Test/Gen.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE OverloadedStrings #-}+------------------------------------------------------------+-- Copyright : Ambiata Pty Ltd+-- Author : Sharif Olorin <sio@tesser.org>+-- 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')]
+ test/Test/Request.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-}+------------------------------------------------------------+-- Copyright (c) Erik de Castro Lopo <erikd@mega-nerd.com>+-- 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+
+ test/Test/ServerDef.hs view
@@ -0,0 +1,48 @@+------------------------------------------------------------+-- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com>+-- 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)
+ test/Test/TestServer.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE OverloadedStrings #-}+------------------------------------------------------------+-- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com>+-- 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
+ test/Test/Util.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE BangPatterns, OverloadedStrings #-}+------------------------------------------------------------+-- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com>+-- 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)
+ test/Test/Wai.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}+------------------------------------------------------------+-- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com>+-- 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++
+ test/test-io.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+------------------------------------------------------------+-- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com>+-- 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"
+ test/test.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+------------------------------------------------------------+-- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com>+-- 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