diff --git a/BerkeleyDB.cabal b/BerkeleyDB.cabal --- a/BerkeleyDB.cabal +++ b/BerkeleyDB.cabal @@ -1,5 +1,5 @@ name: BerkeleyDB -version: 0.7.1 +version: 0.7.2 license: BSD3 license-file: LICENSE cabal-version: >= 1.4 @@ -30,6 +30,8 @@ . DARCS repository: + . + Changes: 0.7.2: Fix on db4.7 category: Database build-type: Simple diff --git a/Database/Berkeley/Db.hs b/Database/Berkeley/Db.hs deleted file mode 100644 --- a/Database/Berkeley/Db.hs +++ /dev/null @@ -1,1131 +0,0 @@ -{-# 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. - -module Database.Berkeley.Db ( - -- * Common - DbFlag(..), - DbError(..), - DbException(..), - -- * DbEnv - 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, - -- * 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_put, - db_set_pagesize, - -- * DbCursor - db_withCursor, - db_cursor, - DbCursor, - dbCursor_close, - dbCursor_count, - dbCursor_del, - dbCursor_withCursor, - dbCursor_dup, - dbCursor_get, - dbCursor_set, - dbCursor_put, - -- * Private - dbToNum, -- | Needed for BerkeleyDBXML: Binary representation of a DbFlag - dbErrFromNum, -- | Needed for BerkeleyDBXML: Convert an error code to a DbError - DbEnv_struct, -- | Needed for BerkeleyDBXML: C pointer type for a DbEnv - DbTxn_struct -- | Needed for BerkeleyDBXML: C pointer type for a DbTxn - ) 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 System.IO.Unsafe -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. - 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. - 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) - -dbErrFromNum :: Int -> DbError -dbErrFromNum (-30999) = DB_BUFFER_SMALL -dbErrFromNum (-30998) = DB_DONOTINDEX -dbErrFromNum (-30997) = DB_KEYEMPTY -dbErrFromNum (-30996) = DB_KEYEXIST -dbErrFromNum (-30995) = DB_LOCK_DEADLOCK -dbErrFromNum (-30994) = DB_LOCK_NOTGRANTED -dbErrFromNum (-30993) = DB_LOG_BUFFER_FULL -dbErrFromNum (-30992) = DB_NOSERVER -dbErrFromNum (-30991) = DB_NOSERVER_HOME -dbErrFromNum (-30990) = DB_NOSERVER_ID -dbErrFromNum (-30989) = DB_NOTFOUND -dbErrFromNum (-30988) = DB_OLD_VERSION -dbErrFromNum (-30987) = DB_PAGE_NOTFOUND -dbErrFromNum (-30986) = DB_REP_DUPMASTER -dbErrFromNum (-30985) = DB_REP_HANDLE_DEAD -dbErrFromNum (-30984) = DB_REP_HOLDELECTION -dbErrFromNum (-30983) = DB_REP_IGNORE -dbErrFromNum (-30982) = DB_REP_ISPERM -dbErrFromNum (-30981) = DB_REP_JOIN_FAILURE -dbErrFromNum (-30980) = DB_REP_LEASE_EXPIRED -dbErrFromNum (-30979) = DB_REP_LOCKOUT -dbErrFromNum (-30978) = DB_REP_NEWSITE -dbErrFromNum (-30977) = DB_REP_NOTPERM -dbErrFromNum (-30976) = DB_REP_UNAVAIL -dbErrFromNum (-30975) = DB_RUNRECOVERY -dbErrFromNum (-30974) = DB_SECONDARY_BAD -dbErrFromNum (-30973) = DB_VERIFY_BAD -dbErrFromNum (-30972) = 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) - --- | 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 ------------------------------------------------------------------ - -data DbEnv_struct -type DbEnv = ForeignPtr DbEnv_struct -foreign import ccall "db_helper.h &_dbenv_delete" _dbenv_delete - :: FunPtr (Ptr DbEnv_struct -> IO ()) - - -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 _dbenv_delete 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_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 | - 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 = 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 -dbToNum DB_AFTER = 1 -- Dbc.put -dbToNum DB_APPEND = 2 -- Db.put -dbToNum DB_BEFORE = 3 -- Dbc.put -dbToNum DB_CONSUME = 4 -- Db.get -dbToNum DB_CONSUME_WAIT = 5 -- Db.get -dbToNum DB_CURRENT = 6 -- Dbc.get, Dbc.put, DbLogc.get -dbToNum DB_FIRST = 7 -- Dbc.get, DbLogc->get -dbToNum DB_GET_BOTH = 8 -- Db.get, Dbc.get -dbToNum DB_GET_BOTHC = 9 -- Dbc.get (internal) -dbToNum DB_GET_BOTH_RANGE = 10 -- Db.get, Dbc.get -dbToNum DB_GET_RECNO = 11 -- Dbc.get -dbToNum DB_JOIN_ITEM = 12 -- Dbc.get; don't do primary lookup -dbToNum DB_KEYFIRST = 13 -- Dbc.put -dbToNum DB_KEYLAST = 14 -- Dbc.put -dbToNum DB_LAST = 15 -- Dbc.get, DbLogc->get -dbToNum DB_NEXT = 16 -- Dbc.get, DbLogc->get -dbToNum DB_NEXT_DUP = 17 -- Dbc.get -dbToNum DB_NEXT_NODUP = 18 -- Dbc.get -dbToNum DB_NODUPDATA = 19 -- Db.put, Dbc.put -dbToNum DB_NOOVERWRITE = 20 -- Db.put -dbToNum DB_NOSYNC = 21 -- Db.close -dbToNum DB_POSITION = 22 -- Dbc.dup -dbToNum DB_PREV = 23 -- Dbc.get, DbLogc->get -dbToNum DB_PREV_DUP = 24 -- Dbc.get -dbToNum DB_PREV_NODUP = 25 -- Dbc.get -dbToNum DB_SET = 26 -- Dbc.get, DbLogc->get -dbToNum DB_SET_RANGE = 27 -- Dbc.get -dbToNum DB_SET_RECNO = 28 -- Db.get, Dbc.get -dbToNum DB_UPDATE_SECONDARY = 29 -- Dbc.get, Dbc.del (internal) -dbToNum DB_WRITECURSOR = 30 -- Db.cursor -dbToNum DB_WRITELOCK = 31 -- Db.cursor (internal) - -dbOrFlags flags = foldr (.|.) 0 $ map dbToNum flags - --- | 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 -> CUInt -> 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 = 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 - --- | 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 () - - ------- 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 -> CUInt -> 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 - -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 - --- | 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) -> CUInt -> 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 -> CUInt -> 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 -> CUInt -> 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 -> IO CUInt - --- | Get the locker ID for a transaction, which can be used with 'dbEnv_withLock'. -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 -> Ptr Word8 -> CUInt -> CUInt -> 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 -> CUInt -> 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 -> CUInt -> 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 -> 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 () - - ------- 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) -> CUInt -> 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 -> CUInt -> 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 -> CUInt -> 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) -> CUInt -> 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 -> CUInt -> 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 -> CUInt -> 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) 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 - --- | 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 () diff --git a/Database/Berkeley/Db.hsc b/Database/Berkeley/Db.hsc new file mode 100644 --- /dev/null +++ b/Database/Berkeley/Db.hsc @@ -0,0 +1,1132 @@ +{-# 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_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, + -- * 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_put, + db_set_pagesize, + -- * DbCursor + db_withCursor, + db_cursor, + DbCursor, + dbCursor_close, + dbCursor_count, + dbCursor_del, + dbCursor_withCursor, + dbCursor_dup, + dbCursor_get, + dbCursor_set, + dbCursor_put, + -- * Private + dbToNum, -- | Needed for BerkeleyDBXML: Binary representation of a DbFlag + dbErrFromNum, -- | Needed for BerkeleyDBXML: Convert an error code to a DbError + DbEnv_struct, -- | Needed for BerkeleyDBXML: C pointer type for a DbEnv + DbTxn_struct -- | Needed for BerkeleyDBXML: C pointer type for a DbTxn + ) 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 System.IO.Unsafe +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. + 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. + 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) + +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 +dbErrFromNum (#const DB_NOSERVER_HOME) = DB_NOSERVER_HOME +dbErrFromNum (#const DB_NOSERVER_ID) = DB_NOSERVER_ID +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 ------------------------------------------------------------------ + +data DbEnv_struct +type DbEnv = ForeignPtr DbEnv_struct +foreign import ccall "db_helper.h &_dbenv_delete" _dbenv_delete + :: FunPtr (Ptr DbEnv_struct -> IO ()) + + +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 _dbenv_delete 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_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 | + 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 = #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_XA_CREATE = #const DB_XA_CREATE +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) + + +dbOrFlags flags = foldr (.|.) 0 $ map dbToNum flags + +-- | 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 -> CUInt -> 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 () + + +------ 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 -> CUInt -> 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 + +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 + +-- | 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) -> CUInt -> 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 -> CUInt -> 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 -> CUInt -> 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 -> IO CUInt + +-- | Get the locker ID for a transaction, which can be used with 'dbEnv_withLock'. +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 = #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 -> CUInt -> Ptr Word8 -> CUInt -> CUInt -> 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 -> CUInt -> 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 -> CUInt -> 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 -> 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 () + + +------ 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) -> CUInt -> 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 -> CUInt -> 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 -> CUInt -> 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) -> CUInt -> 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 -> CUInt -> 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 -> CUInt -> 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) 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 + +-- | 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 ()