module Snap.Snaplet.Hdbc (
HdbcSnaplet(..)
, HasHdbc(..)
, HdbcIO
, HdbcPool
, Row
, hdbcInit
, query
, query'
, clone
, commit
, dbServerVer
, dbTransactionSupport
, describeTable
, disconnect
, getTables
, hdbcClientVer
, hdbcDriverName
, prepare
, proxiedClientName
, proxiedClientVer
, quickQuery
, quickQuery'
, rollback
, run
, runRaw
, sRun
, withHdbc
, withHdbc'
, withTransaction
, withTransaction'
, SqlValue(..)
, HDBC.toSql
, HDBC.fromSql
, HDBC.safeFromSql
, HDBC.nToSql
, HDBC.iToSql
, HDBC.posixToSql
, HDBC.withWConn
, Statement(..)
, HDBC.sExecute
, HDBC.sExecuteMany
, HDBC.fetchRowAL
, HDBC.fetchRowMap
, HDBC.sFetchRow
, HDBC.fetchAllRows
, HDBC.fetchAllRows'
, HDBC.fetchAllRowsAL
, HDBC.fetchAllRowsAL'
, HDBC.fetchAllRowsMap
, HDBC.fetchAllRowsMap'
, HDBC.sFetchAllRows
, HDBC.sFetchAllRows'
, SqlError(..)
, HDBC.throwSqlError
, HDBC.catchSql
, HDBC.handleSql
, HDBC.sqlExceptions
, HDBC.handleSqlError
, module Database.HDBC.ColTypes
) where
import Prelude hiding (catch)
import Control.Concurrent.MVar
import Data.Map (Map)
import Data.Pool
import qualified Database.HDBC as HDBC
import Database.HDBC (IConnection(), SqlValue, SqlError, Statement)
import Database.HDBC.ColTypes
import Snap.Snaplet
import Snap.Snaplet.Hdbc.Types
#if MIN_VERSION_monad_control(0,3,0)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Base
import Control.Exception.Lifted
#else
import Control.Monad.IO.Control (MonadControlIO(..))
import Control.Monad.IO.Class (liftIO)
import Control.Exception.Control hiding (Handler)
#define control controlIO
#define liftBase liftIO
#endif
type Row = Map String SqlValue
class ( IConnection c
, ConnSrc s
#if MIN_VERSION_monad_control(0,3,0)
, MonadBaseControl IO m
#else
, MonadControlIO m
#endif
)
=> HasHdbc m c s | m -> c s where
getHdbcState :: m (HdbcSnaplet c s)
#if MIN_VERSION_monad_control(0,3,0)
#else
instance MonadControlIO (Handler b v) where
liftControlIO f = liftBase (f return)
#endif
type HdbcIO c = HdbcSnaplet c IO
type HdbcPool c = HdbcSnaplet c Pool
hdbcInit
:: ( ConnSrc s
, IConnection c
#if MIN_VERSION_monad_control(0,3,0)
, MonadBase IO (Initializer b (HdbcSnaplet c s))
#endif
)
=> s c
-> SnapletInit b (HdbcSnaplet c s)
hdbcInit src = makeSnaplet "hdbc" "HDBC abstraction" Nothing $ do
mv <- liftBase newEmptyMVar
return $ HdbcSnaplet src mv
withHdbc :: HasHdbc m c s => (c -> IO a) -> m a
withHdbc f = do
st <- getHdbcState
withConn st (liftBase . f)
withHdbc' :: HasHdbc m c s => (c -> a) -> m a
withHdbc' f = do
st <- getHdbcState
withConn st (return . f)
query
:: HasHdbc m c s
=> String
-> [SqlValue]
-> m [Row]
query sql bind = do
stmt <- prepare sql
liftBase $ HDBC.execute stmt bind
liftBase $ HDBC.fetchAllRowsMap stmt
query' :: HasHdbc m c s => String -> [SqlValue] -> m Integer
query' sql bind = withTransaction $ \conn -> do
stmt <- HDBC.prepare conn sql
liftBase $ HDBC.execute stmt bind
withTransaction :: HasHdbc m c s => (c -> IO a) -> m a
withTransaction f = withHdbc (`HDBC.withTransaction` f)
withTransaction' :: HasHdbc m c s => m a -> m a
withTransaction' action = do
r <- action `onException` doRollback
commit
return r
where doRollback = rollback `catch` doRollbackHandler
#if MIN_VERSION_monad_control(0,3,0)
doRollbackHandler :: MonadBaseControl IO m => SomeException -> m ()
#else
doRollbackHandler :: MonadControlIO m => SomeException -> m ()
#endif
doRollbackHandler _ = return ()
disconnect :: HasHdbc m c s => m ()
disconnect = withHdbc HDBC.disconnect
commit :: HasHdbc m c s => m ()
commit = withHdbc HDBC.commit
rollback :: HasHdbc m c s => m ()
rollback = withHdbc HDBC.rollback
runRaw :: HasHdbc m c s => String -> m ()
runRaw str = withHdbc (`HDBC.runRaw` str)
run :: HasHdbc m c s => String -> [SqlValue] -> m Integer
run str vs = withHdbc (\conn -> HDBC.run conn str vs)
prepare :: HasHdbc m c s => String -> m Statement
prepare str = withHdbc (`HDBC.prepare` str)
clone :: HasHdbc m c s => m c
clone = withHdbc HDBC.clone
hdbcDriverName :: HasHdbc m c s => m String
hdbcDriverName = withHdbc' HDBC.hdbcDriverName
hdbcClientVer :: HasHdbc m c s => m String
hdbcClientVer = withHdbc' HDBC.hdbcClientVer
proxiedClientName :: HasHdbc m c s => m String
proxiedClientName = withHdbc' HDBC.proxiedClientName
proxiedClientVer :: HasHdbc m c s => m String
proxiedClientVer = withHdbc' HDBC.proxiedClientVer
dbServerVer :: HasHdbc m c s => m String
dbServerVer = withHdbc' HDBC.dbServerVer
dbTransactionSupport :: HasHdbc m c s => m Bool
dbTransactionSupport = withHdbc' HDBC.dbTransactionSupport
getTables :: HasHdbc m c s => m [String]
getTables = withHdbc HDBC.getTables
describeTable :: HasHdbc m c s => String -> m [(String, SqlColDesc)]
describeTable str = withHdbc (`HDBC.describeTable` str)
quickQuery' :: HasHdbc m c s => String -> [SqlValue] -> m [[SqlValue]]
quickQuery' str vs = withHdbc (\conn -> HDBC.quickQuery' conn str vs)
quickQuery :: HasHdbc m c s => String -> [SqlValue] -> m [[SqlValue]]
quickQuery str vs = withHdbc (\conn -> HDBC.quickQuery conn str vs)
sRun :: HasHdbc m c s => String -> [Maybe String] -> m Integer
sRun str mstrs = withHdbc (\conn -> HDBC.sRun conn str mstrs)