{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, DeriveDataTypeable #-} {-# CFILES Database/Berkeley/db_helper.c #-} -- | Berkeley DB binding. All IO monad functions can throw DbException. -- -- This documentation is not a complete description of the Berkeley DB interface. -- You will need to refer to Berkeley DB's C or C++ API documentation for the details. #include module Database.Berkeley.Db ( -- * Common DbFlag(..), DbError(..), DbException(..), -- * DbEnv DbEnv, dbEnv_close, DbEnvCreateFlag, dbEnv_create, dbEnv_set_data_dir, dbEnv_set_lg_dir, dbEnv_get_cache_size, 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, 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_set_flags, -- * DbTxn dbEnv_withTxn, dbEnv_txn_begin, DbTxn, dbTxn_abort, dbTxn_commit, dbTxn_id, -- * Db Db, db_create, db_del, db_get, DbType(..), db_open, db_close, db_set_flags, db_put, db_set_pagesize, db_sync, -- * DbCursor db_withCursor, db_cursor, DbCursor, dbCursor_close, dbCursor_count, dbCursor_del, dbCursor_withCursor, dbCursor_dup, dbCursor_get, dbCursor_set, dbCursor_set_range, dbCursor_put, -- * Logging subsystem #if (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 7) || DB_VERSION_MAJOR > 4 DbLogFlag(..), dbEnv_log_set_config, #endif dbEnv_get_lg_regionmax, dbEnv_set_lg_regionmax, -- * Private dbToNum, dbErrFromNum, DbEnv_struct, DbTxn_struct, -- * C integration DbEnv_native, dbEnv_toNative ) 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 {- 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. #if DB_VERSION_MAJOR < 5 DB_NOSERVER_HOME | -- ^ Bad home sent to server. DB_NOSERVER_ID | -- ^ Bad ID sent to server. #endif 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. DB_ACCESSED_DB_ENV_AFTER_CLOSE | -- ^ Haskell binding: Attempted to use a DbEnv handle after it was closed DB_ACCESSED_DB_AFTER_CLOSE | -- ^ Haskell binding: Attempted to use a Db handle after it was closed DB_ACCESSED_DB_TXN_AFTER_CLOSE | -- ^ Haskell binding: Attempted to use a DbTxn handle after it was closed DB_ACCESSED_DB_CURSOR_AFTER_CLOSE | -- ^ Haskell binding: Attempted to use a DbCursor handle after it was closed SYSTEM_ERROR Int -- ^ An errno value returned by the operating system deriving (Eq,Show) -- | Needed for BerkeleyDBXML: Convert an error code to a DbError dbErrFromNum :: Int -> DbError dbErrFromNum (#const DB_BUFFER_SMALL) = DB_BUFFER_SMALL dbErrFromNum (#const DB_DONOTINDEX) = DB_DONOTINDEX dbErrFromNum (#const DB_KEYEMPTY) = DB_KEYEMPTY dbErrFromNum (#const DB_KEYEXIST) = DB_KEYEXIST dbErrFromNum (#const DB_LOCK_DEADLOCK) = DB_LOCK_DEADLOCK dbErrFromNum (#const DB_LOCK_NOTGRANTED) = DB_LOCK_NOTGRANTED dbErrFromNum (#const DB_LOG_BUFFER_FULL) = DB_LOG_BUFFER_FULL dbErrFromNum (#const DB_NOSERVER) = DB_NOSERVER #if DB_VERSION_MAJOR < 5 dbErrFromNum (#const DB_NOSERVER_HOME) = DB_NOSERVER_HOME dbErrFromNum (#const DB_NOSERVER_ID) = DB_NOSERVER_ID #endif dbErrFromNum (#const DB_NOTFOUND) = DB_NOTFOUND dbErrFromNum (#const DB_OLD_VERSION) = DB_OLD_VERSION dbErrFromNum (#const DB_PAGE_NOTFOUND) = DB_PAGE_NOTFOUND dbErrFromNum (#const DB_REP_DUPMASTER) = DB_REP_DUPMASTER dbErrFromNum (#const DB_REP_HANDLE_DEAD) = DB_REP_HANDLE_DEAD dbErrFromNum (#const DB_REP_HOLDELECTION) = DB_REP_HOLDELECTION dbErrFromNum (#const DB_REP_IGNORE) = DB_REP_IGNORE dbErrFromNum (#const DB_REP_ISPERM) = DB_REP_ISPERM dbErrFromNum (#const DB_REP_JOIN_FAILURE) = DB_REP_JOIN_FAILURE dbErrFromNum (#const DB_REP_LEASE_EXPIRED) = DB_REP_LEASE_EXPIRED dbErrFromNum (#const DB_REP_LOCKOUT) = DB_REP_LOCKOUT dbErrFromNum (#const DB_REP_NEWSITE) = DB_REP_NEWSITE dbErrFromNum (#const DB_REP_NOTPERM) = DB_REP_NOTPERM dbErrFromNum (#const DB_REP_UNAVAIL) = DB_REP_UNAVAIL dbErrFromNum (#const DB_RUNRECOVERY) = DB_RUNRECOVERY dbErrFromNum (#const DB_SECONDARY_BAD) = DB_SECONDARY_BAD dbErrFromNum (#const DB_VERIFY_BAD) = DB_VERIFY_BAD dbErrFromNum (#const DB_VERSION_MISMATCH) = DB_VERSION_MISMATCH dbErrFromNum (-20881) = DB_ACCESSED_DB_ENV_AFTER_CLOSE -- specific to this binding dbErrFromNum (-20882) = DB_ACCESSED_DB_AFTER_CLOSE -- specific to this binding dbErrFromNum (-20883) = DB_ACCESSED_DB_TXN_AFTER_CLOSE -- specific to this binding dbErrFromNum (-20884) = DB_ACCESSED_DB_CURSOR_AFTER_CLOSE -- specific to this binding dbErrFromNum n = (SYSTEM_ERROR n) -- | An exception indicating an error in a Berkeley DB operation. 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) ------ DbEnv ------------------------------------------------------------------ -- | Needed for BerkeleyDBXML: C pointer type for a DbEnv 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 -- | Create a Berkeley DB environment handle. 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 unsafe "db_helper.h _dbenv_set_data_dir" _dbenv_set_data_dir :: Ptr DbEnv_struct -> CString -> IO CInt dbEnv_set_data_dir :: DbEnv -> FilePath -> IO () dbEnv_set_data_dir dbenv dir = withCString dir $ \c_str -> withForeignPtr dbenv $ \c_dbenv -> do ret <- _dbenv_set_data_dir c_dbenv c_str if ret /= 0 then throwDB "dbEnv_set_data_dir" ret else return () foreign import ccall unsafe "db_helper.h _dbenv_set_lg_dir" _dbenv_set_lg_dir :: Ptr DbEnv_struct -> CString -> IO CInt dbEnv_set_lg_dir :: DbEnv -> FilePath -> IO () dbEnv_set_lg_dir dbenv dir = withCString dir $ \c_str -> withForeignPtr dbenv $ \c_dbenv -> do ret <- _dbenv_set_lg_dir c_dbenv c_str if ret /= 0 then throwDB "dbEnv_set_lg_dir" ret else return () foreign import ccall unsafe "db_helper.h _dbenv_toNative" _dbenv_toNative :: Ptr DbEnv_struct -> Ptr (Ptr DbEnv_native) -> IO CInt data DbEnv_native -- | Convert the Haskell handle into a native handle of type DB_ENV* which can be passed to C. dbEnv_toNative :: DbEnv -> (Ptr DbEnv_native -> IO a) -> IO a dbEnv_toNative dbenv code = alloca $ \pNative -> withForeignPtr dbenv $ \c_dbenv -> do ret <- _dbenv_toNative c_dbenv pNative if ret /= 0 then throwDB "dbEnv_toNative" ret else code =<< peek pNative 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 () 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 | DB_DUP | DB_DUPSORT -- | Needed for BerkeleyDBXML: Binary representation of a DbFlag dbToNum :: DbFlag -> Word32 dbToNum DB_CREATE = #const DB_CREATE dbToNum DB_DURABLE_UNKNOWN = #const DB_DURABLE_UNKNOWN dbToNum DB_FORCE = #const DB_FORCE dbToNum DB_MULTIVERSION = #const DB_MULTIVERSION dbToNum DB_NOMMAP = #const DB_NOMMAP dbToNum DB_RDONLY = #const DB_RDONLY dbToNum DB_RECOVER = #const DB_RECOVER dbToNum DB_THREAD = #const DB_THREAD dbToNum DB_TRUNCATE = #const DB_TRUNCATE dbToNum DB_TXN_NOSYNC = #const DB_TXN_NOSYNC dbToNum DB_TXN_NOWAIT = #const DB_TXN_NOWAIT dbToNum DB_TXN_NOT_DURABLE = #const DB_TXN_NOT_DURABLE dbToNum DB_TXN_WRITE_NOSYNC = #const DB_TXN_WRITE_NOSYNC dbToNum DB_TXN_SYNC = #const DB_TXN_SYNC dbToNum DB_TXN_WAIT = #const DB_TXN_WAIT dbToNum DB_IGNORE_LEASE = #const DB_IGNORE_LEASE dbToNum DB_AUTO_COMMIT = #const DB_AUTO_COMMIT dbToNum DB_READ_COMMITTED = #const DB_READ_COMMITTED dbToNum DB_DEGREE_2 = #const DB_DEGREE_2 dbToNum DB_READ_UNCOMMITTED = #const DB_READ_UNCOMMITTED dbToNum DB_DIRTY_READ = #const DB_DIRTY_READ dbToNum DB_TXN_SNAPSHOT = #const DB_TXN_SNAPSHOT dbToNum DB_CXX_NO_EXCEPTIONS = #const DB_CXX_NO_EXCEPTIONS dbToNum DB_USE_ENVIRON = #const DB_USE_ENVIRON dbToNum DB_USE_ENVIRON_ROOT = #const DB_USE_ENVIRON_ROOT dbToNum DB_INIT_CDB = #const DB_INIT_CDB dbToNum DB_INIT_LOCK = #const DB_INIT_LOCK dbToNum DB_INIT_LOG = #const DB_INIT_LOG dbToNum DB_INIT_MPOOL = #const DB_INIT_MPOOL dbToNum DB_INIT_REP = #const DB_INIT_REP dbToNum DB_INIT_TXN = #const DB_INIT_TXN dbToNum DB_LOCKDOWN = #const DB_LOCKDOWN dbToNum DB_PRIVATE = #const DB_PRIVATE dbToNum DB_RECOVER_FATAL = #const DB_RECOVER_FATAL dbToNum DB_REGISTER = #const DB_REGISTER dbToNum DB_SYSTEM_MEM = #const DB_SYSTEM_MEM dbToNum DB_EXCL = #const DB_EXCL dbToNum DB_FCNTL_LOCKING = #const DB_FCNTL_LOCKING dbToNum DB_NO_AUTO_COMMIT = #const DB_NO_AUTO_COMMIT dbToNum DB_RDWRMASTER = #const DB_RDWRMASTER dbToNum DB_WRITEOPEN = #const DB_WRITEOPEN dbToNum DB_MULTIPLE = #const DB_MULTIPLE dbToNum DB_MULTIPLE_KEY = #const DB_MULTIPLE_KEY dbToNum DB_RMW = #const DB_RMW dbToNum DB_LOCK_NOWAIT = #const DB_LOCK_NOWAIT dbToNum DB_AFTER = (#const DB_AFTER) -- Dbc.put dbToNum DB_APPEND = (#const DB_APPEND) -- Db.put dbToNum DB_BEFORE = (#const DB_BEFORE) -- Dbc.put dbToNum DB_CONSUME = (#const DB_CONSUME) -- Db.get dbToNum DB_CONSUME_WAIT = (#const DB_CONSUME_WAIT) -- Db.get dbToNum DB_CURRENT = (#const DB_CURRENT) -- Dbc.get, Dbc.put, DbLogc.get dbToNum DB_FIRST = (#const DB_FIRST) -- Dbc.get, DbLogc->get dbToNum DB_GET_BOTH = (#const DB_GET_BOTH) -- Db.get, Dbc.get dbToNum DB_GET_BOTHC = (#const DB_GET_BOTHC) -- Dbc.get (internal) dbToNum DB_GET_BOTH_RANGE = (#const DB_GET_BOTH_RANGE) -- Db.get, Dbc.get dbToNum DB_GET_RECNO = (#const DB_GET_RECNO) -- Dbc.get dbToNum DB_JOIN_ITEM = (#const DB_JOIN_ITEM) -- Dbc.get; don't do primary lookup dbToNum DB_KEYFIRST = (#const DB_KEYFIRST) -- Dbc.put dbToNum DB_KEYLAST = (#const DB_KEYLAST) -- Dbc.put dbToNum DB_LAST = (#const DB_LAST) -- Dbc.get, DbLogc->get dbToNum DB_NEXT = (#const DB_NEXT) -- Dbc.get, DbLogc->get dbToNum DB_NEXT_DUP = (#const DB_NEXT_DUP) -- Dbc.get dbToNum DB_NEXT_NODUP = (#const DB_NEXT_NODUP) -- Dbc.get dbToNum DB_NODUPDATA = (#const DB_NODUPDATA) -- Db.put, Dbc.put dbToNum DB_NOOVERWRITE = (#const DB_NOOVERWRITE) -- Db.put dbToNum DB_NOSYNC = (#const DB_NOSYNC) -- Db.close dbToNum DB_POSITION = (#const DB_POSITION) -- Dbc.dup dbToNum DB_PREV = (#const DB_PREV) -- Dbc.get, DbLogc->get dbToNum DB_PREV_DUP = (#const DB_PREV_DUP) -- Dbc.get dbToNum DB_PREV_NODUP = (#const DB_PREV_NODUP) -- Dbc.get dbToNum DB_SET = (#const DB_SET) -- Dbc.get, DbLogc->get dbToNum DB_SET_RANGE = (#const DB_SET_RANGE) -- Dbc.get dbToNum DB_SET_RECNO = (#const DB_SET_RECNO) -- Db.get, Dbc.get dbToNum DB_UPDATE_SECONDARY = (#const DB_UPDATE_SECONDARY) -- Dbc.get, Dbc.del (internal) dbToNum DB_WRITECURSOR = (#const DB_WRITECURSOR) -- Db.cursor dbToNum DB_WRITELOCK = (#const DB_WRITELOCK) -- Db.cursor (internal) dbToNum DB_DUP = (#const DB_DUP) -- Db.set_flags dbToNum DB_DUPSORT = (#const DB_DUPSORT) -- Db.set_flags dbOrFlags :: [DbFlag] -> Word32 dbOrFlags flags = foldr (.|.) 0 $ map dbToNum flags foreign import ccall safe "db_helper.h _dbenv_open" _dbenv_open :: Ptr DbEnv_struct -> CString -> Word32 -> CInt -> IO CInt -- | Open the Berkeley DB environment, which must be done before 'db_open'. dbEnv_open :: [DbFlag] -> Int -- ^ UNIX file creation mode, or 0, meaning \"readable and writable by both owner and group\" -> DbEnv -> FilePath -- ^ Database environment's home directory -> 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 -> Word32 -> IO CInt -- | Close the Berkeley DB environment. 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 = #const DB_LOCK_NORUN dbLockToNum DB_LOCK_DEFAULT = #const DB_LOCK_DEFAULT dbLockToNum DB_LOCK_EXPIRE = #const DB_LOCK_EXPIRE dbLockToNum DB_LOCK_MAXLOCKS = #const DB_LOCK_MAXLOCKS dbLockToNum DB_LOCK_MAXWRITE = #const DB_LOCK_MAXWRITE dbLockToNum DB_LOCK_MINLOCKS = #const DB_LOCK_MINLOCKS dbLockToNum DB_LOCK_MINWRITE = #const DB_LOCK_MINWRITE dbLockToNum DB_LOCK_OLDEST = #const DB_LOCK_OLDEST dbLockToNum DB_LOCK_RANDOM = #const DB_LOCK_RANDOM dbLockToNum DB_LOCK_YOUNGEST = #const DB_LOCK_YOUNGEST foreign import ccall "db_helper.h _dbenv_set_lk_detect" _dbenv_set_lk_detect :: Ptr DbEnv_struct -> CUInt -> IO CInt -- | Start the Berkeley DB lock detector. 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 () foreign import ccall "db_helper.h _dbenv_set_flags" _dbenv_set_flags :: Ptr DbEnv_struct -> Word32 -> CInt -> IO CInt dbEnv_set_flags :: DbEnv -> [DbFlag] -- ^ environment flags -> Bool -- ^ onoff: False to clear the specified flags, True to set them -> IO () dbEnv_set_flags dbenv flags onoff = withForeignPtr dbenv $ \c_dbenv -> do ret <- _dbenv_set_flags c_dbenv (dbOrFlags flags) (if onoff then 1 else 0) if ret /= 0 then throwDB "dbEnv_set_flags" ret else return () ------ Logging subsystem ------------------------------------------------------- #if (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 7) || DB_VERSION_MAJOR > 4 data DbLogFlag = DB_LOG_DIRECT | DB_LOG_DSYNC | DB_LOG_AUTO_REMOVE | DB_LOG_IN_MEMORY | DB_LOG_ZERO dbLogToNum :: DbLogFlag -> Word32 dbLogToNum DB_LOG_DIRECT = (#const DB_LOG_DIRECT) dbLogToNum DB_LOG_DSYNC = (#const DB_LOG_DSYNC) dbLogToNum DB_LOG_AUTO_REMOVE = (#const DB_LOG_AUTO_REMOVE) dbLogToNum DB_LOG_IN_MEMORY = (#const DB_LOG_IN_MEMORY) dbLogToNum DB_LOG_ZERO = (#const DB_LOG_ZERO) dbLogOrFlags :: [DbLogFlag] -> Word32 dbLogOrFlags flags = foldr (.|.) 0 $ map dbLogToNum flags foreign import ccall "db_helper.h _dbenv_log_set_config" _dbenv_log_set_config :: Ptr DbEnv_struct -> Word32 -> CInt -> IO CInt dbEnv_log_set_config :: DbEnv -> [DbLogFlag] -> Bool -- ^ onoff: False to clear the specified flags, True to set them -> IO () dbEnv_log_set_config dbenv flags onoff = withForeignPtr dbenv $ \c_dbenv -> do ret <- _dbenv_log_set_config c_dbenv (dbLogOrFlags flags) (if onoff then 1 else 0) if ret /= 0 then throwDB "dbEnv_log_set_config" ret else return () #endif 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 () ------ Db ---------------------------------------------------------------------- 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 -> Word32 -> IO CInt -- | Create a database handle. 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 -- | Needed for BerkeleyDBXML: C pointer type for a DbTxn 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 -> Word32 -> CInt -> IO CInt -- | Open a database. db_open :: [DbFlag] -> DbType -> Int -- ^ Unix file creation mode, or 0, meaning \"readable and writable by both owner and group\" -> Db -> Maybe DbTxn -> FilePath -- ^ Filename -> Maybe String -- ^ Optional name of database within the file -> 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) -> Word32 -> IO CInt -- | Create a new transaction. You are recommended to use 'dbEnv_withTxn' -- instead of this function. dbEnv_txn_begin :: [DbFlag] -> DbEnv -> Maybe DbTxn -- ^ Optional parent transaction -> 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 -- | An exception-safe helper that runs an action inside a transaction. -- It will commit on completion, or abort if an exception is thrown. dbEnv_withTxn :: [DbFlag] -- ^ 'dbEnv_txn_begin' flags -> [DbFlag] -- ^ 'dbTxn_commit' flags -> DbEnv -> Maybe DbTxn -- ^ Parent transaction -> (DbTxn -> IO a) -- ^ The action to run inside a transaction -> 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 -> Word32 -> IO CInt -- | Checkpoint the transaction subsystem. dbEnv_txn_checkpoint :: [DbFlag] -> DbEnv -> Word -- ^ kbyte -> Word -- ^ minutes -> 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 -- | Abort a transaction, rolling back any writes that were made. You are -- recommended to use 'dbEnv_withTxn' instead of this function. 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 -> Word32 -> IO CInt -- | Commit a transaction. You are recommended to use 'dbEnv_withTxn' -- instead of this function. 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 -- | Get the locker ID for a transaction, which can be used with 'dbEnv_withLock'. 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 = #const DB_LOCK_READ dbLockModeToNum DB_LOCK_WRITE = #const DB_LOCK_WRITE dbLockModeToNum DB_LOCK_IWRITE = #const DB_LOCK_IWRITE dbLockModeToNum DB_LOCK_IREAD = #const DB_LOCK_IREAD dbLockModeToNum DB_LOCK_IWR = #const DB_LOCK_IWR 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 -> Word32 -> Ptr Word8 -> CUInt -> Word32 -> Ptr (Ptr DbLock_struct) -> IO CInt -- | Acquire a DbLock. 'dbTxn_id' converts a DbTxn to a DbLocker. dbEnv_lock_get :: [DbFlag] -> DbLockMode -> ByteString -- ^ Object, which is a key that identifies this lock -> DbEnv -> DbLocker -- ^ The identity of the locker. -> 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 -- | Release a DbLock acquired by dbEnv_lock_get. 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 () -- | Wrap dbEnv_lock_get / dbEnv_lock_put around the specified computation. -- 'dbTxn_id' converts a DbTxn to a DbLocker. dbEnv_withLock :: [DbFlag] -> DbLockMode -> ByteString -- ^ Object, which is an environment-wide key that identifies this lock -> DbEnv -> DbLocker -- ^ The identity of the locker. -> IO a -- ^ Computation to perform under lock -> IO a dbEnv_withLock flags lockMode object dbEnv locker computation = do bracket (dbEnv_lock_get flags lockMode object dbEnv locker) -- acquire dbEnv_lock_put -- release (\_ -> 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 -> Word32 -> IO CInt -- | Look the key up in the database, and return Just the stored value, or Nothing -- if it was not found. db_get :: [DbFlag] -> Db -> Maybe DbTxn -> ByteString -- ^ Key -> 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 -> Word32 -> IO CInt -- | Store the specified value into the database under the specified key. db_put :: [DbFlag] -> Db -> Maybe DbTxn -> ByteString -- ^ Key -> ByteString -- ^ Value -> 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 -> Word32 -> 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 -> Word32 -> 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 () foreign import ccall "db_helper.h _db_set_flags" _db_set_flags :: Ptr Db_struct -> Word32 -> IO CInt db_set_flags :: [DbFlag] -> Db -> IO () db_set_flags flags db = withForeignPtr db $ \c_db -> do ret <- _db_set_flags c_db (dbOrFlags flags) if ret /= 0 then throwDB "db_set_flags" ret else return () foreign import ccall "db_helper.h _db_sync" _db_sync :: Ptr Db_struct -> Word32 -> IO CInt db_sync :: [DbFlag] -> Db -> IO () db_sync flags db = do withForeignPtr db $ \c_db -> do ret <- _db_sync c_db (dbOrFlags flags) if ret /= 0 then throwDB "db_sync" ret else return () ------ DbCursor ---------------------------------------------------------------- data DbCursor_struct type DbCursor = ForeignPtr DbCursor_struct foreign import ccall "db_helper.h &_dbcursor_delete" _dbcursor_delete :: FunPtr (Ptr DbCursor_struct -> IO ()) -- | An exception-safe helper that creates a cursor, passes it to an action, and -- cleans up afterwards. db_withCursor :: [DbFlag] -- ^ 'db_cursor' flags -> Db -> Maybe DbTxn -- ^ Optional tansaction -> (DbCursor -> IO a) -- ^ The action that operates on the cursor -> 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) -> Word32 -> IO CInt -- | Open a DbCursor. You are recommended to use 'db_withCursor' instead of this -- function. 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 -- | Close a DBCursor. You are recommended to use 'db_withCursor' instead of this -- function. 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 -> Word32 -> IO CInt -- | Count the number of duplicates at the cursor position. 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 -> Word32 -> IO CInt -- | Delete the record at the cursor position. 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 () -- | An exception-safe helper that duplicates a cursor using 'dbCursor_dup', -- passes it to an action, and cleans up afterwards. dbCursor_withCursor :: [DbFlag] -- ^ 'db_cursor' flags -> DbCursor -- ^ The source cursor -> (DbCursor -> IO a) -- ^ The action that operates on the cursor -> 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) -> Word32 -> IO CInt -- | Create a duplicate of the specified cursor. 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 -> Word32 -> IO CInt -- | Fetch the record pointed at by the cursor (modified by the flags - see the -- Berkeley DB documentation), and return Just the (key, value) pair at the cursor -- position, or Nothing if no record was found. 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 -> Ptr (Ptr Word8) -> Ptr CUInt -> Word32 -> IO CInt -- | Move the cursor to the specified key/data pair of the database, and return -- the datum associated with the given key, or Nothing if it wasn't matched. -- (This is DBC->get with the DB_SET flag. The DB_SET flag is implied.) 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) nullPtr nullPtr 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) -- | Move the cursor to the specified key/data pair of the database, and return -- the next record (key, value) where the key is greater than or equal to -- the specified key, or Nothing if no such record was found. -- (This is DBC->get with the DB_SET_RANGE flag. The DB_SET_RANGE flag is implied.) dbCursor_set_range :: [DbFlag] -> DbCursor -> ByteString -> IO (Maybe (ByteString, ByteString)) dbCursor_set_range flags cur key = withByteString key $ \c_key key_len -> alloca $ \ptr1 -> alloca $ \ptr2 -> alloca $ \ptr3 -> alloca $ \ptr4 -> withForeignPtr cur $ \c_cur -> do ret <- _dbCursor_set c_cur c_key (fromIntegral key_len) ptr1 ptr2 ptr3 ptr4 (dbOrFlags (DB_SET_RANGE:flags)) if ret /= 0 then if (dbErrFromNum$ fromIntegral ret) == DB_NOTFOUND then return Nothing else throwDB "dbCursor_set" ret else do c_key <- peek ptr1 key_len <- peek ptr2 key_str <- newForeignPtr _freeString_finalizer c_key c_value <- peek ptr3 value_len <- peek ptr4 value_str <- newForeignPtr _freeString_finalizer c_value return $ Just (BSI.fromForeignPtr key_str 0 (fromIntegral key_len), BSI.fromForeignPtr value_str 0 (fromIntegral value_len)) foreign import ccall "db_helper.h _dbCursor_put" _dbCursor_put :: Ptr DbCursor_struct -> Ptr Word8 -> CUInt -> Ptr Word8 -> CUInt -> Word32 -> IO CInt -- | stores key/data pairs into the database in the context of the cursor. 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 ()