diff --git a/BerkeleyDB.cabal b/BerkeleyDB.cabal --- a/BerkeleyDB.cabal +++ b/BerkeleyDB.cabal @@ -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: + + . + Haskell binding tutorial: + + . + DARCS repository: + + +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++ diff --git a/Database/Berkeley/Db.hs b/Database/Berkeley/Db.hs new file mode 100644 --- /dev/null +++ b/Database/Berkeley/Db.hs @@ -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 () + diff --git a/Database/Berkeley/db_helper.cpp b/Database/Berkeley/db_helper.cpp new file mode 100644 --- /dev/null +++ b/Database/Berkeley/db_helper.cpp @@ -0,0 +1,300 @@ +#include "db_helper.h" + +#include +#include +#include + +#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); +} + diff --git a/Database/Berkeley/db_helper.h b/Database/Berkeley/db_helper.h new file mode 100644 --- /dev/null +++ b/Database/Berkeley/db_helper.h @@ -0,0 +1,53 @@ +#ifndef _DB_HELPER_H_ +#define _DB_HELPER_H_ + +#include + +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 + diff --git a/Database/BerkeleyDB.hs b/Database/BerkeleyDB.hs deleted file mode 100644 --- a/Database/BerkeleyDB.hs +++ /dev/null @@ -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 - Maintainer: John McCall - 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)) diff --git a/Database/BerkeleyDB.hsc b/Database/BerkeleyDB.hsc deleted file mode 100644 --- a/Database/BerkeleyDB.hsc +++ /dev/null @@ -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 - Maintainer: John McCall - 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 -#include - -#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)) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 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. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,3 +1,3 @@ import Distribution.Simple - main = defaultMain + diff --git a/examples/capitals.hs b/examples/capitals.hs new file mode 100644 --- /dev/null +++ b/examples/capitals.hs @@ -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 -> "") + +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")] diff --git a/examples/tests.hs b/examples/tests.hs new file mode 100644 --- /dev/null +++ b/examples/tests.hs @@ -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 + ] +