ResourceT inside StateT

Stack.hs

{-# LANGUAGE OverloadedStrings #-} 
{-# LANGUAGE FlexibleInstances #-} 

module Database.CouchDB.Conduit.Mock.Stack (tests) where

import Test.Framework (testGroup, mutuallyExclusive, Test)
import Test.Framework.Providers.HUnit (testCase)
import Test.HUnit (Assertion, (@=?))

import Control.Monad.Trans.State

import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Class (lift)

import Data.Maybe (fromJust)
import qualified Data.ByteString as B

import Data.Conduit
import qualified Network.HTTP.Conduit as H
import qualified Network.HTTP.Types as HT

tests :: Test
tests = mutuallyExclusive $ testGroup "Mock StateT" [
    testCase "Connect" mock_stateT
    ]

data ConnState = ConnState (Maybe H.Manager)
    
class (ResourceIO m) => TMonad m where
    getMan :: m H.Manager
    putMan :: H.Manager -> m ()

instance (ResourceIO m) => 
    TMonad (StateT ConnState m) where
    getMan = do
        ConnState man <- get
        return $ fromJust man
    putMan man = put $ ConnState $ Just man

mock_stateT :: Assertion
mock_stateT = runSeq (ConnState Nothing) $ do
    res <- wrapFn "http://google.com"
    liftIO $ res @=? 200
    mapM_ (\_ -> do
        res' <- wrapFn "http://google.com"
        liftIO $ res' @=? 200) ([0..200] :: [Int])

runSeq :: (ResourceIO m) =>
     ConnState -> ResourceT (StateT ConnState m) a -> m a
runSeq env sq = flip evalStateT env . runResourceT $  do
            man <- H.newManager
            lift $ putMan man  -- Store state
            sq

wrapFn :: TMonad m =>
          String -> 
          ResourceT m Int
wrapFn p = do
    H.Response (HT.Status s _) _ _ <- getFn p
    return s

getFn :: TMonad m =>
         String -> 
         ResourceT m (H.Response (BufferedSource m B.ByteString))
getFn p = do
    man <- lift getMan
    req <- liftIO $ H.parseUrl p
    H.http req man