Allow CONNECT requests to be modified

Previously (as pointed out by @jcpetruzza in github issue erikd#6), the `proxyRequestModifier` was only being applied *after* the case analysis on the connect method, meaning that `CONNECT` request could not be modified. This has now been fixed by applying `proxyRequestModifier` first. Closes: erikd#6
restaumatic · May 4, 2016 · 5b1cf4b · 5b1cf4b
1 parent f94b0f0
commit 5b1cf4b
Showing 1 changed file with 29 additions and 28 deletions.
diff --git a/Network/HTTP/Proxy.hs b/Network/HTTP/Proxy.hs
@@ -46,7 +46,7 @@ import Data.Conduit (Flush (..), Sink, Source, ($$), mapOutput, yield)
 import Data.Conduit.Network
 import Data.Monoid
 import Network.Socket
-import Network.Wai.Conduit hiding (Request)
+import Network.Wai.Conduit hiding (Request, requestMethod)
 
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.ByteString.Lazy.Char8 as LBS
@@ -148,36 +148,37 @@ defaultExceptionResponse e =
 -- -----------------------------------------------------------------------------
 
 proxyApp :: Settings -> HC.Manager -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived
-proxyApp settings mgr wreq respond
-    | Wai.requestMethod wreq == "CONNECT" =
-            respond $ responseRawSource (handleConnect wreq)
-                    (Wai.responseLBS HT.status500 [("Content-Type", "text/plain")] "No support for responseRaw")
-    | otherwise =
-        either respond (doUpstreamRequest settings mgr respond . waiRequest wreq) =<< proxyRequestModifier settings (proxyRequest wreq)
+proxyApp settings mgr wreq respond = do
+    mwreq <- proxyRequestModifier settings $ proxyRequest wreq
+    either respond (doUpstreamRequest settings mgr respond . waiRequest wreq) mwreq
 
 
 doUpstreamRequest :: Settings -> HC.Manager -> (Wai.Response -> IO Wai.ResponseReceived) -> Wai.Request -> IO Wai.ResponseReceived
-doUpstreamRequest settings mgr respond mwreq = do
-            hreq0 <- HC.parseUrl $ BS.unpack (Wai.rawPathInfo mwreq <> Wai.rawQueryString mwreq)
-            let hreq = hreq0
-                    { HC.method = Wai.requestMethod mwreq
-                    , HC.requestHeaders = filter dropRequestHeader $ Wai.requestHeaders mwreq
-                    , HC.redirectCount = 0 -- Always pass redirects back to the client.
-                    , HC.requestBody =
-                        case Wai.requestBodyLength mwreq of
-                            Wai.ChunkedBody ->
-                                HC.requestBodySourceChunkedIO (sourceRequestBody mwreq)
-                            Wai.KnownLength l ->
-                                HC.requestBodySourceIO (fromIntegral l) (sourceRequestBody mwreq)
-                    , HC.decompress = const True
-                    , HC.checkStatus = \_ _ _ -> Nothing
-                    }
-            handle (respond . errorResponse) $
-                HC.withResponse hreq mgr $ \res -> do
-                    let body = mapOutput (Chunk . fromByteString) . HCC.bodyReaderSource $ HC.responseBody res
-                        headers = (CI.mk "X-Via-Proxy", "yes") : filter dropResponseHeader (HC.responseHeaders res)
-                    respond $ responseSource (HC.responseStatus res) headers body
-  where
+doUpstreamRequest settings mgr respond mwreq
+    | Wai.requestMethod mwreq == "CONNECT" =
+        respond $ responseRawSource (handleConnect mwreq)
+                    (Wai.responseLBS HT.status500 [("Content-Type", "text/plain")] "No support for responseRaw")
+    | otherwise = do
+        hreq0 <- HC.parseUrl $ BS.unpack (Wai.rawPathInfo mwreq <> Wai.rawQueryString mwreq)
+        let hreq = hreq0
+                { HC.method = Wai.requestMethod mwreq
+                , HC.requestHeaders = filter dropRequestHeader $ Wai.requestHeaders mwreq
+                , HC.redirectCount = 0 -- Always pass redirects back to the client.
+                , HC.requestBody =
+                    case Wai.requestBodyLength mwreq of
+                        Wai.ChunkedBody ->
+                            HC.requestBodySourceChunkedIO (sourceRequestBody mwreq)
+                        Wai.KnownLength l ->
+                            HC.requestBodySourceIO (fromIntegral l) (sourceRequestBody mwreq)
+                , HC.decompress = const True
+                , HC.checkStatus = \_ _ _ -> Nothing
+                }
+        handle (respond . errorResponse) $
+            HC.withResponse hreq mgr $ \res -> do
+                let body = mapOutput (Chunk . fromByteString) . HCC.bodyReaderSource $ HC.responseBody res
+                    headers = (CI.mk "X-Via-Proxy", "yes") : filter dropResponseHeader (HC.responseHeaders res)
+                respond $ responseSource (HC.responseStatus res) headers body
+      where
         dropRequestHeader (k, _) = k `notElem`
             [ "content-encoding"
             , "content-length"