{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, DeriveDataTypeable #-}
{-# CFILES Database/Berkeley/db_helper.c #-}

-- | Berkeley DB binding. All IO monad functions can throw DbException.

module Database.Berkeley.Db (
        -- * Common
        DbFlag(..),
        DbError(..),
        DbException(..),
        -- * DbEnv
        DbEnv,
        dbEnv_close,
        DbEnvCreateFlag,
        dbEnv_create,
        dbEnv_get_cache_size,
        dbEnv_get_lg_regionmax,
        dbEnv_get_lk_max_lockers,
        dbEnv_get_lk_max_locks,
        dbEnv_get_lk_max_objects,
        dbEnv_get_tx_max,
        DbLock,
        DbLocker,
        DbLockMode(..),
        dbEnv_lock_get,
        dbEnv_lock_put,
        dbEnv_withLock,
        dbEnv_open,
        dbEnv_set_cache_size,
        dbEnv_set_lg_regionmax,
        DbLockFlag(..),
        dbEnv_set_lk_detect,
        dbEnv_set_lk_max_lockers,
        dbEnv_set_lk_max_locks,
        dbEnv_set_lk_max_objects,
        dbEnv_set_tx_max,
        dbEnv_txn_begin,
        dbEnv_txn_checkpoint,
        dbEnv_withTxn,
        -- * DbTxn
        DbTxn,
        dbTxn_abort,
        dbTxn_commit,
        dbTxn_id,
        -- * Db
        Db,
        db_close,
        db_create,
        db_del,
        db_get,
        DbType(..),
        db_open,
        db_put,
        db_set_pagesize,
        -- * Private
        dbToNum,       -- | Needed for BerkeleyDBXML: Binary representation of a DbFlag
        dbErrFromNum,  -- | Needed for BerkeleyDBXML: Convert an error code to a DbError
        DbEnv_struct,  -- | Needed for BerkeleyDBXML: C pointer type for a DbEnv
        DbTxn_struct   -- | Needed for BerkeleyDBXML: C pointer type for a DbTxn
    ) where

import Foreign.C
import Foreign.Marshal.Alloc
import Foreign.Storable
import Foreign.Ptr
import Control.Monad
import Data.Bits
import Data.Maybe
import System.IO.Error
import System.IO (FilePath)
import Foreign.ForeignPtr
import System.IO.Unsafe
import Data.ByteString (ByteString)
import qualified Data.ByteString.Internal as BSI
import Data.Word
import Control.Exception
import Data.Typeable

{-
   DB (user visible) error return codes.
  
   !!!
   We don't want our error returns to conflict with other packages where
   possible, so pick a base error value that's hopefully not common.  We
   document that we own the error name space from -30,800 to -30,999.
 -}
data DbError = 
    DB_BUFFER_SMALL         |    -- ^ User memory too small for return.
    DB_DONOTINDEX           |    -- ^ \"Null\" return from 2ndary callbk.
    DB_KEYEMPTY             |    -- ^ Key/data deleted or never created.
    DB_KEYEXIST             |    -- ^ The key/data pair already exists.
    DB_LOCK_DEADLOCK        |    -- ^ Deadlock.
    DB_LOCK_NOTGRANTED      |    -- ^ Lock unavailable.
    DB_LOG_BUFFER_FULL      |    -- ^ In-memory log buffer full.
    DB_NOSERVER             |    -- ^ Server panic return.
    DB_NOSERVER_HOME        |    -- ^ Bad home sent to server.
    DB_NOSERVER_ID          |    -- ^ Bad ID sent to server.
    DB_NOTFOUND             |    -- ^ Key/data pair not found (EOF).
    DB_OLD_VERSION          |    -- ^ Out-of-date version.
    DB_PAGE_NOTFOUND        |    -- ^ Requested page not found.
    DB_REP_DUPMASTER        |    -- ^ There are two masters.
    DB_REP_HANDLE_DEAD      |    -- ^ Rolled back a commit.
    DB_REP_HOLDELECTION     |    -- ^ Time to hold an election.
    DB_REP_IGNORE           |    -- ^ This msg should be ignored.
    DB_REP_ISPERM           |    -- ^ Cached not written perm written.
    DB_REP_JOIN_FAILURE     |    -- ^ Unable to join replication group.
    DB_REP_LEASE_EXPIRED    |    -- ^ Master lease has expired.
    DB_REP_LOCKOUT          |    -- ^ API/Replication lockout now.
    DB_REP_NEWSITE          |    -- ^ New site entered system.
    DB_REP_NOTPERM          |    -- ^ Permanent log record not written.
    DB_REP_UNAVAIL          |    -- ^ Site cannot currently be reached.
    DB_RUNRECOVERY          |    -- ^ Panic return.
    DB_SECONDARY_BAD        |    -- ^ Secondary index corrupt.
    DB_VERIFY_BAD           |    -- ^ Verify failed; bad format.
    DB_VERSION_MISMATCH     |    -- ^ Environment version mismatch.
    DB_ACCESSED_DB_ENV_AFTER_CLOSE |  -- ^ Haskell binding: Attempted to use a DbEnv handle after it was closed
    DB_ACCESSED_DB_AFTER_CLOSE |      -- ^ Haskell binding: Attempted to use a Db handle after it was closed
    DB_ACCESSED_DB_TXN_AFTER_CLOSE |  -- ^ Haskell binding: Attempted to use a DbTxn handle after it was closed
    SYSTEM_ERROR Int             -- ^ An errno value returned by the operating system
    deriving (Eq,Show)

dbErrFromNum :: Int -> DbError
dbErrFromNum (-30999) = DB_BUFFER_SMALL
dbErrFromNum (-30998) = DB_DONOTINDEX
dbErrFromNum (-30997) = DB_KEYEMPTY
dbErrFromNum (-30996) = DB_KEYEXIST
dbErrFromNum (-30995) = DB_LOCK_DEADLOCK
dbErrFromNum (-30994) = DB_LOCK_NOTGRANTED
dbErrFromNum (-30993) = DB_LOG_BUFFER_FULL
dbErrFromNum (-30992) = DB_NOSERVER
dbErrFromNum (-30991) = DB_NOSERVER_HOME
dbErrFromNum (-30990) = DB_NOSERVER_ID
dbErrFromNum (-30989) = DB_NOTFOUND
dbErrFromNum (-30988) = DB_OLD_VERSION
dbErrFromNum (-30987) = DB_PAGE_NOTFOUND
dbErrFromNum (-30986) = DB_REP_DUPMASTER
dbErrFromNum (-30985) = DB_REP_HANDLE_DEAD
dbErrFromNum (-30984) = DB_REP_HOLDELECTION
dbErrFromNum (-30983) = DB_REP_IGNORE
dbErrFromNum (-30982) = DB_REP_ISPERM
dbErrFromNum (-30981) = DB_REP_JOIN_FAILURE
dbErrFromNum (-30980) = DB_REP_LEASE_EXPIRED
dbErrFromNum (-30979) = DB_REP_LOCKOUT
dbErrFromNum (-30978) = DB_REP_NEWSITE
dbErrFromNum (-30977) = DB_REP_NOTPERM
dbErrFromNum (-30976) = DB_REP_UNAVAIL
dbErrFromNum (-30975) = DB_RUNRECOVERY
dbErrFromNum (-30974) = DB_SECONDARY_BAD
dbErrFromNum (-30973) = DB_VERIFY_BAD
dbErrFromNum (-30972) = DB_VERSION_MISMATCH
dbErrFromNum (-20881) = DB_ACCESSED_DB_ENV_AFTER_CLOSE
dbErrFromNum (-20882) = DB_ACCESSED_DB_AFTER_CLOSE
dbErrFromNum (-20883) = DB_ACCESSED_DB_TXN_AFTER_CLOSE
dbErrFromNum n        = (SYSTEM_ERROR n)

-- | An exception indicating an error in a Berkeley DB operation.
data DbException = DbException String DbError
    deriving (Eq, Show, Typeable)

instance Exception DbException where

throwDB :: String -> CInt -> IO a
throwDB func code =
    throwIO $ DbException func (dbErrFromNum $ fromIntegral code)

        
------ DbEnv ------------------------------------------------------------------

data DbEnv_struct
type DbEnv = ForeignPtr DbEnv_struct
foreign import ccall "db_helper.h &_dbenv_delete" _dbenv_delete
    :: FunPtr (Ptr DbEnv_struct -> IO ())

    
foreign import ccall safe "db_helper.h _dbenv_create" _dbenv_create
    :: Ptr (Ptr DbEnv_struct) -> CUInt -> IO CInt

data DbEnvCreateFlag = DB_RPCCLIENT

dbEnv_create :: [DbEnvCreateFlag] -> IO DbEnv
dbEnv_create flags =
    alloca $ \ptr -> do
        ret <- _dbenv_create ptr orFlags
        if ret /= 0
            then throwDB "_dbenv_create" ret
            else do
                p <- peek ptr
                newForeignPtr _dbenv_delete p
    where
        orFlags = foldr (.|.) 0 $ map toNum flags
        toNum DB_RPCCLIENT = 0x0000002

        
foreign import ccall safe "db_helper.h _dbenv_get_lk_max_lockers" _dbenv_get_lk_max_lockers
    :: Ptr DbEnv_struct -> Ptr CUInt -> IO CInt

dbEnv_get_lk_max_lockers :: DbEnv -> IO Int
dbEnv_get_lk_max_lockers dbenv =
    withForeignPtr dbenv $ \c_dbenv ->
    alloca $ \ptr -> do
        ret <- _dbenv_get_lk_max_lockers c_dbenv ptr
        if ret /= 0
            then throwDB "dbEnv_get_lk_max_lockers" ret
            else do
                ci <- peek ptr
                return $ fromIntegral ci

                
foreign import ccall safe "db_helper.h _dbenv_set_lk_max_lockers" _dbenv_set_lk_max_lockers
    :: Ptr DbEnv_struct -> CUInt -> IO CInt

dbEnv_set_lk_max_lockers :: DbEnv -> Int -> IO ()
dbEnv_set_lk_max_lockers dbenv max =
    withForeignPtr dbenv $ \c_dbenv -> do
        ret <- _dbenv_set_lk_max_lockers c_dbenv (fromIntegral max)
        if ret /= 0
            then throwDB "dbEnv_set_lk_max_lockers" ret
            else return ()

        
foreign import ccall safe "db_helper.h _dbenv_get_lk_max_locks" _dbenv_get_lk_max_locks
    :: Ptr DbEnv_struct -> Ptr CUInt -> IO CInt
    
dbEnv_get_lk_max_locks :: DbEnv -> IO Int
dbEnv_get_lk_max_locks dbenv =
    withForeignPtr dbenv $ \c_dbenv ->
    alloca $ \ptr -> do
        ret <- _dbenv_get_lk_max_locks c_dbenv ptr
        if ret /= 0
            then throwDB "dbEnv_get_lk_max_locks" ret
            else do
                ci <- peek ptr
                return $ fromIntegral ci

                
foreign import ccall safe "db_helper.h _dbenv_set_lk_max_locks" _dbenv_set_lk_max_locks
    :: Ptr DbEnv_struct -> CUInt -> IO CInt

dbEnv_set_lk_max_locks :: DbEnv -> Int -> IO ()
dbEnv_set_lk_max_locks dbenv max =
    withForeignPtr dbenv $ \c_dbenv -> do
        ret <- _dbenv_set_lk_max_locks c_dbenv (fromIntegral max)
        if ret /= 0
            then throwDB "dbEnv_set_lk_max_locks" ret
            else return ()

            
foreign import ccall safe "db_helper.h _dbenv_get_lk_max_objects" _dbenv_get_lk_max_objects
    :: Ptr DbEnv_struct -> Ptr CUInt -> IO CInt

dbEnv_get_lk_max_objects :: DbEnv -> IO Int
dbEnv_get_lk_max_objects dbenv =
    withForeignPtr dbenv $ \c_dbenv ->
    alloca $ \ptr -> do
        ret <- _dbenv_get_lk_max_objects c_dbenv ptr
        if ret /= 0
            then throwDB "dbEnv_get_lk_max_objects" ret
            else do
                ci <- peek ptr
                return $ fromIntegral ci

                
foreign import ccall safe "db_helper.h _dbenv_set_lk_max_objects" _dbenv_set_lk_max_objects
    :: Ptr DbEnv_struct -> CUInt -> IO CInt

dbEnv_set_lk_max_objects :: DbEnv -> Int -> IO ()
dbEnv_set_lk_max_objects dbenv max =
    withForeignPtr dbenv $ \c_dbenv -> do
        ret <- _dbenv_set_lk_max_objects c_dbenv (fromIntegral max)
        if ret /= 0
            then throwDB "dbEnv_set_lk_max_objects" ret
            else return ()

        
foreign import ccall safe "db_helper.h _dbenv_get_tx_max" _dbenv_get_tx_max
    :: Ptr DbEnv_struct -> Ptr CUInt -> IO CInt

dbEnv_get_tx_max :: DbEnv -> IO Int
dbEnv_get_tx_max dbenv =
    withForeignPtr dbenv $ \c_dbenv ->
    alloca $ \ptr -> do
        ret <- _dbenv_get_tx_max c_dbenv ptr
        if ret /= 0
            then throwDB "dbEnv_get_tx_max" ret
            else do
                ci <- peek ptr
                return $ fromIntegral ci

                
foreign import ccall safe "db_helper.h _dbenv_set_tx_max" _dbenv_set_tx_max
    :: Ptr DbEnv_struct -> CUInt -> IO CInt

dbEnv_set_tx_max :: DbEnv -> Int -> IO ()
dbEnv_set_tx_max dbenv max =
    withForeignPtr dbenv $ \c_dbenv -> do
        ret <- _dbenv_set_tx_max c_dbenv (fromIntegral max)
        if ret /= 0
            then throwDB "dbEnv_set_tx_max" ret
            else return ()


foreign import ccall safe "db_helper.h _dbenv_get_cachesize" _dbenv_get_cachesize
    :: Ptr DbEnv_struct -> Ptr CUInt -> Ptr CUInt -> Ptr Int -> IO CInt

dbEnv_get_cache_size :: DbEnv -> IO (Int, Int, Int)
dbEnv_get_cache_size dbenv =
    withForeignPtr dbenv $ \c_dbenv ->
    alloca $ \ptr1 -> alloca $ \ptr2 -> alloca $ \ptr3 -> do
        ret <- _dbenv_get_cachesize c_dbenv ptr1 ptr2 ptr3
        if ret /= 0
            then throwDB "dbEnv_get_cache_size" ret
            else do
                c1 <- peek ptr1
                c2 <- peek ptr2
                c3 <- peek ptr3
                return $ (fromIntegral c1, fromIntegral c2, fromIntegral c3)

                
foreign import ccall safe "db_helper.h _dbenv_set_cachesize" _dbenv_set_cachesize
    :: Ptr DbEnv_struct -> CUInt -> CUInt -> CInt -> IO CInt

dbEnv_set_cache_size :: DbEnv -> Int -> Int -> Int -> IO ()
dbEnv_set_cache_size dbenv gbytes bytes ncache =
    withForeignPtr dbenv $ \c_dbenv -> do
        ret <- _dbenv_set_cachesize c_dbenv
                (fromIntegral gbytes) (fromIntegral bytes) (fromIntegral ncache)
        if ret /= 0
            then throwDB "dbEnv_set_cache_size" ret
            else return ()


foreign import ccall safe "db_helper.h _dbenv_get_lg_regionmax" _dbenv_get_lg_regionmax
    :: Ptr DbEnv_struct -> Ptr CUInt -> IO CInt

dbEnv_get_lg_regionmax :: DbEnv -> IO Int
dbEnv_get_lg_regionmax dbenv =
    withForeignPtr dbenv $ \c_dbenv ->
    alloca $ \ptr -> do
        ret <- _dbenv_get_lg_regionmax c_dbenv ptr
        if ret /= 0
            then throwDB "dbEnv_get_lg_regionmax" ret
            else do
                ci <- peek ptr
                return $ fromIntegral ci

                
foreign import ccall safe "db_helper.h _dbenv_set_lg_regionmax" _dbenv_set_lg_regionmax
    :: Ptr DbEnv_struct -> CUInt -> IO CInt

dbEnv_set_lg_regionmax :: DbEnv -> Int -> IO ()
dbEnv_set_lg_regionmax dbenv max =
    withForeignPtr dbenv $ \c_dbenv -> do
        ret <- _dbenv_set_lg_regionmax c_dbenv (fromIntegral max)
        if ret /= 0
            then throwDB "dbEnv_set_lg_regionmax" ret
            else return ()


foreign import ccall safe "db_helper.h _dbenv_open" _dbenv_open
    :: Ptr DbEnv_struct -> CString -> CUInt -> CInt -> IO CInt

data DbFlag =
    DB_CREATE |
    DB_DURABLE_UNKNOWN |
    DB_FORCE |
    DB_MULTIVERSION |
    DB_NOMMAP |
    DB_RDONLY |
    DB_RECOVER |
    DB_THREAD |
    DB_TRUNCATE |
    DB_TXN_NOSYNC |
    DB_TXN_NOWAIT |
    DB_TXN_NOT_DURABLE |
    DB_TXN_WRITE_NOSYNC |
    DB_SPARE_FLAG |
    DB_TXN_SYNC |
    DB_TXN_WAIT |
    DB_IGNORE_LEASE |
    DB_AUTO_COMMIT |
    DB_READ_COMMITTED |
    DB_DEGREE_2 |
    DB_READ_UNCOMMITTED |
    DB_DIRTY_READ |
    DB_TXN_SNAPSHOT |
    DB_CXX_NO_EXCEPTIONS |
    DB_XA_CREATE |
    DB_USE_ENVIRON |
    DB_USE_ENVIRON_ROOT |
    DB_INIT_CDB |
    DB_INIT_LOCK |
    DB_INIT_LOG |
    DB_INIT_MPOOL |
    DB_INIT_REP |
    DB_INIT_TXN |
    DB_LOCKDOWN |
    DB_PRIVATE |
    DB_RECOVER_FATAL |
    DB_REGISTER |
    DB_SYSTEM_MEM |
    DB_EXCL |
    DB_FCNTL_LOCKING |
    DB_NO_AUTO_COMMIT |
    DB_RDWRMASTER |
    DB_WRITEOPEN |
    DB_MULTIPLE |
    DB_MULTIPLE_KEY |
    DB_RMW |
    DB_LOCK_NOWAIT

dbToNum :: DbFlag -> CUInt
dbToNum DB_CREATE = 0x0000001
dbToNum	DB_DURABLE_UNKNOWN = 0x0000002
dbToNum	DB_FORCE = 0x0000004
dbToNum	DB_MULTIVERSION = 0x0000008
dbToNum	DB_NOMMAP = 0x0000010
dbToNum	DB_RDONLY = 0x0000020
dbToNum	DB_RECOVER = 0x0000040
dbToNum	DB_THREAD = 0x0000080
dbToNum	DB_TRUNCATE = 0x0000100
dbToNum	DB_TXN_NOSYNC = 0x0000200
dbToNum	DB_TXN_NOWAIT = 0x0000400
dbToNum	DB_TXN_NOT_DURABLE = 0x0000800
dbToNum	DB_TXN_WRITE_NOSYNC = 0x0001000
dbToNum	DB_SPARE_FLAG = 0x0002000
dbToNum DB_TXN_SYNC = 0x0004000
dbToNum DB_TXN_WAIT = 0x0008000
dbToNum	DB_IGNORE_LEASE = 0x01000000
dbToNum	DB_AUTO_COMMIT = 0x02000000
dbToNum	DB_READ_COMMITTED = 0x04000000
dbToNum	DB_DEGREE_2 = 0x04000000
dbToNum	DB_READ_UNCOMMITTED = 0x08000000
dbToNum	DB_DIRTY_READ = 0x08000000
dbToNum	DB_TXN_SNAPSHOT = 0x10000000
dbToNum	DB_CXX_NO_EXCEPTIONS = 0x0000001	
dbToNum	DB_XA_CREATE = 0x0000002	
dbToNum	DB_USE_ENVIRON = 0x0004000	
dbToNum	DB_USE_ENVIRON_ROOT = 0x0008000	
dbToNum	DB_INIT_CDB = 0x0010000	
dbToNum	DB_INIT_LOCK = 0x0020000	
dbToNum	DB_INIT_LOG = 0x0040000	
dbToNum	DB_INIT_MPOOL = 0x0080000	
dbToNum	DB_INIT_REP = 0x0100000	
dbToNum	DB_INIT_TXN = 0x0200000	
dbToNum	DB_LOCKDOWN = 0x0400000	
dbToNum	DB_PRIVATE = 0x0800000	
dbToNum	DB_RECOVER_FATAL = 0x1000000	
dbToNum	DB_REGISTER = 0x2000000	
dbToNum	DB_SYSTEM_MEM = 0x4000000	
dbToNum	DB_EXCL = 0x0004000	
dbToNum	DB_FCNTL_LOCKING = 0x0008000	
dbToNum	DB_NO_AUTO_COMMIT = 0x0010000	
dbToNum	DB_RDWRMASTER = 0x0020000	
dbToNum	DB_WRITEOPEN = 0x0040000	
dbToNum DB_MULTIPLE = 0x10000000
dbToNum DB_MULTIPLE_KEY = 0x20000000
dbToNum DB_RMW = 0x40000000
dbToNum DB_LOCK_NOWAIT = 0x002

dbOrFlags flags = foldr (.|.) 0 $ map dbToNum flags

dbEnv_open :: [DbFlag]
           -> Int        -- ^ UNIX file creation mode, or 0, meaning "readable and writable by both owner and group"
           -> DbEnv
           -> FilePath   -- ^ Database environment's home directory
           -> IO ()
dbEnv_open flags mode dbenv db_home =
    withForeignPtr dbenv $ \c_dbenv ->
    withCAString db_home $ \c_db_home -> do
        ret <- _dbenv_open c_dbenv c_db_home (dbOrFlags flags) (fromIntegral mode)
        if ret /= 0
            then throwDB "dbEnv_open" ret
            else return ()


------ Db ---------------------------------------------------------------------

data Db_struct
type Db = ForeignPtr Db_struct
foreign import ccall "db_helper.h &_db_delete" _db_delete
    :: FunPtr (Ptr Db_struct -> IO ())

    
foreign import ccall safe "db_helper.h _db_create" _db_create
    ::  Ptr (Ptr Db_struct) -> Ptr DbEnv_struct -> CUInt -> IO CInt

db_create :: [DbFlag] -> DbEnv -> IO Db
db_create flags dbenv =
    withForeignPtr dbenv $ \c_dbenv ->
    alloca $ \ptr -> do
        ret <- _db_create ptr c_dbenv (dbOrFlags flags)
        if ret /= 0
            then throwDB "db_create" ret
            else do
                p <- peek ptr
                newForeignPtr _db_delete p

                
foreign import ccall safe "db_helper.h _db_set_pagesize" _db_set_pagesize
    :: Ptr Db_struct -> CUInt -> IO CInt

db_set_pagesize :: Db -> Int -> IO ()
db_set_pagesize db size =
    withForeignPtr db $ \c_db -> do
        ret <- _db_set_pagesize c_db (fromIntegral size)
        if ret /= 0
            then throwDB "db_set_pagesize" ret
            else return ()

data DbType = DB_BTREE | DB_HASH | DB_RECNO | DB_QUEUE | DB_UNKNOWN

dbTypeToNum DB_BTREE = 1
dbTypeToNum DB_HASH = 2
dbTypeToNum DB_RECNO = 3
dbTypeToNum DB_QUEUE = 4
dbTypeToNum DB_UNKNOWN = 5

data DbTxn_struct
type DbTxn = ForeignPtr DbTxn_struct
foreign import ccall "db_helper.h &_dbtxn_delete" _dbtxn_delete
    :: FunPtr (Ptr DbTxn_struct -> IO ())

    
foreign import ccall "db_helper.h _db_open" _db_open
    :: Ptr Db_struct -> Ptr DbTxn_struct -> CString -> CString -> CInt -> CUInt -> CInt -> IO CInt

db_open :: [DbFlag]
        -> DbType
        -> Int          -- ^ Unix file creation mode, or 0, meaning "readable and writable by both owner and group"
        -> Db
        -> Maybe DbTxn
        -> FilePath     -- ^ Filename
        -> Maybe String -- ^ Optional name of database within the file
        -> IO ()
db_open flags typ mode db mTxn file mDatabase =
    withCAString file$ \c_file ->
    withForeignPtr db $ \c_db -> do
        ret <- case mTxn of
            Just dbtxn ->
                withForeignPtr dbtxn$ \c_dbtxn ->
                case mDatabase of
                    Just database ->
                        withCAString database$ \c_database ->
                        _db_open c_db c_dbtxn c_file c_database
                            (dbTypeToNum typ) (dbOrFlags flags) (fromIntegral mode)
                    Nothing ->
                        _db_open c_db c_dbtxn c_file nullPtr
                            (dbTypeToNum typ) (dbOrFlags flags) (fromIntegral mode)
            Nothing ->
                case mDatabase of
                    Just database ->
                        withCAString database$ \c_database ->
                        _db_open c_db nullPtr c_file c_database
                            (dbTypeToNum typ) (dbOrFlags flags) (fromIntegral mode)
                    Nothing ->
                        _db_open c_db nullPtr c_file nullPtr
                            (dbTypeToNum typ) (dbOrFlags flags) (fromIntegral mode)
        if ret /= 0
            then throwDB ("db_open file="++(show file)++" database="++(show mDatabase)) ret
            else return ()

            
foreign import ccall "db_helper.h _dbenv_txn_begin" _dbenv_txn_begin
    :: Ptr DbEnv_struct -> Ptr DbTxn_struct -> Ptr (Ptr DbTxn_struct) -> CUInt -> IO CInt

dbEnv_txn_begin :: [DbFlag]
                -> DbEnv
                -> Maybe DbTxn -- ^ Optional parent transaction
                -> IO DbTxn
dbEnv_txn_begin flags dbenv mParent =
    withForeignPtr dbenv $ \c_dbenv ->
    alloca $ \ptr -> do
        ret <- case mParent of
            Nothing -> do
                _dbenv_txn_begin c_dbenv nullPtr ptr (dbOrFlags flags)
            Just parent ->
                withForeignPtr parent$ \c_parent -> do
                    _dbenv_txn_begin c_dbenv c_parent ptr (dbOrFlags flags)
        if ret /= 0
            then throwDB "dbEnv_txn_begin" ret
            else do
                p <- peek ptr
                newForeignPtr _dbtxn_delete p

-- | Execute a computation within a transaction.
dbEnv_withTxn :: [DbFlag]         -- ^ dbEnv_txn_begin flags
              -> [DbFlag]         -- ^ dbTxn_commit flags
              -> DbEnv
              -> Maybe DbTxn      -- ^ Optional parent transaction
              -> (DbTxn -> IO ()) -- ^ The computation to run within a transactional context
              -> IO ()
dbEnv_withTxn beginFlags commitFlags dbenv mParent computation = do
    bracketOnError
        (dbEnv_txn_begin beginFlags dbenv mParent)
        dbTxn_abort
        (\txn -> do
            computation txn
            dbTxn_commit commitFlags txn)

foreign import ccall "db_helper.h _dbenv_txn_checkpoint" _dbenv_txn_checkpoint
    :: Ptr DbEnv_struct -> CUInt -> CUInt -> CUInt -> IO CInt

dbEnv_txn_checkpoint :: [DbFlag]
                     -> DbEnv
                     -> CUInt -- ^ kbyte
                     -> CUInt -- ^ min
                     -> IO ()
dbEnv_txn_checkpoint flags dbenv kbyte min =
    withForeignPtr dbenv $ \c_dbenv -> do
        ret <- _dbenv_txn_checkpoint c_dbenv kbyte min (dbOrFlags flags)
        if ret /= 0
            then throwDB "dbEnv_txn_checkpoint" ret
            else return ()

            
foreign import ccall "db_helper.h _dbtxn_abort" _dbtxn_abort
    :: Ptr DbTxn_struct -> IO CInt

dbTxn_abort :: DbTxn -> IO ()
dbTxn_abort dbtxn = do
    withForeignPtr dbtxn $ \c_dbtxn -> do
        ret <- _dbtxn_abort c_dbtxn
        if ret /= 0
            then throwDB "dbTxn_abort" ret
            else return ()

            
foreign import ccall "db_helper.h _dbtxn_commit" _dbtxn_commit
    :: Ptr DbTxn_struct -> CUInt -> IO CInt

dbTxn_commit :: [DbFlag] -> DbTxn -> IO ()
dbTxn_commit flags dbtxn = do
    withForeignPtr dbtxn $ \c_dbtxn -> do
        ret <- _dbtxn_commit c_dbtxn (dbOrFlags flags)
        if ret /= 0
            then throwDB "dbTxn_commit" ret
            else return ()

newtype DbLocker = DbLocker CUInt


foreign import ccall "db_helper.h _dbtxn_id" _dbtxn_id
    :: Ptr DbTxn_struct -> IO CUInt

dbTxn_id :: DbTxn -> DbLocker
dbTxn_id dbtxn =
    unsafePerformIO $
    withForeignPtr dbtxn $ \c_dbtxn ->
        liftM DbLocker$ _dbtxn_id c_dbtxn

data DbLockMode = DB_LOCK_READ | DB_LOCK_WRITE | DB_LOCK_IWRITE | DB_LOCK_IREAD | DB_LOCK_IWR

dbLockModeToNum DB_LOCK_READ = 1
dbLockModeToNum DB_LOCK_WRITE = 2
dbLockModeToNum DB_LOCK_IWRITE = 4
dbLockModeToNum DB_LOCK_IREAD = 5
dbLockModeToNum DB_LOCK_IWR = 6

data DbLock_struct
type DbLock = ForeignPtr DbLock_struct
foreign import ccall "db_helper.h &_dblock_delete" _dblock_delete
    :: FunPtr (Ptr DbLock_struct -> IO ())

    
foreign import ccall "db_helper.h _dbenv_lock_get" _dbenv_lock_get
    :: Ptr DbEnv_struct -> CUInt -> CUInt -> Ptr Word8 -> CUInt -> CUInt -> Ptr (Ptr DbLock_struct) -> IO CInt

-- | Acquire a DbLock. 'dbTxn_id' converts a DbTxn to a DbLocker.
dbEnv_lock_get :: [DbFlag]
               -> DbLockMode
               -> ByteString  -- ^ Object, which is a key that identifies this lock
               -> DbEnv
               -> DbLocker
               -> IO DbLock
dbEnv_lock_get flags lockMode object dbenv (DbLocker locker) =
    withForeignPtr dbenv $ \c_dbenv ->
    alloca $ \ptr ->
    withByteString object$ \c_object object_len -> do
        ret <- _dbenv_lock_get c_dbenv locker (dbOrFlags flags) c_object
                    (fromIntegral object_len) (dbLockModeToNum lockMode) ptr
        if ret /= 0
            then throwDB "dbEnv_lock_get" ret
            else do
                p <- peek ptr
                newForeignPtr _dblock_delete p


foreign import ccall "db_helper.h _dbenv_lock_put" _dbenv_lock_put
    :: Ptr DbLock_struct -> IO CInt

-- | Release a DbLock acquired by dbEnv_lock_get.
dbEnv_lock_put :: DbLock -> IO ()
dbEnv_lock_put dblock =
    withForeignPtr dblock$ \c_dblock -> do
        ret <- _dbenv_lock_put c_dblock
        if ret /= 0
            then throwDB "dbEnv_lock_put" ret
            else return ()


-- | Wrap dbEnv_lock_get / dbEnv_lock_put around the specified computation.
--  'dbTxn_id' converts a DbTxn to a DbLocker.
dbEnv_withLock :: [DbFlag]
               -> DbLockMode
               -> ByteString -- ^ Object, which is an environment-wide key that identifies this lock
               -> DbEnv
               -> DbLocker
               -> IO ()      -- ^ Computation to perform under lock
               -> IO ()
dbEnv_withLock flags lockMode object dbEnv locker computation = do
    bracket
        (dbEnv_lock_get flags lockMode object dbEnv locker)  -- acquire
        dbEnv_lock_put                                       -- release
        (\_ -> computation)


foreign import ccall unsafe "db_helper.h _freeString" _freeString
    :: CString -> IO ()

foreign import ccall unsafe "db_helper.h &_freeString" _freeString_finalizer
    :: FunPtr (Ptr Word8 -> IO ())

foreign import ccall "db_helper.h _db_get" _db_get
    :: Ptr Db_struct -> Ptr DbTxn_struct -> Ptr Word8 -> CUInt -> Ptr (Ptr Word8) -> Ptr CUInt -> CUInt -> IO CInt

db_get :: [DbFlag] -> Db -> Maybe DbTxn -> ByteString -> IO (Maybe ByteString)
db_get flags db mTxn key =
    alloca $ \ptr1 ->
    alloca $ \ptr2 ->
    withByteString key$ \c_key key_len ->
    withForeignPtr db $ \c_db -> do
        ret <- case mTxn of
            Nothing ->
                _db_get c_db nullPtr c_key (fromIntegral key_len) ptr1 ptr2 (dbOrFlags flags)
            Just txn ->
                withForeignPtr txn$ \c_txn ->
                _db_get c_db c_txn   c_key (fromIntegral key_len) ptr1 ptr2 (dbOrFlags flags)
        if ret /= 0
            then
                if (dbErrFromNum$ fromIntegral ret) == DB_NOTFOUND
                    then return Nothing
                    else throwDB "db_get" ret
            else do
                c_value <- peek ptr1
                value_len <- peek ptr2
                str <- newForeignPtr _freeString_finalizer c_value
                return $ Just $ BSI.fromForeignPtr str 0 (fromIntegral value_len)


foreign import ccall "db_helper.h _db_put" _db_put
    :: Ptr Db_struct -> Ptr DbTxn_struct -> Ptr Word8 -> CUInt -> Ptr Word8 -> CUInt -> CUInt -> IO CInt

db_put :: [DbFlag]
       -> Db
       -> Maybe DbTxn
       -> ByteString    -- ^ Key
       -> ByteString    -- ^ Value
       -> IO ()
db_put flags db mTxn key value =
    withByteString key$ \c_key key_len ->
    withByteString value $ \c_value value_len ->
    withForeignPtr db $ \c_db -> do
        ret <- case mTxn of
            Nothing ->
                _db_put c_db nullPtr c_key (fromIntegral key_len)
                    c_value (fromIntegral value_len) (dbOrFlags flags)
            Just txn ->
                withForeignPtr txn$ \c_txn ->
                _db_put c_db c_txn   c_key (fromIntegral key_len)
                    c_value (fromIntegral value_len) (dbOrFlags flags)
        if ret /= 0
            then throwDB "db_put" ret
            else return ()

withByteString :: ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a
withByteString bs code = do
    let (fp, fp_offset, length) = BSI.toForeignPtr bs
    withForeignPtr fp $ \c_fp ->
        code (c_fp `plusPtr` fp_offset) length

        
foreign import ccall "db_helper.h _db_del" _db_del
    :: Ptr Db_struct -> Ptr DbTxn_struct -> Ptr Word8 -> CUInt -> CUInt -> IO CInt

db_del :: [DbFlag] -> Db -> Maybe DbTxn -> ByteString -> IO ()
db_del flags db mTxn key =
    withByteString key$ \c_key key_len ->
    withForeignPtr db $ \c_db -> do
        ret <- case mTxn of
            Nothing ->
                _db_del c_db nullPtr c_key (fromIntegral key_len) (dbOrFlags flags)
            Just txn ->
                withForeignPtr txn$ \c_txn ->
                _db_del c_db c_txn   c_key (fromIntegral key_len) (dbOrFlags flags)
        if ret /= 0
            then throwDB "db_del" ret
            else return ()

            
foreign import ccall "db_helper.h _db_close" _db_close
    :: Ptr Db_struct -> CUInt -> IO CInt
            
db_close :: [DbFlag] -> Db -> IO ()
db_close flags db =
    withForeignPtr db $ \c_db -> do
        ret <- _db_close c_db (dbOrFlags flags)
        if ret /= 0
            then throwDB "db_close" ret
            else return ()

            
foreign import ccall "db_helper.h _dbenv_close" _dbenv_close
    :: Ptr DbEnv_struct -> CUInt -> IO CInt

dbEnv_close :: [DbFlag] -> DbEnv -> IO ()
dbEnv_close flags dbenv =
    withForeignPtr dbenv $ \c_dbenv -> do
        ret <- _dbenv_close c_dbenv (dbOrFlags flags)
        if ret /= 0
            then throwDB "dbEnv_close" ret
            else return ()
        

data DbLockFlag =
    DB_LOCK_NORUN |
    DB_LOCK_DEFAULT |
    DB_LOCK_EXPIRE |
    DB_LOCK_MAXLOCKS |   
    DB_LOCK_MAXWRITE |
    DB_LOCK_MINLOCKS |
    DB_LOCK_MINWRITE |
    DB_LOCK_OLDEST |
    DB_LOCK_RANDOM |
    DB_LOCK_YOUNGEST

dbLockToNum DB_LOCK_NORUN = 0
dbLockToNum DB_LOCK_DEFAULT = 1
dbLockToNum DB_LOCK_EXPIRE = 2
dbLockToNum DB_LOCK_MAXLOCKS = 3
dbLockToNum DB_LOCK_MAXWRITE = 4
dbLockToNum DB_LOCK_MINLOCKS = 5
dbLockToNum DB_LOCK_MINWRITE = 6
dbLockToNum DB_LOCK_OLDEST = 7
dbLockToNum DB_LOCK_RANDOM = 8
dbLockToNum DB_LOCK_YOUNGEST = 9

foreign import ccall "db_helper.h _dbenv_set_lk_detect" _dbenv_set_lk_detect
    :: Ptr DbEnv_struct -> CUInt -> IO CInt

dbEnv_set_lk_detect :: DbEnv -> DbLockFlag -> IO ()
dbEnv_set_lk_detect dbenv flag =
    withForeignPtr dbenv $ \c_dbenv -> do
        ret <- _dbenv_set_lk_detect c_dbenv (dbLockToNum flag)
        if ret /= 0
            then throwDB "dbEnv_set_lk_detect" ret
            else return ()