module Database.HDBC.Session (
withConnectionCommit,
withConnectionIO, withConnectionIO',
withConnection,
showSqlError, handleSqlError'
) 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
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 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)
withConnectionIO :: IConnection conn
=> IO conn
-> (conn -> IO a)
-> IO a
withConnectionIO = withConnection bracket id
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
withConnectionIO' :: IConnection conn
=> IO conn
-> (conn -> IO a)
-> IO a
withConnectionIO' connect body = withConnectionIO connect $ handleSqlError' . body