Using an IORef versus using Control.Monad.Trans.Control

Question

I wanted to be able to examine the chain of redirects that my application was seeing when making a request via Network.HTTP.Client.

That functionality is not built into Network.HTTP.Client, though there are some references to the idea in the documentation, including (non-working) sample code. It seemed like it could be done mostly reusing almost entirely existing pieces, so I decided to try.

In doing some googling, it sounded like Control.Monad.Trans.Control might be able to serve my need to accumulate the requests within a StateT [Request] IO stack, however, after a couple of days of unsuccessfully poking around with it, I realized that I could do what I wanted much more easily if I just used an IORef---but I'm still curious if I've missed some clever way to do this without resorting to mutability.

My working, IORef-based routine looks like:

responseOpenWithRedirects :: Request -> Manager -> IO (Response BodyReader, [Request])
responseOpenWithRedirects req man = do
  mWrapIOException man $ do
    requestHistory <- newIORef []
    let
      handleRedirects localReq = do
        res <- httpRaw localReq {redirectCount = 0} man
        modifyIORef' requestHistory (localReq :)
        return (res, getRedirectedRequest localReq (responseHeaders res) (responseCookieJar res) (statusCode (responseStatus res)))
    res <- httpRedirect (redirectCount req) handleRedirects req
    redirectRequests <- readIORef requestHistory
    maybe (return (res, redirectRequests)) throwIO =<< applyCheckStatus (checkStatus req) res

My non-working (in that it does not accumulate requests), Control.Monad.Trans.Control-based routine looked like:

responseOpenWithRedirects :: Request -> Manager -> IO (Response BodyReader, [Request])
responseOpenWithRedirects req man =
  mWrapIOException man $ do
    let
       handleRedirects run localReq = do
         res <- httpRaw localReq {redirectCount = 0} man
         run (modify (\rs -> localReq : rs))
         return (res, getRedirectedRequest localReq (responseHeaders res) (responseCookieJar res) (statusCode (responseStatus res)))
    (res, redirectRequests) <- flip runStateT [] $ liftBaseWith $ \run -> httpRedirect (redirectCount req) (handleRedirects run) req
    maybe (return (res, redirectRequests)) throwIO =<< applyCheckStatus (checkStatus req) res

The problem, as I see it, is that I can't return the updated state from the handleRedirects function, because that is called from within httpRedirect---and as a consequence, I never get the chance to use restoreM on the updated value. I'm failing to see how I can combine this stuff successfully, but I suspect that's just a failure of imagination or understanding in my part.

To make things as simple as possible, here's a test harness you can use with each version:

#!/usr/bin/runghc

import Control.Exception
import Control.Monad.Trans.Control
import Control.Monad.Trans.State
import Data.IORef
import Data.ByteString.Lazy
import Network.HTTP.Client.Internal
import Network.HTTP.Types

main :: IO (Response ByteString, [Request])
main = do
  manager <- newManager defaultManagerSettings
  request <- parseUrl "http://feeds.feedburner.com/oreilly/newbooks"
  withResponseAndRedirects request manager $ \(res, reqs) -> do
    bss <- brConsume $ responseBody res
    return (res { responseBody = fromChunks bss }, reqs)

withResponseAndRedirects :: Request -> Manager -> ((Response BodyReader, [Request]) -> IO a) -> IO a
withResponseAndRedirects req man =
  bracket (responseOpenWithRedirects req man) (responseClose . fst)