BerkeleyDB-0.2: Database/BerkeleyDB.hsc
{-
Database.BerkeleyDB v0.2
Copyright 2007 John McCall
Licensed for general use under a BSD3-style license; for the exact
license text, see the LICENSE file included in this distribution. If
you find this file distributed without a LICENSE file, please contact
me at rjmccall@gmail.com and tell me where you found it.
It's my hope that this module could be used to bootstrap bindings for a
modern version of Berkeley DB, but I'm not currently working on that.
Author: John McCall <rjmccall@gmail.com>
Maintainer: John McCall <rjmccall@gmail.com>
History:
v0.2 2007-04-06 Haddock documentation; FileMode.
v0.1 2007-04-05 Creation.
-}
{- We require a preprocessor pass in order to bring the structure
layout into scope. We can't rely the LANGUAGE CPP pragma, though,
because we're a literate Haskell file, and it doesn't mix well
(in particular, GHC doesn't add the current directory to the include
path, which is a problem, because unlitting this file creates a file
in /tmp somewhere). -}
{-# LANGUAGE ForeignFunctionInterface #-}
#include <fcntl.h>
#include <db.h>
#ifdef __GNUC__
#let alignment type = "%d", __alignof__(type)
#else
#let alignment type = "alignment (undefined :: Ptr a)"
#endif
{-|
Haskell bindings for Berkeley DB v1.85, i.e. @db.h@ on BSD-derived Unices.
This module is intended to be imported qualified.
The database implementations provided by this module are not safe
against concurrent access; for that, users must seek a more resilient
database.
This module has been written with GHC 6.6 in mind; it is quite
possible that it will function with minimal changes on other
implementations of Haskell or earlier versions of GHC, and patches for
this purpose would be welcome, providing they don't compromise the integrity
of the up-to-date GHC implementation.
The open functions generally interpret 'IOMode' as follows:
- 'ReadMode' attempts to open a database in read-only mode; if the database
doesn't exist, an exception is thrown.
- 'ReadWriteMode' and 'AppendMode' are synonymous; both open the database in
read\/write mode, creating it if necessary.
- 'WriteMode' opens the database in read\/write mode, but it truncates any
existing database file.
-}
module Database.BerkeleyDB
(HashDB, openHash, HashDBCursor,HashDBConf(..), defaultHashDBConf,
TreeDB, openTree, TreeDBCursor,TreeDBConf(..), defaultTreeDBConf,
RecordDB, openRecord, Record, RecordDBCursor,
RecordDBConf(..), defaultRecordDBConf,
FixedRecordDB, openFixedRecord, FixedRecordDBCursor,
FixedRecordDBConf(..), defaultFixedRecordDBConf,
DB(..), DBCursor(..),
IOMode(..)) where
import System.IO (IOMode(..)) -- re-exported
import System.Posix.Files -- for FileMode's helpful constants
import System.Posix.Types -- for mode_t
import Foreign
import Foreign.C
import Control.Monad (when, liftM)
import Control.Exception (bracketOnError)
import Data.ByteString (ByteString, packCStringLen, 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 = #{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 -> 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 _ = #{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 -> 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))