Using IORef versus using Control.Monad.Trans.Control

I wanted to test the redirect chain that my application saw when making a request through Network.HTTP.Client

.

This functionality is not built into Network.HTTP.Client

, although there are some references to the idea in the documentation , including (non-working) sample code. It seemed like it could be done mainly by reusing almost entirely existing fragments, so I decided to give it a try.

While doing some search queries it looked like Control.Monad.Trans.Control

it might satisfy my need to pile up queries on the stack StateT [Request] IO

, however, after a few days of unsuccessful trick with it, I realized that I could do what I wanted much easier if I only used IORef

--- but I'm still wondering if I missed some clever way to do this without resorting to mutability.

My working procedure IORef

is 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 (despite the fact that it does not accumulate requests), the procedure based on Control.Monad.Trans.Control

looked like this:

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 cannot return the updated state from the function handleRedirects

because it is called from within httpRedirect

--- and as a consequence I never get the opportunity to use restoreM on the updated value. I do not understand how I can successfully combine this stuff, but I suspect it is just a failure of imagination or understanding in my part.

To keep things as simple as possible, here is 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)