Permalink
Browse files

Pass on content-length request header

  • Loading branch information...
1 parent 3cc1ac2 commit dbc7dd92fb1ab66ebe1f47bd7122a80dd4d9263b @snoyberg snoyberg committed Apr 10, 2013
Showing with 40 additions and 1 deletion.
  1. +13 −1 Network/HTTP/ReverseProxy.hs
  2. +27 −0 test/main.hs
@@ -146,7 +146,7 @@ waiProxyToSettings getDest wps manager req = do
, HC.path = WAI.rawPathInfo req
, HC.queryString = WAI.rawQueryString req
, HC.requestHeaders = filter (\(key, _) -> not $ key `member` strippedHeaders) $ WAI.requestHeaders req
- , HC.requestBody = HC.RequestBodySourceChunked $ mapOutput fromByteString $ WAI.requestBody req
+ , HC.requestBody = body
, HC.redirectCount = 0
#if MIN_VERSION_http_conduit(1, 9, 0)
, HC.checkStatus = \_ _ _ -> Nothing
@@ -155,6 +155,18 @@ waiProxyToSettings getDest wps manager req = do
#endif
, HC.responseTimeout = wpsTimeout wps
}
+ bodySrc = mapOutput fromByteString $ WAI.requestBody req
+ bodyChunked = HC.RequestBodySourceChunked bodySrc
+#if MIN_VERSION_wai(1, 4, 0)
+ body =
+ case WAI.requestBodyLength req of
+ WAI.KnownLength i -> HC.RequestBodySource
+ (fromIntegral i)
+ bodySrc
+ WAI.ChunkedBody -> bodyChunked
+#else
+ body = bodyChunked
+#endif
ex <- try $ HC.http req' manager
case ex of
Left e -> wpsOnExc wps e req
View
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
import Blaze.ByteString.Builder (fromByteString)
@@ -7,6 +8,8 @@ import Control.Exception (IOException, bracket, onException,
try)
import Control.Monad (forever)
import Control.Monad.IO.Class (liftIO)
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy.Char8 as L8
import Data.Conduit (Flush (..), await, runResourceT,
yield, ($$+-))
@@ -95,6 +98,30 @@ main = hspec $ do
res <- HC.http req manager
HC.responseBody res $$+- await
mbs `shouldBe` Just (Just "hello")
+#if MIN_VERSION_wai(1, 4, 0)
+ it "passes on body length" $
+ let app req = return $ responseLBS
+ status200
+ [("uplength", show' $ Network.Wai.requestBodyLength req)]
+ ""
+ body = "some body"
+ show' Network.Wai.ChunkedBody = "chunked"
+ show' (Network.Wai.KnownLength i) = S8.pack $ show i
+ in withMan $ \manager ->
+ withWApp app $ \port1 ->
+ withWApp (waiProxyTo (const $ return $ Right $ ProxyDest "127.0.0.1" port1) defaultOnExc manager) $ \port2 -> do
+ req' <- HC.parseUrl $ "http://127.0.0.1:" ++ show port2
+ let req = req'
+ { HC.requestBody = HC.RequestBodyBS body
+ }
+ mlen <- runResourceT $ do
+ res <- HC.http req manager
+ return $ lookup "uplength" $ HC.responseHeaders res
+ mlen `shouldBe` Just (show'
+ $ Network.Wai.KnownLength
+ $ fromIntegral
+ $ S.length body)
+#endif
describe "waiToRaw" $ do
it "works" $ do
let content = "waiToRaw"

0 comments on commit dbc7dd9

Please sign in to comment.