{-# 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 :: SqlError -> String
showSqlError SqlError
se = [String] -> String
unlines
[String
"seState: '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SqlError -> String
seState SqlError
se String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'",
String
"seNativeError: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (SqlError -> Int
seNativeError SqlError
se),
String
"seErrorMsg: '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SqlError -> String
seErrorMsg SqlError
se String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"]
handleSqlError' :: IO a -> IO a
handleSqlError' :: forall a. IO a -> IO a
handleSqlError' = (SqlError -> IO a) -> IO a -> IO a
forall a. (SqlError -> IO a) -> IO a -> IO a
handleSql (String -> IO a
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO a) -> (SqlError -> String) -> SqlError -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
reformat (String -> String) -> (SqlError -> String) -> SqlError -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlError -> String
showSqlError) where
reformat :: String -> String
reformat = (String
"SQL error: \n" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
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 :: forall (m :: * -> *) conn a.
(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 forall c. m c -> (c -> m ()) -> (c -> m a) -> m a
bracket_ forall b. IO b -> m b
lift IO conn
connect conn -> m a
tbody =
m conn -> (conn -> m ()) -> (conn -> m a) -> m a
forall c. m c -> (c -> m ()) -> (c -> m a) -> m a
bracket_ (IO conn -> m conn
forall b. IO b -> m b
lift IO conn
open) (IO () -> m ()
forall b. IO b -> m b
lift (IO () -> m ()) -> (conn -> IO ()) -> conn -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. conn -> IO ()
forall conn. IConnection conn => conn -> IO ()
close) conn -> m a
bodyWithRollback
where
open :: IO conn
open = IO conn -> IO conn
forall a. IO a -> IO a
handleSqlError' IO conn
connect
close :: IConnection conn => conn -> IO ()
close :: forall conn. IConnection conn => conn -> IO ()
close = IO () -> IO ()
forall a. IO a -> IO a
handleSqlError' (IO () -> IO ()) -> (conn -> IO ()) -> conn -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. conn -> IO ()
forall conn. IConnection conn => conn -> IO ()
HDBC.disconnect
bodyWithRollback :: conn -> m a
bodyWithRollback conn
conn =
m () -> (() -> m ()) -> (() -> m a) -> m a
forall c. m c -> (c -> m ()) -> (c -> m a) -> m a
bracket_
(() -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
(m () -> () -> m ()
forall a b. a -> b -> a
const (m () -> () -> m ()) -> (IO () -> m ()) -> IO () -> () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> m ()
forall b. IO b -> m b
lift (IO () -> m ()) -> (IO () -> IO ()) -> IO () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ()
forall a. IO a -> IO a
handleSqlError' (IO () -> () -> m ()) -> IO () -> () -> m ()
forall a b. (a -> b) -> a -> b
$ conn -> IO ()
forall conn. IConnection conn => conn -> IO ()
HDBC.rollback conn
conn)
(m a -> () -> m a
forall a b. a -> b -> a
const (m a -> () -> m a) -> m a -> () -> m a
forall a b. (a -> b) -> a -> b
$ conn -> m a
tbody conn
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 :: forall (m :: * -> *) conn a.
(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 = (forall c. m c -> (c -> m ()) -> (c -> m a) -> m a)
-> (forall b. IO b -> m b) -> IO conn -> (conn -> m a) -> m a
forall (m :: * -> *) conn a.
(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
withConnectionIO_ :: IConnection conn
=> IO conn
-> (conn -> IO a)
-> IO a
withConnectionIO_ :: forall conn a.
IConnection conn =>
IO conn -> (conn -> IO a) -> IO a
withConnectionIO_ = (forall c. IO c -> (c -> IO ()) -> (c -> IO a) -> IO a)
-> (forall a. IO a -> IO a) -> IO conn -> (conn -> IO a) -> IO a
forall (m :: * -> *) conn a.
(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 IO c -> (c -> IO ()) -> (c -> IO a) -> IO a
forall c. IO c -> (c -> IO ()) -> (c -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO b -> IO b
forall a. a -> a
forall a. IO a -> IO a
id
withConnectionIO :: IConnection conn
=> IO conn
-> (conn -> IO a)
-> IO a
withConnectionIO :: forall conn a.
IConnection conn =>
IO conn -> (conn -> IO a) -> IO a
withConnectionIO IO conn
connect conn -> IO a
body = IO conn -> (conn -> IO a) -> IO a
forall conn a.
IConnection conn =>
IO conn -> (conn -> IO a) -> IO a
withConnectionIO_ IO conn
connect ((conn -> IO a) -> IO a) -> (conn -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ IO a -> IO a
forall a. IO a -> IO a
handleSqlError' (IO a -> IO a) -> (conn -> IO a) -> conn -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. conn -> IO a
body
{-# DEPRECATED withConnectionIO' "use 'withConnectionIO' instead of this." #-}
withConnectionIO' :: IConnection conn
=> IO conn
-> (conn -> IO a)
-> IO a
withConnectionIO' :: forall conn a.
IConnection conn =>
IO conn -> (conn -> IO a) -> IO a
withConnectionIO' = IO conn -> (conn -> IO a) -> IO a
forall conn a.
IConnection conn =>
IO conn -> (conn -> IO a) -> IO a
withConnectionIO
transaction :: IConnection conn
=> IO conn
-> (conn -> IO a)
-> IO a
transaction :: forall conn a.
IConnection conn =>
IO conn -> (conn -> IO a) -> IO a
transaction IO conn
conn conn -> IO a
body =
IO conn -> (conn -> IO a) -> IO a
forall conn a.
IConnection conn =>
IO conn -> (conn -> IO a) -> IO a
withConnectionIO IO conn
conn ((conn -> IO a) -> IO a) -> (conn -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \conn
c -> do
a
x <- conn -> IO a
body conn
c
conn -> IO ()
forall conn. IConnection conn => conn -> IO ()
HDBC.commit conn
c
a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
{-# DEPRECATED withConnectionCommit "use 'transaction' instead of this." #-}
withConnectionCommit :: IConnection conn
=> IO conn
-> (conn -> IO a)
-> IO a
withConnectionCommit :: forall conn a.
IConnection conn =>
IO conn -> (conn -> IO a) -> IO a
withConnectionCommit IO conn
conn conn -> IO a
body =
IO conn -> (conn -> IO a) -> IO a
forall conn a.
IConnection conn =>
IO conn -> (conn -> IO a) -> IO a
withConnectionIO_ IO conn
conn ((conn -> IO a) -> IO a) -> (conn -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \conn
c -> do
a
x <- conn -> IO a
body conn
c
conn -> IO ()
forall conn. IConnection conn => conn -> IO ()
HDBC.commit conn
c
a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x