haskell - IORef の使用と Control.Monad.Trans.Control の使用

Question

経由でリクエストを行ったときにアプリケーションが見たリダイレクトのチェーンを調べられるようにしたかったのNetwork.HTTP.Clientです。

この機能は には組み込まれていませんが、(動作していない) サンプル コードを含むドキュメント のアイデアへの参照Network.HTTP.Clientがいくつかあります。既存の部品をほぼすべて再利用できるように思えたので、試してみることにしました。

グーグルで調べてみるとControl.Monad.Trans.Control、スタック内にリクエストを蓄積するという私のニーズを満たすことができるようStateT [Request] IOに思えましたが、数日間試してみてうまくいかなかった後、 ---を使用したばかりIORefですが、可変性に頼らずにこれを行うための巧妙な方法を見逃していないかどうか、まだ興味があります。

私の作業IORefベースのルーチンは次のようになります。

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

私の非動作 (リクエストが蓄積されないという点で)Control.Monad.Trans.Controlベースのルーチンは次のようになりました。

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

問題は、私が見ているように、更新された状態をhandleRedirects関数から返すことができないことです。これは、内部から呼び出されるためですhttpRedirect。結果として、更新された値で restoreM を使用する機会がありません。どうすればこれらのものをうまく組み合わせることができるかわかりませんが、それは私の想像力や理解力の単なる失敗だと思います.

できるだけ簡単にするために、各バージョンで使用できるテスト ハーネスを次に示します。

#!/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)