From d60bc1adf4af5a038432c35cde222654dfabf6dd Mon Sep 17 00:00:00 2001
From: "Myles C. Maxfield" <litherum@gmail.com>
Date: Mon, 23 Jan 2012 21:44:12 -0800
Subject: [PATCH] Adding a redirection chain field to Responses

---
 Network/HTTP/Conduit.hs          |    7 ++++---
 Network/HTTP/Conduit/Request.hs  |   24 +++++++++++++++++++++++-
 Network/HTTP/Conduit/Response.hs |    7 ++++---
 3 files changed, 31 insertions(+), 7 deletions(-)

diff --git a/Network/HTTP/Conduit.hs b/Network/HTTP/Conduit.hs
index 794a62a..879d5a8 100644
--- a/Network/HTTP/Conduit.hs
+++ b/Network/HTTP/Conduit.hs
@@ -147,7 +147,7 @@ http
     -> Manager
     -> ResourceT m (Response (C.Source m S.ByteString))
 http req0 manager = do
-    res@(Response status hs body) <-
+    res@(Response _ status hs body) <-
         if redirectCount req0 == 0
             then httpRaw req0 manager
             else go (redirectCount req0) req0
@@ -160,7 +160,7 @@ http req0 manager = do
   where
     go 0 _ = liftBase $ throwIO TooManyRedirects
     go count req = do
-        res@(Response (W.Status code _) hs _) <- httpRaw req manager
+        res@(Response uri (W.Status code _) hs _) <- httpRaw req manager
         case (300 <= code && code < 400, lookup "location" hs) of
             (True, Just l'') -> do
                 -- Prepend scheme, host and port if missing
@@ -192,7 +192,8 @@ http req0 manager = do
                                 then "GET"
                                 else method l
                         }
-                go (count - 1) req'
+                response <- go (count - 1) req'
+                return $ response {requestChain = (head uri) : (requestChain response)}
             _ -> return res
 
 -- | Get a 'Response' without any redirect following.
diff --git a/Network/HTTP/Conduit/Request.hs b/Network/HTTP/Conduit/Request.hs
index e6e8876..a777285 100644
--- a/Network/HTTP/Conduit/Request.hs
+++ b/Network/HTTP/Conduit/Request.hs
@@ -7,6 +7,7 @@ module Network.HTTP.Conduit.Request
     , ContentType
     , Proxy (..)
     , parseUrl
+    , unParseUrl
     , browserDecompress
     , HttpException (..)
     , alwaysDecompress
@@ -39,7 +40,7 @@ import qualified Network.HTTP.Types as W
 
 import Control.Exception (Exception, SomeException, toException)
 import Control.Failure (Failure (failure))
-import Codec.Binary.UTF8.String (encodeString)
+import Codec.Binary.UTF8.String (encode, encodeString)
 import qualified Data.CaseInsensitive as CI
 import qualified Data.ByteString.Base64 as B64
 
@@ -207,6 +208,27 @@ parseUrl2 full sec s = do
                 (readDec rest)
             x -> error $ "parseUrl1: this should never happen: " ++ show x
 
+unParseUrl :: Request m -> W.Ascii
+unParseUrl Request { secure = secure'
+                   , host = host'
+                   , port = port'
+                   , path = path'
+                   , queryString = querystring'
+                   } = S.concat
+  [ "http"
+  , if secure' then "s" else S.empty
+  , "://"
+  , host'
+  , case (secure', port') of
+      (True, 443) -> S.empty
+      (True, p) -> S.pack $ encode $ ":" ++ show p
+      (False, 80) -> S.empty
+      (False, p) -> S.pack $ encode $ ":" ++ show p
+  , path'
+  , "?"
+  , querystring'
+  ]
+
 data HttpException = StatusCodeException W.Status W.ResponseHeaders
                    | InvalidUrlException String String
                    | TooManyRedirects
diff --git a/Network/HTTP/Conduit/Response.hs b/Network/HTTP/Conduit/Response.hs
index 5c6fd23..c183e34 100644
--- a/Network/HTTP/Conduit/Response.hs
+++ b/Network/HTTP/Conduit/Response.hs
@@ -33,7 +33,8 @@ import Network.HTTP.Conduit.Chunk
 
 -- | A simple representation of the HTTP response created by 'lbsConsumer'.
 data Response body = Response
-    { statusCode :: W.Status
+    { requestChain :: [W.Ascii]
+    , statusCode :: W.Status
     , responseHeaders :: W.ResponseHeaders
     , responseBody :: body
     }
@@ -41,7 +42,7 @@ data Response body = Response
 
 -- | Since 1.1.2.
 instance Functor Response where
-    fmap f (Response status headers body) = Response status headers (f body)
+    fmap f res@(Response {responseBody = body}) = res {responseBody = (f body)}
 
 -- | Convert a 'Response' that has a 'C.Source' body to one with a lazy
 -- 'L.ByteString' body.
@@ -90,7 +91,7 @@ getResponse connRelease req@(Request {..}) bsrc = do
                             else bsrc'
                 return $ addCleanup cleanup bsrc''
 
-    return $ Response s hs' body
+    return $ Response [unParseUrl req] s hs' body
 
 -- | Add some cleanup code to the given 'C.Source'. General purpose
 -- function, could be included in conduit itself.
-- 
1.7.7.4