module Database.Berkeley.Db (
DbFlag(..),
DbError(..),
DbException(..),
DbEnv,
dbEnv_close,
DbEnvCreateFlag,
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,
DbLock,
DbLocker,
DbLockMode(..),
dbEnv_lock_get,
dbEnv_lock_put,
dbEnv_withLock,
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_checkpoint,
dbEnv_withTxn,
dbEnv_txn_begin,
DbTxn,
dbTxn_abort,
dbTxn_commit,
dbTxn_id,
Db,
db_create,
db_del,
db_get,
DbType(..),
db_open,
db_close,
db_put,
db_set_pagesize,
db_withCursor,
db_cursor,
DbCursor,
dbCursor_close,
dbCursor_count,
dbCursor_del,
dbCursor_withCursor,
dbCursor_dup,
dbCursor_get,
dbCursor_set,
dbCursor_put,
dbToNum,
dbErrFromNum,
DbEnv_struct,
DbTxn_struct
) where
import Foreign.C
import Foreign.Marshal.Alloc
import Foreign.Storable
import Foreign.Ptr
import Control.Applicative
import Control.Monad
import Data.Bits
import Data.Maybe
import System.IO.Error
import System.IO (FilePath)
import Foreign.ForeignPtr
import Data.ByteString (ByteString)
import qualified Data.ByteString.Internal as BSI
import Data.Word
import Control.Exception.Extensible
import Data.Typeable
data DbError =
DB_BUFFER_SMALL |
DB_DONOTINDEX |
DB_KEYEMPTY |
DB_KEYEXIST |
DB_LOCK_DEADLOCK |
DB_LOCK_NOTGRANTED |
DB_LOG_BUFFER_FULL |
DB_NOSERVER |
DB_NOSERVER_HOME |
DB_NOSERVER_ID |
DB_NOTFOUND |
DB_OLD_VERSION |
DB_PAGE_NOTFOUND |
DB_REP_DUPMASTER |
DB_REP_HANDLE_DEAD |
DB_REP_HOLDELECTION |
DB_REP_IGNORE |
DB_REP_ISPERM |
DB_REP_JOIN_FAILURE |
DB_REP_LEASE_EXPIRED |
DB_REP_LOCKOUT |
DB_REP_NEWSITE |
DB_REP_NOTPERM |
DB_REP_UNAVAIL |
DB_RUNRECOVERY |
DB_SECONDARY_BAD |
DB_VERIFY_BAD |
DB_VERSION_MISMATCH |
DB_ACCESSED_DB_ENV_AFTER_CLOSE |
DB_ACCESSED_DB_AFTER_CLOSE |
DB_ACCESSED_DB_TXN_AFTER_CLOSE |
DB_ACCESSED_DB_CURSOR_AFTER_CLOSE |
SYSTEM_ERROR Int
deriving (Eq,Show)
dbErrFromNum :: Int -> DbError
dbErrFromNum (30999) = DB_BUFFER_SMALL
dbErrFromNum (30998) = DB_DONOTINDEX
dbErrFromNum (30996) = DB_KEYEMPTY
dbErrFromNum (30995) = DB_KEYEXIST
dbErrFromNum (30994) = DB_LOCK_DEADLOCK
dbErrFromNum (30993) = DB_LOCK_NOTGRANTED
dbErrFromNum (30992) = DB_LOG_BUFFER_FULL
dbErrFromNum (30991) = DB_NOSERVER
dbErrFromNum (30990) = DB_NOSERVER_HOME
dbErrFromNum (30989) = DB_NOSERVER_ID
dbErrFromNum (30988) = DB_NOTFOUND
dbErrFromNum (30987) = DB_OLD_VERSION
dbErrFromNum (30986) = DB_PAGE_NOTFOUND
dbErrFromNum (30985) = DB_REP_DUPMASTER
dbErrFromNum (30984) = DB_REP_HANDLE_DEAD
dbErrFromNum (30983) = DB_REP_HOLDELECTION
dbErrFromNum (30982) = DB_REP_IGNORE
dbErrFromNum (30981) = DB_REP_ISPERM
dbErrFromNum (30980) = DB_REP_JOIN_FAILURE
dbErrFromNum (30979) = DB_REP_LEASE_EXPIRED
dbErrFromNum (30978) = DB_REP_LOCKOUT
dbErrFromNum (30977) = DB_REP_NEWSITE
dbErrFromNum (30976) = DB_REP_NOTPERM
dbErrFromNum (30975) = DB_REP_UNAVAIL
dbErrFromNum (30974) = DB_RUNRECOVERY
dbErrFromNum (30973) = DB_SECONDARY_BAD
dbErrFromNum (30972) = DB_VERIFY_BAD
dbErrFromNum (30971) = DB_VERSION_MISMATCH
dbErrFromNum (20881) = DB_ACCESSED_DB_ENV_AFTER_CLOSE
dbErrFromNum (20882) = DB_ACCESSED_DB_AFTER_CLOSE
dbErrFromNum (20883) = DB_ACCESSED_DB_TXN_AFTER_CLOSE
dbErrFromNum (20884) = DB_ACCESSED_DB_CURSOR_AFTER_CLOSE
dbErrFromNum n = (SYSTEM_ERROR n)
data DbException = DbException String DbError
deriving (Eq, Show, Typeable)
instance Exception DbException where
throwDB :: String -> CInt -> IO a
throwDB func code =
throwIO $ DbException func (dbErrFromNum $ fromIntegral code)
data DbEnv_struct
type DbEnv = ForeignPtr DbEnv_struct
foreign import ccall safe "db_helper.h _dbenv_create" _dbenv_create
:: Ptr (Ptr DbEnv_struct) -> 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 throwDB "_dbenv_create" ret
else do
p <- peek ptr
newForeignPtr finalizerFree p
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
:: Ptr DbEnv_struct -> Ptr CUInt -> IO CInt
dbEnv_get_lk_max_lockers :: DbEnv -> IO Int
dbEnv_get_lk_max_lockers dbenv =
withForeignPtr dbenv $ \c_dbenv ->
alloca $ \ptr -> do
ret <- _dbenv_get_lk_max_lockers c_dbenv ptr
if ret /= 0
then throwDB "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
:: Ptr DbEnv_struct -> CUInt -> IO CInt
dbEnv_set_lk_max_lockers :: DbEnv -> Int -> IO ()
dbEnv_set_lk_max_lockers dbenv max =
withForeignPtr dbenv $ \c_dbenv -> do
ret <- _dbenv_set_lk_max_lockers c_dbenv (fromIntegral max)
if ret /= 0
then throwDB "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
:: Ptr DbEnv_struct -> Ptr CUInt -> IO CInt
dbEnv_get_lk_max_locks :: DbEnv -> IO Int
dbEnv_get_lk_max_locks dbenv =
withForeignPtr dbenv $ \c_dbenv ->
alloca $ \ptr -> do
ret <- _dbenv_get_lk_max_locks c_dbenv ptr
if ret /= 0
then throwDB "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
:: Ptr DbEnv_struct -> CUInt -> IO CInt
dbEnv_set_lk_max_locks :: DbEnv -> Int -> IO ()
dbEnv_set_lk_max_locks dbenv max =
withForeignPtr dbenv $ \c_dbenv -> do
ret <- _dbenv_set_lk_max_locks c_dbenv (fromIntegral max)
if ret /= 0
then throwDB "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
:: Ptr DbEnv_struct -> Ptr CUInt -> IO CInt
dbEnv_get_lk_max_objects :: DbEnv -> IO Int
dbEnv_get_lk_max_objects dbenv =
withForeignPtr dbenv $ \c_dbenv ->
alloca $ \ptr -> do
ret <- _dbenv_get_lk_max_objects c_dbenv ptr
if ret /= 0
then throwDB "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
:: Ptr DbEnv_struct -> CUInt -> IO CInt
dbEnv_set_lk_max_objects :: DbEnv -> Int -> IO ()
dbEnv_set_lk_max_objects dbenv max =
withForeignPtr dbenv $ \c_dbenv -> do
ret <- _dbenv_set_lk_max_objects c_dbenv (fromIntegral max)
if ret /= 0
then throwDB "dbEnv_set_lk_max_objects" ret
else return ()
foreign import ccall safe "db_helper.h _dbenv_get_tx_max" _dbenv_get_tx_max
:: Ptr DbEnv_struct -> Ptr CUInt -> IO CInt
dbEnv_get_tx_max :: DbEnv -> IO Int
dbEnv_get_tx_max dbenv =
withForeignPtr dbenv $ \c_dbenv ->
alloca $ \ptr -> do
ret <- _dbenv_get_tx_max c_dbenv ptr
if ret /= 0
then throwDB "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
:: Ptr DbEnv_struct -> CUInt -> IO CInt
dbEnv_set_tx_max :: DbEnv -> Int -> IO ()
dbEnv_set_tx_max dbenv max =
withForeignPtr dbenv $ \c_dbenv -> do
ret <- _dbenv_set_tx_max c_dbenv (fromIntegral max)
if ret /= 0
then throwDB "dbEnv_set_tx_max" ret
else return ()
foreign import ccall safe "db_helper.h _dbenv_get_cachesize" _dbenv_get_cachesize
:: Ptr DbEnv_struct -> Ptr CUInt -> Ptr CUInt -> Ptr Int -> IO CInt
dbEnv_get_cache_size :: DbEnv -> IO (Int, Int, Int)
dbEnv_get_cache_size dbenv =
withForeignPtr dbenv $ \c_dbenv ->
alloca $ \ptr1 -> alloca $ \ptr2 -> alloca $ \ptr3 -> do
ret <- _dbenv_get_cachesize c_dbenv ptr1 ptr2 ptr3
if ret /= 0
then throwDB "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
:: Ptr DbEnv_struct -> CUInt -> CUInt -> CInt -> IO CInt
dbEnv_set_cache_size :: DbEnv -> Int -> Int -> Int -> IO ()
dbEnv_set_cache_size dbenv gbytes bytes ncache =
withForeignPtr dbenv $ \c_dbenv -> do
ret <- _dbenv_set_cachesize c_dbenv
(fromIntegral gbytes) (fromIntegral bytes) (fromIntegral ncache)
if ret /= 0
then throwDB "dbEnv_set_cache_size" ret
else return ()
foreign import ccall safe "db_helper.h _dbenv_get_lg_regionmax" _dbenv_get_lg_regionmax
:: Ptr DbEnv_struct -> Ptr CUInt -> IO CInt
dbEnv_get_lg_regionmax :: DbEnv -> IO Int
dbEnv_get_lg_regionmax dbenv =
withForeignPtr dbenv $ \c_dbenv ->
alloca $ \ptr -> do
ret <- _dbenv_get_lg_regionmax c_dbenv ptr
if ret /= 0
then throwDB "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
:: Ptr DbEnv_struct -> CUInt -> IO CInt
dbEnv_set_lg_regionmax :: DbEnv -> Int -> IO ()
dbEnv_set_lg_regionmax dbenv max =
withForeignPtr dbenv $ \c_dbenv -> do
ret <- _dbenv_set_lg_regionmax c_dbenv (fromIntegral max)
if ret /= 0
then throwDB "dbEnv_set_lg_regionmax" ret
else return ()
foreign import ccall safe "db_helper.h _dbenv_open" _dbenv_open
:: Ptr DbEnv_struct -> 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_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_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 |
DB_AFTER |
DB_APPEND |
DB_BEFORE |
DB_CONSUME |
DB_CONSUME_WAIT |
DB_CURRENT |
DB_FIRST |
DB_GET_BOTH |
DB_GET_BOTHC |
DB_GET_BOTH_RANGE |
DB_GET_RECNO |
DB_JOIN_ITEM |
DB_KEYFIRST |
DB_KEYLAST |
DB_LAST |
DB_NEXT |
DB_NEXT_DUP |
DB_NEXT_NODUP |
DB_NODUPDATA |
DB_NOOVERWRITE |
DB_NOSYNC |
DB_POSITION |
DB_PREV |
DB_PREV_DUP |
DB_PREV_NODUP |
DB_SET |
DB_SET_RANGE |
DB_SET_RECNO |
DB_UPDATE_SECONDARY |
DB_WRITECURSOR |
DB_WRITELOCK
dbToNum :: DbFlag -> CUInt
dbToNum DB_CREATE = 1
dbToNum DB_DURABLE_UNKNOWN = 32
dbToNum DB_FORCE = 1
dbToNum DB_MULTIVERSION = 4
dbToNum DB_NOMMAP = 8
dbToNum DB_RDONLY = 1024
dbToNum DB_RECOVER = 2
dbToNum DB_THREAD = 16
dbToNum DB_TRUNCATE = 16384
dbToNum DB_TXN_NOSYNC = 1
dbToNum DB_TXN_NOWAIT = 16
dbToNum DB_TXN_NOT_DURABLE = 2
dbToNum DB_TXN_WRITE_NOSYNC = 32
dbToNum DB_TXN_SYNC = 4
dbToNum DB_TXN_WAIT = 8
dbToNum DB_IGNORE_LEASE = 8192
dbToNum DB_AUTO_COMMIT = 256
dbToNum DB_READ_COMMITTED = 1024
dbToNum DB_DEGREE_2 = 1024
dbToNum DB_READ_UNCOMMITTED = 512
dbToNum DB_DIRTY_READ = 512
dbToNum DB_TXN_SNAPSHOT = 2
dbToNum DB_CXX_NO_EXCEPTIONS = 2
dbToNum DB_USE_ENVIRON = 4
dbToNum DB_USE_ENVIRON_ROOT = 8
dbToNum DB_INIT_CDB = 64
dbToNum DB_INIT_LOCK = 128
dbToNum DB_INIT_LOG = 256
dbToNum DB_INIT_MPOOL = 512
dbToNum DB_INIT_REP = 1024
dbToNum DB_INIT_TXN = 2048
dbToNum DB_LOCKDOWN = 4096
dbToNum DB_PRIVATE = 8192
dbToNum DB_RECOVER_FATAL = 16384
dbToNum DB_REGISTER = 32768
dbToNum DB_SYSTEM_MEM = 65536
dbToNum DB_EXCL = 64
dbToNum DB_FCNTL_LOCKING = 2048
dbToNum DB_NO_AUTO_COMMIT = 4096
dbToNum DB_RDWRMASTER = 8192
dbToNum DB_WRITEOPEN = 32768
dbToNum DB_MULTIPLE = 2048
dbToNum DB_MULTIPLE_KEY = 16384
dbToNum DB_RMW = 4096
dbToNum DB_LOCK_NOWAIT = 1
dbToNum DB_AFTER = (1)
dbToNum DB_APPEND = (2)
dbToNum DB_BEFORE = (3)
dbToNum DB_CONSUME = (4)
dbToNum DB_CONSUME_WAIT = (5)
dbToNum DB_CURRENT = (6)
dbToNum DB_FIRST = (7)
dbToNum DB_GET_BOTH = (8)
dbToNum DB_GET_BOTHC = (9)
dbToNum DB_GET_BOTH_RANGE = (10)
dbToNum DB_GET_RECNO = (11)
dbToNum DB_JOIN_ITEM = (12)
dbToNum DB_KEYFIRST = (13)
dbToNum DB_KEYLAST = (14)
dbToNum DB_LAST = (15)
dbToNum DB_NEXT = (16)
dbToNum DB_NEXT_DUP = (17)
dbToNum DB_NEXT_NODUP = (18)
dbToNum DB_NODUPDATA = (19)
dbToNum DB_NOOVERWRITE = (20)
dbToNum DB_NOSYNC = (21)
dbToNum DB_POSITION = (23)
dbToNum DB_PREV = (24)
dbToNum DB_PREV_DUP = (25)
dbToNum DB_PREV_NODUP = (26)
dbToNum DB_SET = (27)
dbToNum DB_SET_RANGE = (28)
dbToNum DB_SET_RECNO = (29)
dbToNum DB_UPDATE_SECONDARY = (30)
dbToNum DB_WRITECURSOR = (8)
dbToNum DB_WRITELOCK = (16)
dbOrFlags flags = foldr (.|.) 0 $ map dbToNum flags
dbEnv_open :: [DbFlag]
-> Int
-> DbEnv
-> FilePath
-> IO ()
dbEnv_open flags mode dbenv db_home =
withForeignPtr dbenv $ \c_dbenv ->
withCAString db_home $ \c_db_home -> do
ret <- _dbenv_open c_dbenv c_db_home (dbOrFlags flags) (fromIntegral mode)
if ret /= 0
then throwDB "dbEnv_open" ret
else return ()
foreign import ccall "db_helper.h _dbenv_close" _dbenv_close
:: Ptr DbEnv_struct -> CUInt -> IO CInt
dbEnv_close :: [DbFlag] -> DbEnv -> IO ()
dbEnv_close flags dbenv =
withForeignPtr dbenv $ \c_dbenv -> do
ret <- _dbenv_close c_dbenv (dbOrFlags flags)
if ret /= 0
then throwDB "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 =
withForeignPtr dbenv $ \c_dbenv -> do
ret <- _dbenv_set_lk_detect c_dbenv (dbLockToNum flag)
if ret /= 0
then throwDB "dbEnv_set_lk_detect" 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 (Ptr Db_struct) -> Ptr DbEnv_struct -> CUInt -> IO CInt
db_create :: [DbFlag] -> DbEnv -> IO Db
db_create flags dbenv =
withForeignPtr dbenv $ \c_dbenv ->
alloca $ \ptr -> do
ret <- _db_create ptr c_dbenv (dbOrFlags flags)
if ret /= 0
then throwDB "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 throwDB "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 :: [DbFlag]
-> DbType
-> Int
-> Db
-> Maybe DbTxn
-> FilePath
-> Maybe String
-> IO ()
db_open flags typ mode db mTxn file mDatabase =
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 throwDB ("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 :: [DbFlag]
-> DbEnv
-> Maybe DbTxn
-> IO DbTxn
dbEnv_txn_begin flags dbenv mParent =
withForeignPtr dbenv $ \c_dbenv ->
alloca $ \ptr -> do
ret <- case mParent of
Nothing -> do
_dbenv_txn_begin c_dbenv nullPtr ptr (dbOrFlags flags)
Just parent ->
withForeignPtr parent$ \c_parent -> do
_dbenv_txn_begin c_dbenv c_parent ptr (dbOrFlags flags)
if ret /= 0
then throwDB "dbEnv_txn_begin" ret
else do
p <- peek ptr
newForeignPtr _dbtxn_delete p
dbEnv_withTxn :: [DbFlag]
-> [DbFlag]
-> DbEnv
-> Maybe DbTxn
-> (DbTxn -> IO a)
-> IO a
dbEnv_withTxn flags1 flags2 env mTxn action = do
bracketOnError
(dbEnv_txn_begin flags1 env mTxn)
dbTxn_abort
$ \txn -> do
retValue <- action txn
dbTxn_commit flags2 txn
return retValue
foreign import ccall "db_helper.h _dbenv_txn_checkpoint" _dbenv_txn_checkpoint
:: Ptr DbEnv_struct -> CUInt -> CUInt -> CUInt -> IO CInt
dbEnv_txn_checkpoint :: [DbFlag]
-> DbEnv
-> Word
-> Word
-> IO ()
dbEnv_txn_checkpoint flags dbenv kbyte min =
withForeignPtr dbenv $ \c_dbenv -> do
ret <- _dbenv_txn_checkpoint c_dbenv (fromIntegral kbyte) (fromIntegral min) (dbOrFlags flags)
if ret /= 0
then throwDB "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 throwDB "dbTxn_abort" ret
else return ()
foreign import ccall "db_helper.h _dbtxn_commit" _dbtxn_commit
:: Ptr DbTxn_struct -> CUInt -> IO CInt
dbTxn_commit :: [DbFlag] -> DbTxn -> IO ()
dbTxn_commit flags dbtxn = do
withForeignPtr dbtxn $ \c_dbtxn -> do
ret <- _dbtxn_commit c_dbtxn (dbOrFlags flags)
if ret /= 0
then throwDB "dbTxn_commit" ret
else return ()
newtype DbLocker = DbLocker CUInt
foreign import ccall "db_helper.h _dbtxn_id" _dbtxn_id
:: Ptr DbTxn_struct -> Ptr CUInt -> IO CInt
dbTxn_id :: DbTxn -> IO DbLocker
dbTxn_id dbtxn =
withForeignPtr dbtxn $ \c_dbtxn ->
alloca $ \ptr -> do
ret <- _dbtxn_id c_dbtxn ptr
if ret /= 0
then throwDB "dbTxn_id" ret
else DbLocker <$> peek ptr
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 -> Ptr Word8 -> CUInt -> CUInt -> Ptr (Ptr DbLock_struct) -> IO CInt
dbEnv_lock_get :: [DbFlag]
-> DbLockMode
-> ByteString
-> DbEnv
-> DbLocker
-> IO DbLock
dbEnv_lock_get flags lockMode object dbenv (DbLocker locker) =
withForeignPtr dbenv $ \c_dbenv ->
alloca $ \ptr ->
withByteString object$ \c_object object_len -> do
ret <- _dbenv_lock_get c_dbenv locker (dbOrFlags flags) c_object
(fromIntegral object_len) (dbLockModeToNum lockMode) ptr
if ret /= 0
then throwDB "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 DbLock_struct -> IO CInt
dbEnv_lock_put :: DbLock -> IO ()
dbEnv_lock_put dblock =
withForeignPtr dblock$ \c_dblock -> do
ret <- _dbenv_lock_put c_dblock
if ret /= 0
then throwDB "dbEnv_lock_put" ret
else return ()
dbEnv_withLock :: [DbFlag]
-> DbLockMode
-> ByteString
-> DbEnv
-> DbLocker
-> IO a
-> IO a
dbEnv_withLock flags lockMode object dbEnv locker computation = do
bracket
(dbEnv_lock_get flags lockMode object dbEnv locker)
dbEnv_lock_put
(\_ -> computation)
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 -> Ptr Word8 -> CUInt -> Ptr (Ptr Word8) -> Ptr CUInt -> CUInt -> IO CInt
db_get :: [DbFlag]
-> Db
-> Maybe DbTxn
-> ByteString
-> IO (Maybe ByteString)
db_get flags db mTxn key =
alloca $ \ptr1 ->
alloca $ \ptr2 ->
withByteString 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) == DB_NOTFOUND
then return Nothing
else throwDB "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 -> Ptr Word8 -> CUInt -> Ptr Word8 -> CUInt -> CUInt -> IO CInt
db_put :: [DbFlag]
-> Db
-> Maybe DbTxn
-> ByteString
-> ByteString
-> IO ()
db_put flags db mTxn key value =
withByteString 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 throwDB "db_put" ret
else return ()
withByteString :: ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a
withByteString bs code = do
let (fp, fp_offset, length) = BSI.toForeignPtr bs
withForeignPtr fp $ \c_fp ->
code (c_fp `plusPtr` fp_offset) length
foreign import ccall "db_helper.h _db_del" _db_del
:: Ptr Db_struct -> Ptr DbTxn_struct -> Ptr Word8 -> CUInt -> CUInt -> IO CInt
db_del :: [DbFlag] -> Db -> Maybe DbTxn -> ByteString -> IO ()
db_del flags db mTxn key =
withByteString 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 throwDB "db_del" ret
else return ()
foreign import ccall "db_helper.h _db_close" _db_close
:: Ptr Db_struct -> CUInt -> IO CInt
db_close :: [DbFlag] -> Db -> IO ()
db_close flags db =
withForeignPtr db $ \c_db -> do
ret <- _db_close c_db (dbOrFlags flags)
if ret /= 0
then throwDB "db_close" ret
else return ()
data DbCursor_struct
type DbCursor = ForeignPtr DbCursor_struct
foreign import ccall "db_helper.h &_dbcursor_delete" _dbcursor_delete
:: FunPtr (Ptr DbCursor_struct -> IO ())
db_withCursor :: [DbFlag]
-> Db
-> Maybe DbTxn
-> (DbCursor -> IO a)
-> IO a
db_withCursor flags db mTxn action = do
bracket
(db_cursor flags db mTxn)
dbCursor_close
action
foreign import ccall "db_helper.h _db_cursor" _db_cursor
:: Ptr Db_struct -> Ptr DbTxn_struct -> Ptr (Ptr DbCursor_struct) -> CUInt -> IO CInt
db_cursor :: [DbFlag] -> Db -> Maybe DbTxn -> IO DbCursor
db_cursor flags db mTxn =
withForeignPtr db $ \c_db ->
alloca $ \pc_cursor -> do
ret <- case mTxn of
Nothing ->
_db_cursor c_db nullPtr pc_cursor (dbOrFlags flags)
Just txn ->
withForeignPtr txn $ \c_txn ->
_db_cursor c_db c_txn pc_cursor (dbOrFlags flags)
if ret /= 0
then throwDB "db_cursor" ret
else newForeignPtr _dbcursor_delete =<< peek pc_cursor
foreign import ccall "db_helper.h _dbCursor_close" _dbCursor_close
:: Ptr DbCursor_struct -> IO CInt
dbCursor_close :: DbCursor -> IO ()
dbCursor_close dbc =
withForeignPtr dbc $ \c_dbc -> do
ret <- _dbCursor_close c_dbc
if ret /= 0
then throwDB "dbCursor_close" ret
else return ()
foreign import ccall "db_helper.h _dbCursor_count" _dbCursor_count
:: Ptr DbCursor_struct -> Ptr CUInt -> CUInt -> IO CInt
dbCursor_count :: [DbFlag] -> DbCursor -> IO Int
dbCursor_count flags dbc =
withForeignPtr dbc $ \c_dbc ->
alloca $ \p_count -> do
ret <- _dbCursor_count c_dbc p_count (dbOrFlags flags)
if ret /= 0
then throwDB "dbCursor_count" ret
else fromIntegral <$> peek p_count
foreign import ccall "db_helper.h _dbCursor_del" _dbCursor_del
:: Ptr DbCursor_struct -> CUInt -> IO CInt
dbCursor_del :: [DbFlag] -> DbCursor -> IO ()
dbCursor_del flags dbc =
withForeignPtr dbc $ \c_dbc -> do
ret <- _dbCursor_del c_dbc (dbOrFlags flags)
if ret /= 0
then throwDB "dbCursor_del" ret
else return ()
dbCursor_withCursor :: [DbFlag]
-> DbCursor
-> (DbCursor -> IO a)
-> IO a
dbCursor_withCursor flags cur action = do
bracket
(dbCursor_dup flags cur)
dbCursor_close
action
foreign import ccall "db_helper.h _dbCursor_dup" _dbCursor_dup
:: Ptr DbCursor_struct -> Ptr (Ptr DbCursor_struct) -> CUInt -> IO CInt
dbCursor_dup :: [DbFlag] -> DbCursor -> IO DbCursor
dbCursor_dup flags dbc =
withForeignPtr dbc $ \c_dbc ->
alloca $ \pc_cursor -> do
ret <- _dbCursor_dup c_dbc pc_cursor (dbOrFlags flags)
if ret /= 0
then throwDB "dbCursor_dup" ret
else newForeignPtr _dbcursor_delete =<< peek pc_cursor
foreign import ccall "db_helper.h _dbCursor_get" _dbCursor_get
:: Ptr DbCursor_struct -> Ptr (Ptr Word8) -> Ptr CUInt -> Ptr (Ptr Word8) -> Ptr CUInt -> CUInt -> IO CInt
dbCursor_get :: [DbFlag] -> DbCursor -> IO (Maybe (ByteString, ByteString))
dbCursor_get flags cur =
alloca $ \ptr1 ->
alloca $ \ptr2 ->
alloca $ \ptr3 ->
alloca $ \ptr4 ->
withForeignPtr cur $ \c_cur -> do
ret <- _dbCursor_get c_cur ptr1 ptr2 ptr3 ptr4 (dbOrFlags flags)
if ret /= 0
then
if (dbErrFromNum$ fromIntegral ret) == DB_NOTFOUND
then return Nothing
else throwDB "dbCursor_get" ret
else do
c_key <- peek ptr1
key_len <- peek ptr2
key <- newForeignPtr _freeString_finalizer c_key
c_value <- peek ptr3
value_len <- peek ptr4
value <- newForeignPtr _freeString_finalizer c_value
return $ Just
(BSI.fromForeignPtr key 0 (fromIntegral key_len),
BSI.fromForeignPtr value 0 (fromIntegral value_len))
foreign import ccall "db_helper.h _dbCursor_set" _dbCursor_set
:: Ptr DbCursor_struct -> Ptr Word8 -> CUInt -> Ptr (Ptr Word8) -> Ptr CUInt -> CUInt -> IO CInt
dbCursor_set :: [DbFlag] -> DbCursor -> ByteString -> IO (Maybe ByteString)
dbCursor_set flags cur key =
withByteString key $ \c_key key_len ->
alloca $ \ptr1 ->
alloca $ \ptr2 ->
withForeignPtr cur $ \c_cur -> do
ret <- _dbCursor_set c_cur c_key (fromIntegral key_len) ptr1 ptr2 (dbOrFlags (DB_SET:flags))
if ret /= 0
then
if (dbErrFromNum$ fromIntegral ret) == DB_NOTFOUND
then return Nothing
else throwDB "dbCursor_set" 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 _dbCursor_put" _dbCursor_put
:: Ptr DbCursor_struct -> Ptr Word8 -> CUInt -> Ptr Word8 -> CUInt -> CUInt -> IO CInt
dbCursor_put :: [DbFlag] -> DbCursor -> ByteString -> ByteString -> IO ()
dbCursor_put flags cur key value =
withByteString key $ \c_key key_len ->
withByteString value $ \c_value value_len ->
withForeignPtr cur $ \c_cur -> do
ret <- _dbCursor_put c_cur c_key (fromIntegral key_len)
c_value (fromIntegral value_len) (dbOrFlags flags)
if ret /= 0
then throwDB "dbCursor_put" ret
else return ()