Test.Gen: Generate a Wai.Request instead of a Proxy Request

The proxy receives a Wai.Request, converts it to the proxy's own Request
type, potentially modifies it and then converts it back to a Wai.Request.

However, the conversion from a Wai.Request to a proxy Request is lossy
so that when we do a conversion of Wai.Request to proxy Request and then
back to a Wai.Request we copy the unchanged fields from the original to
the destination.

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'

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

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')]

Test/Wai.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE OverloadedStrings #-}
+------------------------------------------------------------
+-- Copyright : Erik de Castro Lopo <[email protected]>
+-- 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

@@ -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"

http-proxy.cabal

@@ -75,6 +75,7 @@ Test-Suite testsuite
                    , random                  >= 1.1
                    , resourcet
                    , text
+                   , vault
                    , wai
                    , wai-conduit
                    , warp