BerkeleyDB 0.3 → 0.6
raw patch · 10 files changed
+1674/−2325 lines, 10 filesdep −unixdep ~basedep ~bytestringsetup-changednew-uploader
Dependencies removed: unix
Dependency ranges changed: base, bytestring
Files
- BerkeleyDB.cabal +42/−33
- Database/Berkeley/Db.hs +857/−0
- Database/Berkeley/db_helper.cpp +300/−0
- Database/Berkeley/db_helper.h +53/−0
- Database/BerkeleyDB.hs +0/−1149
- Database/BerkeleyDB.hsc +0/−1114
- LICENSE +26/−28
- Setup.hs +1/−1
- examples/capitals.hs +247/−0
- examples/tests.hs +148/−0
BerkeleyDB.cabal view
@@ -1,34 +1,43 @@-name: BerkeleyDB-version: 0.3-license: BSD3-license-file: LICENSE-copyright: John McCall, 2007-author: John McCall-maintainer: rjmccall@gmail.com-stability: alpha-homepage: http://www.cs.pdx.edu/~rjmccall/hackage/BerkeleyDB/-category: Database-build-depends: base, unix, bytestring-synopsis: Bindings for Berkeley DB v1.x+name: BerkeleyDB+version: 0.6+license: BSD3+license-file: LICENSE+cabal-version: >= 1.4+copyright: (c) 2009 Stephen Blackheath+author: Stephen Blackheath+maintainer: http://blacksapphire.com/antispam/+stability: beta+synopsis: Berkeley DB binding description:- Provides Haskell bindings for Berkeley DB v1.x, a simple file-backed- database library which is included by default with many UNIX- distributions. This package presently makes no effort to support- modern versions of Berkeley DB.- .- Databases may be organized in one of four methods: in a hashtable,- in a b-tree, in a stream of fixed-length records, and in a stream- of variable-length records. Custom comparison and hash functions- are supported. Most of the standard database API is supported.- .- This implementation *seems* stable, inasmuch as I don't know of any- glaring flaws, but I haven't done anything that could even jokingly- be referred to as coverage testing.-exposed-modules:- Database.BerkeleyDB-extensions:- ForeignFunctionInterface- MultiParamTypeClasses- FunctionalDependencies- GeneralizedNewtypeDeriving-includes: db.h+ Berkeley DB is a fast, scalable, fully transactional database that runs on a local file+ system, and functions as a dictionary of arbitrary-sized binary blobs.+ (It is NOT an SQL-based database.) This package provides a thin Haskell binding for Berkeley DB.+ .+ This is a work in progress: The coverage of the Berkeley DB API is not yet complete. Tested with+ Berkeley DB version 4.6.+ .+ Berkeley DB home page:+ <http://www.oracle.com/database/berkeley-db/index.html>+ .+ Haskell binding tutorial:+ <http://www.haskell.org/haskellwiki/BerkeleyDBXML>+ .+ DARCS repository:+ <http://blacksapphire.com/BerkeleyDB>++category: Database+build-type: Simple+homepage: http://www.haskell.org/haskellwiki/BerkeleyDBXML+extra-source-files:+ Database/Berkeley/db_helper.h,+ examples/tests.hs+ examples/capitals.hs++Library+ exposed-modules: Database.Berkeley.Db+ c-sources: Database/Berkeley/db_helper.cpp++ build-depends: base >= 4, bytestring >= 0.9+ include-dirs: Database/Berkeley/+ extra-libraries: db, db_cxx+ ghc-options: -pgml c++
+ Database/Berkeley/Db.hs view
@@ -0,0 +1,857 @@+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, DeriveDataTypeable #-}+{-# CFILES Database/Berkeley/db_helper.c #-}++-- | Berkeley DB binding. All IO monad functions can throw DbException.++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_begin,+ dbEnv_txn_checkpoint,+ dbEnv_withTxn,+ -- * DbTxn+ DbTxn,+ dbTxn_abort,+ dbTxn_commit,+ dbTxn_id,+ -- * Db+ Db,+ db_close,+ db_create,+ db_del,+ db_get,+ DbType(..),+ db_open,+ db_put,+ db_set_pagesize,+ -- * 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.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+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+ 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 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++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++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++dbOrFlags flags = foldr (.|.) 0 $ map dbToNum flags++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 ()+++------ 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++db_create :: [DbFlag] -> DbEnv -> IO Db+db_create flags dbenv =+ withForeignPtr dbenv $ \c_dbenv ->+ alloca $ \ptr -> do+ ret <- _db_create ptr c_dbenv (dbOrFlags flags)+ if ret /= 0+ then throwDB "db_create" ret+ else do+ p <- peek ptr+ newForeignPtr _db_delete p++ +foreign import ccall safe "db_helper.h _db_set_pagesize" _db_set_pagesize+ :: Ptr Db_struct -> CUInt -> IO CInt++db_set_pagesize :: Db -> Int -> IO ()+db_set_pagesize db size =+ withForeignPtr db $ \c_db -> do+ ret <- _db_set_pagesize c_db (fromIntegral size)+ if ret /= 0+ then throwDB "db_set_pagesize" ret+ else return ()++data DbType = DB_BTREE | DB_HASH | DB_RECNO | DB_QUEUE | DB_UNKNOWN++dbTypeToNum DB_BTREE = 1+dbTypeToNum DB_HASH = 2+dbTypeToNum DB_RECNO = 3+dbTypeToNum DB_QUEUE = 4+dbTypeToNum DB_UNKNOWN = 5++data DbTxn_struct+type DbTxn = ForeignPtr DbTxn_struct+foreign import ccall "db_helper.h &_dbtxn_delete" _dbtxn_delete+ :: FunPtr (Ptr DbTxn_struct -> IO ())++ +foreign import ccall "db_helper.h _db_open" _db_open+ :: Ptr Db_struct -> Ptr DbTxn_struct -> CString -> CString -> CInt -> CUInt -> CInt -> IO CInt++db_open :: [DbFlag]+ -> DbType+ -> Int -- ^ 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++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++-- | Execute a computation within a transaction.+dbEnv_withTxn :: [DbFlag] -- ^ dbEnv_txn_begin flags+ -> [DbFlag] -- ^ dbTxn_commit flags+ -> DbEnv+ -> Maybe DbTxn -- ^ Optional parent transaction+ -> (DbTxn -> IO ()) -- ^ The computation to run within a transactional context+ -> IO ()+dbEnv_withTxn beginFlags commitFlags dbenv mParent computation = do+ bracketOnError+ (dbEnv_txn_begin beginFlags dbenv mParent)+ dbTxn_abort+ (\txn -> do+ computation txn+ dbTxn_commit commitFlags txn)++foreign import ccall "db_helper.h _dbenv_txn_checkpoint" _dbenv_txn_checkpoint+ :: Ptr DbEnv_struct -> CUInt -> CUInt -> CUInt -> IO CInt++dbEnv_txn_checkpoint :: [DbFlag]+ -> DbEnv+ -> CUInt -- ^ kbyte+ -> CUInt -- ^ min+ -> IO ()+dbEnv_txn_checkpoint flags dbenv kbyte min =+ withForeignPtr dbenv $ \c_dbenv -> do+ ret <- _dbenv_txn_checkpoint c_dbenv kbyte min (dbOrFlags flags)+ if ret /= 0+ then throwDB "dbEnv_txn_checkpoint" ret+ else return ()++ +foreign import ccall "db_helper.h _dbtxn_abort" _dbtxn_abort+ :: Ptr DbTxn_struct -> IO CInt++dbTxn_abort :: DbTxn -> IO ()+dbTxn_abort dbtxn = do+ withForeignPtr dbtxn $ \c_dbtxn -> do+ ret <- _dbtxn_abort c_dbtxn+ if ret /= 0+ then throwDB "dbTxn_abort" ret+ else return ()++ +foreign import ccall "db_helper.h _dbtxn_commit" _dbtxn_commit+ :: Ptr DbTxn_struct -> CUInt -> IO CInt++dbTxn_commit :: [DbFlag] -> DbTxn -> IO ()+dbTxn_commit flags dbtxn = do+ withForeignPtr dbtxn $ \c_dbtxn -> do+ ret <- _dbtxn_commit c_dbtxn (dbOrFlags flags)+ if ret /= 0+ then throwDB "dbTxn_commit" ret+ else return ()++newtype DbLocker = DbLocker CUInt+++foreign import ccall "db_helper.h _dbtxn_id" _dbtxn_id+ :: Ptr DbTxn_struct -> IO CUInt++dbTxn_id :: DbTxn -> DbLocker+dbTxn_id dbtxn =+ unsafePerformIO $+ withForeignPtr dbtxn $ \c_dbtxn ->+ liftM DbLocker$ _dbtxn_id c_dbtxn++data DbLockMode = DB_LOCK_READ | DB_LOCK_WRITE | DB_LOCK_IWRITE | DB_LOCK_IREAD | DB_LOCK_IWR++dbLockModeToNum DB_LOCK_READ = 1+dbLockModeToNum DB_LOCK_WRITE = 2+dbLockModeToNum DB_LOCK_IWRITE = 4+dbLockModeToNum DB_LOCK_IREAD = 5+dbLockModeToNum DB_LOCK_IWR = 6++data DbLock_struct+type DbLock = ForeignPtr DbLock_struct+foreign import ccall "db_helper.h &_dblock_delete" _dblock_delete+ :: FunPtr (Ptr DbLock_struct -> IO ())++ +foreign import ccall "db_helper.h _dbenv_lock_get" _dbenv_lock_get+ :: Ptr DbEnv_struct -> CUInt -> CUInt -> 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+ -> 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+ -> IO () -- ^ Computation to perform under lock+ -> IO ()+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++db_get :: [DbFlag] -> Db -> Maybe DbTxn -> ByteString -> IO (Maybe ByteString)+db_get flags db mTxn key =+ alloca $ \ptr1 ->+ alloca $ \ptr2 ->+ withByteString key$ \c_key key_len ->+ withForeignPtr db $ \c_db -> do+ ret <- case mTxn of+ Nothing ->+ _db_get c_db nullPtr c_key (fromIntegral key_len) ptr1 ptr2 (dbOrFlags flags)+ Just txn ->+ withForeignPtr txn$ \c_txn ->+ _db_get c_db c_txn c_key (fromIntegral key_len) ptr1 ptr2 (dbOrFlags flags)+ if ret /= 0+ then+ if (dbErrFromNum$ fromIntegral ret) == DB_NOTFOUND+ then return Nothing+ else throwDB "db_get" ret+ else do+ c_value <- peek ptr1+ value_len <- peek ptr2+ str <- newForeignPtr _freeString_finalizer c_value+ return $ Just $ BSI.fromForeignPtr str 0 (fromIntegral value_len)+++foreign import ccall "db_helper.h _db_put" _db_put+ :: Ptr Db_struct -> Ptr DbTxn_struct -> Ptr Word8 -> CUInt -> Ptr Word8 -> CUInt -> CUInt -> IO CInt++db_put :: [DbFlag]+ -> Db+ -> Maybe DbTxn+ -> ByteString -- ^ 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 ()++ +foreign import ccall "db_helper.h _dbenv_close" _dbenv_close+ :: Ptr DbEnv_struct -> CUInt -> IO CInt++dbEnv_close :: [DbFlag] -> DbEnv -> IO ()+dbEnv_close flags dbenv =+ withForeignPtr dbenv $ \c_dbenv -> do+ ret <- _dbenv_close c_dbenv (dbOrFlags flags)+ if ret /= 0+ then throwDB "dbEnv_close" ret+ else return ()+ ++data DbLockFlag =+ DB_LOCK_NORUN |+ DB_LOCK_DEFAULT |+ DB_LOCK_EXPIRE |+ DB_LOCK_MAXLOCKS | + DB_LOCK_MAXWRITE |+ DB_LOCK_MINLOCKS |+ DB_LOCK_MINWRITE |+ DB_LOCK_OLDEST |+ DB_LOCK_RANDOM |+ DB_LOCK_YOUNGEST++dbLockToNum DB_LOCK_NORUN = 0+dbLockToNum DB_LOCK_DEFAULT = 1+dbLockToNum DB_LOCK_EXPIRE = 2+dbLockToNum DB_LOCK_MAXLOCKS = 3+dbLockToNum DB_LOCK_MAXWRITE = 4+dbLockToNum DB_LOCK_MINLOCKS = 5+dbLockToNum DB_LOCK_MINWRITE = 6+dbLockToNum DB_LOCK_OLDEST = 7+dbLockToNum DB_LOCK_RANDOM = 8+dbLockToNum DB_LOCK_YOUNGEST = 9++foreign import ccall "db_helper.h _dbenv_set_lk_detect" _dbenv_set_lk_detect+ :: Ptr DbEnv_struct -> CUInt -> IO CInt++dbEnv_set_lk_detect :: DbEnv -> DbLockFlag -> IO ()+dbEnv_set_lk_detect dbenv flag =+ withForeignPtr dbenv $ \c_dbenv -> do+ ret <- _dbenv_set_lk_detect c_dbenv (dbLockToNum flag)+ if ret /= 0+ then throwDB "dbEnv_set_lk_detect" ret+ else return ()+
+ Database/Berkeley/db_helper.cpp view
@@ -0,0 +1,300 @@+#include "db_helper.h"++#include <string.h>+#include <stdlib.h>+#include <errno.h>++#define UNWRAP_DBENV() \+ DB_ENV* dbenv = dbenvp->get_DB_ENV(); \+ if (dbenv == NULL) return -20881; /* Haskell binding-specific error code */++#define UNWRAP_DB() \+ DB* db = *dbp; \+ if (db == NULL) return -20882; /* Haskell binding-specific error code */++#define UNWRAP_DBTXN_() \+ if (dbtxnp == NULL) \+ dbtxn = NULL; \+ else { \+ if (*dbtxnp == NULL) return -20883; /* Haskell binding-specific error code */ \+ dbtxn = (*dbtxnp)->get_DB_TXN(); \+ }++#define UNWRAP_DBTXN() \+ DB_TXN* dbtxn; \+ UNWRAP_DBTXN_()++int _dbenv_create(DbEnv** dbenvpp, u_int32_t flags)+{+ *dbenvpp = new DbEnv(flags);+ return 0;+}++void _dbenv_delete(DbEnv* dbenvp)+{+}++int _dbenv_get_lk_max_lockers(DbEnv* dbenvp, u_int32_t *lk_maxp) {+ UNWRAP_DBENV();+ return dbenv->get_lk_max_lockers(dbenv, lk_maxp);+}++int _dbenv_set_lk_max_lockers(DbEnv* dbenvp, u_int32_t max) {+ UNWRAP_DBENV();+ return dbenv->set_lk_max_lockers(dbenv, max);+}++int _dbenv_get_lk_max_locks(DbEnv* dbenvp, u_int32_t *lk_maxp) {+ UNWRAP_DBENV();+ return dbenv->get_lk_max_locks(dbenv, lk_maxp);+}++int _dbenv_set_lk_max_locks(DbEnv* dbenvp, u_int32_t max) {+ UNWRAP_DBENV();+ return dbenv->set_lk_max_locks(dbenv, max);+}++int _dbenv_get_lk_max_objects(DbEnv* dbenvp, u_int32_t *lk_maxp) {+ UNWRAP_DBENV();+ return dbenv->get_lk_max_objects(dbenv, lk_maxp);+}++int _dbenv_set_lk_max_objects(DbEnv* dbenvp, u_int32_t max) {+ UNWRAP_DBENV();+ return dbenv->set_lk_max_objects(dbenv, max);+}++int _dbenv_get_tx_max(DbEnv* dbenvp, u_int32_t *lk_maxp) {+ UNWRAP_DBENV();+ return dbenv->get_tx_max(dbenv, lk_maxp);+}++int _dbenv_set_tx_max(DbEnv* dbenvp, u_int32_t max) {+ UNWRAP_DBENV();+ return dbenv->set_tx_max(dbenv, max);+}++int _dbenv_get_cachesize(DbEnv* dbenvp, u_int32_t *gbytesp, u_int32_t *bytesp, int *ncachep) {+ UNWRAP_DBENV();+ return dbenv->get_cachesize(dbenv, gbytesp, bytesp, ncachep);+}++int _dbenv_set_cachesize(DbEnv* dbenvp, u_int32_t gbytes, u_int32_t bytes, int ncache) {+ UNWRAP_DBENV();+ return dbenv->set_cachesize(dbenv, gbytes, bytes, ncache);+}++int _dbenv_get_lg_regionmax(DbEnv* dbenvp, u_int32_t *lk_maxp) {+ UNWRAP_DBENV();+ return dbenv->get_lg_regionmax(dbenv, lk_maxp);+}++int _dbenv_set_lg_regionmax(DbEnv* dbenvp, u_int32_t max) {+ UNWRAP_DBENV();+ return dbenv->set_lg_regionmax(dbenv, max);+}++int _dbenv_open(DbEnv* dbenvp, char *db_home, u_int32_t flags, int mode) {+ UNWRAP_DBENV();+ return dbenv->open(dbenv, db_home, flags, mode);+}++int _db_create(DB*** dbpp, DbEnv* dbenvp, u_int32_t flags)+{+ int ret;+ UNWRAP_DBENV();+ *dbpp = (DB**)malloc(sizeof(DB**));+ ret = db_create(*dbpp, dbenv, flags);+ if (ret != 0)+ free(*dbpp);+ return ret;+}++void _db_delete(DB** dbp)+{+ if (*dbp != NULL)+ (*dbp)->close(*dbp, 0);+ free(dbp);+}++int _db_set_pagesize(DB** dbp, u_int32_t pagesize)+{+ UNWRAP_DB();+ return db->set_pagesize(db, pagesize);+}++int _db_open(DB** dbp, DbTxn** txnp, const char* file, const char* database,+ int type, u_int32_t flags, int mode)+{+ DB_TXN* txn;+ UNWRAP_DB();+ if (txnp == NULL)+ txn = NULL;+ else {+ if (*txnp == NULL) return -20883; /* Haskell binding-specific error code */+ txn = (*txnp)->get_DB_TXN();+ }+ return db->open(db, txn, file, database, (DBTYPE) type, flags, mode);+}++int _dbenv_txn_begin(DbEnv* dbenvp, DbTxn** parentp, DbTxn*** txnpp, u_int32_t flags)+{+ DbTxn* parent;+ if (parentp == NULL)+ parent = NULL;+ else {+ parent = *parentp;+ if (parent == NULL) return -20883; /* Haskell binding-specific error code */+ }+ *txnpp = (DbTxn**)malloc(sizeof(DbTxn*));+ try {+ return dbenvp->txn_begin(parent, *txnpp, flags);+ }+ catch (DbException& exc) {+ free(*txnpp);+ return exc.get_errno();+ }+}++int _dbenv_txn_checkpoint(DbEnv* dbenvp, u_int32_t kbyte, u_int32_t min, u_int32_t flags)+{+ UNWRAP_DBENV();+ return dbenv->txn_checkpoint(dbenv, kbyte, min, flags);+}++int _dbtxn_abort(DbTxn** dbtxnp)+{+ UNWRAP_DBTXN();+ *dbtxnp = NULL;+ dbtxn->abort(dbtxn);+}++int _dbtxn_commit(DbTxn** dbtxnp, u_int32_t flags)+{+ UNWRAP_DBTXN();+ *dbtxnp = NULL;+ dbtxn->commit(dbtxn, flags);+}++void _dbtxn_delete(DbTxn** dbtxnp)+{+ if (*dbtxnp != NULL)+ (*dbtxnp)->abort();+ free(dbtxnp);+}++u_int32_t _dbtxn_id(DbTxn** dbtxnp)+{+ UNWRAP_DBTXN();+ return dbtxn->id(dbtxn);+}++int _dbenv_lock_get(DbEnv* dbenvp, u_int32_t lockerID, u_int32_t flags,+ const char* object, u_int32_t object_len, u_int32_t lockmode, _DB_LOCK** dblock)+{+ DBT dbt;+ UNWRAP_DBENV();++ memset(&dbt, 0, sizeof(dbt));+ dbt.flags = DB_DBT_USERMEM;+ dbt.data = (void*)object;+ dbt.size = object_len;+ *dblock = (_DB_LOCK*)malloc(sizeof(_DB_LOCK));+ (*dblock)->dbenv = dbenvp;+ return dbenv->lock_get(dbenv, lockerID, flags, &dbt, (db_lockmode_t)lockmode, &(*dblock)->lock);+}++int _dbenv_lock_put(_DB_LOCK* dblock)+{+ DbEnv* dbenvp = dblock->dbenv;+ UNWRAP_DBENV();+ return dbenv->lock_put(dbenv, &dblock->lock);+}++void _dblock_delete(_DB_LOCK* dblock)+{+ free(dblock);+}++void _freeString(char* str)+{+ free(str);+}++int _db_get(DB** dbp, DbTxn** dbtxnp, const char* key, u_int32_t key_len, char** value, u_int32_t* value_len, u_int32_t flags)+{+ DBT keyDbt;+ DBT valueDbt;+ int ret;+ DB_TXN* dbtxn;+ UNWRAP_DB();+ UNWRAP_DBTXN_();++ memset(&keyDbt, 0, sizeof(keyDbt));+ keyDbt.flags = DB_DBT_USERMEM;+ keyDbt.data = (void*)key;+ keyDbt.size = key_len;+ memset(&valueDbt, 0, sizeof(valueDbt));+ valueDbt.flags = DB_DBT_MALLOC;++ *value = NULL;+ *value_len = 0;+ ret = db->get(db, dbtxn, &keyDbt, &valueDbt, flags);+ if (ret == 0) {+ *value = (char*)valueDbt.data;+ *value_len = valueDbt.size;+ }+ return ret;+}++int _db_put(DB** dbp, DbTxn** dbtxnp, const char* key, u_int32_t key_len, const char* value, u_int32_t value_len, u_int32_t flags)+{+ DBT keyDbt;+ DBT valueDbt;+ DB_TXN* dbtxn;+ UNWRAP_DB();+ UNWRAP_DBTXN_();+ + memset(&keyDbt, 0, sizeof(keyDbt));+ keyDbt.flags = DB_DBT_USERMEM;+ keyDbt.data = (void*)key;+ keyDbt.size = key_len;+ memset(&valueDbt, 0, sizeof(valueDbt));+ valueDbt.flags = DB_DBT_USERMEM;+ valueDbt.data = (void*)value;+ valueDbt.size = value_len;+ return db->put(db, dbtxn, &keyDbt, &valueDbt, flags);+}++int _db_del(DB** dbp, DbTxn** dbtxnp, const char* key, u_int32_t key_len, u_int32_t flags)+{+ DBT keyDbt;+ DB_TXN* dbtxn;+ UNWRAP_DB();+ UNWRAP_DBTXN_();++ memset(&keyDbt, 0, sizeof(keyDbt));+ keyDbt.flags = DB_DBT_USERMEM;+ keyDbt.data = (void*)key;+ keyDbt.size = key_len;+ return db->del(db, dbtxn, &keyDbt, flags);+}++int _db_close(DB** dbp, u_int32_t flags)+{+ UNWRAP_DB();+ *dbp = NULL;+ return db->close(db, flags);+}++int _dbenv_close(DbEnv* dbenvp, u_int32_t flags)+{+ dbenvp->close(flags);+}++int _dbenv_set_lk_detect(DbEnv* dbenvp, u_int32_t flag)+{+ UNWRAP_DBENV();+ return dbenv->set_lk_detect(dbenv, flag);+}+
+ Database/Berkeley/db_helper.h view
@@ -0,0 +1,53 @@+#ifndef _DB_HELPER_H_+#define _DB_HELPER_H_++#include <db_cxx.h>++typedef struct _DB_LOCK {+ DbEnv* dbenv;+ DB_LOCK lock;+} _DB_LOCK;++extern "C" {+int _dbenv_create(DbEnv** dbenvpp, u_int32_t flags);+void _dbenv_delete(DbEnv* dbenvp);+int _dbenv_get_lk_max_lockers(DbEnv* dbenvp, u_int32_t *lk_maxp);+int _dbenv_set_lk_max_lockers(DbEnv* dbenvp, u_int32_t max);+int _dbenv_get_lk_max_locks(DbEnv* dbenvp, u_int32_t *lk_maxp);+int _dbenv_set_lk_max_locks(DbEnv* dbenvp, u_int32_t max);+int _dbenv_get_lk_max_objects(DbEnv* dbenvp, u_int32_t *lk_maxp);+int _dbenv_set_lk_max_objects(DbEnv* dbenvp, u_int32_t max);+int _dbenv_get_tx_max(DbEnv* dbenvp, u_int32_t *lk_maxp);+int _dbenv_set_tx_max(DbEnv* dbenvp, u_int32_t max);+int _dbenv_get_cachesize(DbEnv* dbenvp, u_int32_t *gbytesp, u_int32_t *bytesp, int *ncachep);+int _dbenv_set_cachesize(DbEnv* dbenvp, u_int32_t gbytes, u_int32_t bytes, int ncache);+int _dbenv_get_lg_regionmax(DbEnv* dbenvp, u_int32_t *lk_maxp);+int _dbenv_set_lg_regionmax(DbEnv* dbenvp, u_int32_t max);+int _dbenv_open(DbEnv* dbenvp, char *db_home, u_int32_t flags, int mode);+int _db_create(DB*** dbpp, DbEnv* dbenvp, u_int32_t flags);+void _db_delete(DB** db);+int _db_set_pagesize(DB** dbp, u_int32_t pagesize);+int _db_open(DB** dbp, DbTxn** txnp, const char* file, const char* database,+ int type, u_int32_t flags, int mode);+int _dbenv_txn_begin(DbEnv* dbenvp, DbTxn** parent, DbTxn*** txnpp, u_int32_t flags);+int _dbenv_txn_checkpoint(DbEnv* dbenvp, u_int32_t kbyte, u_int32_t min, u_int32_t flags);+int _dbtxn_abort(DbTxn** dbtxnp);+int _dbtxn_commit(DbTxn** dbtxnp, u_int32_t flags);+void _dbtxn_delete(DbTxn** dbtxnp);+u_int32_t _dbtxn_id(DbTxn** dbtxnp);+void _dblock_delete(_DB_LOCK* dblock);+int _dbenv_lock_get(DbEnv* dbenvp, u_int32_t lockerID, u_int32_t flags,+ const char* object, u_int32_t object_len, u_int32_t lockmode, _DB_LOCK** dblock);+int _dbenv_lock_put(_DB_LOCK* dblock);+void _deleteString(char* str);+void _freeString(char* str);+int _db_get(DB** dbp, DbTxn** dbtxnp, const char* key, u_int32_t key_len, char** value, u_int32_t* value_len, u_int32_t flags);+int _db_put(DB** dbp, DbTxn** dbtxnp, const char* key, u_int32_t key_len, const char* value, u_int32_t value_len, u_int32_t flags);+int _db_del(DB** dbp, DbTxn** dbtxnp, const char* key, u_int32_t key_len, u_int32_t flags);+int _db_close(DB** dbp, u_int32_t flags);+int _dbenv_close(DbEnv* dbEnv, u_int32_t flags);+int _dbenv_set_lk_detect(DbEnv* dbEnv, u_int32_t flag);+}++#endif+
− Database/BerkeleyDB.hs
@@ -1,1149 +0,0 @@-{-# INCLUDE "Database/BerkeleyDB_hsc.h" #-}-{-# LINE 1 "Database/BerkeleyDB.hsc" #-}-{--{-# LINE 2 "Database/BerkeleyDB.hsc" #-}- Database.BerkeleyDB v0.2- Copyright 2007 John McCall- Licensed for general use under a BSD3-style license; for the exact- license text, see the LICENSE file included in this distribution. If- you find this file distributed without a LICENSE file, please contact- me at rjmccall@gmail.com and tell me where you found it.-- It's my hope that this module could be used to bootstrap bindings for a- modern version of Berkeley DB, but I'm not currently working on that.-- Author: John McCall <rjmccall@gmail.com>- Maintainer: John McCall <rjmccall@gmail.com>- History:- v0.2 2007-04-06 Haddock documentation; FileMode.- v0.1 2007-04-05 Creation.--}--{- We require a preprocessor pass in order to bring the structure- layout into scope. We can't rely the LANGUAGE CPP pragma, though,- because we're a literate Haskell file, and it doesn't mix well- (in particular, GHC doesn't add the current directory to the include- path, which is a problem, because unlitting this file creates a file- in /tmp somewhere). -}--{-# LANGUAGE ForeignFunctionInterface #-}---{-# LINE 29 "Database/BerkeleyDB.hsc" #-}--{-# LINE 30 "Database/BerkeleyDB.hsc" #-}---{-# LINE 32 "Database/BerkeleyDB.hsc" #-}--{-# LINE 33 "Database/BerkeleyDB.hsc" #-}--{-# LINE 36 "Database/BerkeleyDB.hsc" #-}--{-|-Haskell bindings for Berkeley DB v1.85, i.e. @db.h@ on BSD-derived Unices.-This module is intended to be imported qualified.--The database implementations provided by this module are not safe-against concurrent access; for that, users must seek a more resilient-database.--This module has been written with GHC 6.6 in mind; it is quite-possible that it will function with minimal changes on other-implementations of Haskell or earlier versions of GHC, and patches for-this purpose would be welcome, providing they don't compromise the integrity-of the up-to-date GHC implementation.--The open functions generally interpret 'IOMode' as follows:--- 'ReadMode' attempts to open a database in read-only mode; if the database- doesn't exist, an exception is thrown.--- 'ReadWriteMode' and 'AppendMode' are synonymous; both open the database in- read\/write mode, creating it if necessary.--- 'WriteMode' opens the database in read\/write mode, but it truncates any- existing database file.- -}-module Database.BerkeleyDB- (HashDB, openHash, HashDBCursor,HashDBConf(..), defaultHashDBConf,- TreeDB, openTree, TreeDBCursor,TreeDBConf(..), defaultTreeDBConf, - RecordDB, openRecord, Record, RecordDBCursor,- RecordDBConf(..), defaultRecordDBConf,- FixedRecordDB, openFixedRecord, FixedRecordDBCursor,- FixedRecordDBConf(..), defaultFixedRecordDBConf,- DB(..), DBCursor(..),- IOMode(..)) where--import System.IO (IOMode(..)) -- re-exported-import System.Posix.Files -- for FileMode's helpful constants-import System.Posix.Types -- for mode_t--import Foreign-import Foreign.C-import Control.Monad (when, liftM)-import Control.Exception (bracketOnError)-import Data.ByteString (ByteString, packCStringLen, copyCStringLen, useAsCStringLen)-import Prelude hiding (lookup)--{- We use 0666 as our default umask, but we define it in this crazy way. -}-defaultUmask :: FileMode-defaultUmask = foldl1 unionFileModes [ownerReadMode,- ownerWriteMode,- groupReadMode,- groupWriteMode,- otherReadMode,- otherWriteMode]----------- TYPE CLASSES -----------{-| Common operations supported by databases. The database type- functionally defines its key, value, and cursor types. -}-class (DBCursor c k v) => DB t c k v | t -> c k v where-- {-| The simplified "open" command. Individual database types usually- provide a specialized open operation. If no filepath is given, the- database will exist primarily in memory or a temporary file. -}- open :: Maybe FilePath -> IOMode -> IO t-- {-| Closes the database. Just as with files, it's important to explicitly- close a database to avoid memory leaks; it's also important to explicitly- close a database in order to flush database writes which might currently- be cached.-- The internal database structures may be in an unstable state after this- function is called; it's unsafe to make any further calls on the same- database object after it's been closed. -}- close :: t -> IO ()-- {-| Inserts an entry into the database. -}- insert :: t -> k -> v -> IO ()-- {-| Looks up an entry in the database. -}- lookup :: t -> k -> IO (Maybe v)-- {-| Deletes an entry from the database. Returns true if the entry existed- before it was deleted. -}- delete :: t -> k -> IO Bool-- {-| Creates a new cursor for sequential access to the database. The- standard Berkeley DB implementations only support a single cursor- per database, so even if multiple cursors are created, they'll- all change the same state. Other database implementations might- support multiple simultaneous cursors. -}- cursor :: t -> IO c-- {-| Forces a sync with the disk, to the extent that this is possible- with system calls. -}- sync :: t -> IO ()---{-| A type-class for database cursors. The cursor type functionally- defines the key and value types. -}-class DBCursor c k v | c -> k v where-- {-| Jumps to the first entry in the database. -}- jumpFirst :: c -> IO (Maybe (k,v))-- {-| Jumps to the last entry in the database. Not all database- implementations support this operation. -}- jumpLast :: c -> IO (Maybe (k,v))-- {-| Jumps to an arbitrary place in the database. The returned match- may not be an exact match for the key; see the notes for each- database implementation for more details. -}- jump :: c -> k -> IO (Maybe (k,v))-- {-| Moves to the next entry in the database. -}- next :: c -> IO (Maybe (k,v))-- {-| Moves to the previous entry in the database. -}- previous :: c -> IO (Maybe (k,v))-- {-| Replaces the current entry with a new value. The cursor must be- initialized for this operation to succeed. -}- replace :: c -> k -> v -> IO ()-- {-| Removes the entry at the current cursor position. -}- remove :: c -> IO ()-- {-| Closes the cursor. For Berkeley databases, this doesn't do anything. -}- closeCursor:: c -> IO ()----------- GENERAL IMPLEMENTATION ---------{- The type of databases; in C-land, this is "DB". Here, it's- completely opaque, we never try to modify it, and we don't export- it. -}-data DBStruct = DBStruct--{- The type of "database thangs"; in C-land, this is "DBT". -}-data DBT = DBT Int (Ptr CChar)-instance Storable DBT where- sizeOf _ = sizeOf (undefined :: CInt) + sizeOf (undefined :: Ptr CChar)- alignment _ = alignment (undefined :: Ptr CChar)- peek ptr = do- dat <- peek (castPtr ptr)- size <- peek (plusPtr ptr (sizeOf (undefined :: Ptr CChar)))- return $ DBT size dat- poke ptr (DBT size dat) = do- poke (castPtr ptr) dat- poke (plusPtr ptr (sizeOf (undefined :: Ptr CChar))) size--{- Copies a DBT into a new ByteString, which will have a finalizer- associated with it. -}-copyDBT :: Ptr DBT -> IO ByteString-copyDBT ptr = do- DBT sz dat <- peek ptr- copyCStringLen (dat, sz)--{- Temporarily wraps a DBT in a ByteString. ByteStrings created this way- should never become visible out of this module --- the database doesn't- guarantee that returned values will remain consistent across subsequent- database calls, so it's important to copy anything that we think should- stick around. We provide this wrapping only for our callbacks, which- (since they're not monadic) shouldn't ever capture the memory. -}-wrapDBT :: Ptr DBT -> ByteString-wrapDBT ptr = unsafePerformIO $ do- DBT sz dat <- peek ptr- return $ packCStringLen (dat, sz)--{- Use a ByteString transparently as a DBT. The DBT- will become unstable as soon as withDBT completes, so don't capture- a reference to it in the enclosed computation. -}-withDBT :: ByteString -> (Ptr DBT -> IO a) -> IO a-withDBT bs fn =- useAsCStringLen bs $ \(dat,sz) ->- alloca $ \bst -> do- poke bst (DBT sz dat)- fn bst--{- Using a Maybe String transparently as a CString. The CString- will become unstable as soon as withMaybeString completes, so don't- capture a reference to it in the enclosed computation. -}-withMaybeString :: Maybe String -> (CString -> IO a) -> IO a-withMaybeString Nothing action = action nullPtr-withMaybeString (Just s) action = withCAString s action--{- Permanently allocates a function pointer, but frees it if the enclosed- operation fails. This is useful for ensuring that the function pointer- survives until it can be successfully compiled into some structure- which the user is obliged to manually destroy. -}-allocFunPtr :: IO (FunPtr a) -> (FunPtr a -> IO b) -> IO b-allocFunPtr makeFun action = do- bracketOnError makeFun freeHaskellFunPtr action--{- A helper routine to convert a list of boolean/mask pairs into a mask. -}-toFlags :: [(Bool,CULong)] -> CULong-toFlags = foldr (\(bool,mask) -> if bool then (mask .&.) else id) 0--{- Converts an IOMode constant into the appropriate bitmask. -}--fromIOMode :: IOMode -> CInt-fromIOMode ReadMode = 0-{-# LINE 239 "Database/BerkeleyDB.hsc" #-}-fromIOMode WriteMode = 1538-{-# LINE 240 "Database/BerkeleyDB.hsc" #-}-fromIOMode AppendMode = 514-{-# LINE 241 "Database/BerkeleyDB.hsc" #-}-fromIOMode ReadWriteMode = 514-{-# LINE 242 "Database/BerkeleyDB.hsc" #-}--{- The standard database cursor. The second parameter is whether safe or- unsafe routines must be used. -}-data Cursor = Cursor (Ptr DBStruct) Bool-instance DBCursor Cursor ByteString ByteString where- jump (Cursor ptr sf) key = _cursorKeyed sf ptr key 1-{-# LINE 248 "Database/BerkeleyDB.hsc" #-}- jumpFirst (Cursor ptr sf) = _cursorUnkeyed sf ptr 3-{-# LINE 249 "Database/BerkeleyDB.hsc" #-}- jumpLast (Cursor ptr sf) = _cursorUnkeyed sf ptr 6-{-# LINE 250 "Database/BerkeleyDB.hsc" #-}- next (Cursor ptr sf) = _cursorUnkeyed sf ptr 7-{-# LINE 251 "Database/BerkeleyDB.hsc" #-}- previous (Cursor ptr sf) = _cursorUnkeyed sf ptr 9-{-# LINE 252 "Database/BerkeleyDB.hsc" #-}- replace (Cursor ptr sf) key val = _insert sf ptr key val 10-{-# LINE 253 "Database/BerkeleyDB.hsc" #-}- remove (Cursor ptr sf) = _deleteCursor sf ptr- closeCursor _ = return ()--{- Create a new standard cursor. -}-newCursor :: Ptr DBStruct -> Bool -> IO Cursor-newCursor ptr sf = return $ Cursor ptr sf--------- HASHTABLES ----------{-| Hashtable-based databases. -}-data HashDB = HashDB (Ptr DBStruct) Bool HashToken-instance DB HashDB HashDBCursor ByteString ByteString where- open file mode = openHash file mode defaultUmask defaultHashDBConf- close (HashDB ptr sf t) = do- freeHashToken t- _close ptr- insert (HashDB ptr sf _) key value = _insert sf ptr key value 0- lookup (HashDB ptr sf _) key = _lookup sf ptr key- delete (HashDB ptr sf _) key = _delete sf ptr key- cursor (HashDB ptr sf _) = liftM HashDBCursor $ newCursor ptr sf- sync (HashDB ptr sf _) = _sync ptr--{-| The type of hashtable database cursors. -}-newtype HashDBCursor = HashDBCursor Cursor-instance DBCursor HashDBCursor ByteString ByteString where- jump (HashDBCursor c) = jump c- jumpFirst (HashDBCursor c) = jumpFirst c- jumpLast (HashDBCursor c) = jumpLast c- next (HashDBCursor c) = next c- previous (HashDBCursor c) = previous c- replace (HashDBCursor c) = replace c- remove (HashDBCursor c) = remove c- closeCursor (HashDBCursor c) = closeCursor c--{-| The configuration of a hashtable database. -}-data HashDBConf = HashDBConf {-- {-| The size of a hash bucket, in bytes. -}- hash_bucketSize :: Int,-- {-| A desired density for the hashtable. This value approximates the- maximum number of keys allowed in a bucket; the default value is 8. -}- hash_keyDensity :: Int,-- {-| The initial size of the database. The hashtable will grow gracefully - as keys are added, but performance may temporarily suffer at each- expansion, so it's always better to get this right. -}- hash_initialSize :: Int,-- {-| An advistory maximum size for the in-memory database cache. -}- hash_cacheSize :: Int,-- {-| The byte order of hashtable metadata; for example, 4321 specifies a- big-endian format. Not all byte orders are necessarily supported, and- this setting is ignored when opening existing databases. 0 means to use- host order. -}- hash_byteOrder :: Int,-- {-| A custom hash function. Specifying a custom hash function can- sometimes improve hashtable performance, depending on the expected- range of keys; however, since it requires a callback into Haskell, it- can also hurt performance by requiring "safe" calls into C (which forces- the runtime system to stabilize itself before every database call). -}- hash_hashFunction :: Maybe (ByteString -> Word32)-}--{-| The default database configuration. -}-defaultHashDBConf :: HashDBConf-defaultHashDBConf = HashDBConf {- hash_bucketSize = 0,- hash_keyDensity = 0,- hash_initialSize = 0,- hash_cacheSize = 0,- hash_byteOrder = 0,- hash_hashFunction = Nothing-}--{-| Opens or creates a hashtable database. -}-openHash :: Maybe FilePath -> IOMode -> FileMode -> HashDBConf -> IO HashDB-openHash path iomode umask conf = - withMaybeString path $ \cpath ->- alloca $ \info ->- allocFunPtr (makeHash $ hash_hashFunction conf) $ \fpHash -> do- writeHashDBConf conf fpHash info- ptr <- throwErrnoIfNull "BerkeleyDB.openHash"- $ db_open_hash cpath (fromIOMode iomode) umask info- let safe = fpHash /= nullFunPtr- return $ HashDB ptr safe fpHash--{- Tokens are created during database initialization and must be manually- freed during database teardown. -}-type HashToken = FunPtr (CString -> CSize -> Word32)-freeHashToken :: HashToken -> IO ()-freeHashToken fpHash = do- when (fpHash /= nullFunPtr) $ freeHaskellFunPtr fpHash--{- Writes a hashtable configuration into the corresponding C structure.- We pass in the function pointer from elsewhere because it- aids emergency cleanup to do so. -}-writeHashDBConf :: HashDBConf- -> FunPtr (CString -> CSize -> Word32)- -> Ptr HASHINFO- -> IO ()-writeHashDBConf conf fpHash info = do- poke info $ HASHINFO {- hi_bsize = toEnum $ hash_bucketSize conf,- hi_ffactor = toEnum $ hash_keyDensity conf,- hi_nelem = toEnum $ hash_initialSize conf,- hi_cachesize = toEnum $ hash_cacheSize conf,- hi_lorder = toEnum $ hash_byteOrder conf,- hi_hash = fpHash- }--{- Turns a Haskell hash function into a database-appropriate foreign hash- function. -}-makeHash :: Maybe (ByteString -> Word32) -> IO (FunPtr (CString -> CSize -> Word32))-makeHash Nothing = return nullFunPtr-makeHash (Just h) = wrapHash $ wrap h- where wrap hash dat sz = hash $ packCStringLen (dat, fromEnum sz)--{-- typedef struct {- u_int bsize;- u_int ffactor;- u_int nelem;- u_int cachesize;- u_int32_t (*hash)(const void *, size_t);- int lorder;- } HASHINFO;--}-data HASHINFO = HASHINFO {- hi_bsize, hi_ffactor, hi_nelem, hi_cachesize :: CUInt,- hi_hash :: FunPtr (CString -> CSize -> Word32),- hi_lorder :: CInt-}-instance Storable HASHINFO where- sizeOf _ = (24)-{-# LINE 390 "Database/BerkeleyDB.hsc" #-}- alignment _ = 4-{-# LINE 391 "Database/BerkeleyDB.hsc" #-}- poke ptr info = do- (\hsc_ptr -> pokeByteOff hsc_ptr 0) ptr (hi_bsize info)-{-# LINE 393 "Database/BerkeleyDB.hsc" #-}- (\hsc_ptr -> pokeByteOff hsc_ptr 4) ptr (hi_ffactor info)-{-# LINE 394 "Database/BerkeleyDB.hsc" #-}- (\hsc_ptr -> pokeByteOff hsc_ptr 8) ptr (hi_nelem info)-{-# LINE 395 "Database/BerkeleyDB.hsc" #-}- (\hsc_ptr -> pokeByteOff hsc_ptr 12) ptr (hi_cachesize info)-{-# LINE 396 "Database/BerkeleyDB.hsc" #-}- (\hsc_ptr -> pokeByteOff hsc_ptr 20) ptr (hi_lorder info)-{-# LINE 397 "Database/BerkeleyDB.hsc" #-}- (\hsc_ptr -> pokeByteOff hsc_ptr 16) ptr (hi_hash info)-{-# LINE 398 "Database/BerkeleyDB.hsc" #-}- peek ptr = do- bsize <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr-{-# LINE 400 "Database/BerkeleyDB.hsc" #-}- ffactor <- (\hsc_ptr -> peekByteOff hsc_ptr 4) ptr-{-# LINE 401 "Database/BerkeleyDB.hsc" #-}- nelem <- (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr-{-# LINE 402 "Database/BerkeleyDB.hsc" #-}- cachesize <- (\hsc_ptr -> peekByteOff hsc_ptr 12) ptr-{-# LINE 403 "Database/BerkeleyDB.hsc" #-}- hash <- (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr-{-# LINE 404 "Database/BerkeleyDB.hsc" #-}- lorder <- (\hsc_ptr -> peekByteOff hsc_ptr 20) ptr-{-# LINE 405 "Database/BerkeleyDB.hsc" #-}- return $ HASHINFO { hi_bsize = bsize, hi_ffactor = ffactor,- hi_nelem = nelem, hi_cachesize = cachesize,- hi_hash = hash, hi_lorder = lorder }--------- B-TREE DATABASES -----------{-| A database built on a b-tree. -}-data TreeDB = TreeDB (Ptr DBStruct) Bool TreeToken-instance DB TreeDB TreeDBCursor ByteString ByteString where- open file mode = openTree file mode defaultUmask defaultTreeDBConf- close (TreeDB ptr sf t) = do- freeTreeToken t- _close ptr- insert (TreeDB ptr sf _) key value = _insert sf ptr key value 0- lookup (TreeDB ptr sf _) key = _lookup sf ptr key- delete (TreeDB ptr sf _) key = _delete sf ptr key- sync (TreeDB ptr sf _) = _sync ptr- cursor (TreeDB ptr sf _) = liftM TreeDBCursor (newCursor ptr sf)--{-| The cursor for a tree database. -}-newtype TreeDBCursor = TreeDBCursor Cursor-instance DBCursor TreeDBCursor ByteString ByteString where- jump (TreeDBCursor c) = jump c- jumpFirst (TreeDBCursor c) = jumpFirst c- jumpLast (TreeDBCursor c) = jumpLast c- next (TreeDBCursor c) = next c- previous (TreeDBCursor c) = previous c- replace (TreeDBCursor c) = replace c- remove (TreeDBCursor c) = remove c- closeCursor (TreeDBCursor c) = closeCursor c--{-| The configuration for a b-tree database. -}-data TreeDBConf = TreeDBConf {-- {-| Permit multiple entries to appear in the database per key. Only- sequential operations can observe the difference. -}- tree_duplicateKeys :: Bool,-- {-| An advistory maximum size of the in-memory database cache, in- bytes. A default cache size is used if this value is 0. -}- tree_cacheSize :: Int,-- {-| An advisory maximum number of keys to store on a page. btree(3)- says this isn't implemented. -}- tree_maxKeysPerPage :: Int,-- {-| The minimum number of keys to store on a page (other than the- root). This can never been less than 2. -}- tree_minKeysPerPage :: Int,-- {-| The size of each pages of the btree, in bytes. This much be at- least 512 and no more than 64K; if it is zero, a default size is- chosen based on the filesystem block size. This value is ignored- when opening existing databases. -}- tree_pageSize :: Int,-- {-| The byte order of btree metadata; for example, 4321 specifies a- big-endian format. Not all byte orders are necessarily supported,- and this setting is ignored when opening existing databases. 0 means- to use host order. -}- tree_byteOrder :: Int,-- {-| A comparison function for keys. It is important that the same function- be used every time the tree is opened. The default comparison order is- lexicographic (i.e. shorter keys sort first, then each byte is compared- from the beginning to the end). -}- tree_compare :: Maybe (ByteString -> ByteString -> Ordering),-- {-| A function indicating how many bytes are required from the second key- argument in order to decide the ordering. If the keys are equal, this- should be the length of the key. This can produce highly-compressed trees- in certain domains. -}- tree_prefix :: Maybe (ByteString -> ByteString -> Int)-}--{-| The default b-tree configuration. -}-defaultTreeDBConf :: TreeDBConf-defaultTreeDBConf = TreeDBConf {- tree_duplicateKeys = False, -- disallow duplicate keys- tree_cacheSize = 0, -- use default cache size- tree_maxKeysPerPage = 0, -- evidentally, not implemented yet anyway in Berkeley DB- tree_minKeysPerPage = 0, -- use the default minimum number of keys per page- tree_pageSize = 0, -- use the default page size- tree_compare = Nothing, -- no custom comparison operation- tree_prefix = Nothing, -- no custom prefix operation- tree_byteOrder = 0 -- host order-}--{-| Opens a b-tree database, failing with an I\/O exception if the database- couldn't be opened. -}-openTree :: Maybe FilePath -> IOMode -> FileMode -> TreeDBConf -> IO TreeDB-openTree path iomode filemode conf =- alloca $ \info ->- withMaybeString path $ \cpath ->- allocFunPtr (makeCompare $ tree_compare conf) $ \fpCompare ->- allocFunPtr (makePrefix $ tree_prefix conf) $ \fpPrefix -> do- writeTreeDBConf conf fpCompare fpPrefix info- ptr <- throwErrnoIfNull "BerkeleyDB.openTree"- $ db_open_btree cpath (fromIOMode iomode) filemode info- let safe = fpCompare /= nullFunPtr || fpPrefix /= nullFunPtr- return $ TreeDB ptr safe (fpCompare,fpPrefix)--{- The token which must be explicitly freed when a database is shut down.- Here, it's a pointer to the two foreign function pointers. -}-type TreeToken = (FunPtr (Ptr DBT -> Ptr DBT -> CInt),- FunPtr (Ptr DBT -> Ptr DBT -> CSize))-freeTreeToken :: TreeToken -> IO ()-freeTreeToken (fpCompare, fpPrefix) = do- when (fpCompare /= nullFunPtr) $ freeHaskellFunPtr fpCompare- when (fpPrefix /= nullFunPtr) $ freeHaskellFunPtr fpPrefix--{- Writes a b-tree database configuration into a C structure.- We pass in the function pointers from elsewhere because it- aids emergency cleanup to do so. -}-writeTreeDBConf :: TreeDBConf- -> FunPtr (Ptr DBT -> Ptr DBT -> CInt)- -> FunPtr (Ptr DBT -> Ptr DBT -> CSize)- -> Ptr BTREEINFO- -> IO ()-writeTreeDBConf conf fpCompare fpPrefix info = do- poke info $ BTREEINFO {- bi_flags = toFlags [(tree_duplicateKeys conf, 1)],-{-# LINE 527 "Database/BerkeleyDB.hsc" #-}- bi_cachesize = toEnum $ tree_cacheSize conf,- bi_maxkeypage = toEnum $ tree_maxKeysPerPage conf,- bi_minkeypage = toEnum $ tree_minKeysPerPage conf,- bi_psize = toEnum $ tree_pageSize conf,- bi_compare = fpCompare,- bi_prefix = fpPrefix,- bi_lorder = toEnum $ tree_byteOrder conf- }--{- Wraps a Haskell comparison function as a pointer to a C function. -}-makeCompare :: Maybe (ByteString -> ByteString -> Ordering) -> IO (FunPtr (Ptr DBT -> Ptr DBT -> CInt))-makeCompare Nothing = return nullFunPtr-makeCompare (Just f) = wrapCompare wrap- where wrap a b =- case f (wrapDBT a) (wrapDBT b) of- LT -> -1- EQ -> 0- GT -> 1--{- Wraps a Haskell prefix function as a pointer to a C function. -}-makePrefix :: Maybe (ByteString -> ByteString -> Int) -> IO (FunPtr (Ptr DBT -> Ptr DBT -> CSize))-makePrefix Nothing = return nullFunPtr-makePrefix (Just f) = wrapPrefix (wrap f)- where wrap f a b = toEnum $ f (wrapDBT a) (wrapDBT b)--{-- typedef struct {- u_long flags;- u_int cachesize;- int maxkeypage;- int minkeypage;- u_int psize;- int (*compare)(const DBT *key1, const DBT *key2);- size_t (*prefix)(const DBT *key1, const DBT *key2);- int lorder;- } BTREEINFO;--}--data BTREEINFO = BTREEINFO {- bi_flags :: CULong,- bi_cachesize, bi_psize :: CUInt,- bi_maxkeypage, bi_minkeypage, bi_lorder :: CInt,- bi_compare :: FunPtr (Ptr DBT -> Ptr DBT -> CInt),- bi_prefix :: FunPtr (Ptr DBT -> Ptr DBT -> CSize)-}-instance Storable BTREEINFO where- sizeOf _ = (32)-{-# LINE 574 "Database/BerkeleyDB.hsc" #-}- alignment _ = 4-{-# LINE 575 "Database/BerkeleyDB.hsc" #-}- peek ptr = do- flags <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr-{-# LINE 577 "Database/BerkeleyDB.hsc" #-}- cachesize <- (\hsc_ptr -> peekByteOff hsc_ptr 4) ptr-{-# LINE 578 "Database/BerkeleyDB.hsc" #-}- maxkeypage <- (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr-{-# LINE 579 "Database/BerkeleyDB.hsc" #-}- minkeypage <- (\hsc_ptr -> peekByteOff hsc_ptr 12) ptr-{-# LINE 580 "Database/BerkeleyDB.hsc" #-}- psize <- (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr-{-# LINE 581 "Database/BerkeleyDB.hsc" #-}- lorder <- (\hsc_ptr -> peekByteOff hsc_ptr 28) ptr-{-# LINE 582 "Database/BerkeleyDB.hsc" #-}- compare <- (\hsc_ptr -> peekByteOff hsc_ptr 20) ptr-{-# LINE 583 "Database/BerkeleyDB.hsc" #-}- prefix <- (\hsc_ptr -> peekByteOff hsc_ptr 24) ptr-{-# LINE 584 "Database/BerkeleyDB.hsc" #-}- return $ BTREEINFO { bi_flags = flags, bi_cachesize = cachesize,- bi_maxkeypage = maxkeypage, bi_minkeypage = minkeypage,- bi_psize = psize, bi_lorder = lorder,- bi_compare = compare, bi_prefix = prefix }- poke ptr info = do- (\hsc_ptr -> pokeByteOff hsc_ptr 0) ptr (bi_flags info)-{-# LINE 590 "Database/BerkeleyDB.hsc" #-}- (\hsc_ptr -> pokeByteOff hsc_ptr 4) ptr (bi_cachesize info)-{-# LINE 591 "Database/BerkeleyDB.hsc" #-}- (\hsc_ptr -> pokeByteOff hsc_ptr 8) ptr (bi_maxkeypage info)-{-# LINE 592 "Database/BerkeleyDB.hsc" #-}- (\hsc_ptr -> pokeByteOff hsc_ptr 12) ptr (bi_minkeypage info)-{-# LINE 593 "Database/BerkeleyDB.hsc" #-}- (\hsc_ptr -> pokeByteOff hsc_ptr 16) ptr (bi_psize info)-{-# LINE 594 "Database/BerkeleyDB.hsc" #-}- (\hsc_ptr -> pokeByteOff hsc_ptr 20) ptr (bi_compare info)-{-# LINE 595 "Database/BerkeleyDB.hsc" #-}- (\hsc_ptr -> pokeByteOff hsc_ptr 24) ptr (bi_prefix info)-{-# LINE 596 "Database/BerkeleyDB.hsc" #-}- (\hsc_ptr -> pokeByteOff hsc_ptr 28) ptr (bi_lorder info)-{-# LINE 597 "Database/BerkeleyDB.hsc" #-}--------- RECORD DATABASES ----------{-| recno_t, the type of record indices. recno(3) says this is "normally- the largest unsigned integral type available to the implementation", but on- modern systems it's usually just uint32_t. -}-newtype Record = Record Recno- deriving (Bits,Bounded,Enum,Eq,Integral,Num,- Ord,Read,Real,Show,Storable)-type Recno = Word32-{-# LINE 607 "Database/BerkeleyDB.hsc" #-}--{- The type of record cursors. -}-newtype RecCursor = RecCursor (Ptr DBStruct)---- Haddock wants to publicize this because it mentions Record, but I--- don't really want to preprocess before running Haddock, because CPP--- will throw all the HSC stuff in my face. Really, Haddock needs to--- recognize that this instance is functionally defined by a private--- type and therefore not expose it.-instance DBCursor RecCursor Record ByteString where- jump (RecCursor ptr) (Record key) = _cursorRecord ptr key 1-{-# LINE 618 "Database/BerkeleyDB.hsc" #-}- jumpFirst (RecCursor ptr) = _cursorRecord ptr 0 3-{-# LINE 619 "Database/BerkeleyDB.hsc" #-}- jumpLast (RecCursor ptr) = _cursorRecord ptr 0 6-{-# LINE 620 "Database/BerkeleyDB.hsc" #-}- next (RecCursor ptr) = _cursorRecord ptr 0 7-{-# LINE 621 "Database/BerkeleyDB.hsc" #-}- previous (RecCursor ptr) = _cursorRecord ptr 0 9-{-# LINE 622 "Database/BerkeleyDB.hsc" #-}- replace (RecCursor ptr) (Record key) val = _insertRecord ptr key val 10-{-# LINE 623 "Database/BerkeleyDB.hsc" #-}- remove (RecCursor ptr) = _deleteCursor False ptr -- never needs to be safe- closeCursor _ = return ()--newRecCursor :: Ptr DBStruct -> IO RecCursor-newRecCursor ptr = return $ RecCursor ptr--{-| Variable-length record databases. -}-newtype RecordDB = RecordDB (Ptr DBStruct)-instance DB RecordDB RecordDBCursor Record ByteString where- open file mode = openRecord file mode defaultUmask defaultRecordDBConf- close (RecordDB ptr) = _close ptr- insert (RecordDB ptr) (Record key) value = _insertRecord ptr key value 0- lookup (RecordDB ptr) (Record key) = _lookupRecord ptr key- delete (RecordDB ptr) (Record key) = _deleteRecord ptr key- cursor (RecordDB ptr) = liftM RecordDBCursor $ newRecCursor ptr- sync (RecordDB ptr) = _sync ptr--{-| The type of variable-length record database cursors. The key returned by- cursor procedures is always 0. -}-newtype RecordDBCursor = RecordDBCursor RecCursor-instance DBCursor RecordDBCursor Record ByteString where- jump (RecordDBCursor c) = jump c- jumpFirst (RecordDBCursor c) = jumpFirst c- jumpLast (RecordDBCursor c) = jumpLast c- next (RecordDBCursor c) = next c- previous (RecordDBCursor c) = previous c- replace (RecordDBCursor c) = replace c- remove (RecordDBCursor c) = remove c- closeCursor (RecordDBCursor c) = closeCursor c--{-| A configuration for variable-length record databases. -}-data RecordDBConf = RecordDBConf {- {-| Forces a snapshot of the database to be taken when the file- is opened. -}- record_snapshot :: Bool,-- {-| An advisory maximum size of the in-memory database cache. -}- record_cacheSize :: Int,-- {-| The page size used for the in-memory database cache, which happens- to be a b-tree. If this value is 0, a default size will be chosen. -}- record_pageSize :: Int,-- {-| The byte order for integers in the database metadata; for example,- 4321 represents big-endian order. Not all orders are guaranteed to- be supported; if the byte order is 0, host order will be used.- Unlike the other database types, record databases have no metadata,- so it's important to get this right when opening existing- databases. -}- record_byteOrder :: Int,-- {-| The byte value used to separate records in the database. By default,- this is a newline character (0x0A). -}- record_separatorByte :: Word8,-- {-| A file which should be used to store the the in-memory record cache. -}- record_treeFile :: Maybe String-}--{-| The default variable-length record database configuration. -}-defaultRecordDBConf :: RecordDBConf-defaultRecordDBConf = RecordDBConf {--- record_noKey = False,- record_snapshot = False,- record_cacheSize = 0,- record_pageSize = 0,- record_byteOrder = 0,- record_separatorByte = 0x0a,- record_treeFile = Nothing-}--{-| Opens a variable-length record database. -}-openRecord :: Maybe FilePath -> IOMode -> FileMode -> RecordDBConf -> IO RecordDB-openRecord path iomode filemode conf =- withMaybeString path $ \cpath ->- withMaybeString (record_treeFile conf) $ \ctreefile ->- alloca $ \info -> do- writeRecordDBConf conf ctreefile info- ptr <- throwErrnoIfNull "BerkeleyDB.openRecord"- $ db_open_recno cpath (fromIOMode iomode) filemode info- return $ RecordDB ptr--{- Writes a variable-length record database configuration into a C structure.- We pass in the btree filename string from elsewhere because it aids- emergency cleanup to do so. -}-writeRecordDBConf :: RecordDBConf -> CString -> Ptr RECNOINFO -> IO ()-writeRecordDBConf conf bfname info = do- poke info $ RECNOINFO {- ri_flags = toFlags [(False, 1),-{-# LINE 712 "Database/BerkeleyDB.hsc" #-}- (True, 2),-{-# LINE 713 "Database/BerkeleyDB.hsc" #-}- (record_snapshot conf, 4)],-{-# LINE 714 "Database/BerkeleyDB.hsc" #-}- ri_cachesize = toEnum $ record_cacheSize conf,- ri_psize = toEnum $ record_pageSize conf,- ri_lorder = toEnum $ record_byteOrder conf,- ri_reclen = 0,- ri_bval = fromInteger $ toInteger $ record_separatorByte conf,- ri_bfname = bfname- }--{-| Fixed-length record databases. -}-newtype FixedRecordDB = FixedRecordDB (Ptr DBStruct)-instance DB FixedRecordDB FixedRecordDBCursor Record ByteString where- open file mode = openFixedRecord file mode defaultUmask defaultFixedRecordDBConf- close (FixedRecordDB ptr) = _close ptr- insert (FixedRecordDB ptr) (Record key) value = _insertRecord ptr key value 0- lookup (FixedRecordDB ptr) (Record key) = _lookupRecord ptr key- delete (FixedRecordDB ptr) (Record key) = _deleteRecord ptr key- cursor (FixedRecordDB ptr) = liftM FixedRecordDBCursor $ newRecCursor ptr- sync (FixedRecordDB ptr) = _sync ptr--{-| The type of fixed-length record database cursors. The key returned by- cursor procedures is always 0. -}-newtype FixedRecordDBCursor = FixedRecordDBCursor RecCursor-instance DBCursor FixedRecordDBCursor Record ByteString where- jump (FixedRecordDBCursor c) = jump c- jumpFirst (FixedRecordDBCursor c) = jumpFirst c- jumpLast (FixedRecordDBCursor c) = jumpLast c- next (FixedRecordDBCursor c) = next c- previous (FixedRecordDBCursor c) = previous c- replace (FixedRecordDBCursor c) = replace c- remove (FixedRecordDBCursor c) = remove c- closeCursor (FixedRecordDBCursor c) = closeCursor c--{-| A configuration for fixed-length record databases. -}-data FixedRecordDBConf = FixedRecordDBConf {- {-| Forces a snapshot of the database to be taken when the file- is opened. -}- fixed_snapshot :: Bool,-- {-| An advisory maximum size of the in-memory database cache. -}- fixed_cacheSize :: Int,-- {-| The page size used for the in-memory database cache, which happens- to be a b-tree. If this value is 0, a default size will be chosen. -}- fixed_pageSize :: Int,-- {-| The fixed length of the records. This must be manually overridden in- the default configuration, or an exception will be thrown. -}- fixed_recordLength :: Int,-- {-| The byte order for integers in the database metadata; for example,- 4321 represents big-endian order. Not all orders are guaranteed to- be supported; if the byte order is 0, host order will be used.- Unlike the other database types, record databases have no metadata,- so it's important to get this right when opening existing- databases. -}- fixed_byteOrder :: Int,-- {-| The byte value used to pad fixed-length records in the database.- By default, this is a space character (0x20). -}- fixed_paddingByte :: Word8,-- {-| A file which should be used to store the the in-memory record cache. -}- fixed_treeFile :: Maybe String-}--{-| The default configuration for fixed-length record databases. -}-defaultFixedRecordDBConf :: FixedRecordDBConf-defaultFixedRecordDBConf = FixedRecordDBConf {- fixed_snapshot = False,- fixed_cacheSize = 0,- fixed_pageSize = 0,- fixed_recordLength = 0,- fixed_byteOrder = 0,- fixed_paddingByte = 0x20,- fixed_treeFile = Nothing-}--{-| Opens or creates a fixed-length record database. -}-openFixedRecord :: Maybe FilePath -> IOMode -> FileMode -> FixedRecordDBConf -> IO FixedRecordDB-openFixedRecord path iomode filemode conf =- if (fixed_recordLength conf <= 0) then fail "non-positive record length" else- withMaybeString path $ \cpath ->- withMaybeString (fixed_treeFile conf) $ \ctreefile ->- alloca $ \info -> do- writeFixedRecordDBConf conf ctreefile info- ptr <- throwErrnoIfNull "BerkeleyDB.openFixedRecord"- $ db_open_recno cpath (fromIOMode iomode) filemode info- return $ FixedRecordDB ptr--{- Writes a fixed record database configuration into a C structure.- We pass in the btree filename string from elsewhere because it aids- emergency cleanup to do so. -}-writeFixedRecordDBConf :: FixedRecordDBConf -> CString -> Ptr RECNOINFO -> IO ()-writeFixedRecordDBConf conf bfname info = do- poke info $ RECNOINFO {- ri_flags = toFlags [(True, 1),-{-# LINE 810 "Database/BerkeleyDB.hsc" #-}- (True, 2),-{-# LINE 811 "Database/BerkeleyDB.hsc" #-}- (fixed_snapshot conf, 4)],-{-# LINE 812 "Database/BerkeleyDB.hsc" #-}- ri_cachesize = toEnum $ fixed_cacheSize conf,- ri_psize = toEnum $ fixed_pageSize conf,- ri_lorder = toEnum $ fixed_byteOrder conf,- ri_reclen = toEnum $ fixed_recordLength conf,- ri_bval = fromInteger $ toInteger $ fixed_paddingByte conf,- ri_bfname = bfname- }--{-- typedef struct {- u_long flags;- u_int cachesize;- u_int psize;- int lorder;- size_t reclen;- u_char bval;- char *bfname;- } RECNOINFO;--}--data RECNOINFO = RECNOINFO {- ri_flags :: CULong,- ri_cachesize, ri_psize :: CUInt,- ri_lorder :: CInt,- ri_reclen :: CSize,- ri_bval :: CUChar,- ri_bfname :: CString-}-instance Storable RECNOINFO where- sizeOf _ = (28)-{-# LINE 842 "Database/BerkeleyDB.hsc" #-}- alignment _ = 4-{-# LINE 843 "Database/BerkeleyDB.hsc" #-}- peek ptr = do- flags <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr-{-# LINE 845 "Database/BerkeleyDB.hsc" #-}- cachesize <- (\hsc_ptr -> peekByteOff hsc_ptr 4) ptr-{-# LINE 846 "Database/BerkeleyDB.hsc" #-}- psize <- (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr-{-# LINE 847 "Database/BerkeleyDB.hsc" #-}- lorder <- (\hsc_ptr -> peekByteOff hsc_ptr 12) ptr-{-# LINE 848 "Database/BerkeleyDB.hsc" #-}- reclen <- (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr-{-# LINE 849 "Database/BerkeleyDB.hsc" #-}- bval <- (\hsc_ptr -> peekByteOff hsc_ptr 20) ptr-{-# LINE 850 "Database/BerkeleyDB.hsc" #-}- bfname <- (\hsc_ptr -> peekByteOff hsc_ptr 24) ptr-{-# LINE 851 "Database/BerkeleyDB.hsc" #-}- return $ RECNOINFO { ri_flags = flags, ri_cachesize = cachesize,- ri_psize = psize, ri_lorder = lorder,- ri_reclen = reclen, ri_bval = bval,- ri_bfname = bfname }- poke ptr info = do- let pokeAt offset selector = poke (plusPtr ptr offset) (selector info)- (\hsc_ptr -> pokeByteOff hsc_ptr 0) ptr (ri_flags info)-{-# LINE 858 "Database/BerkeleyDB.hsc" #-}- (\hsc_ptr -> pokeByteOff hsc_ptr 4) ptr (ri_cachesize info)-{-# LINE 859 "Database/BerkeleyDB.hsc" #-}- (\hsc_ptr -> pokeByteOff hsc_ptr 8) ptr (ri_psize info)-{-# LINE 860 "Database/BerkeleyDB.hsc" #-}- (\hsc_ptr -> pokeByteOff hsc_ptr 12) ptr (ri_lorder info)-{-# LINE 861 "Database/BerkeleyDB.hsc" #-}- (\hsc_ptr -> pokeByteOff hsc_ptr 16) ptr (ri_reclen info)-{-# LINE 862 "Database/BerkeleyDB.hsc" #-}- (\hsc_ptr -> pokeByteOff hsc_ptr 20) ptr (ri_bval info)-{-# LINE 863 "Database/BerkeleyDB.hsc" #-}- (\hsc_ptr -> pokeByteOff hsc_ptr 24) ptr (ri_bfname info)-{-# LINE 864 "Database/BerkeleyDB.hsc" #-}--------- PRIMITIVE OPERATIONS ----------{- Primitive close. -}-_close :: Ptr DBStruct -> IO ()-_close ptr = do- throwErrnoIfMinus1_ "BerkeleyDB.close" $ db_close ptr--{- Primitive sync. -}-_sync :: Ptr DBStruct -> IO ()-_sync ptr = do- throwErrnoIfMinus1_ "BerkeleyDB.sync" $ db_sync ptr--{- Primitive delete. The first parameter is true if the operation must- use the safe foreign call. -}-_delete :: Bool -> Ptr DBStruct -> ByteString -> IO Bool-_delete sf ptr key =- withDBT key $ \tKey -> do- result <- throwErrnoIfMinus1 "BerkeleyDB.delete"- $ (if sf then db_delete_sf else db_delete) ptr tKey- case result of- 0 -> return True- _ -> return False--_deleteRecord :: Ptr DBStruct -> Recno -> IO Bool-_deleteRecord ptr key = do- result <- throwErrnoIfMinus1 "BerkeleyDB.delete"- $ db_delete_record ptr key- case result of- 0 -> return True- _ -> return False--_deleteCursor :: Bool -> Ptr DBStruct -> IO ()-_deleteCursor sf ptr = do- throwErrnoIfMinus1_ "BerkeleyDB.remove"- $ (if sf then db_delete_cursor_sf else db_delete_cursor) ptr--{- Primitive insertion. The first parameter is true if the operation must- use the safe foreign call. -}-_insert :: Bool -> Ptr DBStruct -> ByteString -> ByteString -> CUInt -> IO ()-_insert sf ptr key val flags =- withDBT key $ \tKey ->- withDBT val $ \tVal -> do- throwErrnoIfMinus1_ "BerkeleyDB.insert"- $ (if sf then db_insert_sf else db_insert) ptr tKey tVal flags--_insertRecord :: Ptr DBStruct -> Recno -> ByteString -> CUInt -> IO ()-_insertRecord ptr key val flags = - withDBT val $ \tVal -> do- throwErrnoIfMinus1_ "BerkeleyDB.insert"- $ db_insert_record ptr key tVal flags--{- Primitive lookup. The first parameter is true if the operation must use- the safe foreign call. -}-_lookup :: Bool -> Ptr DBStruct -> ByteString -> IO (Maybe ByteString)-_lookup sf ptr key =- withDBT key $ \tKey ->- alloca $ \tVal -> do- result <- throwErrnoIfMinus1 "BerkeleyDB.lookup"- $ (if sf then db_lookup_sf else db_lookup) ptr tKey tVal- case result of- 0 -> liftM Just $ copyDBT tVal- _ -> return Nothing--_lookupRecord :: Ptr DBStruct -> Recno -> IO (Maybe ByteString)-_lookupRecord ptr key = - alloca $ \tVal -> do- result <- throwErrnoIfMinus1 "BerkeleyDB.lookup"- $ db_lookup_record ptr key tVal- case result of- 0 -> liftM Just $ copyDBT tVal- _ -> return Nothing--{- Primitive cursor. The first parameter is true if the operation must- use the safe foreign call. -}--{- The 'keyed' version exposes a byte-string key to the database; the- 'unkeyed' version passes a freshly-allocated pointer. The record routine- doesn't need to be split like this because it doesn't require additional- allocation. -}--_cursorKeyed sf ptr key flags = withDBT key (_cursor sf ptr flags)-_cursorUnkeyed sf ptr flags = alloca (_cursor sf ptr flags)--_cursor :: Bool -> Ptr DBStruct -> CUInt -> Ptr DBT -> IO (Maybe (ByteString,ByteString))-_cursor sf ptr flags tKey =- alloca $ \tVal -> do- result <- throwErrnoIfMinus1 "BerkeleyDB.cursor"- $ (if sf then db_cursor_sf else db_cursor) ptr tKey tVal flags- case result of- 0 -> do- retKey <- copyDBT tKey- retVal <- copyDBT tVal- return $ Just (retKey, retVal)- _ -> return Nothing--_cursorRecord :: Ptr DBStruct -> Recno -> CUInt -> IO (Maybe (Record,ByteString))-_cursorRecord ptr rec flags = do- alloca $ \tVal -> do- result <- throwErrnoIfMinus1 "BerkeleyDB.cursor"- $ db_cursor_record ptr rec tVal flags- case result of- 0 -> do- retVal <- copyDBT tVal- return $ Just (Record 0, retVal)- _ -> return Nothing--{- Creation calls are all unsafe. -}--foreign import ccall unsafe "db_open_recno"- db_open_recno :: CString -> CInt -> CMode -> Ptr RECNOINFO -> IO (Ptr DBStruct)--{-# LINE 980 "Database/BerkeleyDB.hsc" #-}--foreign import ccall unsafe "db_open_hash"- db_open_hash :: CString -> CInt -> CMode -> Ptr HASHINFO -> IO (Ptr DBStruct)--{-# LINE 988 "Database/BerkeleyDB.hsc" #-}--foreign import ccall unsafe "db_open_btree"- db_open_btree :: CString -> CInt -> CMode -> Ptr BTREEINFO -> IO (Ptr DBStruct)--{-# LINE 996 "Database/BerkeleyDB.hsc" #-}--{- Close and sync calls. Unsafe against reentry to Haskell. -}-foreign import ccall unsafe "db_close"- db_close :: Ptr DBStruct -> IO CInt--{-# LINE 1005 "Database/BerkeleyDB.hsc" #-}--foreign import ccall unsafe "db_sync"- db_sync :: Ptr DBStruct -> IO CInt--{-# LINE 1013 "Database/BerkeleyDB.hsc" #-}--{- Deletion family of calls. -}-{- delete-by-key, safe and unsafe. -}-foreign import ccall unsafe "db_delete"- db_delete :: Ptr DBStruct -> Ptr DBT -> IO CInt-foreign import ccall safe "db_delete"- db_delete_sf :: Ptr DBStruct -> Ptr DBT -> IO CInt--{-# LINE 1025 "Database/BerkeleyDB.hsc" #-}--{- delete-record, always unsafe -}-foreign import ccall unsafe "db_delete_record"- db_delete_record :: Ptr DBStruct -> Recno -> IO CInt--{-# LINE 1035 "Database/BerkeleyDB.hsc" #-}--{- delete-at-cursor, safe and unsafe -}-foreign import ccall unsafe "db_delete_cursor"- db_delete_cursor :: Ptr DBStruct -> IO CInt-foreign import ccall safe "db_delete_cursor"- db_delete_cursor_sf :: Ptr DBStruct -> IO CInt--{-# LINE 1046 "Database/BerkeleyDB.hsc" #-}--{- Lookup family of calls. -}-{- lookup-by-key, safe and unsafe -}-foreign import ccall unsafe "db_lookup"- db_lookup :: Ptr DBStruct -> Ptr DBT -> Ptr DBT -> IO CInt-foreign import ccall safe "db_lookup"- db_lookup_sf :: Ptr DBStruct -> Ptr DBT -> Ptr DBT -> IO CInt--{-# LINE 1058 "Database/BerkeleyDB.hsc" #-}--{- lookup-record, always unsafe -}-foreign import ccall unsafe "db_lookup_record"- db_lookup_record :: Ptr DBStruct -> Recno -> Ptr DBT -> IO CInt--{-# LINE 1068 "Database/BerkeleyDB.hsc" #-}--{- Insert family of calls. -}-{- insert-by-key, safe and unsafe -}-foreign import ccall unsafe "db_c.h"- db_insert :: Ptr DBStruct -> Ptr DBT -> Ptr DBT -> CUInt -> IO CInt-foreign import ccall safe "db_c.h db_insert"- db_insert_sf :: Ptr DBStruct -> Ptr DBT -> Ptr DBT -> CUInt -> IO CInt--{-# LINE 1080 "Database/BerkeleyDB.hsc" #-}--{- insert-record, always unsafe -}-foreign import ccall unsafe "db_c.h"- db_insert_record :: Ptr DBStruct -> Recno -> Ptr DBT -> CUInt -> IO CInt--{-# LINE 1090 "Database/BerkeleyDB.hsc" #-}--{- Sequence family of calls. -}-{- cursor-by-key, safe and unsafe -}-foreign import ccall unsafe "db_c.h"- db_cursor :: Ptr DBStruct -> Ptr DBT -> Ptr DBT -> CUInt -> IO CInt-foreign import ccall safe "db_c.h db_cursor"- db_cursor_sf :: Ptr DBStruct -> Ptr DBT -> Ptr DBT -> CUInt -> IO CInt--{-# LINE 1102 "Database/BerkeleyDB.hsc" #-}--{- cursor-record, always unsafe -}-foreign import ccall unsafe "db_c.h"- db_cursor_record :: Ptr DBStruct -> Recno -> Ptr DBT -> CUInt -> IO CInt--{- Wrapper-creation functions for callbacks. -}-foreign import ccall unsafe "wrapper"- wrapHash :: (CString -> CSize -> Word32) -> IO (FunPtr (CString -> CSize -> Word32))-foreign import ccall unsafe "wrapper"- wrapCompare :: (Ptr DBT -> Ptr DBT -> CInt) -> IO (FunPtr (Ptr DBT -> Ptr DBT -> CInt))-foreign import ccall unsafe "wrapper"- wrapPrefix :: (Ptr DBT -> Ptr DBT -> CSize) -> IO (FunPtr (Ptr DBT -> Ptr DBT -> CSize))
− Database/BerkeleyDB.hsc
@@ -1,1114 +0,0 @@-{-- Database.BerkeleyDB v0.3- Copyright 2007 John McCall- Licensed for general use under a BSD3-style license; for the exact- license text, see the LICENSE file included in this distribution. If- you find this file distributed without a LICENSE file, please contact- me at rjmccall@gmail.com and tell me where you found it.-- It's my hope that this module could be used to bootstrap bindings for a- modern version of Berkeley DB, but I'm not currently working on that.-- Author: John McCall <rjmccall@gmail.com>- Maintainer: John McCall <rjmccall@gmail.com>- History:- v0.2 2007-04-06 Haddock documentation; FileMode.- v0.1 2007-04-05 Creation.--}--{- We require a preprocessor pass in order to bring the structure- layout into scope. We can't rely the LANGUAGE CPP pragma, though,- because we're a literate Haskell file, and it doesn't mix well- (in particular, GHC doesn't add the current directory to the include- path, which is a problem, because unlitting this file creates a file- in /tmp somewhere). -}--{-# LANGUAGE ForeignFunctionInterface #-}--#include <fcntl.h>-#include <db.h>--#ifdef __GNUC__-#let alignment type = "%d", __alignof__(type)-#else-#let alignment type = "alignment (undefined :: Ptr a)"-#endif--{-|-Haskell bindings for Berkeley DB v1.85, i.e. @db.h@ on BSD-derived Unices.-This module is intended to be imported qualified.--The database implementations provided by this module are not safe-against concurrent access; for that, users must seek a more resilient-database.--This module has been written with GHC 6.6 in mind; it is quite-possible that it will function with minimal changes on other-implementations of Haskell or earlier versions of GHC, and patches for-this purpose would be welcome, providing they don't compromise the integrity-of the up-to-date GHC implementation.--The open functions generally interpret 'IOMode' as follows:--- 'ReadMode' attempts to open a database in read-only mode; if the database- doesn't exist, an exception is thrown.--- 'ReadWriteMode' and 'AppendMode' are synonymous; both open the database in- read\/write mode, creating it if necessary.--- 'WriteMode' opens the database in read\/write mode, but it truncates any- existing database file.- -}-module Database.BerkeleyDB- (HashDB, openHash, HashDBCursor,HashDBConf(..), defaultHashDBConf,- TreeDB, openTree, TreeDBCursor,TreeDBConf(..), defaultTreeDBConf, - RecordDB, openRecord, Record, RecordDBCursor,- RecordDBConf(..), defaultRecordDBConf,- FixedRecordDB, openFixedRecord, FixedRecordDBCursor,- FixedRecordDBConf(..), defaultFixedRecordDBConf,- DB(..), DBCursor(..),- IOMode(..)) where--import System.IO (IOMode(..)) -- re-exported-import System.Posix.Files -- for FileMode's helpful constants-import System.Posix.Types -- for mode_t--import Foreign-import Foreign.C-import Control.Monad (when, liftM)-import Control.Exception (bracketOnError)-import Data.ByteString (ByteString, packCStringLen, useAsCStringLen)-import Data.ByteString.Unsafe (unsafePackCStringLen)-import Prelude hiding (lookup)--{- We use 0666 as our default umask, but we define it in this crazy way. -}-defaultUmask :: FileMode-defaultUmask = foldl1 unionFileModes [ownerReadMode,- ownerWriteMode,- groupReadMode,- groupWriteMode,- otherReadMode,- otherWriteMode]----------- TYPE CLASSES -----------{-| Common operations supported by databases. The database type- functionally defines its key, value, and cursor types. -}-class (DBCursor c k v) => DB t c k v | t -> c k v where-- {-| The simplified "open" command. Individual database types usually- provide a specialized open operation. If no filepath is given, the- database will exist primarily in memory or a temporary file. -}- open :: Maybe FilePath -> IOMode -> IO t-- {-| Closes the database. Just as with files, it's important to explicitly- close a database to avoid memory leaks; it's also important to explicitly- close a database in order to flush database writes which might currently- be cached.-- The internal database structures may be in an unstable state after this- function is called; it's unsafe to make any further calls on the same- database object after it's been closed. -}- close :: t -> IO ()-- {-| Inserts an entry into the database. -}- insert :: t -> k -> v -> IO ()-- {-| Looks up an entry in the database. -}- lookup :: t -> k -> IO (Maybe v)-- {-| Deletes an entry from the database. Returns true if the entry existed- before it was deleted. -}- delete :: t -> k -> IO Bool-- {-| Creates a new cursor for sequential access to the database. The- standard Berkeley DB implementations only support a single cursor- per database, so even if multiple cursors are created, they'll- all change the same state. Other database implementations might- support multiple simultaneous cursors. -}- cursor :: t -> IO c-- {-| Forces a sync with the disk, to the extent that this is possible- with system calls. -}- sync :: t -> IO ()---{-| A type-class for database cursors. The cursor type functionally- defines the key and value types. -}-class DBCursor c k v | c -> k v where-- {-| Jumps to the first entry in the database. -}- jumpFirst :: c -> IO (Maybe (k,v))-- {-| Jumps to the last entry in the database. Not all database- implementations support this operation. -}- jumpLast :: c -> IO (Maybe (k,v))-- {-| Jumps to an arbitrary place in the database. The returned match- may not be an exact match for the key; see the notes for each- database implementation for more details. -}- jump :: c -> k -> IO (Maybe (k,v))-- {-| Moves to the next entry in the database. -}- next :: c -> IO (Maybe (k,v))-- {-| Moves to the previous entry in the database. -}- previous :: c -> IO (Maybe (k,v))-- {-| Replaces the current entry with a new value. The cursor must be- initialized for this operation to succeed. -}- replace :: c -> k -> v -> IO ()-- {-| Removes the entry at the current cursor position. -}- remove :: c -> IO ()-- {-| Closes the cursor. For Berkeley databases, this doesn't do anything. -}- closeCursor:: c -> IO ()----------- GENERAL IMPLEMENTATION ---------{- The type of databases; in C-land, this is "DB". Here, it's- completely opaque, we never try to modify it, and we don't export- it. -}-data DBStruct = DBStruct--{- The type of "database thangs"; in C-land, this is "DBT". -}-data DBT = DBT Int (Ptr CChar)-instance Storable DBT where- sizeOf _ = sizeOf (undefined :: CInt) + sizeOf (undefined :: Ptr CChar)- alignment _ = alignment (undefined :: Ptr CChar)- peek ptr = do- dat <- peek (castPtr ptr)- size <- peek (plusPtr ptr (sizeOf (undefined :: Ptr CChar)))- return $ DBT size dat- poke ptr (DBT size dat) = do- poke (castPtr ptr) dat- poke (plusPtr ptr (sizeOf (undefined :: Ptr CChar))) size--{- Copies a DBT into a new ByteString, which will have a finalizer- associated with it. -}-copyDBT :: Ptr DBT -> IO ByteString-copyDBT ptr = do- DBT sz dat <- peek ptr- packCStringLen (dat, sz)--{- Temporarily wraps a DBT in a ByteString. ByteStrings created this way- should never become visible out of this module --- the database doesn't- guarantee that returned values will remain consistent across subsequent- database calls, so it's important to copy anything that we think should- stick around. We provide this wrapping only for our callbacks, which- (since they're not monadic) shouldn't ever capture the memory. -}-wrapDBT :: Ptr DBT -> ByteString-wrapDBT ptr = unsafePerformIO $ do- DBT sz dat <- peek ptr- unsafePackCStringLen (dat, sz)--{- Use a ByteString transparently as a DBT. The DBT- will become unstable as soon as withDBT completes, so don't capture- a reference to it in the enclosed computation. -}-withDBT :: ByteString -> (Ptr DBT -> IO a) -> IO a-withDBT bs fn =- useAsCStringLen bs $ \(dat,sz) ->- alloca $ \bst -> do- poke bst (DBT sz dat)- fn bst--{- Using a Maybe String transparently as a CString. The CString- will become unstable as soon as withMaybeString completes, so don't- capture a reference to it in the enclosed computation. -}-withMaybeString :: Maybe String -> (CString -> IO a) -> IO a-withMaybeString Nothing action = action nullPtr-withMaybeString (Just s) action = withCAString s action--{- Permanently allocates a function pointer, but frees it if the enclosed- operation fails. This is useful for ensuring that the function pointer- survives until it can be successfully compiled into some structure- which the user is obliged to manually destroy. -}-allocFunPtr :: IO (FunPtr a) -> (FunPtr a -> IO b) -> IO b-allocFunPtr makeFun action = do- bracketOnError makeFun freeHaskellFunPtr action--{- A helper routine to convert a list of boolean/mask pairs into a mask. -}-toFlags :: [(Bool,CULong)] -> CULong-toFlags = foldr (\(bool,mask) -> if bool then (mask .&.) else id) 0--{- Converts an IOMode constant into the appropriate bitmask. -}--fromIOMode :: IOMode -> CInt-fromIOMode ReadMode = #{const O_RDONLY}-fromIOMode WriteMode = #{const (O_RDWR | O_CREAT | O_TRUNC)}-fromIOMode AppendMode = #{const (O_RDWR | O_CREAT)}-fromIOMode ReadWriteMode = #{const (O_RDWR | O_CREAT)}--{- The standard database cursor. The second parameter is whether safe or- unsafe routines must be used. -}-data Cursor = Cursor (Ptr DBStruct) Bool-instance DBCursor Cursor ByteString ByteString where- jump (Cursor ptr sf) key = _cursorKeyed sf ptr key #{const R_CURSOR}- jumpFirst (Cursor ptr sf) = _cursorUnkeyed sf ptr #{const R_FIRST}- jumpLast (Cursor ptr sf) = _cursorUnkeyed sf ptr #{const R_LAST}- next (Cursor ptr sf) = _cursorUnkeyed sf ptr #{const R_NEXT}- previous (Cursor ptr sf) = _cursorUnkeyed sf ptr #{const R_PREV}- replace (Cursor ptr sf) key val = _insert sf ptr key val #{const R_SETCURSOR}- remove (Cursor ptr sf) = _deleteCursor sf ptr- closeCursor _ = return ()--{- Create a new standard cursor. -}-newCursor :: Ptr DBStruct -> Bool -> IO Cursor-newCursor ptr sf = return $ Cursor ptr sf--------- HASHTABLES ----------{-| Hashtable-based databases. -}-data HashDB = HashDB (Ptr DBStruct) Bool HashToken-instance DB HashDB HashDBCursor ByteString ByteString where- open file mode = openHash file mode defaultUmask defaultHashDBConf- close (HashDB ptr sf t) = do- freeHashToken t- _close ptr- insert (HashDB ptr sf _) key value = _insert sf ptr key value 0- lookup (HashDB ptr sf _) key = _lookup sf ptr key- delete (HashDB ptr sf _) key = _delete sf ptr key- cursor (HashDB ptr sf _) = liftM HashDBCursor $ newCursor ptr sf- sync (HashDB ptr sf _) = _sync ptr--{-| The type of hashtable database cursors. -}-newtype HashDBCursor = HashDBCursor Cursor-instance DBCursor HashDBCursor ByteString ByteString where- jump (HashDBCursor c) = jump c- jumpFirst (HashDBCursor c) = jumpFirst c- jumpLast (HashDBCursor c) = jumpLast c- next (HashDBCursor c) = next c- previous (HashDBCursor c) = previous c- replace (HashDBCursor c) = replace c- remove (HashDBCursor c) = remove c- closeCursor (HashDBCursor c) = closeCursor c--{-| The configuration of a hashtable database. -}-data HashDBConf = HashDBConf {-- {-| The size of a hash bucket, in bytes. -}- hash_bucketSize :: Int,-- {-| A desired density for the hashtable. This value approximates the- maximum number of keys allowed in a bucket; the default value is 8. -}- hash_keyDensity :: Int,-- {-| The initial size of the database. The hashtable will grow gracefully - as keys are added, but performance may temporarily suffer at each- expansion, so it's always better to get this right. -}- hash_initialSize :: Int,-- {-| An advistory maximum size for the in-memory database cache. -}- hash_cacheSize :: Int,-- {-| The byte order of hashtable metadata; for example, 4321 specifies a- big-endian format. Not all byte orders are necessarily supported, and- this setting is ignored when opening existing databases. 0 means to use- host order. -}- hash_byteOrder :: Int,-- {-| A custom hash function. Specifying a custom hash function can- sometimes improve hashtable performance, depending on the expected- range of keys; however, since it requires a callback into Haskell, it- can also hurt performance by requiring "safe" calls into C (which forces- the runtime system to stabilize itself before every database call). -}- hash_hashFunction :: Maybe (ByteString -> Word32)-}--{-| The default database configuration. -}-defaultHashDBConf :: HashDBConf-defaultHashDBConf = HashDBConf {- hash_bucketSize = 0,- hash_keyDensity = 0,- hash_initialSize = 0,- hash_cacheSize = 0,- hash_byteOrder = 0,- hash_hashFunction = Nothing-}--{-| Opens or creates a hashtable database. -}-openHash :: Maybe FilePath -> IOMode -> FileMode -> HashDBConf -> IO HashDB-openHash path iomode umask conf = - withMaybeString path $ \cpath ->- alloca $ \info ->- allocFunPtr (makeHash $ hash_hashFunction conf) $ \fpHash -> do- writeHashDBConf conf fpHash info- ptr <- throwErrnoIfNull "BerkeleyDB.openHash"- $ db_open_hash cpath (fromIOMode iomode) umask info- let safe = fpHash /= nullFunPtr- return $ HashDB ptr safe fpHash--{- Tokens are created during database initialization and must be manually- freed during database teardown. -}-type HashToken = FunPtr (CString -> CSize -> IO Word32)-freeHashToken :: HashToken -> IO ()-freeHashToken fpHash = do- when (fpHash /= nullFunPtr) $ freeHaskellFunPtr fpHash--{- Writes a hashtable configuration into the corresponding C structure.- We pass in the function pointer from elsewhere because it- aids emergency cleanup to do so. -}-writeHashDBConf :: HashDBConf- -> FunPtr (CString -> CSize -> IO Word32)- -> Ptr HASHINFO- -> IO ()-writeHashDBConf conf fpHash info = do- poke info $ HASHINFO {- hi_bsize = toEnum $ hash_bucketSize conf,- hi_ffactor = toEnum $ hash_keyDensity conf,- hi_nelem = toEnum $ hash_initialSize conf,- hi_cachesize = toEnum $ hash_cacheSize conf,- hi_lorder = toEnum $ hash_byteOrder conf,- hi_hash = fpHash- }--{- Turns a Haskell hash function into a database-appropriate foreign hash- function. -}-makeHash :: Maybe (ByteString -> Word32) -> IO (FunPtr (CString -> CSize -> IO Word32))-makeHash Nothing = return nullFunPtr-makeHash (Just hash) = wrapHash hash'- where hash' dat sz = unsafePackCStringLen (dat, fromEnum sz) >>= return . hash--{-- typedef struct {- u_int bsize;- u_int ffactor;- u_int nelem;- u_int cachesize;- u_int32_t (*hash)(const void *, size_t);- int lorder;- } HASHINFO;--}-data HASHINFO = HASHINFO {- hi_bsize, hi_ffactor, hi_nelem, hi_cachesize :: CUInt,- hi_hash :: FunPtr (CString -> CSize -> IO Word32),- hi_lorder :: CInt-}-instance Storable HASHINFO where- sizeOf _ = #{size HASHINFO}- alignment _ = #{alignment HASHINFO}- poke ptr info = do- #{poke HASHINFO, bsize} ptr (hi_bsize info)- #{poke HASHINFO, ffactor} ptr (hi_ffactor info)- #{poke HASHINFO, nelem} ptr (hi_nelem info)- #{poke HASHINFO, cachesize} ptr (hi_cachesize info)- #{poke HASHINFO, lorder} ptr (hi_lorder info)- #{poke HASHINFO, hash} ptr (hi_hash info)- peek ptr = do- bsize <- #{peek HASHINFO, bsize} ptr- ffactor <- #{peek HASHINFO, ffactor} ptr- nelem <- #{peek HASHINFO, nelem} ptr- cachesize <- #{peek HASHINFO, cachesize} ptr- hash <- #{peek HASHINFO, hash} ptr- lorder <- #{peek HASHINFO, lorder} ptr- return $ HASHINFO { hi_bsize = bsize, hi_ffactor = ffactor,- hi_nelem = nelem, hi_cachesize = cachesize,- hi_hash = hash, hi_lorder = lorder }--------- B-TREE DATABASES -----------{-| A database built on a b-tree. -}-data TreeDB = TreeDB (Ptr DBStruct) Bool TreeToken-instance DB TreeDB TreeDBCursor ByteString ByteString where- open file mode = openTree file mode defaultUmask defaultTreeDBConf- close (TreeDB ptr sf t) = do- freeTreeToken t- _close ptr- insert (TreeDB ptr sf _) key value = _insert sf ptr key value 0- lookup (TreeDB ptr sf _) key = _lookup sf ptr key- delete (TreeDB ptr sf _) key = _delete sf ptr key- sync (TreeDB ptr sf _) = _sync ptr- cursor (TreeDB ptr sf _) = liftM TreeDBCursor (newCursor ptr sf)--{-| The cursor for a tree database. -}-newtype TreeDBCursor = TreeDBCursor Cursor-instance DBCursor TreeDBCursor ByteString ByteString where- jump (TreeDBCursor c) = jump c- jumpFirst (TreeDBCursor c) = jumpFirst c- jumpLast (TreeDBCursor c) = jumpLast c- next (TreeDBCursor c) = next c- previous (TreeDBCursor c) = previous c- replace (TreeDBCursor c) = replace c- remove (TreeDBCursor c) = remove c- closeCursor (TreeDBCursor c) = closeCursor c--{-| The configuration for a b-tree database. -}-data TreeDBConf = TreeDBConf {-- {-| Permit multiple entries to appear in the database per key. Only- sequential operations can observe the difference. -}- tree_duplicateKeys :: Bool,-- {-| An advistory maximum size of the in-memory database cache, in- bytes. A default cache size is used if this value is 0. -}- tree_cacheSize :: Int,-- {-| An advisory maximum number of keys to store on a page. btree(3)- says this isn't implemented. -}- tree_maxKeysPerPage :: Int,-- {-| The minimum number of keys to store on a page (other than the- root). This can never been less than 2. -}- tree_minKeysPerPage :: Int,-- {-| The size of each pages of the btree, in bytes. This much be at- least 512 and no more than 64K; if it is zero, a default size is- chosen based on the filesystem block size. This value is ignored- when opening existing databases. -}- tree_pageSize :: Int,-- {-| The byte order of btree metadata; for example, 4321 specifies a- big-endian format. Not all byte orders are necessarily supported,- and this setting is ignored when opening existing databases. 0 means- to use host order. -}- tree_byteOrder :: Int,-- {-| A comparison function for keys. It is important that the same function- be used every time the tree is opened. The default comparison order is- lexicographic (i.e. shorter keys sort first, then each byte is compared- from the beginning to the end). -}- tree_compare :: Maybe (ByteString -> ByteString -> Ordering),-- {-| A function indicating how many bytes are required from the second key- argument in order to decide the ordering. If the keys are equal, this- should be the length of the key. This can produce highly-compressed trees- in certain domains. -}- tree_prefix :: Maybe (ByteString -> ByteString -> Int)-}--{-| The default b-tree configuration. -}-defaultTreeDBConf :: TreeDBConf-defaultTreeDBConf = TreeDBConf {- tree_duplicateKeys = False, -- disallow duplicate keys- tree_cacheSize = 0, -- use default cache size- tree_maxKeysPerPage = 0, -- evidentally, not implemented yet anyway in Berkeley DB- tree_minKeysPerPage = 0, -- use the default minimum number of keys per page- tree_pageSize = 0, -- use the default page size- tree_compare = Nothing, -- no custom comparison operation- tree_prefix = Nothing, -- no custom prefix operation- tree_byteOrder = 0 -- host order-}--{-| Opens a b-tree database, failing with an I\/O exception if the database- couldn't be opened. -}-openTree :: Maybe FilePath -> IOMode -> FileMode -> TreeDBConf -> IO TreeDB-openTree path iomode filemode conf =- alloca $ \info ->- withMaybeString path $ \cpath ->- allocFunPtr (makeCompare $ tree_compare conf) $ \fpCompare ->- allocFunPtr (makePrefix $ tree_prefix conf) $ \fpPrefix -> do- writeTreeDBConf conf fpCompare fpPrefix info- ptr <- throwErrnoIfNull "BerkeleyDB.openTree"- $ db_open_btree cpath (fromIOMode iomode) filemode info- let safe = fpCompare /= nullFunPtr || fpPrefix /= nullFunPtr- return $ TreeDB ptr safe (fpCompare,fpPrefix)--{- The token which must be explicitly freed when a database is shut down.- Here, it's a pointer to the two foreign function pointers. -}-type TreeToken = (FunPtr (Ptr DBT -> Ptr DBT -> CInt),- FunPtr (Ptr DBT -> Ptr DBT -> CSize))-freeTreeToken :: TreeToken -> IO ()-freeTreeToken (fpCompare, fpPrefix) = do- when (fpCompare /= nullFunPtr) $ freeHaskellFunPtr fpCompare- when (fpPrefix /= nullFunPtr) $ freeHaskellFunPtr fpPrefix--{- Writes a b-tree database configuration into a C structure.- We pass in the function pointers from elsewhere because it- aids emergency cleanup to do so. -}-writeTreeDBConf :: TreeDBConf- -> FunPtr (Ptr DBT -> Ptr DBT -> CInt)- -> FunPtr (Ptr DBT -> Ptr DBT -> CSize)- -> Ptr BTREEINFO- -> IO ()-writeTreeDBConf conf fpCompare fpPrefix info = do- poke info $ BTREEINFO {- bi_flags = toFlags [(tree_duplicateKeys conf, #const R_DUP)],- bi_cachesize = toEnum $ tree_cacheSize conf,- bi_maxkeypage = toEnum $ tree_maxKeysPerPage conf,- bi_minkeypage = toEnum $ tree_minKeysPerPage conf,- bi_psize = toEnum $ tree_pageSize conf,- bi_compare = fpCompare,- bi_prefix = fpPrefix,- bi_lorder = toEnum $ tree_byteOrder conf- }--{- Wraps a Haskell comparison function as a pointer to a C function. -}-makeCompare :: Maybe (ByteString -> ByteString -> Ordering) -> IO (FunPtr (Ptr DBT -> Ptr DBT -> CInt))-makeCompare Nothing = return nullFunPtr-makeCompare (Just f) = wrapCompare wrap- where wrap a b =- case f (wrapDBT a) (wrapDBT b) of- LT -> -1- EQ -> 0- GT -> 1--{- Wraps a Haskell prefix function as a pointer to a C function. -}-makePrefix :: Maybe (ByteString -> ByteString -> Int) -> IO (FunPtr (Ptr DBT -> Ptr DBT -> CSize))-makePrefix Nothing = return nullFunPtr-makePrefix (Just f) = wrapPrefix (wrap f)- where wrap f a b = toEnum $ f (wrapDBT a) (wrapDBT b)--{-- typedef struct {- u_long flags;- u_int cachesize;- int maxkeypage;- int minkeypage;- u_int psize;- int (*compare)(const DBT *key1, const DBT *key2);- size_t (*prefix)(const DBT *key1, const DBT *key2);- int lorder;- } BTREEINFO;--}--data BTREEINFO = BTREEINFO {- bi_flags :: CULong,- bi_cachesize, bi_psize :: CUInt,- bi_maxkeypage, bi_minkeypage, bi_lorder :: CInt,- bi_compare :: FunPtr (Ptr DBT -> Ptr DBT -> CInt),- bi_prefix :: FunPtr (Ptr DBT -> Ptr DBT -> CSize)-}-instance Storable BTREEINFO where- sizeOf _ = #{size BTREEINFO}- alignment _ = #{alignment BTREEINFO}- peek ptr = do- flags <- #{peek BTREEINFO, flags} ptr- cachesize <- #{peek BTREEINFO, cachesize} ptr- maxkeypage <- #{peek BTREEINFO, maxkeypage} ptr- minkeypage <- #{peek BTREEINFO, minkeypage} ptr- psize <- #{peek BTREEINFO, psize} ptr- lorder <- #{peek BTREEINFO, lorder} ptr- compare <- #{peek BTREEINFO, compare} ptr- prefix <- #{peek BTREEINFO, prefix} ptr- return $ BTREEINFO { bi_flags = flags, bi_cachesize = cachesize,- bi_maxkeypage = maxkeypage, bi_minkeypage = minkeypage,- bi_psize = psize, bi_lorder = lorder,- bi_compare = compare, bi_prefix = prefix }- poke ptr info = do- #{poke BTREEINFO, flags} ptr (bi_flags info)- #{poke BTREEINFO, cachesize} ptr (bi_cachesize info)- #{poke BTREEINFO, maxkeypage} ptr (bi_maxkeypage info)- #{poke BTREEINFO, minkeypage} ptr (bi_minkeypage info)- #{poke BTREEINFO, psize} ptr (bi_psize info)- #{poke BTREEINFO, compare} ptr (bi_compare info)- #{poke BTREEINFO, prefix} ptr (bi_prefix info)- #{poke BTREEINFO, lorder} ptr (bi_lorder info)--------- RECORD DATABASES ----------{-| recno_t, the type of record indices. recno(3) says this is "normally- the largest unsigned integral type available to the implementation", but on- modern systems it's usually just uint32_t. -}-newtype Record = Record Recno- deriving (Bits,Bounded,Enum,Eq,Integral,Num,- Ord,Read,Real,Show,Storable)-type Recno = #{type recno_t}--{- The type of record cursors. -}-newtype RecCursor = RecCursor (Ptr DBStruct)---- Haddock wants to publicize this because it mentions Record, but I--- don't really want to preprocess before running Haddock, because CPP--- will throw all the HSC stuff in my face. Really, Haddock needs to--- recognize that this instance is functionally defined by a private--- type and therefore not expose it.-instance DBCursor RecCursor Record ByteString where- jump (RecCursor ptr) (Record key) = _cursorRecord ptr key #{const R_CURSOR}- jumpFirst (RecCursor ptr) = _cursorRecord ptr 0 #{const R_FIRST}- jumpLast (RecCursor ptr) = _cursorRecord ptr 0 #{const R_LAST}- next (RecCursor ptr) = _cursorRecord ptr 0 #{const R_NEXT}- previous (RecCursor ptr) = _cursorRecord ptr 0 #{const R_PREV}- replace (RecCursor ptr) (Record key) val = _insertRecord ptr key val #{const R_SETCURSOR}- remove (RecCursor ptr) = _deleteCursor False ptr -- never needs to be safe- closeCursor _ = return ()--newRecCursor :: Ptr DBStruct -> IO RecCursor-newRecCursor ptr = return $ RecCursor ptr--{-| Variable-length record databases. -}-newtype RecordDB = RecordDB (Ptr DBStruct)-instance DB RecordDB RecordDBCursor Record ByteString where- open file mode = openRecord file mode defaultUmask defaultRecordDBConf- close (RecordDB ptr) = _close ptr- insert (RecordDB ptr) (Record key) value = _insertRecord ptr key value 0- lookup (RecordDB ptr) (Record key) = _lookupRecord ptr key- delete (RecordDB ptr) (Record key) = _deleteRecord ptr key- cursor (RecordDB ptr) = liftM RecordDBCursor $ newRecCursor ptr- sync (RecordDB ptr) = _sync ptr--{-| The type of variable-length record database cursors. The key returned by- cursor procedures is always 0. -}-newtype RecordDBCursor = RecordDBCursor RecCursor-instance DBCursor RecordDBCursor Record ByteString where- jump (RecordDBCursor c) = jump c- jumpFirst (RecordDBCursor c) = jumpFirst c- jumpLast (RecordDBCursor c) = jumpLast c- next (RecordDBCursor c) = next c- previous (RecordDBCursor c) = previous c- replace (RecordDBCursor c) = replace c- remove (RecordDBCursor c) = remove c- closeCursor (RecordDBCursor c) = closeCursor c--{-| A configuration for variable-length record databases. -}-data RecordDBConf = RecordDBConf {- {-| Forces a snapshot of the database to be taken when the file- is opened. -}- record_snapshot :: Bool,-- {-| An advisory maximum size of the in-memory database cache. -}- record_cacheSize :: Int,-- {-| The page size used for the in-memory database cache, which happens- to be a b-tree. If this value is 0, a default size will be chosen. -}- record_pageSize :: Int,-- {-| The byte order for integers in the database metadata; for example,- 4321 represents big-endian order. Not all orders are guaranteed to- be supported; if the byte order is 0, host order will be used.- Unlike the other database types, record databases have no metadata,- so it's important to get this right when opening existing- databases. -}- record_byteOrder :: Int,-- {-| The byte value used to separate records in the database. By default,- this is a newline character (0x0A). -}- record_separatorByte :: Word8,-- {-| A file which should be used to store the the in-memory record cache. -}- record_treeFile :: Maybe String-}--{-| The default variable-length record database configuration. -}-defaultRecordDBConf :: RecordDBConf-defaultRecordDBConf = RecordDBConf {--- record_noKey = False,- record_snapshot = False,- record_cacheSize = 0,- record_pageSize = 0,- record_byteOrder = 0,- record_separatorByte = 0x0a,- record_treeFile = Nothing-}--{-| Opens a variable-length record database. -}-openRecord :: Maybe FilePath -> IOMode -> FileMode -> RecordDBConf -> IO RecordDB-openRecord path iomode filemode conf =- withMaybeString path $ \cpath ->- withMaybeString (record_treeFile conf) $ \ctreefile ->- alloca $ \info -> do- writeRecordDBConf conf ctreefile info- ptr <- throwErrnoIfNull "BerkeleyDB.openRecord"- $ db_open_recno cpath (fromIOMode iomode) filemode info- return $ RecordDB ptr--{- Writes a variable-length record database configuration into a C structure.- We pass in the btree filename string from elsewhere because it aids- emergency cleanup to do so. -}-writeRecordDBConf :: RecordDBConf -> CString -> Ptr RECNOINFO -> IO ()-writeRecordDBConf conf bfname info = do- poke info $ RECNOINFO {- ri_flags = toFlags [(False, #{const R_FIXEDLEN}),- (True, #{const R_NOKEY}),- (record_snapshot conf, #{const R_SNAPSHOT})],- ri_cachesize = toEnum $ record_cacheSize conf,- ri_psize = toEnum $ record_pageSize conf,- ri_lorder = toEnum $ record_byteOrder conf,- ri_reclen = 0,- ri_bval = fromInteger $ toInteger $ record_separatorByte conf,- ri_bfname = bfname- }--{-| Fixed-length record databases. -}-newtype FixedRecordDB = FixedRecordDB (Ptr DBStruct)-instance DB FixedRecordDB FixedRecordDBCursor Record ByteString where- open file mode = openFixedRecord file mode defaultUmask defaultFixedRecordDBConf- close (FixedRecordDB ptr) = _close ptr- insert (FixedRecordDB ptr) (Record key) value = _insertRecord ptr key value 0- lookup (FixedRecordDB ptr) (Record key) = _lookupRecord ptr key- delete (FixedRecordDB ptr) (Record key) = _deleteRecord ptr key- cursor (FixedRecordDB ptr) = liftM FixedRecordDBCursor $ newRecCursor ptr- sync (FixedRecordDB ptr) = _sync ptr--{-| The type of fixed-length record database cursors. The key returned by- cursor procedures is always 0. -}-newtype FixedRecordDBCursor = FixedRecordDBCursor RecCursor-instance DBCursor FixedRecordDBCursor Record ByteString where- jump (FixedRecordDBCursor c) = jump c- jumpFirst (FixedRecordDBCursor c) = jumpFirst c- jumpLast (FixedRecordDBCursor c) = jumpLast c- next (FixedRecordDBCursor c) = next c- previous (FixedRecordDBCursor c) = previous c- replace (FixedRecordDBCursor c) = replace c- remove (FixedRecordDBCursor c) = remove c- closeCursor (FixedRecordDBCursor c) = closeCursor c--{-| A configuration for fixed-length record databases. -}-data FixedRecordDBConf = FixedRecordDBConf {- {-| Forces a snapshot of the database to be taken when the file- is opened. -}- fixed_snapshot :: Bool,-- {-| An advisory maximum size of the in-memory database cache. -}- fixed_cacheSize :: Int,-- {-| The page size used for the in-memory database cache, which happens- to be a b-tree. If this value is 0, a default size will be chosen. -}- fixed_pageSize :: Int,-- {-| The fixed length of the records. This must be manually overridden in- the default configuration, or an exception will be thrown. -}- fixed_recordLength :: Int,-- {-| The byte order for integers in the database metadata; for example,- 4321 represents big-endian order. Not all orders are guaranteed to- be supported; if the byte order is 0, host order will be used.- Unlike the other database types, record databases have no metadata,- so it's important to get this right when opening existing- databases. -}- fixed_byteOrder :: Int,-- {-| The byte value used to pad fixed-length records in the database.- By default, this is a space character (0x20). -}- fixed_paddingByte :: Word8,-- {-| A file which should be used to store the the in-memory record cache. -}- fixed_treeFile :: Maybe String-}--{-| The default configuration for fixed-length record databases. -}-defaultFixedRecordDBConf :: FixedRecordDBConf-defaultFixedRecordDBConf = FixedRecordDBConf {- fixed_snapshot = False,- fixed_cacheSize = 0,- fixed_pageSize = 0,- fixed_recordLength = 0,- fixed_byteOrder = 0,- fixed_paddingByte = 0x20,- fixed_treeFile = Nothing-}--{-| Opens or creates a fixed-length record database. -}-openFixedRecord :: Maybe FilePath -> IOMode -> FileMode -> FixedRecordDBConf -> IO FixedRecordDB-openFixedRecord path iomode filemode conf =- if (fixed_recordLength conf <= 0) then fail "non-positive record length" else- withMaybeString path $ \cpath ->- withMaybeString (fixed_treeFile conf) $ \ctreefile ->- alloca $ \info -> do- writeFixedRecordDBConf conf ctreefile info- ptr <- throwErrnoIfNull "BerkeleyDB.openFixedRecord"- $ db_open_recno cpath (fromIOMode iomode) filemode info- return $ FixedRecordDB ptr--{- Writes a fixed record database configuration into a C structure.- We pass in the btree filename string from elsewhere because it aids- emergency cleanup to do so. -}-writeFixedRecordDBConf :: FixedRecordDBConf -> CString -> Ptr RECNOINFO -> IO ()-writeFixedRecordDBConf conf bfname info = do- poke info $ RECNOINFO {- ri_flags = toFlags [(True, #const R_FIXEDLEN),- (True, #const R_NOKEY),- (fixed_snapshot conf, #const R_SNAPSHOT)],- ri_cachesize = toEnum $ fixed_cacheSize conf,- ri_psize = toEnum $ fixed_pageSize conf,- ri_lorder = toEnum $ fixed_byteOrder conf,- ri_reclen = toEnum $ fixed_recordLength conf,- ri_bval = fromInteger $ toInteger $ fixed_paddingByte conf,- ri_bfname = bfname- }--{-- typedef struct {- u_long flags;- u_int cachesize;- u_int psize;- int lorder;- size_t reclen;- u_char bval;- char *bfname;- } RECNOINFO;--}--data RECNOINFO = RECNOINFO {- ri_flags :: CULong,- ri_cachesize, ri_psize :: CUInt,- ri_lorder :: CInt,- ri_reclen :: CSize,- ri_bval :: CUChar,- ri_bfname :: CString-}-instance Storable RECNOINFO where- sizeOf _ = #{size RECNOINFO}- alignment _ = #{alignment RECNOINFO}- peek ptr = do- flags <- #{peek RECNOINFO, flags} ptr- cachesize <- #{peek RECNOINFO, cachesize} ptr- psize <- #{peek RECNOINFO, psize} ptr- lorder <- #{peek RECNOINFO, lorder} ptr- reclen <- #{peek RECNOINFO, reclen} ptr- bval <- #{peek RECNOINFO, bval} ptr- bfname <- #{peek RECNOINFO, bfname} ptr- return $ RECNOINFO { ri_flags = flags, ri_cachesize = cachesize,- ri_psize = psize, ri_lorder = lorder,- ri_reclen = reclen, ri_bval = bval,- ri_bfname = bfname }- poke ptr info = do- let pokeAt offset selector = poke (plusPtr ptr offset) (selector info)- #{poke RECNOINFO, flags} ptr (ri_flags info)- #{poke RECNOINFO, cachesize} ptr (ri_cachesize info)- #{poke RECNOINFO, psize} ptr (ri_psize info)- #{poke RECNOINFO, lorder} ptr (ri_lorder info)- #{poke RECNOINFO, reclen} ptr (ri_reclen info)- #{poke RECNOINFO, bval} ptr (ri_bval info)- #{poke RECNOINFO, bfname} ptr (ri_bfname info)--------- PRIMITIVE OPERATIONS ----------{- Primitive close. -}-_close :: Ptr DBStruct -> IO ()-_close ptr = do- throwErrnoIfMinus1_ "BerkeleyDB.close" $ db_close ptr--{- Primitive sync. -}-_sync :: Ptr DBStruct -> IO ()-_sync ptr = do- throwErrnoIfMinus1_ "BerkeleyDB.sync" $ db_sync ptr--{- Primitive delete. The first parameter is true if the operation must- use the safe foreign call. -}-_delete :: Bool -> Ptr DBStruct -> ByteString -> IO Bool-_delete sf ptr key =- withDBT key $ \tKey -> do- result <- throwErrnoIfMinus1 "BerkeleyDB.delete"- $ (if sf then db_delete_sf else db_delete) ptr tKey- case result of- 0 -> return True- _ -> return False--_deleteRecord :: Ptr DBStruct -> Recno -> IO Bool-_deleteRecord ptr key = do- result <- throwErrnoIfMinus1 "BerkeleyDB.delete"- $ db_delete_record ptr key- case result of- 0 -> return True- _ -> return False--_deleteCursor :: Bool -> Ptr DBStruct -> IO ()-_deleteCursor sf ptr = do- throwErrnoIfMinus1_ "BerkeleyDB.remove"- $ (if sf then db_delete_cursor_sf else db_delete_cursor) ptr--{- Primitive insertion. The first parameter is true if the operation must- use the safe foreign call. -}-_insert :: Bool -> Ptr DBStruct -> ByteString -> ByteString -> CUInt -> IO ()-_insert sf ptr key val flags =- withDBT key $ \tKey ->- withDBT val $ \tVal -> do- throwErrnoIfMinus1_ "BerkeleyDB.insert"- $ (if sf then db_insert_sf else db_insert) ptr tKey tVal flags--_insertRecord :: Ptr DBStruct -> Recno -> ByteString -> CUInt -> IO ()-_insertRecord ptr key val flags = - withDBT val $ \tVal -> do- throwErrnoIfMinus1_ "BerkeleyDB.insert"- $ db_insert_record ptr key tVal flags--{- Primitive lookup. The first parameter is true if the operation must use- the safe foreign call. -}-_lookup :: Bool -> Ptr DBStruct -> ByteString -> IO (Maybe ByteString)-_lookup sf ptr key =- withDBT key $ \tKey ->- alloca $ \tVal -> do- result <- throwErrnoIfMinus1 "BerkeleyDB.lookup"- $ (if sf then db_lookup_sf else db_lookup) ptr tKey tVal- case result of- 0 -> liftM Just $ copyDBT tVal- _ -> return Nothing--_lookupRecord :: Ptr DBStruct -> Recno -> IO (Maybe ByteString)-_lookupRecord ptr key = - alloca $ \tVal -> do- result <- throwErrnoIfMinus1 "BerkeleyDB.lookup"- $ db_lookup_record ptr key tVal- case result of- 0 -> liftM Just $ copyDBT tVal- _ -> return Nothing--{- Primitive cursor. The first parameter is true if the operation must- use the safe foreign call. -}--{- The 'keyed' version exposes a byte-string key to the database; the- 'unkeyed' version passes a freshly-allocated pointer. The record routine- doesn't need to be split like this because it doesn't require additional- allocation. -}--_cursorKeyed sf ptr key flags = withDBT key (_cursor sf ptr flags)-_cursorUnkeyed sf ptr flags = alloca (_cursor sf ptr flags)--_cursor :: Bool -> Ptr DBStruct -> CUInt -> Ptr DBT -> IO (Maybe (ByteString,ByteString))-_cursor sf ptr flags tKey =- alloca $ \tVal -> do- result <- throwErrnoIfMinus1 "BerkeleyDB.cursor"- $ (if sf then db_cursor_sf else db_cursor) ptr tKey tVal flags- case result of- 0 -> do- retKey <- copyDBT tKey- retVal <- copyDBT tVal- return $ Just (retKey, retVal)- _ -> return Nothing--_cursorRecord :: Ptr DBStruct -> Recno -> CUInt -> IO (Maybe (Record,ByteString))-_cursorRecord ptr rec flags = do- alloca $ \tVal -> do- result <- throwErrnoIfMinus1 "BerkeleyDB.cursor"- $ db_cursor_record ptr rec tVal flags- case result of- 0 -> do- retVal <- copyDBT tVal- return $ Just (Record 0, retVal)- _ -> return Nothing--{- Creation calls are all unsafe. -}--foreign import ccall unsafe "db_open_recno"- db_open_recno :: CString -> CInt -> CMode -> Ptr RECNOINFO -> IO (Ptr DBStruct)-#{def- DB *db_open_recno(const char *path, int flags, mode_t umask, RECNOINFO *info) {- return dbopen(path, flags, umask, DB_RECNO, info);- }-}--foreign import ccall unsafe "db_open_hash"- db_open_hash :: CString -> CInt -> CMode -> Ptr HASHINFO -> IO (Ptr DBStruct)-#{def- DB *db_open_hash(const char *path, int flags, mode_t umask, HASHINFO *info) {- return dbopen(path, flags, umask, DB_HASH, info);- }-}--foreign import ccall unsafe "db_open_btree"- db_open_btree :: CString -> CInt -> CMode -> Ptr BTREEINFO -> IO (Ptr DBStruct)-#{def- DB *db_open_btree(const char *path, int flags, mode_t umask, BTREEINFO *info) {- return dbopen(path, flags, umask, DB_BTREE, info);- }-}--{- Close and sync calls. Unsafe against reentry to Haskell. -}-foreign import ccall unsafe "db_close"- db_close :: Ptr DBStruct -> IO CInt-#{def- int db_close(DB *db) {- return db->close(db);- }-}--foreign import ccall unsafe "db_sync"- db_sync :: Ptr DBStruct -> IO CInt-#{def- int db_sync(const DB *db) {- return db->sync(db, 0);- }-}--{- Deletion family of calls. -}-{- delete-by-key, safe and unsafe. -}-foreign import ccall unsafe "db_delete"- db_delete :: Ptr DBStruct -> Ptr DBT -> IO CInt-foreign import ccall safe "db_delete"- db_delete_sf :: Ptr DBStruct -> Ptr DBT -> IO CInt-#{def- int db_delete(const DB *db, const DBT *key) {- return db->del(db, key, 0);- }-}--{- delete-record, always unsafe -}-foreign import ccall unsafe "db_delete_record"- db_delete_record :: Ptr DBStruct -> Recno -> IO CInt-#{def- int db_delete_record(const DB *db, recno_t key) {- const DBT dbt = { &key, sizeof(key) };- return db->del(db, &dbt, 0);- }-}--{- delete-at-cursor, safe and unsafe -}-foreign import ccall unsafe "db_delete_cursor"- db_delete_cursor :: Ptr DBStruct -> IO CInt-foreign import ccall safe "db_delete_cursor"- db_delete_cursor_sf :: Ptr DBStruct -> IO CInt-#{def- int db_delete_cursor(const DB *db) {- return db->del(db, 0, R_CURSOR);- }-}--{- Lookup family of calls. -}-{- lookup-by-key, safe and unsafe -}-foreign import ccall unsafe "db_lookup"- db_lookup :: Ptr DBStruct -> Ptr DBT -> Ptr DBT -> IO CInt-foreign import ccall safe "db_lookup"- db_lookup_sf :: Ptr DBStruct -> Ptr DBT -> Ptr DBT -> IO CInt-#{def- int db_lookup(const DB *db, const DBT *key, DBT *val) {- return db->get(db, key, val, 0);- }-}--{- lookup-record, always unsafe -}-foreign import ccall unsafe "db_lookup_record"- db_lookup_record :: Ptr DBStruct -> Recno -> Ptr DBT -> IO CInt-#{def- int db_lookup_record(const DB *db, recno_t key, DBT *val) {- const DBT dbt = { &key, sizeof(key) };- return db->get(db, &dbt, val, 0);- }-}--{- Insert family of calls. -}-{- insert-by-key, safe and unsafe -}-foreign import ccall unsafe "db_c.h"- db_insert :: Ptr DBStruct -> Ptr DBT -> Ptr DBT -> CUInt -> IO CInt-foreign import ccall safe "db_c.h db_insert"- db_insert_sf :: Ptr DBStruct -> Ptr DBT -> Ptr DBT -> CUInt -> IO CInt-#{def- int db_insert(const DB *db, DBT *key, DBT *val, u_int flags) {- return db->put(db, key, val, flags);- }-}--{- insert-record, always unsafe -}-foreign import ccall unsafe "db_c.h"- db_insert_record :: Ptr DBStruct -> Recno -> Ptr DBT -> CUInt -> IO CInt-#{def- int db_insert_record(const DB *db, recno_t key, DBT *val, u_int flags) {- DBT dbt = { &key, sizeof(key) };- return db->put(db, &dbt, val, flags);- }-}--{- Sequence family of calls. -}-{- cursor-by-key, safe and unsafe -}-foreign import ccall unsafe "db_c.h"- db_cursor :: Ptr DBStruct -> Ptr DBT -> Ptr DBT -> CUInt -> IO CInt-foreign import ccall safe "db_c.h db_cursor"- db_cursor_sf :: Ptr DBStruct -> Ptr DBT -> Ptr DBT -> CUInt -> IO CInt-#{def- int db_cursor(const DB *db, DBT *key, DBT *val, u_int flags) {- return db->seq(db, key, val, flags);- }-}--{- cursor-record, always unsafe -}-foreign import ccall unsafe "db_c.h"- db_cursor_record :: Ptr DBStruct -> Recno -> Ptr DBT -> CUInt -> IO CInt--{- Wrapper-creation functions for callbacks. -}-foreign import ccall unsafe "wrapper"- wrapHash :: (CString -> CSize -> IO Word32) -> IO (FunPtr (CString -> CSize -> IO Word32))-foreign import ccall unsafe "wrapper"- wrapCompare :: (Ptr DBT -> Ptr DBT -> CInt) -> IO (FunPtr (Ptr DBT -> Ptr DBT -> CInt))-foreign import ccall unsafe "wrapper"- wrapPrefix :: (Ptr DBT -> Ptr DBT -> CSize) -> IO (FunPtr (Ptr DBT -> Ptr DBT -> CSize))
LICENSE view
@@ -1,29 +1,27 @@-Copyright (c) 2007, Robert John McCall--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions-are met:-- * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.- * Redistributions in binary form must reproduce the above copyright- notice, this list of conditions and the following disclaimer in- the documentation and/or other materials provided with the- distribution.- * The author's name may not be used to endorse or promote products- derived from this software without specific prior written- permission.+/*+ * Copyright (c) 2008, Stephen Blackheath+ * All rights reserved.+ *+ * Redistribution and use in source and binary forms, with or without+ * modification, are permitted provided that the following conditions are met:+ * * Redistributions of source code must retain the above copyright+ * notice, this list of conditions and the following disclaimer.+ * * Redistributions in binary form must reproduce the above copyright+ * notice, this list of conditions and the following disclaimer in the+ * documentation and/or other materials provided with the distribution.+ * * Neither the name of the <organization> nor the+ * names of its contributors may be used to endorse or promote products+ * derived from this software without specific prior written permission.+ *+ * THIS SOFTWARE IS PROVIDED BY STEPHEN BLACKHEATH ''AS IS'' AND ANY+ * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+ * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+ * DISCLAIMED. IN NO EVENT SHALL STEPHEN BLACKHEATH BE LIABLE FOR ANY+ * DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+ * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+ * LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+ * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+ * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+ */ -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Setup.hs view
@@ -1,3 +1,3 @@ import Distribution.Simple- main = defaultMain+
+ examples/capitals.hs view
@@ -0,0 +1,247 @@+module Main where++import System.Environment+import Database.Berkeley.Db+import Control.Monad+import qualified Data.ByteString as B+import Data.Char++pack :: String -> B.ByteString+pack = B.pack . map (fromIntegral . ord)++unpack :: B.ByteString -> String+unpack = map (chr . fromIntegral) . B.unpack ++data Action = Read | Write | Fail deriving Eq++writeDb :: Db -> IO ()+writeDb db = do+ forM_ testData $ \(country, capital) -> do+ db_put [] db Nothing (pack country) (pack capital)++readDb :: Db -> IO ()+readDb db = do+ forM_ testData$ \(country, capital) -> do+ mCapital <- db_get [] db Nothing (pack country)+ putStrLn $ country ++ " - " +++ (case mCapital of+ Just capital -> unpack capital+ otherwise -> "<empty>")++main = do+ args <- getArgs+ let action = case args of+ ["read"] -> Read+ ["write"] -> Write+ otherwise -> Fail+ if action == Fail+ then putStrLn "Please say 'read' or 'write' on the command line"+ else do+ dbenv <- dbEnv_create []+ dbEnv_open [DB_CREATE,DB_INIT_MPOOL] 0 dbenv "."+ db <- db_create [] dbenv+ db_set_pagesize db 2048+ db_open [DB_CREATE] DB_HASH 0 db Nothing "capitals.db" Nothing + if action == Read+ then readDb db+ else writeDb db+ db_close [] db+ dbEnv_close [] dbenv+ putStrLn "Finished."++testData = [+ ("Afghanistan", "Kabul"),+ ("Albania", "Tirane"),+ ("Algeria", "Algiers"),+ ("Andorra", "Andorra la Vella"),+ ("Angola", "Luanda"),+ ("Antigua and Barbuda", "Saint John's"),+ ("Argentina", "Buenos Aires"),+ ("Armenia", "Yerevan"),+ ("Australia", "Canberra"),+ ("Austria", "Vienna"),+ ("Azerbaijan", "Baku"),+ ("The Bahamas", "Nassau"),+ ("Bahrain", "Manama"),+ ("Bangladesh", "Dhaka"),+ ("Barbados", "Bridgetown"),+ ("Belarus", "Minsk"),+ ("Belgium", "Brussels"),+ ("Belize", "Belmopan"),+ ("Benin", "Porto-Novo"),+ ("Bhutan", "Thimphu"),+ ("Bolivia", "La Paz (administrative); Sucre (judicial)"),+ ("Bosnia and Herzegovina", "Sarajevo"),+ ("Botswana", "Gaborone"),+ ("Brazil", "Brasilia"),+ ("Brunei", "Bandar Seri Begawan"),+ ("Bulgaria", "Sofia"),+ ("Burkina Faso", "Ouagadougou"),+ ("Burundi", "Bujumbura"),+ ("Cambodia", "Phnom Penh"),+ ("Cameroon", "Yaounde"),+ ("Canada", "Ottawa"),+ ("Cape Verde", "Praia"),+ ("Central African Republic", "Bangui"),+ ("Chad", "N'Djamena"),+ ("Chile", "Santiago"),+ ("China", "Beijing"),+ ("Colombia", "Bogota"),+ ("Comoros", "Moroni"),+ ("Congo, Republic of the", "Brazzaville"),+ ("Congo, Democratic Republic of the", "Kinshasa"),+ ("Costa Rica", "San Jose"),+ ("Cote d'Ivoire", "Yamoussoukro (official); Abidjan (de facto)"),+ ("Croatia", "Zagreb"),+ ("Cuba", "Havana"),+ ("Cyprus", "Nicosia"),+ ("Czech Republic", "Prague"),+ ("Denmark", "Copenhagen"),+ ("Djibouti", "Djibouti"),+ ("Dominica", "Roseau"),+ ("Dominican Republic", "Santo Domingo"),+ ("East Timor (Timor-Leste)", "Dili"),+ ("Ecuador", "Quito"),+ ("Egypt", "Cairo"),+ ("El Salvador", "San Salvador"),+ ("Equatorial Guinea", "Malabo"),+ ("Eritrea", "Asmara"),+ ("Estonia", "Tallinn"),+ ("Ethiopia", "Addis Ababa"),+ ("Fiji", "Suva"),+ ("Finland", "Helsinki"),+ ("France", "Paris"),+ ("Gabon", "Libreville"),+ ("The Gambia", "Banjul"),+ ("Georgia", "Tbilisi"),+ ("Germany", "Berlin"),+ ("Ghana", "Accra"),+ ("Greece", "Athens"),+ ("Grenada", "Saint George's"),+ ("Guatemala", "Guatemala City"),+ ("Guinea", "Conakry"),+ ("Guinea-Bissau", "Bissau"),+ ("Guyana", "Georgetown"),+ ("Haiti", "Port-au-Prince"),+ ("Honduras", "Tegucigalpa"),+ ("Hungary", "Budapest"),+ ("Iceland", "Reykjavik"),+ ("India", "New Delhi"),+ ("Indonesia", "Jakarta"),+ ("Iran", "Tehran"),+ ("Iraq", "Baghdad"),+ ("Ireland", "Dublin"),+ ("Israel", "Jerusalem"),+ ("Italy", "Rome"),+ ("Jamaica", "Kingston"),+ ("Japan", "Tokyo"),+ ("Jordan", "Amman"),+ ("Kazakhstan", "Astana"),+ ("Kenya", "Nairobi"),+ ("Kiribati", "Tarawa Atoll"),+ ("Korea, North", "Pyongyang"),+ ("Korea, South", "Seoul"),+ ("Kosovo", "Pristina"),+ ("Kuwait", "Kuwait City"),+ ("Kyrgyzstan", "Bishkek"),+ ("Laos", "Vientiane"),+ ("Latvia", "Riga"),+ ("Lebanon", "Beirut"),+ ("Lesotho", "Maseru"),+ ("Liberia", "Monrovia"),+ ("Libya", "Tripoli"),+ ("Liechtenstein", "Vaduz"),+ ("Lithuania", "Vilnius"),+ ("Luxembourg", "Luxembourg"),+ ("Macedonia", "Skopje"),+ ("Madagascar", "Antananarivo"),+ ("Malawi", "Lilongwe"),+ ("Malaysia", "Kuala Lumpur"),+ ("Maldives", "Male"),+ ("Mali", "Bamako"),+ ("Malta", "Valletta"),+ ("Marshall Islands", "Majuro"),+ ("Mauritania", "Nouakchott"),+ ("Mauritius", "Port Louis"),+ ("Mexico", "Mexico City"),+ ("Micronesia, Federated States of", "Palikir"),+ ("Moldova", "Chisinau"),+ ("Monaco", "Monaco"),+ ("Mongolia", "Ulaanbaatar"),+ ("Montenegro", "Podgorica"),+ ("Morocco", "Rabat"),+ ("Mozambique", "Maputo"),+ ("Myanmar (Burma)", "Rangoon (Yangon); Naypyidaw or Nay Pyi Taw (administrative)"),+ ("Namibia", "Windhoek"),+ ("Nauru", "no official capital; government offices in Yaren District"),+ ("Nepal", "Kathmandu"),+ ("Netherlands", "Amsterdam; The Hague (seat of government)"),+ ("New Zealand", "Wellington"),+ ("Nicaragua", "Managua"),+ ("Niger", "Niamey"),+ ("Nigeria", "Abuja"),+ ("Norway", "Oslo"),+ ("Oman", "Muscat"),+ ("Pakistan", "Islamabad"),+ ("Palau", "Melekeok"),+ ("Panama", "Panama City"),+ ("Papua New Guinea", "Port Moresby"),+ ("Paraguay", "Asuncion"),+ ("Peru", "Lima"),+ ("Philippines", "Manila"),+ ("Poland", "Warsaw"),+ ("Portugal", "Lisbon"),+ ("Qatar", "Doha"),+ ("Romania", "Bucharest"),+ ("Russia", "Moscow"),+ ("Rwanda", "Kigali"),+ ("Saint Kitts and Nevis", "Basseterre"),+ ("Saint Lucia", "Castries"),+ ("Saint Vincent and the Grenadines", "Kingstown"),+ ("Samoa", "Apia"),+ ("San Marino", "San Marino"),+ ("Sao Tome and Principe", "Sao Tome"),+ ("Saudi Arabia", "Riyadh"),+ ("Senegal", "Dakar"),+ ("Serbia", "Belgrade"),+ ("Seychelles", "Victoria"),+ ("Sierra Leone", "Freetown"),+ ("Singapore", "Singapore"),+ ("Slovakia", "Bratislava"),+ ("Slovenia", "Ljubljana"),+ ("Solomon Islands", "Honiara"),+ ("Somalia", "Mogadishu"),+ ("South Africa", "Pretoria (administrative); Cape Town (legislative); Bloemfontein (judiciary)"),+ ("Spain", "Madrid"),+ ("Sri Lanka", "Colombo; Sri Jayewardenepura Kotte (legislative)"),+ ("Sudan", "Khartoum"),+ ("Suriname", "Paramaribo"),+ ("Swaziland", "Mbabane"),+ ("Sweden", "Stockholm"),+ ("Switzerland", "Bern"),+ ("Syria", "Damascus"),+ ("Taiwan", "Taipei"),+ ("Tajikistan", "Dushanbe"),+ ("Tanzania", "Dar es Salaam; Dodoma (legislative)"),+ ("Thailand", "Bangkok"),+ ("Togo", "Lome"),+ ("Tonga", "Nuku'alofa"),+ ("Trinidad and Tobago", "Port-of-Spain"),+ ("Tunisia", "Tunis"),+ ("Turkey", "Ankara"),+ ("Turkmenistan", "Ashgabat"),+ ("Tuvalu", "Vaiaku village, Funafuti province"),+ ("Uganda", "Kampala"),+ ("Ukraine", "Kyiv"),+ ("United Arab Emirates", "Abu Dhabi"),+ ("United Kingdom", "London"),+ ("United States of America", "Washington D.C."),+ ("Uruguay", "Montevideo"),+ ("Uzbekistan", "Tashkent"),+ ("Vanuatu", "Port-Vila"),+ ("Vatican City (Holy See)", "Vatican City"),+ ("Venezuela", "Caracas"),+ ("Vietnam", "Hanoi"),+ ("Yemen", "Sanaa"),+ ("Zambia", "Lusaka"),+ ("Zimbabwe", "Harare")]
+ examples/tests.hs view
@@ -0,0 +1,148 @@+import System.Directory+import Database.Berkeley.Db+import Test.HUnit+import Control.Exception+import Control.Monad+import qualified Data.ByteString as B+import Data.Char+import Prelude hiding (catch)+++pack :: String -> B.ByteString+pack = B.pack . map (fromIntegral . ord)++unpack :: B.ByteString -> String+unpack = map (chr . fromIntegral) . B.unpack ++cleanDir :: IO () -> IO ()+cleanDir code = do+ original <- getCurrentDirectory+ removeDirectoryRecursive "test" `catch` ((\exc -> return ())::SomeException -> IO ())+ createDirectory "test"+ setCurrentDirectory "test"+ code+ setCurrentDirectory original++cleanEnv :: (DbEnv -> IO ()) -> IO ()+cleanEnv code = do+ cleanDir $+ bracket+ (do+ dbenv <- dbEnv_create []+ dbEnv_open [DB_CREATE,DB_INIT_LOCK,DB_INIT_LOG,DB_INIT_MPOOL,+ DB_INIT_TXN,DB_THREAD] 0 dbenv "."+ return dbenv)+ (dbEnv_close [])+ code++cleanDb :: (DbEnv -> Db -> IO ()) -> IO ()+cleanDb code =+ cleanEnv $ \dbenv -> do+ bracket+ (do+ db <- db_create [] dbenv+ db_open [DB_CREATE,DB_THREAD,DB_AUTO_COMMIT] DB_BTREE 0 db Nothing "test.db" Nothing+ return db)+ (db_close [])+ (code dbenv)++test_exception = do+ cleanEnv $ \dbenv -> do+ answer <-+ catch+ (do+ bracket+ (db_create [] dbenv)+ (db_close [])+ (\db -> db_open [] DB_HASH 0 db Nothing "not-there.db" Nothing)+ return Nothing)+ (\exc -> do+ case fromException exc of+ Just (DbException _ code) -> return $ Just code+ Nothing -> throwIO exc+ )+ assertEqual "exception" (Just (SYSTEM_ERROR 2)) answer -- 2 == ENOENT++test_putget = do+ cleanDb $ \dbenv db -> do+ db_put [] db Nothing (pack "car") (pack "triumph")+ db_put [] db Nothing (pack "fruit") (pack "banana")+ db_put [] db Nothing (pack "car") (pack "honda")+ db_put [] db Nothing (pack "tree") (pack "poplar")+ assertEqual "putget_fruit" (Just $ pack "banana") =<< db_get [] db Nothing (pack "fruit")+ assertEqual "putget_car" (Just $ pack "honda") =<< db_get [] db Nothing (pack "car")+ assertEqual "putget_tree" (Just $ pack "poplar") =<< db_get [] db Nothing (pack "tree")+ assertEqual "putget_pet" Nothing =<< db_get [] db Nothing (pack "pet")++test_txn = do+ cleanDb $ \dbenv db -> do+ dbEnv_withTxn [] [] dbenv Nothing $ \txn -> do+ db_put [] db (Just txn) (pack "fruit") (pack "apricot")+ assertEqual "txn_1" (Just $ pack "apricot") =<< db_get [] db Nothing (pack "fruit")+ -- Check that a rolled back exception doesn't modify the database+ catch+ (dbEnv_withTxn [] [] dbenv Nothing $ \txn -> do+ db_put [] db (Just txn) (pack "fruit") (pack "pomegranate")+ throwIO $ DbException "" (SYSTEM_ERROR 0))+ ((\exc -> return ()) :: SomeException -> IO ())+ assertEqual "txn_1" (Just $ pack "apricot") =<< db_get [] db Nothing (pack "fruit")++test_afterclose = do+ cleanDir $ do+ mDbErr <- catch (do+ dbenv <- dbEnv_create []+ dbEnv_open [DB_CREATE,DB_INIT_LOCK,DB_INIT_LOG,DB_INIT_MPOOL,+ DB_INIT_TXN,DB_THREAD] 0 dbenv "."+ dbEnv_close [] dbenv+ db <- db_create [] dbenv+ db_open [DB_CREATE,DB_THREAD,DB_AUTO_COMMIT] DB_BTREE 0 db Nothing "test.db" Nothing+ db_close [] db+ return Nothing)+ (\exc ->+ case fromException exc of+ Just (DbException _ code) -> return $ Just code+ Nothing -> throwIO exc)+ assertEqual "afterclose_1" (Just DB_ACCESSED_DB_ENV_AFTER_CLOSE) mDbErr++ cleanEnv $ \dbenv -> do+ mDbErr <- catch (do+ db <- db_create [] dbenv+ db_open [DB_CREATE,DB_THREAD,DB_AUTO_COMMIT] DB_BTREE 0 db Nothing "test.db" Nothing+ db_close [] db+ db_put [] db Nothing (pack "fruit") (pack "guava")+ return Nothing)+ (\exc ->+ case fromException exc of+ Just (DbException _ code) -> return $ Just code+ Nothing -> throwIO exc)+ assertEqual "afterclose_2" (Just DB_ACCESSED_DB_AFTER_CLOSE) mDbErr+ + cleanDb $ \dbenv db -> do+ mDbErr <- catch (do+ txn <- dbEnv_txn_begin [] dbenv Nothing+ dbTxn_abort txn+ db_put [] db (Just txn) (pack "fruit") (pack "melon")+ return Nothing)+ (\exc ->+ case fromException exc of+ Just (DbException _ code) -> return $ Just code+ Nothing -> throwIO exc)+ assertEqual "afterclose_3" (Just DB_ACCESSED_DB_TXN_AFTER_CLOSE) mDbErr++test_lock = do+ cleanDb $ \dbenv db -> do+ -- This doesn't test very much: Just that locking doesn't cause any+ -- runtime errors, hangs or crashes.+ dbEnv_withTxn [] [] dbenv Nothing $ \txn -> do+ dbEnv_withLock [] DB_LOCK_WRITE (pack "my_lock") dbenv (dbTxn_id txn) $ do+ db_put [] db (Just txn) (pack "fruit") (pack "durian")++main = do+ runTestTT $ TestList [+ TestCase test_exception,+ TestCase test_putget,+ TestCase test_txn,+ TestCase test_afterclose,+ TestCase test_lock+ ]+