BerkeleyDBXML-0.5: Database/Berkeley/Db.hs
{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}
{-# CFILES Database/Berkeley/db_helper.cpp #-}
-- | All IO monad functions can throw exceptions. Use getDbError to fetch the
-- error code.
module Database.Berkeley.Db (
-- * General
DbFlag(..),
DbError(..),
getDbError,
-- * DbEnv
DbEnv,
dbEnv_close,
dbEnv_create,
dbEnv_get_cache_size,
dbEnv_get_lg_regionmax,
dbEnv_get_lk_max_lockers,
dbEnv_get_lk_max_locks,
dbEnv_get_lk_max_objects,
dbEnv_get_tx_max,
DbLocker,
DbLockMode(..),
dbEnv_lock_get,
dbEnv_lock_put,
dbEnv_open,
dbEnv_set_cache_size,
dbEnv_set_lg_regionmax,
DbLockFlag(..),
dbEnv_set_lk_detect,
dbEnv_set_lk_max_lockers,
dbEnv_set_lk_max_locks,
dbEnv_set_lk_max_objects,
dbEnv_set_tx_max,
dbEnv_txn_begin,
dbEnv_txn_checkpoint,
-- * DbTxn
DbTxn,
dbTxn_abort,
dbTxn_commit,
dbTxn_id,
-- * Db
Db,
db_close,
db_create,
db_del,
db_get,
DbType(..),
db_open,
db_put,
db_set_pagesize,
-- * Private
dbOrFlags, -- Private to DbXml
dbToNum, -- Private to DbXml
DbTxn_struct -- Private to DbXml
) 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
import Data.ByteString (ByteString)
import qualified Data.ByteString.Internal as BSI
import Data.Word
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)
-- | Helper specific to Haskell binding: Fetches a DbError value out of a Haskell
-- IOError, so the caller can catch an exception and check the error code.
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 safe "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 safe "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 safe "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 safe "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 safe "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 safe "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 safe "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 safe "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 safe "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 safe "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 safe "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 safe "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 safe "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 safe "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 safe "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 safe "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 unsafe "db_helper.h &_freeString" _freeString_finalizer
:: FunPtr (Ptr Word8 -> IO ())
foreign import ccall "db_helper.h _db_get" _db_get
:: Ptr Db_struct -> Ptr DbTxn_struct -> CString -> CUInt -> Ptr (Ptr Word8) -> Ptr CUInt -> CUInt -> IO CInt
db_get :: Db -> Maybe DbTxn -> String -> [DbFlag] -> IO (Maybe ByteString)
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
str <- newForeignPtr _freeString_finalizer c_value
return $ Just $ BSI.fromForeignPtr str 0 (fromIntegral value_len)
foreign import ccall "db_helper.h _db_put" _db_put
:: Ptr Db_struct -> Ptr DbTxn_struct -> CString -> CUInt -> Ptr Word8 -> CUInt -> CUInt -> IO CInt
db_put :: Db -> Maybe DbTxn -> String -> ByteString -> [DbFlag] -> IO ()
db_put db mTxn key value flags =
withCAStringLen key$ \(c_key, key_len) ->
withByteString 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_del" _db_del
:: Ptr Db_struct -> Ptr DbTxn_struct -> CString -> CUInt -> CUInt -> IO CInt
db_del :: Db -> Maybe DbTxn -> String -> [DbFlag] -> IO ()
db_del db mTxn key flags =
withCAStringLen key$ \(c_key, key_len) ->
withForeignPtr db$ \c_db -> do
ret <- case mTxn of
Nothing ->
_db_del c_db nullPtr c_key (fromIntegral key_len) (dbOrFlags flags)
Just txn ->
withForeignPtr txn$ \c_txn ->
_db_del c_db c_txn c_key (fromIntegral key_len) (dbOrFlags flags)
if ret /= 0
then throw "db_del" 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 ()
data DbLockFlag =
DB_LOCK_NORUN |
DB_LOCK_DEFAULT |
DB_LOCK_EXPIRE |
DB_LOCK_MAXLOCKS |
DB_LOCK_MAXWRITE |
DB_LOCK_MINLOCKS |
DB_LOCK_MINWRITE |
DB_LOCK_OLDEST |
DB_LOCK_RANDOM |
DB_LOCK_YOUNGEST
dbLockToNum DB_LOCK_NORUN = 0
dbLockToNum DB_LOCK_DEFAULT = 1
dbLockToNum DB_LOCK_EXPIRE = 2
dbLockToNum DB_LOCK_MAXLOCKS = 3
dbLockToNum DB_LOCK_MAXWRITE = 4
dbLockToNum DB_LOCK_MINLOCKS = 5
dbLockToNum DB_LOCK_MINWRITE = 6
dbLockToNum DB_LOCK_OLDEST = 7
dbLockToNum DB_LOCK_RANDOM = 8
dbLockToNum DB_LOCK_YOUNGEST = 9
foreign import ccall "db_helper.h _dbenv_set_lk_detect" _dbenv_set_lk_detect
:: Ptr DbEnv_struct -> CUInt -> IO CInt
dbEnv_set_lk_detect :: DbEnv -> DbLockFlag -> IO ()
dbEnv_set_lk_detect dbenv flag = do
ret <- _dbenv_set_lk_detect dbenv (dbLockToNum flag)
if ret /= 0
then throw "dbEnv_set_lk_detect" ret
else return ()