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