diff --git a/Network/HTTP/Proxy.hs b/Network/HTTP/Proxy.hs index 5cfbe3c..0b02f47 100644 --- a/Network/HTTP/Proxy.hs +++ b/Network/HTTP/Proxy.hs @@ -142,7 +142,7 @@ proxyApp settings mgr wreq respond respond $ responseRawSource (handleConnect wreq) (Wai.responseLBS HT.status500 [("Content-Type", "text/plain")] "No support for responseRaw") | otherwise = do - wreq' <- waiRequest <$> proxyRequestModifier settings (proxyRequest wreq) + wreq' <- waiRequest wreq <$> proxyRequestModifier settings (proxyRequest wreq) hreq0 <- HC.parseUrl $ BS.unpack (Wai.rawPathInfo wreq' <> Wai.rawQueryString wreq') let hreq = hreq0 { HC.method = Wai.requestMethod wreq' diff --git a/Network/HTTP/Proxy/Request.hs b/Network/HTTP/Proxy/Request.hs index e08085e..579adb7 100644 --- a/Network/HTTP/Proxy/Request.hs +++ b/Network/HTTP/Proxy/Request.hs @@ -48,8 +48,8 @@ proxyRequest wreq = Request (Wai.rawPathInfo wreq) (Wai.rawQueryString wreq) -waiRequest :: Request -> Wai.Request -waiRequest req = Wai.defaultRequest +waiRequest :: Wai.Request -> Request -> Wai.Request +waiRequest original req = original { Wai.requestMethod = requestMethod req , Wai.httpVersion = httpVersion req , Wai.requestHeaders = requestHeaders req diff --git a/Test/Gen.hs b/Test/Gen.hs index b14ce51..b25c84d 100644 --- a/Test/Gen.hs +++ b/Test/Gen.hs @@ -6,25 +6,55 @@ ------------------------------------------------------------ module Test.Gen - ( genRequest + ( genWaiRequest ) where import Control.Applicative import Data.ByteString.Char8 (ByteString) import Data.CaseInsensitive (CI) +import Data.List (intersperse) import Data.Monoid ((<>)) -import Network.HTTP.Proxy.Request 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 + + +genRequestBody :: Gen (Wai.RequestBodyLength, ByteString) +genRequestBody = + let mkResult body = (Wai.KnownLength (fromIntegral $ BS.length body), body) + in mkResult <$> genAscii -genRequest :: Gen Request -genRequest = - Request <$> genHttpMethod <*> genHttpVersion <*> genHeaderList <*> genSimpleUri <*> genQueryString - genHttpMethod :: Gen ByteString genHttpMethod = elements [ "GET", "POST", "HEAD", "PUT", "DELETE", "TRACE", "CONNECT" @@ -34,23 +64,11 @@ genHttpMethod = elements genHttpVersion :: Gen HttpVersion genHttpVersion = elements [ http09, http10, http11 ] -genSimpleUri :: Gen ByteString -genSimpleUri = BS.concat <$> sequence - [ elements [ "http://", "https://" ] - , BS.intercalate "." <$> listOf1 genAscii - , genMaybePortStr - , pure "/" - , BS.intercalate "/" <$> listOf genAscii - ] - -genMaybePortStr :: Gen ByteString -genMaybePortStr = oneof - [ pure "" - , BS.pack . (:) ':' . show <$> genPort - ] +genHostname :: Gen ByteString +genHostname = BS.intercalate "." <$> listOf1 genAscii -genPort :: Gen Int -genPort = arbitrary `suchThat` (\x -> x > 0 && x < 65536) +genPort :: Gen PortNumber +genPort = fromIntegral <$> arbitrary `suchThat` (\x -> x > 1024 && x < (65536 :: Int)) genHeaderList :: Gen [Header] genHeaderList = listOf genHeader @@ -61,14 +79,11 @@ genHeader = (,) <$> genHeaderName <*> genAscii genHeaderName :: Gen (CI ByteString) genHeaderName = CI.mk <$> genAscii -genQueryString :: Gen ByteString -genQueryString = do - list <- genQuery - case list of - [] -> pure "" - _ -> return $ "?" <> BS.intercalate "&" (map mkPair list) - where - mkPair (name, value) = name <> maybe "" ("=" <>) value +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 @@ -77,4 +92,6 @@ genQueryItem :: Gen QueryItem genQueryItem = (,) <$> genAscii <*> oneof [Just <$> genAscii, pure Nothing] genAscii :: Gen ByteString -genAscii = BS.pack <$> listOf1 (oneof [choose ('a', 'z'), choose ('0', '9')]) +genAscii = BS.pack <$> do + srange <- choose (3, 10) + vectorOf srange $ oneof [choose ('a', 'z'), choose ('0', '9')] diff --git a/Test/Wai.hs b/Test/Wai.hs new file mode 100644 index 0000000..2753da5 --- /dev/null +++ b/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/testsuite.hs b/Test/testsuite.hs index 8937d50..e926e28 100644 --- a/Test/testsuite.hs +++ b/Test/testsuite.hs @@ -27,6 +27,7 @@ import Test.Gen import Test.QuickCheck import Test.TestServer import Test.Util +import Test.Wai import Test.Request import Test.ServerDef @@ -130,8 +131,8 @@ streamingTest dbg = withProxy defaultProxySettings $ -- anything. requestTest :: Spec requestTest = describe "Request:" $ do - prop "Roundtrips with waiRequest." $ forAll genRequest $ \req -> - req `shouldBe` (proxyRequest . waiRequest) req + prop "Roundtrips with waiRequest." $ forAll genWaiRequest $ \wreq -> + wreq `waiShouldBe` (waiRequest wreq . proxyRequest) wreq it "Can add a request header." $ proxyExpect proxySettingsAddHeader $ do req <- addTestProxy <$> mkGetRequest Http "/whatever" diff --git a/http-proxy.cabal b/http-proxy.cabal index 7c40ab6..235c9a0 100644 --- a/http-proxy.cabal +++ b/http-proxy.cabal @@ -75,6 +75,7 @@ Test-Suite testsuite , random >= 1.1 , resourcet , text + , vault , wai , wai-conduit , warp