runSqlConn that works nicely with ExceptT et al

runSqlConn.hs

#!/usr/bin/env stack
-- stack --resolver nightly-2015-10-08 runghc --package monadio-unwrappable-0.3
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}

import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.IO.Class
import Control.Monad.Trans.Control
import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader
import Control.Exception.Lifted (onException)
import Control.Exception (try, SomeException)
import Control.Monad.Base

import Control.Monad.IO.MonadIOException
import Control.Monad.IO.Unwrappable

type SqlPersistT = ReaderT Int

connRollback :: a -> b -> IO ()
connRollback _ _ = putStrLn "rollback"

connCommit :: a -> b -> IO ()
connCommit _ _ = putStrLn "commit"

connBegin :: a -> b -> IO ()
connBegin _ _ = putStrLn "begin"

getStmtConn :: a
getStmtConn = undefined

runSqlConn :: MonadBaseControl IO m => SqlPersistT m a -> Int -> m a
runSqlConn r conn = do
    let getter = getStmtConn conn
    liftBase $ connBegin conn getter
    x <- onException
            (runReaderT r conn)
            (liftBase $ connRollback conn getter)
    liftBase $ connCommit conn getter
    return x

finally :: MonadIOUnwrappable m => m a -> IO b -> m a
finally act cleanup = bracketIO (return ()) (const cleanup) (const act)

runSqlConn' :: (MonadIOUnwrappable m, MonadBaseControl IO m) => SqlPersistT m a -> Int -> m a
runSqlConn' r conn = do
    let getter = getStmtConn conn
    liftBase $ connBegin conn getter
    (onException
            (runReaderT r conn)
            (liftBase $ connRollback conn getter)) `finally` connCommit conn getter

t1 :: SqlPersistT (ExceptT String IO) Int
t1 = lift $ throwE "err"

t2 :: SqlPersistT (ExceptT String IO) Int
t2 =  return $ error "err"

t3 :: SqlPersistT (ExceptT String IO) Int
t3 =  lift $ error "err"

main = do
    putStrLn "Original behaviour:"
    runExceptT $ runSqlConn t1 1
    runExceptT $ runSqlConn t2 1
    try $ runExceptT (runSqlConn t3 1 ) :: IO (Either SomeException (Either String Int))
    putStrLn "New behaviour:"
    runExceptT $ runSqlConn' t1 1
    runExceptT $ runSqlConn' t2 1
    try $ runExceptT (runSqlConn' t3 1 ) :: IO (Either SomeException (Either String Int))

{-
Original behaviour:
begin
begin
commit
begin
rollback
New behaviour:
begin
commit
begin
commit
begin
rollback
commit
-}

------------------------------------------------------------------------------
-- This instance is missing from monadio-unwrappable
newtype EitherChain a b c = EitherChain (a (Either b c))
instance (MonadIO m, MonadIOUnwrappable m) => MonadIOUnwrappable (ExceptT e m) where
  type MonadIOWrapType (ExceptT e m) = EitherChain (MonadIOWrapType m) e
  type MonadIOStateType (ExceptT e m) = MonadIOStateType m
  unwrapState = lift (unwrapState)
  unwrapMonadIO s m = liftM EitherChain $ unwrapMonadIO s (runExceptT m)
  rewrapMonadIO s (EitherChain v) = ExceptT (rewrapMonadIO s v)