{-# 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 ()