From 3ee5352dc72a56f3838de8b3e494bf0bbf3d35cd Mon Sep 17 00:00:00 2001
From: "Myles C. Maxfield" <litherum@gmail.com>
Date: Sat, 28 Jan 2012 10:32:24 -0800
Subject: [PATCH] Exporing a function which allows callers to pull a new
 request from a redirection response

---
 Network/HTTP/Conduit.hs          |   40 +++--------------------------
 Network/HTTP/Conduit/Response.hs |   51 ++++++++++++++++++++++++++++++++++++++
 2 files changed, 56 insertions(+), 35 deletions(-)

diff --git a/Network/HTTP/Conduit.hs b/Network/HTTP/Conduit.hs
index 794a62a..fb79ddf 100644
--- a/Network/HTTP/Conduit.hs
+++ b/Network/HTTP/Conduit.hs
@@ -88,6 +88,7 @@ module Network.HTTP.Conduit
     , applyBasicAuth
     , addProxy
     , lbsResponse
+    , getRedirectedRequest
       -- * Decompression predicates
     , alwaysDecompress
     , browserDecompress
@@ -103,7 +104,6 @@ module Network.HTTP.Conduit
 
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Lazy as L
-import qualified Data.ByteString.Char8 as S8
 
 import qualified Network.HTTP.Types as W
 import Data.Default (def)
@@ -160,40 +160,10 @@ http req0 manager = do
   where
     go 0 _ = liftBase $ throwIO TooManyRedirects
     go count req = do
-        res@(Response (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
-                let l' =
-                        case S8.uncons l'' of
-                            Just ('/', _) -> concat
-                                [ "http"
-                                , if secure req then "s" else ""
-                                , "://"
-                                , S8.unpack $ host req
-                                , ":"
-                                , show $ port req
-                                , S8.unpack l''
-                                ]
-                            _ -> S8.unpack l''
-                l <- liftBase $ parseUrl l'
-                let req' = req
-                        { host = host l
-                        , port = port l
-                        , secure = secure l
-                        , path = path l
-                        , queryString = queryString l
-                        , method =
-                            -- According to the spec, this should *only* be for
-                            -- status code 303. However, almost all clients
-                            -- mistakenly implement it for 302 as well. So we
-                            -- have to be wrong like everyone else...
-                            if code == 302 || code == 303
-                                then "GET"
-                                else method l
-                        }
-                go (count - 1) req'
-            _ -> return res
+        res <- httpRaw req manager
+        case getRedirectedRequest req (responseHeaders res) (W.statusCode (statusCode res)) of
+            Just req' -> go (count - 1) req'
+            Nothing -> return res
 
 -- | Get a 'Response' without any redirect following.
 httpRaw
diff --git a/Network/HTTP/Conduit/Response.hs b/Network/HTTP/Conduit/Response.hs
index 5c6fd23..c54cf1b 100644
--- a/Network/HTTP/Conduit/Response.hs
+++ b/Network/HTTP/Conduit/Response.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Network.HTTP.Conduit.Response
     ( Response (..)
+    , getRedirectedRequest
     , getResponse
     , lbsResponse
     ) where
@@ -17,6 +18,8 @@ import qualified Data.ByteString.Lazy as L
 
 import qualified Data.CaseInsensitive as CI
 
+import Data.Maybe
+
 import Control.Monad.Trans.Resource (ResourceT, ResourceIO)
 import qualified Data.Conduit as C
 import qualified Data.Conduit.Zlib as CZ
@@ -43,6 +46,54 @@ data Response body = Response
 instance Functor Response where
     fmap f (Response status headers body) = Response status headers (f body)
 
+-- | If a request is a redirection (status code 3xx) this function will create
+-- a new request from the old request, the server headers returned with the
+-- redirection, and the redirection code itself. This function returns 'Nothing'
+-- if the code is not a 3xx, there is no 'location' header included, or if the
+-- redirected response couldn't be parsed with 'parseUrl'.
+--
+-- If a user of this library wants to know the url chain that results from a
+-- specific request, that user has to re-implement the redirect-following logic
+-- themselves. An example of that might look like this:
+--
+-- > myHttp req man = E.catch (C.runResourceT $ http req' man >> return [req'])
+-- >                    (\ (StatusCodeException status headers) -> do
+-- >                        l <- myHttp (fromJust $ nextRequest status headers) man
+-- >                        return $ req' : l)
+-- >     where req' = req { redirectCount = 0 }
+-- >           nextRequest status headers = getRedirectedRequest req' headers $ W.statusCode status
+getRedirectedRequest :: Request m -> W.ResponseHeaders -> Int -> Maybe (Request m)
+getRedirectedRequest req hs code
+    | 300 <= code && code < 400 = do
+        l' <- lookup "location" hs
+        l <- parseUrl $ case S8.uncons l' of
+                Just ('/', _) -> concat
+                    [ "http"
+                    , if secure req then "s" else ""
+                    , "://"
+                    , S8.unpack $ host req
+                    , ":"
+                    , show $ port req
+                    , S8.unpack l'
+                    ]
+                _ -> S8.unpack l'
+        return req
+          { host = host l
+          , port = port l
+          , secure = secure l
+          , path = path l
+          , queryString = queryString l
+          , method =
+              -- According to the spec, this should *only* be for
+              -- status code 303. However, almost all clients
+              -- mistakenly implement it for 302 as well. So we
+              -- have to be wrong like everyone else...
+              if code == 302 || code == 303
+                  then "GET"
+                  else method l
+          }
+    | otherwise = Nothing
+
 -- | Convert a 'Response' that has a 'C.Source' body to one with a lazy
 -- 'L.ByteString' body.
 lbsResponse :: C.Resource m
-- 
1.7.7.4