{-# LANGUAGE Rank2Types #-}
module Database.HDBC.Session (
transaction,
withConnectionIO, withConnectionIO_,
bracketConnection,
showSqlError, handleSqlError',
withConnection,
withConnectionIO',
withConnectionCommit,
) where
import Database.HDBC (IConnection, handleSql,
SqlError(seState, seNativeError, seErrorMsg))
import qualified Database.HDBC as HDBC
import Control.Exception (bracket)
showSqlError :: SqlError -> String
showSqlError se = unlines
["seState: '" ++ seState se ++ "'",
"seNativeError: " ++ show (seNativeError se),
"seErrorMsg: '" ++ seErrorMsg se ++ "'"]
handleSqlError' :: IO a -> IO a
handleSqlError' = handleSql (fail . reformat . showSqlError) where
reformat = ("SQL error: \n" ++) . unlines . map (" " ++) . lines
bracketConnection :: (Monad m, IConnection conn)
=> (forall c. m c -> (c -> m ()) -> (c -> m a) -> m a)
-> (forall b. IO b -> m b)
-> IO conn
-> (conn -> m a)
-> m a
bracketConnection bracket_ lift connect tbody =
bracket_ (lift open) (lift . close) bodyWithRollback
where
open = handleSqlError' connect
close :: IConnection conn => conn -> IO ()
close = handleSqlError' . HDBC.disconnect
bodyWithRollback conn =
bracket_
(return ())
(const . lift . handleSqlError' $ HDBC.rollback conn)
(const $ tbody conn)
{-# DEPRECATED withConnection "use 'bracketConnection' instead of this." #-}
withConnection :: (Monad m, IConnection conn)
=> (forall c. m c -> (c -> m ()) -> (c -> m a) -> m a)
-> (forall b. IO b -> m b)
-> IO conn
-> (conn -> m a)
-> m a
withConnection = bracketConnection
withConnectionIO_ :: IConnection conn
=> IO conn
-> (conn -> IO a)
-> IO a
withConnectionIO_ = bracketConnection bracket id
withConnectionIO :: IConnection conn
=> IO conn
-> (conn -> IO a)
-> IO a
withConnectionIO connect body = withConnectionIO_ connect $ handleSqlError' . body
{-# DEPRECATED withConnectionIO' "use 'withConnectionIO' instead of this." #-}
withConnectionIO' :: IConnection conn
=> IO conn
-> (conn -> IO a)
-> IO a
withConnectionIO' = withConnectionIO
transaction :: IConnection conn
=> IO conn
-> (conn -> IO a)
-> IO a
transaction conn body =
withConnectionIO conn $ \c -> do
x <- body c
HDBC.commit c
return x
{-# DEPRECATED withConnectionCommit "use 'transaction' instead of this." #-}
withConnectionCommit :: IConnection conn
=> IO conn
-> (conn -> IO a)
-> IO a
withConnectionCommit conn body =
withConnectionIO_ conn $ \c -> do
x <- body c
HDBC.commit c
return x