X-Request-URL #63

snoyberg · Jul 31, 2014 · 4a9b66b · 4a9b66b
1 parent da08c2d
commit 4a9b66b
Show file tree

Hide file tree

Showing 2 changed files with 12 additions and 6 deletions.
diff --git a/http-client/Network/HTTP/Client/Core.hs b/http-client/Network/HTTP/Client/Core.hs
@@ -8,7 +8,6 @@ module Network.HTTP.Client.Core
     , httpRaw
     , responseOpen
     , responseClose
-    , applyCheckStatus
     , httpRedirect
     ) where
 
@@ -150,7 +149,7 @@ responseOpen req0 manager = mWrapIOException manager $ do
         if redirectCount req0 == 0
             then httpRaw req0 manager
             else go (redirectCount req0) req0
-    maybe (return res) throwIO =<< applyCheckStatus (checkStatus req0) res
+    maybe (return res) throwIO =<< applyCheckStatus req0 (checkStatus req0) res
   where
     go count req' = httpRedirect
       count
@@ -162,10 +161,11 @@ responseOpen req0 manager = mWrapIOException manager $ do
 
 -- | Apply 'Request'\'s 'checkStatus' and return resulting exception if any.
 applyCheckStatus
-    :: (Status -> ResponseHeaders -> CookieJar -> Maybe SomeException)
+    :: Request
+    -> (Status -> ResponseHeaders -> CookieJar -> Maybe SomeException)
     -> Response BodyReader
     -> IO (Maybe SomeException)
-applyCheckStatus checkStatus' res =
+applyCheckStatus req checkStatus' res =
     case checkStatus' (responseStatus res) (responseHeaders res) (responseCookieJar res) of
         Nothing -> return Nothing
         Just exc -> do
@@ -174,7 +174,13 @@ applyCheckStatus checkStatus' res =
                     Just (StatusCodeException s hdrs cookie_jar) -> do
                         lbs <- brReadSome (responseBody res) 1024
                         return $ toException $ StatusCodeException s (hdrs ++
-                            [("X-Response-Body-Start", toStrict' lbs)]) cookie_jar
+                            [ ("X-Response-Body-Start", toStrict' lbs)
+                            , ("X-Request-URL", S.concat
+                                [ method req
+                                , " "
+                                , S8.pack $ show $ getUri req
+                                ])
+                            ]) cookie_jar
                     _ -> return exc
             responseClose res
             return (Just exc')

diff --git a/http-client/http-client.cabal b/http-client/http-client.cabal
@@ -1,5 +1,5 @@
 name:                http-client
-version:             0.3.6
+version:             0.3.6.1
 synopsis:            An HTTP client engine, intended as a base layer for more user-friendly packages.
 description:         This codebase has been refactored from http-conduit.
 homepage:            https://github.com/snoyberg/http-client