BerkeleyDBXML-0.1: Database/Berkeley/Db.hs
{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}
{-# CFILES Database/Berkeley/db_helper.cpp #-}
module Database.Berkeley.Db (
DbEnv,
DbError(..),
getDbError,
dbEnv_create,
dbEnv_get_lk_max_lockers,
dbEnv_set_lk_max_lockers,
dbEnv_get_lk_max_locks,
dbEnv_set_lk_max_locks,
dbEnv_get_lk_max_objects,
dbEnv_set_lk_max_objects,
dbEnv_get_tx_max,
dbEnv_set_tx_max,
dbEnv_get_cache_size,
dbEnv_set_cache_size,
dbEnv_get_lg_regionmax,
dbEnv_set_lg_regionmax,
DbFlag(..),
dbEnv_open,
dbToNum, -- ^ Used by DbXml
dbOrFlags, -- ^ Used by DbXml
Db,
db_create,
db_set_pagesize,
DbType(..),
DbTxn,
db_open,
dbEnv_txn_begin,
dbEnv_txn_checkpoint,
dbTxn_abort,
dbTxn_commit,
DbLocker,
dbTxn_id,
DbLockMode(..),
dbEnv_lock_get,
dbEnv_lock_put,
db_get,
db_put,
db_close,
dbEnv_close
) where
import Foreign.C
import Foreign.Marshal.Alloc
import Foreign.Storable
import Foreign.Ptr
import Control.Monad
import Data.Bits
import Database.Berkeley.Util
import Data.Maybe
import System.IO.Error
import Foreign.ForeignPtr
import System.IO.Unsafe
data DbEnv_struct
type DbEnv = Ptr DbEnv_struct
{-
DB (user visible) error return codes.
!!!
We don't want our error returns to conflict with other packages where
possible, so pick a base error value that's hopefully not common. We
document that we own the error name space from -30,800 to -30,999.
-}
data DbError =
DB_BUFFER_SMALL | -- User memory too small for return.
DB_DONOTINDEX | -- "Null" return from 2ndary callbk.
DB_KEYEMPTY | -- Key/data deleted or never created.
DB_KEYEXIST | -- The key/data pair already exists.
DB_LOCK_DEADLOCK | -- Deadlock.
DB_LOCK_NOTGRANTED | -- Lock unavailable.
DB_LOG_BUFFER_FULL | -- In-memory log buffer full.
DB_NOSERVER | -- Server panic return.
DB_NOSERVER_HOME | -- Bad home sent to server.
DB_NOSERVER_ID | -- Bad ID sent to server.
DB_NOTFOUND | -- Key/data pair not found (EOF).
DB_OLD_VERSION | -- Out-of-date version.
DB_PAGE_NOTFOUND | -- Requested page not found.
DB_REP_DUPMASTER | -- There are two masters.
DB_REP_HANDLE_DEAD | -- Rolled back a commit.
DB_REP_HOLDELECTION | -- Time to hold an election.
DB_REP_IGNORE | -- This msg should be ignored.*/
DB_REP_ISPERM | -- Cached not written perm written.*/
DB_REP_JOIN_FAILURE | -- Unable to join replication group.
DB_REP_LEASE_EXPIRED | -- Master lease has expired.
DB_REP_LOCKOUT | -- API/Replication lockout now.
DB_REP_NEWSITE | -- New site entered system.
DB_REP_NOTPERM | -- Permanent log record not written.
DB_REP_UNAVAIL | -- Site cannot currently be reached.
DB_RUNRECOVERY | -- Panic return.
DB_SECONDARY_BAD | -- Secondary index corrupt.
DB_VERIFY_BAD | -- Verify failed; bad format.
DB_VERSION_MISMATCH | -- Environment version mismatch.
SYSTEM_ERROR Int
deriving (Eq,Show)
dbErrFromNum (-30999) = Just DB_BUFFER_SMALL
dbErrFromNum (-30998) = Just DB_DONOTINDEX
dbErrFromNum (-30997) = Just DB_KEYEMPTY
dbErrFromNum (-30996) = Just DB_KEYEXIST
dbErrFromNum (-30995) = Just DB_LOCK_DEADLOCK
dbErrFromNum (-30994) = Just DB_LOCK_NOTGRANTED
dbErrFromNum (-30993) = Just DB_LOG_BUFFER_FULL
dbErrFromNum (-30992) = Just DB_NOSERVER
dbErrFromNum (-30991) = Just DB_NOSERVER_HOME
dbErrFromNum (-30990) = Just DB_NOSERVER_ID
dbErrFromNum (-30989) = Just DB_NOTFOUND
dbErrFromNum (-30988) = Just DB_OLD_VERSION
dbErrFromNum (-30987) = Just DB_PAGE_NOTFOUND
dbErrFromNum (-30986) = Just DB_REP_DUPMASTER
dbErrFromNum (-30985) = Just DB_REP_HANDLE_DEAD
dbErrFromNum (-30984) = Just DB_REP_HOLDELECTION
dbErrFromNum (-30983) = Just DB_REP_IGNORE
dbErrFromNum (-30982) = Just DB_REP_ISPERM
dbErrFromNum (-30981) = Just DB_REP_JOIN_FAILURE
dbErrFromNum (-30980) = Just DB_REP_LEASE_EXPIRED
dbErrFromNum (-30979) = Just DB_REP_LOCKOUT
dbErrFromNum (-30978) = Just DB_REP_NEWSITE
dbErrFromNum (-30977) = Just DB_REP_NOTPERM
dbErrFromNum (-30976) = Just DB_REP_UNAVAIL
dbErrFromNum (-30975) = Just DB_RUNRECOVERY
dbErrFromNum (-30974) = Just DB_SECONDARY_BAD
dbErrFromNum (-30973) = Just DB_VERIFY_BAD
dbErrFromNum (-30972) = Just DB_VERSION_MISMATCH
dbErrFromNum 0 = Nothing
dbErrFromNum n = Just (SYSTEM_ERROR n)
getDbError :: IOError -> Maybe DbError
getDbError ioError =
if isUserError ioError
then
let s = ioeGetErrorString ioError in
case extract "db=\"" s ['"'] of
Just nStr -> dbErrFromNum $ fromMaybe 0 $ maybeRead nStr
Nothing -> Nothing
else Nothing
throw :: String -> CInt -> IO a
throw func code = do
ioError $ userError $ "db error func="++func++" db=\""++(show $ fromIntegral code)++"\""
foreign import ccall unsafe "db_helper.h _dbenv_create__" _dbenv_create__
:: Ptr DbEnv -> CUInt -> IO CInt
data DbEnvCreateFlag = DB_RPCCLIENT
dbEnv_create :: [DbEnvCreateFlag] -> IO DbEnv
dbEnv_create flags =
alloca $ \ptr -> do
ret <- _dbenv_create__ ptr orFlags
if ret /= 0
then throw "_dbenv_create" ret
else peek ptr
where
orFlags = foldr (.|.) 0 $ map toNum flags
toNum DB_RPCCLIENT = 0x0000002
foreign import ccall unsafe "db_helper.h _dbenv_get_lk_max_lockers" _dbenv_get_lk_max_lockers
:: DbEnv -> Ptr CUInt -> IO CInt
dbEnv_get_lk_max_lockers :: DbEnv -> IO Int
dbEnv_get_lk_max_lockers dbenv =
alloca $ \ptr -> do
ret <- _dbenv_get_lk_max_lockers dbenv ptr
if ret /= 0
then throw "dbEnv_get_lk_max_lockers" ret
else do
ci <- peek ptr
return $ fromIntegral ci
foreign import ccall unsafe "db_helper.h _dbenv_set_lk_max_lockers" _dbenv_set_lk_max_lockers
:: DbEnv -> CUInt -> IO CInt
dbEnv_set_lk_max_lockers :: DbEnv -> Int -> IO ()
dbEnv_set_lk_max_lockers dbenv max = do
ret <- _dbenv_set_lk_max_lockers dbenv (fromIntegral max)
if ret /= 0
then throw "dbEnv_set_lk_max_lockers" ret
else return ()
foreign import ccall unsafe "db_helper.h _dbenv_get_lk_max_locks" _dbenv_get_lk_max_locks
:: DbEnv -> Ptr CUInt -> IO CInt
dbEnv_get_lk_max_locks :: DbEnv -> IO Int
dbEnv_get_lk_max_locks dbenv =
alloca $ \ptr -> do
ret <- _dbenv_get_lk_max_locks dbenv ptr
if ret /= 0
then throw "dbEnv_get_lk_max_locks" ret
else do
ci <- peek ptr
return $ fromIntegral ci
foreign import ccall unsafe "db_helper.h _dbenv_set_lk_max_locks" _dbenv_set_lk_max_locks
:: DbEnv -> CUInt -> IO CInt
dbEnv_set_lk_max_locks :: DbEnv -> Int -> IO ()
dbEnv_set_lk_max_locks dbenv max = do
ret <- _dbenv_set_lk_max_locks dbenv (fromIntegral max)
if ret /= 0
then throw "dbEnv_set_lk_max_locks" ret
else return ()
foreign import ccall unsafe "db_helper.h _dbenv_get_lk_max_objects" _dbenv_get_lk_max_objects
:: DbEnv -> Ptr CUInt -> IO CInt
dbEnv_get_lk_max_objects :: DbEnv -> IO Int
dbEnv_get_lk_max_objects dbenv =
alloca $ \ptr -> do
ret <- _dbenv_get_lk_max_objects dbenv ptr
if ret /= 0
then throw "dbEnv_get_lk_max_objects" ret
else do
ci <- peek ptr
return $ fromIntegral ci
foreign import ccall unsafe "db_helper.h _dbenv_set_lk_max_objects" _dbenv_set_lk_max_objects
:: DbEnv -> CUInt -> IO CInt
dbEnv_set_lk_max_objects :: DbEnv -> Int -> IO ()
dbEnv_set_lk_max_objects dbenv max = do
ret <- _dbenv_set_lk_max_objects dbenv (fromIntegral max)
if ret /= 0
then throw "dbEnv_set_lk_max_objects" ret
else return ()
foreign import ccall unsafe "db_helper.h _dbenv_get_tx_max" _dbenv_get_tx_max
:: DbEnv -> Ptr CUInt -> IO CInt
dbEnv_get_tx_max :: DbEnv -> IO Int
dbEnv_get_tx_max dbenv =
alloca $ \ptr -> do
ret <- _dbenv_get_tx_max dbenv ptr
if ret /= 0
then throw "dbEnv_get_tx_max" ret
else do
ci <- peek ptr
return $ fromIntegral ci
foreign import ccall unsafe "db_helper.h _dbenv_set_tx_max" _dbenv_set_tx_max
:: DbEnv -> CUInt -> IO CInt
dbEnv_set_tx_max :: DbEnv -> Int -> IO ()
dbEnv_set_tx_max dbenv max = do
ret <- _dbenv_set_tx_max dbenv (fromIntegral max)
if ret /= 0
then throw "dbEnv_set_tx_max" ret
else return ()
foreign import ccall unsafe "db_helper.h _dbenv_get_cachesize" _dbenv_get_cachesize
:: DbEnv -> Ptr CUInt -> Ptr CUInt -> Ptr Int -> IO CInt
dbEnv_get_cache_size :: DbEnv -> IO (Int, Int, Int)
dbEnv_get_cache_size dbenv =
alloca $ \ptr1 -> alloca $ \ptr2 -> alloca $ \ptr3 -> do
ret <- _dbenv_get_cachesize dbenv ptr1 ptr2 ptr3
if ret /= 0
then throw "dbEnv_get_cache_size" ret
else do
c1 <- peek ptr1
c2 <- peek ptr2
c3 <- peek ptr3
return $ (fromIntegral c1, fromIntegral c2, fromIntegral c3)
foreign import ccall unsafe "db_helper.h _dbenv_set_cachesize" _dbenv_set_cachesize
:: DbEnv -> CUInt -> CUInt -> CInt -> IO CInt
dbEnv_set_cache_size :: DbEnv -> Int -> Int -> Int -> IO ()
dbEnv_set_cache_size dbenv gbytes bytes ncache = do
ret <- _dbenv_set_cachesize dbenv (fromIntegral gbytes) (fromIntegral bytes) (fromIntegral ncache)
if ret /= 0
then throw "dbEnv_set_cache_size" ret
else return ()
foreign import ccall unsafe "db_helper.h _dbenv_get_lg_regionmax" _dbenv_get_lg_regionmax
:: DbEnv -> Ptr CUInt -> IO CInt
dbEnv_get_lg_regionmax :: DbEnv -> IO Int
dbEnv_get_lg_regionmax dbenv =
alloca $ \ptr -> do
ret <- _dbenv_get_lg_regionmax dbenv ptr
if ret /= 0
then throw "dbEnv_get_lg_regionmax" ret
else do
ci <- peek ptr
return $ fromIntegral ci
foreign import ccall unsafe "db_helper.h _dbenv_set_lg_regionmax" _dbenv_set_lg_regionmax
:: DbEnv -> CUInt -> IO CInt
dbEnv_set_lg_regionmax :: DbEnv -> Int -> IO ()
dbEnv_set_lg_regionmax dbenv max = do
ret <- _dbenv_set_lg_regionmax dbenv (fromIntegral max)
if ret /= 0
then throw "dbEnv_set_lg_regionmax" ret
else return ()
foreign import ccall unsafe "db_helper.h _dbenv_open" _dbenv_open
:: DbEnv -> CString -> CUInt -> CInt -> IO CInt
data DbFlag =
DB_CREATE |
DB_DURABLE_UNKNOWN |
DB_FORCE |
DB_MULTIVERSION |
DB_NOMMAP |
DB_RDONLY |
DB_RECOVER |
DB_THREAD |
DB_TRUNCATE |
DB_TXN_NOSYNC |
DB_TXN_NOWAIT |
DB_TXN_NOT_DURABLE |
DB_TXN_WRITE_NOSYNC |
DB_SPARE_FLAG |
DB_TXN_SYNC |
DB_TXN_WAIT |
DB_IGNORE_LEASE |
DB_AUTO_COMMIT |
DB_READ_COMMITTED |
DB_DEGREE_2 |
DB_READ_UNCOMMITTED |
DB_DIRTY_READ |
DB_TXN_SNAPSHOT |
DB_CXX_NO_EXCEPTIONS |
DB_XA_CREATE |
DB_USE_ENVIRON |
DB_USE_ENVIRON_ROOT |
DB_INIT_CDB |
DB_INIT_LOCK |
DB_INIT_LOG |
DB_INIT_MPOOL |
DB_INIT_REP |
DB_INIT_TXN |
DB_LOCKDOWN |
DB_PRIVATE |
DB_RECOVER_FATAL |
DB_REGISTER |
DB_SYSTEM_MEM |
DB_EXCL |
DB_FCNTL_LOCKING |
DB_NO_AUTO_COMMIT |
DB_RDWRMASTER |
DB_WRITEOPEN |
DB_MULTIPLE |
DB_MULTIPLE_KEY |
DB_RMW |
DB_LOCK_NOWAIT
dbToNum DB_CREATE = 0x0000001
dbToNum DB_DURABLE_UNKNOWN = 0x0000002
dbToNum DB_FORCE = 0x0000004
dbToNum DB_MULTIVERSION = 0x0000008
dbToNum DB_NOMMAP = 0x0000010
dbToNum DB_RDONLY = 0x0000020
dbToNum DB_RECOVER = 0x0000040
dbToNum DB_THREAD = 0x0000080
dbToNum DB_TRUNCATE = 0x0000100
dbToNum DB_TXN_NOSYNC = 0x0000200
dbToNum DB_TXN_NOWAIT = 0x0000400
dbToNum DB_TXN_NOT_DURABLE = 0x0000800
dbToNum DB_TXN_WRITE_NOSYNC = 0x0001000
dbToNum DB_SPARE_FLAG = 0x0002000
dbToNum DB_TXN_SYNC = 0x0004000
dbToNum DB_TXN_WAIT = 0x0008000
dbToNum DB_IGNORE_LEASE = 0x01000000
dbToNum DB_AUTO_COMMIT = 0x02000000
dbToNum DB_READ_COMMITTED = 0x04000000
dbToNum DB_DEGREE_2 = 0x04000000
dbToNum DB_READ_UNCOMMITTED = 0x08000000
dbToNum DB_DIRTY_READ = 0x08000000
dbToNum DB_TXN_SNAPSHOT = 0x10000000
dbToNum DB_CXX_NO_EXCEPTIONS = 0x0000001
dbToNum DB_XA_CREATE = 0x0000002
dbToNum DB_USE_ENVIRON = 0x0004000
dbToNum DB_USE_ENVIRON_ROOT = 0x0008000
dbToNum DB_INIT_CDB = 0x0010000
dbToNum DB_INIT_LOCK = 0x0020000
dbToNum DB_INIT_LOG = 0x0040000
dbToNum DB_INIT_MPOOL = 0x0080000
dbToNum DB_INIT_REP = 0x0100000
dbToNum DB_INIT_TXN = 0x0200000
dbToNum DB_LOCKDOWN = 0x0400000
dbToNum DB_PRIVATE = 0x0800000
dbToNum DB_RECOVER_FATAL = 0x1000000
dbToNum DB_REGISTER = 0x2000000
dbToNum DB_SYSTEM_MEM = 0x4000000
dbToNum DB_EXCL = 0x0004000
dbToNum DB_FCNTL_LOCKING = 0x0008000
dbToNum DB_NO_AUTO_COMMIT = 0x0010000
dbToNum DB_RDWRMASTER = 0x0020000
dbToNum DB_WRITEOPEN = 0x0040000
dbToNum DB_MULTIPLE = 0x10000000
dbToNum DB_MULTIPLE_KEY = 0x20000000
dbToNum DB_RMW = 0x40000000
dbToNum DB_LOCK_NOWAIT = 0x002
dbOrFlags flags = foldr (.|.) 0 $ map dbToNum flags
dbEnv_open :: DbEnv -> String -> [DbFlag] -> Int -> IO ()
dbEnv_open dbenv db_home flags mode =
withCAString db_home $ \c_db_home -> do
ret <- _dbenv_open dbenv c_db_home (dbOrFlags flags) (fromIntegral mode)
if ret /= 0
then throw "dbEnv_open" ret
else return ()
data Db_struct
type Db = ForeignPtr Db_struct
foreign import ccall "db_helper.h &_db_delete" _db_delete
:: FunPtr (Ptr Db_struct -> IO ())
foreign import ccall unsafe "db_helper.h _db_create" _db_create
:: Ptr DbEnv_struct -> CUInt -> Ptr (Ptr Db_struct) -> IO CInt
db_create :: DbEnv -> [DbFlag] -> IO Db
db_create dbenv flags =
alloca$ \ptr -> do
ret <- _db_create dbenv (dbOrFlags flags) ptr
if ret /= 0
then throw "db_create" ret
else do
p <- peek ptr
newForeignPtr _db_delete p
foreign import ccall unsafe "db_helper.h _db_set_pagesize" _db_set_pagesize
:: Ptr Db_struct -> CUInt -> IO CInt
db_set_pagesize :: Db -> Int -> IO ()
db_set_pagesize db size =
withForeignPtr db$ \c_db -> do
ret <- _db_set_pagesize c_db (fromIntegral size)
if ret /= 0
then throw "db_set_pagesize" ret
else return ()
data DbType = DB_BTREE | DB_HASH | DB_RECNO | DB_QUEUE | DB_UNKNOWN
dbTypeToNum DB_BTREE = 1
dbTypeToNum DB_HASH = 2
dbTypeToNum DB_RECNO = 3
dbTypeToNum DB_QUEUE = 4
dbTypeToNum DB_UNKNOWN = 5
data DbTxn_struct
type DbTxn = ForeignPtr DbTxn_struct
foreign import ccall "db_helper.h &_dbtxn_delete" _dbtxn_delete
:: FunPtr (Ptr DbTxn_struct -> IO ())
foreign import ccall "db_helper.h _db_open" _db_open
:: Ptr Db_struct -> Ptr DbTxn_struct -> CString -> CString -> CInt -> CUInt -> CInt -> IO CInt
db_open :: Db -> Maybe DbTxn -> String -> Maybe String -> DbType -> [DbFlag] -> Int -> IO ()
db_open db mTxn file mDatabase typ flags mode =
withCAString file$ \c_file ->
withForeignPtr db$ \c_db -> do
ret <- case mTxn of
Just dbtxn ->
withForeignPtr dbtxn$ \c_dbtxn ->
case mDatabase of
Just database ->
withCAString database$ \c_database ->
_db_open c_db c_dbtxn c_file c_database
(dbTypeToNum typ) (dbOrFlags flags) (fromIntegral mode)
Nothing ->
_db_open c_db c_dbtxn c_file nullPtr
(dbTypeToNum typ) (dbOrFlags flags) (fromIntegral mode)
Nothing ->
case mDatabase of
Just database ->
withCAString database$ \c_database ->
_db_open c_db nullPtr c_file c_database
(dbTypeToNum typ) (dbOrFlags flags) (fromIntegral mode)
Nothing ->
_db_open c_db nullPtr c_file nullPtr
(dbTypeToNum typ) (dbOrFlags flags) (fromIntegral mode)
if ret /= 0
then throw ("db_open file="++(show file)++" database="++(show mDatabase)) ret
else return ()
foreign import ccall "db_helper.h _dbenv_txn_begin" _dbenv_txn_begin
:: Ptr DbEnv_struct -> Ptr DbTxn_struct -> Ptr (Ptr DbTxn_struct) -> CUInt -> IO CInt
dbEnv_txn_begin :: DbEnv -> Maybe DbTxn -> [DbFlag] -> IO DbTxn
dbEnv_txn_begin dbenv mParent flags = do
alloca$ \ptr -> do
ret <- case mParent of
Nothing -> do
_dbenv_txn_begin dbenv nullPtr ptr (dbOrFlags flags)
Just parent ->
withForeignPtr parent$ \c_parent -> do
_dbenv_txn_begin dbenv c_parent ptr (dbOrFlags flags)
if ret /= 0
then throw "dbEnv_txn_begin" ret
else do
p <- peek ptr
newForeignPtr _dbtxn_delete p
foreign import ccall "db_helper.h _dbenv_txn_checkpoint" _dbenv_txn_checkpoint
:: Ptr DbEnv_struct -> CUInt -> CUInt -> CUInt -> IO CInt
dbEnv_txn_checkpoint :: DbEnv -> CUInt -> CUInt -> [DbFlag] -> IO ()
dbEnv_txn_checkpoint dbenv kbyte min flags = do
ret <- _dbenv_txn_checkpoint dbenv kbyte min (dbOrFlags flags)
if ret /= 0
then throw "dbEnv_txn_checkpoint" ret
else return ()
foreign import ccall "db_helper.h _dbtxn_abort" _dbtxn_abort
:: Ptr DbTxn_struct -> IO CInt
dbTxn_abort :: DbTxn -> IO ()
dbTxn_abort dbtxn = do
withForeignPtr dbtxn$ \c_dbtxn -> do
ret <- _dbtxn_abort c_dbtxn
if ret /= 0
then throw "dbTxn_abort" ret
else return ()
foreign import ccall "db_helper.h _dbtxn_commit" _dbtxn_commit
:: Ptr DbTxn_struct -> CUInt -> IO CInt
dbTxn_commit :: DbTxn -> [DbFlag] -> IO ()
dbTxn_commit dbtxn flags = do
withForeignPtr dbtxn$ \c_dbtxn -> do
ret <- _dbtxn_commit c_dbtxn (dbOrFlags flags)
if ret /= 0
then throw "dbTxn_commit" ret
else return ()
newtype DbLocker = DbLocker CUInt
foreign import ccall "db_helper.h _dbtxn_id" _dbtxn_id
:: Ptr DbTxn_struct -> IO CUInt
dbTxn_id :: DbTxn -> DbLocker
dbTxn_id dbtxn =
unsafePerformIO$
withForeignPtr dbtxn$ \c_dbtxn ->
liftM DbLocker$ _dbtxn_id c_dbtxn
data DbLockMode = DB_LOCK_READ | DB_LOCK_WRITE | DB_LOCK_IWRITE | DB_LOCK_IREAD | DB_LOCK_IWR
dbLockModeToNum DB_LOCK_READ = 1
dbLockModeToNum DB_LOCK_WRITE = 2
dbLockModeToNum DB_LOCK_IWRITE = 4
dbLockModeToNum DB_LOCK_IREAD = 5
dbLockModeToNum DB_LOCK_IWR = 6
data DbLock_struct
type DbLock = ForeignPtr DbLock_struct
foreign import ccall "db_helper.h &_dblock_delete" _dblock_delete
:: FunPtr (Ptr DbLock_struct -> IO ())
foreign import ccall "db_helper.h _dbenv_lock_get" _dbenv_lock_get
:: Ptr DbEnv_struct -> CUInt -> CUInt -> CString -> CUInt -> CUInt -> Ptr (Ptr DbLock_struct) -> IO CInt
dbEnv_lock_get :: DbEnv -> DbLocker -> [DbFlag] -> String -> DbLockMode -> IO DbLock
dbEnv_lock_get dbenv (DbLocker locker) flags object lockMode =
alloca$ \ptr ->
withCAStringLen object$ \(c_object, object_len) -> do
ret <- _dbenv_lock_get dbenv locker (dbOrFlags flags) c_object
(fromIntegral object_len) (dbLockModeToNum lockMode) ptr
if ret /= 0
then throw "dbEnv_lock_get" ret
else do
p <- peek ptr
newForeignPtr _dblock_delete p
foreign import ccall "db_helper.h _dbenv_lock_put" _dbenv_lock_put
:: Ptr DbEnv_struct -> Ptr DbLock_struct -> IO CInt
dbEnv_lock_put :: DbEnv -> DbLock -> IO ()
dbEnv_lock_put dbenv dblock =
withForeignPtr dblock$ \c_dblock -> do
ret <- _dbenv_lock_put dbenv c_dblock
if ret /= 0
then throw "dbEnv_lock_put" ret
else return ()
foreign import ccall unsafe "db_helper.h _deleteString" _deleteString
:: CString -> IO ()
foreign import ccall unsafe "db_helper.h _freeString" _freeString
:: CString -> IO ()
foreign import ccall "db_helper.h _db_get" _db_get
:: Ptr Db_struct -> Ptr DbTxn_struct -> CString -> CUInt -> Ptr CString -> Ptr CUInt -> CUInt -> IO CInt
db_get :: Db -> Maybe DbTxn -> String -> [DbFlag] -> IO (Maybe String)
db_get db mTxn key flags =
alloca$ \ptr1 ->
alloca$ \ptr2 ->
withCAStringLen key$ \(c_key, key_len) ->
withForeignPtr db$ \c_db -> do
ret <- case mTxn of
Nothing ->
_db_get c_db nullPtr c_key (fromIntegral key_len) ptr1 ptr2 (dbOrFlags flags)
Just txn ->
withForeignPtr txn$ \c_txn ->
_db_get c_db c_txn c_key (fromIntegral key_len) ptr1 ptr2 (dbOrFlags flags)
if ret /= 0
then
if (dbErrFromNum$ fromIntegral ret) == Just DB_NOTFOUND
then return Nothing
else throw "db_get" ret
else do
c_value <- peek ptr1
value_len <- peek ptr2
value <- peekCAStringLen (c_value, fromIntegral value_len)
_freeString c_value
return$ Just value
foreign import ccall "db_helper.h _db_put" _db_put
:: Ptr Db_struct -> Ptr DbTxn_struct -> CString -> CUInt -> CString -> CUInt -> CUInt -> IO CInt
db_put :: Db -> Maybe DbTxn -> String -> String -> [DbFlag] -> IO ()
db_put db mTxn key value flags =
withCAStringLen key$ \(c_key, key_len) ->
withCAStringLen value$ \(c_value, value_len) ->
withForeignPtr db$ \c_db -> do
ret <- case mTxn of
Nothing ->
_db_put c_db nullPtr c_key (fromIntegral key_len)
c_value (fromIntegral value_len) (dbOrFlags flags)
Just txn ->
withForeignPtr txn$ \c_txn ->
_db_put c_db c_txn c_key (fromIntegral key_len)
c_value (fromIntegral value_len) (dbOrFlags flags)
if ret /= 0
then throw "db_put" ret
else return ()
foreign import ccall "db_helper.h _db_close" _db_close
:: Ptr Db_struct -> CUInt -> IO CInt
db_close :: Db -> [DbFlag] -> IO ()
db_close db flags =
withForeignPtr db$ \c_db -> do
ret <- _db_close c_db (dbOrFlags flags)
if ret /= 0
then throw "db_close" ret
else return ()
foreign import ccall "db_helper.h _dbenv_close" _dbenv_close
:: Ptr DbEnv_struct -> CUInt -> IO CInt
dbEnv_close :: DbEnv -> [DbFlag] -> IO ()
dbEnv_close dbEnv flags = do
ret <- _dbenv_close dbEnv (dbOrFlags flags)
if ret /= 0
then throw "dbEnv_close" ret
else return ()