BerkeleyDB (empty) → 0.1

raw patch · 4 files changed

+1103/−0 lines, 4 filesdep +basebuild-type:Customsetup-changed

Dependencies added: base

Files

• BerkeleyDB.cabal +31/−0
• Database/BerkeleyDB.hsc +1040/−0
• LICENSE +29/−0
• Setup.hs +3/−0

@@ -0,0 +1,31 @@+name:		BerkeleyDB+version:	0.1+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+synopsis:	Bindings for Berkeley DB v1.x+description:+	Provides Haskell bindings for Berkeley DB v1.x, a simple file-backed+	database library which is included by default with many UNIX+	distributions.  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+includes:	db.h

@@ -0,0 +1,1040 @@+{-+Haskell bindings for Berkeley DB v1.5, 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 IO mode 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.++This file could also be used to bootstrap bindings for a modern version of+Berkeley DB.+-}++{- 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++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(..), UMask) where++import System.IO+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)++------ ELEMENTARY DEFINITIONS -------++{- POSIX file-creation masks;  see the manpage for umask(2). -}++type UMask = Int++{- The default umask doesn't restrict created files in any way other than+   that specified in the process umask. -}++defaultUmask :: UMask+defaultUmask = 0666++--------- 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 {+  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 -> UMask -> 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) (toEnum 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 {+  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 -> UMask -> TreeDBConf -> IO TreeDB+openTree path iomode umask 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) (toEnum umask) 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)+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 {+--  record_noKey         :: Bool,+  record_snapshot      :: Bool,+  record_cacheSize     :: Int,+  record_pageSize      :: Int,+  record_byteOrder     :: Int,+  record_separatorByte :: Word8,+  record_treeFile      :: Maybe String+}+defaultRecordDBConf = RecordDBConf {+--  record_noKey         = False,+  record_snapshot      = False,+  record_cacheSize     = 0,+  record_pageSize      = 0,+  record_byteOrder     = 0,+  record_separatorByte = 32,   -- ' '+  record_treeFile      = Nothing+}++openRecord :: Maybe FilePath -> IOMode -> UMask -> RecordDBConf -> IO RecordDB+openRecord path iomode umask 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) (toEnum umask) 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 {+--  fixed_noKey        :: Bool,+  fixed_snapshot     :: Bool,+  fixed_cacheSize    :: Int,+  fixed_pageSize     :: Int,+  fixed_recordLength :: Int,+  fixed_byteOrder    :: Int,+  fixed_paddingByte  :: Word8,+  fixed_treeFile     :: Maybe String+}+defaultFixedRecordDBConf = FixedRecordDBConf {+--  fixed_noKey        = False,+  fixed_snapshot     = False,+  fixed_cacheSize    = 0,+  fixed_pageSize     = 0,+  fixed_recordLength = 0,+  fixed_byteOrder    = 0,+  fixed_paddingByte  = 10, -- '\n'+  fixed_treeFile     = Nothing+}++{- Opens or creates a fixed-length record database. -}+openFixedRecord :: Maybe FilePath -> IOMode -> UMask -> FixedRecordDBConf -> IO FixedRecordDB+openFixedRecord path iomode umask conf =+  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) (toEnum umask) 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 -> CInt -> Ptr RECNOINFO -> IO (Ptr DBStruct)+#{def+  DB *db_open_recno(const char *path, int flags, int umask, RECNOINFO *info) {+    return dbopen(path, flags, umask, DB_RECNO, info);+  }+}++foreign import ccall unsafe "db_open_hash"+  db_open_hash  :: CString -> CInt -> CInt -> Ptr HASHINFO -> IO (Ptr DBStruct)+#{def+  DB *db_open_hash(const char *path, int flags, int umask, HASHINFO *info) {+    return dbopen(path, flags, umask, DB_HASH, info);+  }+}++foreign import ccall unsafe "db_open_btree"+  db_open_btree :: CString -> CInt -> CInt -> Ptr BTREEINFO -> IO (Ptr DBStruct)+#{def+  DB *db_open_btree(const char *path, int flags, int 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))

@@ -0,0 +1,29 @@+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.++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.

@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain