BerkeleyDB 0.7.1 → 0.7.2
raw patch · 3 files changed
+1135/−1132 lines, 3 files
Files
- BerkeleyDB.cabal +3/−1
- Database/Berkeley/Db.hs +0/−1131
- Database/Berkeley/Db.hsc +1132/−0
BerkeleyDB.cabal view
@@ -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: <http://code.haskell.org/BerkeleyDB/>+ .+ Changes: 0.7.2: Fix on db4.7 category: Database build-type: Simple
− Database/Berkeley/Db.hs
@@ -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 ()
+ Database/Berkeley/Db.hsc view
@@ -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 <db.h>++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 ()