urbit/pkg/hs/lmdb-static/hsrc_lib/Database/LMDB/Raw.hsc

{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable #-}

-- | This module is a thin wrapper above lmdb.h.
-- 
-- Provisions for performance, convenience, or safety:
--
-- * Errors are shifted to `LMDB_Error` Haskell exceptions
-- * flag fields and enums are represented with Haskell types
-- * MDB_env includes its own write mutex for Haskell's threads
-- * MDB_RESERVE operations use their own functions
-- * Databases types are divided for user-defined comparisons
-- * Boolean-option functions are divided into two functions
-- * MDB_NOTLS is added implicitly, and may not be removed
-- * unix mode is set to 0660 (user+group read-write)
--
-- Some functions come in two forms based on 'safe' vs. 'unsafe'
-- FFI bindings. Unsafe FFI bindings are unsuitable for databases
-- with user-defined comparison operations. (Though, if you plan
-- to load a database with MDB_APPEND or MDB_APPENDDUP, you can
-- use an unsafe dbi for just that portion.)
-- 
-- Despite these provisions, developers must still be cautious:
--
-- * MDB_val objects are invalid outside their transaction. 
-- * Don't use write operations on a read-only transaction.
-- * Use 'bound threads' for write transactions.
--
-- A slightly higher level API is planned, mostly to provide safer
-- and more convenient access compared to raw MDB_val objects. 
--
-- Features not implemented:
--
-- * functions directly using file handles 
-- * user-defined relocation functions 
-- * MDB_MULTIPLE is not currently supported (todo)
-- 
module Database.LMDB.Raw
    ( LMDB_Version(..), lmdb_version, lmdb_dyn_version
    , LMDB_Error(..), MDB_ErrCode(..)

    , MDB_env
    , MDB_dbi, MDB_dbi'
    , MDB_txn, MDB_txnid
    , MDB_cursor, MDB_cursor'

    , MDB_val(..)
    , MDB_stat, ms_psize, ms_depth, ms_branch_pages, ms_leaf_pages, ms_overflow_pages, ms_entries
    , MDB_envinfo, me_mapaddr, me_mapsize, me_last_pgno, me_last_txnid, me_maxreaders, me_numreaders
    , MDB_cmp_func, wrapCmpFn
    , MDB_EnvFlag(..), MDB_DbFlag(..)
    , MDB_cursor_op(..)

    , MDB_WriteFlag(..), MDB_WriteFlags, compileWriteFlags
    --, MDB_cursor_op(..)

    -- * Environment Operations
    , mdb_env_create
    , mdb_env_open
    , mdb_env_copy
    , mdb_env_stat
    , mdb_env_info
    , mdb_env_sync, mdb_env_sync_flush
    , mdb_env_close
    , mdb_env_set_flags, mdb_env_unset_flags
    , mdb_env_get_flags
    , mdb_env_get_path
    , mdb_env_set_mapsize
    , mdb_env_set_maxreaders
    , mdb_env_get_maxreaders
    , mdb_env_set_maxdbs
    , mdb_env_get_maxkeysize

    -- * Transactions
    , mdb_txn_begin
    , mdb_txn_env
    , mdb_txn_commit
    , mdb_txn_abort

    -- * Databases
    , mdb_dbi_open
    , mdb_stat
    , mdb_dbi_flags
    , mdb_dbi_close
    , mdb_drop, mdb_clear
    , mdb_set_compare
    , mdb_set_dupsort

    , mdb_dbi_open'
    , mdb_stat'
    , mdb_dbi_flags'
    , mdb_dbi_close'
    , mdb_drop', mdb_clear'

    -- * Basic Key-Value Access
    , mdb_get, mdb_put, mdb_del, mdb_reserve
    , mdb_get', mdb_put', mdb_del', mdb_reserve'

    -- * Database key and value Comparisons
    , mdb_cmp, mdb_dcmp
    , mdb_cmp', mdb_dcmp'

    -- * Cursors
    , mdb_cursor_open
    , mdb_cursor_get
    , mdb_cursor_put
    , mdb_cursor_del
    , mdb_cursor_close
    , mdb_cursor_txn
    , mdb_cursor_dbi
    , mdb_cursor_count

    , mdb_cursor_open'
    , mdb_cursor_get'
    , mdb_cursor_put'
    , mdb_cursor_del'
    , mdb_cursor_close'
    , mdb_cursor_txn'
    , mdb_cursor_dbi'
    , mdb_cursor_count'

    -- * Misc
    , mdb_reader_list
    , mdb_reader_check

    , mdb_txn_reset
    , mdb_txn_renew

    , withKVPtrs
    , withKVOptPtrs
    ) where

#include <lmdb.h>

import Prelude

import Foreign
import Foreign.C
import Control.Monad
import Control.Exception
import Control.Concurrent
import qualified Data.Array.Unboxed as A
import qualified Data.List as L
import Data.Typeable
--import System.IO (FilePath)
import Data.Function (on)
import Data.Maybe (isNothing)
import Data.IORef

#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)

-- FFI
--  'safe': higher overhead, thread juggling, allows callbacks into Haskell
--  'unsafe': lower overhead, reduced concurrency, no callbacks into Haskell
foreign import ccall unsafe "lmdb.h mdb_version" _mdb_version :: Ptr CInt -> Ptr CInt -> Ptr CInt -> IO CString
foreign import ccall unsafe "lmdb.h mdb_strerror" _mdb_strerror :: CInt -> CString 

foreign import ccall "lmdb.h mdb_env_create" _mdb_env_create :: Ptr (Ptr MDB_env) -> IO CInt
foreign import ccall "lmdb.h mdb_env_open" _mdb_env_open :: Ptr MDB_env -> CString -> CUInt -> MDB_mode_t -> IO CInt
foreign import ccall "lmdb.h mdb_env_copy" _mdb_env_copy :: Ptr MDB_env -> CString -> IO CInt
foreign import ccall "lmdb.h mdb_env_stat" _mdb_env_stat :: Ptr MDB_env -> Ptr MDB_stat -> IO CInt
foreign import ccall "lmdb.h mdb_env_info" _mdb_env_info :: Ptr MDB_env -> Ptr MDB_envinfo -> IO CInt
foreign import ccall "lmdb.h mdb_env_sync" _mdb_env_sync :: Ptr MDB_env -> CInt -> IO CInt
foreign import ccall "lmdb.h mdb_env_close" _mdb_env_close :: Ptr MDB_env -> IO ()
foreign import ccall "lmdb.h mdb_env_set_flags" _mdb_env_set_flags :: Ptr MDB_env -> CUInt -> CInt -> IO CInt
foreign import ccall unsafe "lmdb.h mdb_env_get_flags" _mdb_env_get_flags :: Ptr MDB_env -> Ptr CUInt -> IO CInt
foreign import ccall unsafe "lmdb.h mdb_env_get_path" _mdb_env_get_path :: Ptr MDB_env -> Ptr CString -> IO CInt
foreign import ccall "lmdb.h mdb_env_set_mapsize" _mdb_env_set_mapsize :: Ptr MDB_env -> CSize -> IO CInt
foreign import ccall "lmdb.h mdb_env_set_maxreaders" _mdb_env_set_maxreaders :: Ptr MDB_env -> CUInt -> IO CInt
foreign import ccall unsafe "lmdb.h mdb_env_get_maxreaders" _mdb_env_get_maxreaders :: Ptr MDB_env -> Ptr CUInt -> IO CInt
foreign import ccall "lmdb.h mdb_env_set_maxdbs" _mdb_env_set_maxdbs :: Ptr MDB_env -> MDB_dbi_t -> IO CInt
foreign import ccall unsafe "lmdb.h mdb_env_get_maxkeysize" _mdb_env_get_maxkeysize :: Ptr MDB_env -> IO CInt

foreign import ccall "lmdb.h mdb_txn_begin" _mdb_txn_begin :: Ptr MDB_env -> Ptr MDB_txn -> CUInt -> Ptr (Ptr MDB_txn) -> IO CInt
-- foreign import ccall "lmdb.h mdb_txn_env" _mdb_txn_env :: MDB_txn -> IO (Ptr MDB_env)
foreign import ccall "lmdb.h mdb_txn_commit" _mdb_txn_commit :: Ptr MDB_txn -> IO CInt
foreign import ccall "lmdb.h mdb_txn_abort" _mdb_txn_abort :: Ptr MDB_txn -> IO ()

-- I'm hoping to get a patch adding the following function into LMDB: 
-- foreign import ccall "lmdb.h mdb_txn_id" _mdb_txn_id :: MDB_txn -> IO MDB_txnid_t 

foreign import ccall "lmdb.h mdb_dbi_open" _mdb_dbi_open :: Ptr MDB_txn -> CString -> CUInt -> Ptr MDB_dbi_t -> IO CInt
foreign import ccall "lmdb.h mdb_stat" _mdb_stat :: Ptr MDB_txn -> MDB_dbi_t -> Ptr MDB_stat -> IO CInt
foreign import ccall "lmdb.h mdb_dbi_flags" _mdb_dbi_flags :: Ptr MDB_txn -> MDB_dbi_t -> Ptr CUInt -> IO CInt
foreign import ccall "lmdb.h mdb_dbi_close" _mdb_dbi_close :: Ptr MDB_env -> MDB_dbi_t -> IO ()
foreign import ccall "lmdb.h mdb_drop" _mdb_drop :: Ptr MDB_txn -> MDB_dbi_t -> CInt -> IO CInt

-- comparisons may only be configured for a 'safe' MDB_dbi.
foreign import ccall "lmdb.h mdb_set_compare" _mdb_set_compare :: Ptr MDB_txn -> MDB_dbi -> FunPtr MDB_cmp_func -> IO CInt
foreign import ccall "lmdb.h mdb_set_dupsort" _mdb_set_dupsort :: Ptr MDB_txn -> MDB_dbi -> FunPtr MDB_cmp_func -> IO CInt

foreign import ccall safe "lmdb.h mdb_cmp" _mdb_cmp :: Ptr MDB_txn -> MDB_dbi -> Ptr MDB_val -> Ptr MDB_val -> IO CInt
foreign import ccall safe "lmdb.h mdb_dcmp" _mdb_dcmp :: Ptr MDB_txn -> MDB_dbi -> Ptr MDB_val -> Ptr MDB_val -> IO CInt
foreign import ccall unsafe "lmdb.h mdb_cmp" _mdb_cmp' :: Ptr MDB_txn -> MDB_dbi' -> Ptr MDB_val -> Ptr MDB_val -> IO CInt
foreign import ccall unsafe "lmdb.h mdb_dcmp" _mdb_dcmp' :: Ptr MDB_txn -> MDB_dbi' -> Ptr MDB_val -> Ptr MDB_val -> IO CInt

foreign import ccall safe "lmdb.h mdb_get" _mdb_get :: Ptr MDB_txn -> MDB_dbi -> Ptr MDB_val -> Ptr MDB_val -> IO CInt
foreign import ccall safe "lmdb.h mdb_put" _mdb_put :: Ptr MDB_txn -> MDB_dbi -> Ptr MDB_val -> Ptr MDB_val -> MDB_WriteFlags -> IO CInt
foreign import ccall safe "lmdb.h mdb_del" _mdb_del :: Ptr MDB_txn -> MDB_dbi -> Ptr MDB_val -> Ptr MDB_val -> IO CInt
foreign import ccall unsafe "lmdb.h mdb_get" _mdb_get' :: Ptr MDB_txn -> MDB_dbi' -> Ptr MDB_val -> Ptr MDB_val -> IO CInt
foreign import ccall unsafe "lmdb.h mdb_put" _mdb_put' :: Ptr MDB_txn -> MDB_dbi' -> Ptr MDB_val -> Ptr MDB_val -> MDB_WriteFlags -> IO CInt
foreign import ccall unsafe "lmdb.h mdb_del" _mdb_del' :: Ptr MDB_txn -> MDB_dbi' -> Ptr MDB_val -> Ptr MDB_val -> IO CInt

-- I dislike LMDB's cursor interface: one 'get' function with 18 special cases. 
-- Seems like it should be 18 functions.
foreign import ccall safe "lmdb.h mdb_cursor_open" _mdb_cursor_open :: Ptr MDB_txn -> MDB_dbi -> Ptr (Ptr MDB_cursor) -> IO CInt
foreign import ccall safe "lmdb.h mdb_cursor_close" _mdb_cursor_close :: Ptr MDB_cursor -> IO ()
foreign import ccall safe "lmdb.h mdb_cursor_get" _mdb_cursor_get :: Ptr MDB_cursor -> Ptr MDB_val -> Ptr MDB_val -> (#type MDB_cursor_op) -> IO CInt
foreign import ccall safe "lmdb.h mdb_cursor_put" _mdb_cursor_put :: Ptr MDB_cursor -> Ptr MDB_val -> Ptr MDB_val -> MDB_WriteFlags -> IO CInt
foreign import ccall safe "lmdb.h mdb_cursor_del" _mdb_cursor_del :: Ptr MDB_cursor -> MDB_WriteFlags -> IO CInt
foreign import ccall safe "lmdb.h mdb_cursor_count" _mdb_cursor_count :: Ptr MDB_cursor -> Ptr CSize -> IO CInt
-- foreign import ccall safe "lmdb.h mdb_cursor_txn" _mdb_cursor_txn :: Ptr MDB_cursor -> IO (Ptr MDB_txn)
-- foreign import ccall safe "lmdb.h mdb_cursor_dbi" _mdb_cursor_dbi :: Ptr MDB_cursor -> IO MDB_dbi

foreign import ccall unsafe "lmdb.h mdb_cursor_open" _mdb_cursor_open' :: Ptr MDB_txn -> MDB_dbi' -> Ptr (Ptr MDB_cursor') -> IO CInt
foreign import ccall unsafe "lmdb.h mdb_cursor_close" _mdb_cursor_close' :: Ptr MDB_cursor' -> IO ()
foreign import ccall unsafe "lmdb.h mdb_cursor_get" _mdb_cursor_get' :: Ptr MDB_cursor' -> Ptr MDB_val -> Ptr MDB_val -> (#type MDB_cursor_op) -> IO CInt
foreign import ccall unsafe "lmdb.h mdb_cursor_put" _mdb_cursor_put' :: Ptr MDB_cursor' -> Ptr MDB_val -> Ptr MDB_val -> MDB_WriteFlags -> IO CInt
foreign import ccall unsafe "lmdb.h mdb_cursor_del" _mdb_cursor_del' :: Ptr MDB_cursor' -> MDB_WriteFlags -> IO CInt
foreign import ccall unsafe "lmdb.h mdb_cursor_count" _mdb_cursor_count' :: Ptr MDB_cursor' -> Ptr CSize -> IO CInt
-- foreign import ccall unsafe "lmdb.h mdb_cursor_txn" _mdb_cursor_txn' :: Ptr MDB_cursor -> IO (Ptr MDB_txn)
-- foreign import ccall unsafe "lmdb.h mdb_cursor_dbi" _mdb_cursor_dbi' :: Ptr MDB_cursor -> IO MDB_dbi

foreign import ccall unsafe "lmdb.h mdb_txn_reset" _mdb_txn_reset :: Ptr MDB_txn -> IO ()
foreign import ccall "lmdb.h mdb_txn_renew" _mdb_txn_renew :: Ptr MDB_txn -> IO CInt

foreign import ccall "lmdb.h mdb_reader_list" _mdb_reader_list :: Ptr MDB_env -> FunPtr MDB_msg_func -> Ptr () -> IO CInt
foreign import ccall "lmdb.h mdb_reader_check" _mdb_reader_check :: Ptr MDB_env -> Ptr CInt -> IO CInt

-- | User-defined comparison functions for keys. 
type MDB_cmp_func = Ptr MDB_val -> Ptr MDB_val -> IO CInt
foreign import ccall "wrapper"  wrapCmpFn :: MDB_cmp_func -> IO (FunPtr MDB_cmp_func)

-- callback function for reader list (used internally to this binding)
type MDB_msg_func = CString -> Ptr () -> IO CInt
foreign import ccall "wrapper" wrapMsgFunc :: MDB_msg_func -> IO (FunPtr MDB_msg_func)


-- Haskell seems to have difficulty inferring the `Ptr CInt` from 
-- the _mdb_version call. (This seriously annoys me.)
_peekCInt :: Ptr CInt -> IO CInt
_peekCInt = peek

_peekCUInt :: Ptr CUInt -> IO CUInt
_peekCUInt = peek

-- | Version information for LMDB. Two potentially different versions
-- can be obtained: lmdb_version returns the version at the time of 
-- binding (via C preprocessor macros) and lmdb_dyn_version returns a
-- version for the bound library.
--
-- These bindings to Haskell will refuse to open the database when
-- the dynamic version of LMDB is different in the major or minor 
-- fields.
data LMDB_Version = LMDB_Version
    { v_major :: {-# UNPACK #-} !Int
    , v_minor :: {-# UNPACK #-} !Int
    , v_patch :: {-# UNPACK #-} !Int
    , v_text  :: !String
    } deriving (Eq, Ord, Show)

-- | Version of LMDB when the Haskell-LMDB binding was compiled.
lmdb_version :: LMDB_Version
lmdb_version = LMDB_Version
    { v_major = #const MDB_VERSION_MAJOR
    , v_minor = #const MDB_VERSION_MINOR
    , v_patch = #const MDB_VERSION_PATCH
    , v_text  = #const_str MDB_VERSION_STRING
    }


-- | Version of LMDB linked to the current Haskell process.
lmdb_dyn_version :: IO LMDB_Version
lmdb_dyn_version =
    let szInt = sizeOf (undefined :: CInt) in
    allocaBytes (3 * szInt) $ \ pMajor -> do
        let pMinor = pMajor `plusPtr` szInt
        let pPatch = pMinor `plusPtr` szInt
        cvText <- _mdb_version pMajor pMinor pPatch 
        vMajor <- fromIntegral <$> _peekCInt pMajor
        vMinor <- fromIntegral <$> _peekCInt pMinor
        vPatch <- fromIntegral <$> _peekCInt pPatch
        vText  <- peekCString cvText
        return $! LMDB_Version
            { v_major = vMajor
            , v_minor = vMinor
            , v_patch = vPatch
            , v_text  = vText
            }

-- | LMDB_Error is the exception type thrown in case a function from
-- the LMDB API does not return successfully. Clients should be 
-- prepared to catch exceptions from any LMDB operation.
data LMDB_Error = LMDB_Error 
    { e_context     :: String 
    , e_description :: String 
    , e_code        :: Either Int MDB_ErrCode
    } deriving (Eq, Ord, Show, Typeable)
instance Exception LMDB_Error

-- | Opaque structure for LMDB environment.
--
-- The environment additionally contains an MVar to enforce at most
-- one lightweight Haskell thread is writing at a time. This is 
-- necessary so long as LMDB uses a long-lived mutex for writes, as
-- in v0.9.10.
-- 
data MDB_env = MDB_env
    { _env_ptr   :: {-# UNPACK #-} !(Ptr MDB_env) -- opaque pointer to LMDB object
    , _env_wlock :: {-# UNPACK #-} !(MVar ThreadId) -- write lock
    }

-- | Opaque structure for LMDB transaction.
data MDB_txn = MDB_txn
    { _txn_ptr :: {-# UNPACK #-} !(Ptr MDB_txn)
    , _txn_env :: !MDB_env -- environment that owns this transaction.
    , _txn_rw  :: !Bool -- is this a read-write transaction? (vs read-only)
    , _txn_p   :: !(Maybe MDB_txn) -- parent transaction, if any
    }

-- | Identifier for a transaction.
newtype MDB_txnid = MDB_txnid { _txnid :: MDB_txnid_t } deriving (Ord, Eq, Show)

-- | Handle for a database in the environment.
newtype MDB_dbi = MDB_dbi { _dbi :: MDB_dbi_t } 

-- | Opaque structure for LMDB cursor.
data MDB_cursor = MDB_cursor
    { _crs_ptr :: {-# UNPACK #-} !(Ptr MDB_cursor)
    , _crs_dbi :: {-# UNPACK #-} !MDB_dbi
    , _crs_txn :: !MDB_txn
    }

-- | Handle for a database in the environment.
--
-- This variation is associated with 'unsafe' FFI calls, with reduced
-- overhead but no user-defined comparisons. I expect most code using
-- LMDB could use this variation.
newtype MDB_dbi' = MDB_dbi' { _dbi' :: MDB_dbi_t }

-- | Opaque structure for a cursor on an MDB_dbi' object. Cursors
-- in this case also use the 'unsafe' FFI calls.
data MDB_cursor' = MDB_cursor'
    { _crs_ptr' :: {-# UNPACK #-} !(Ptr MDB_cursor')
    , _crs_dbi' :: {-# UNPACK #-} !MDB_dbi'
    , _crs_txn' :: !MDB_txn
    }

type MDB_mode_t = #type mdb_mode_t
type MDB_dbi_t = #type MDB_dbi
type MDB_txnid_t = CSize -- typedef not currently exposed

-- | A value stored in the database. Be cautious; committing the
-- transaction that obtained a value should also invalidate it;
-- avoid capturing MDB_val in a lazy value. A safe interface
-- similar to STRef could be provided by another module.
data MDB_val = MDB_val
    { mv_size :: {-# UNPACK #-} !CSize
    , mv_data :: {-# UNPACK #-} !(Ptr Word8)
    }

data MDB_stat = MDB_stat
    { ms_psize :: {-# UNPACK #-} !CUInt
    , ms_depth :: {-# UNPACK #-} !CUInt
    , ms_branch_pages :: {-# UNPACK #-} !CSize
    , ms_leaf_pages :: {-# UNPACK #-} !CSize
    , ms_overflow_pages :: {-# UNPACK #-} !CSize
    , ms_entries :: {-# UNPACK #-} !CSize
    } deriving (Eq, Ord, Show)

data MDB_envinfo = MDB_envinfo
    { me_mapaddr :: {-# UNPACK #-} !(Ptr ())
    , me_mapsize :: {-# UNPACK #-} !CSize
    , me_last_pgno :: {-# UNPACK #-} !CSize
    , me_last_txnid :: {-# UNPACK #-} !MDB_txnid
    , me_maxreaders :: {-# UNPACK #-} !CUInt
    , me_numreaders :: {-# UNPACK #-} !CUInt
    } deriving (Eq, Ord, Show)


-- | Environment flags from lmdb.h
--
-- Note: MDB_NOTLS is implicit and enforced for this binding.
data MDB_EnvFlag
    = MDB_FIXEDMAP
    | MDB_NOSUBDIR
    | MDB_NOSYNC
    | MDB_RDONLY
    | MDB_NOMETASYNC
    | MDB_WRITEMAP
    | MDB_MAPASYNC
    --  | MDB_NOTLS
    | MDB_NOLOCK
    | MDB_NORDAHEAD
    | MDB_NOMEMINIT
    deriving (Eq, Ord, Bounded, A.Ix, Show)

envFlags :: [(MDB_EnvFlag, Int)]
envFlags =
    [(MDB_FIXEDMAP, #const MDB_FIXEDMAP)
    ,(MDB_NOSUBDIR, #const MDB_NOSUBDIR)
    ,(MDB_NOSYNC, #const MDB_NOSYNC)
    ,(MDB_RDONLY, #const MDB_RDONLY)
    ,(MDB_NOMETASYNC, #const MDB_NOMETASYNC)
    ,(MDB_WRITEMAP, #const MDB_WRITEMAP)
    ,(MDB_MAPASYNC, #const MDB_MAPASYNC)
    -- ,(MDB_NOTLS, #const MDB_NOTLS)
    ,(MDB_NOLOCK, #const MDB_NOLOCK)
    ,(MDB_NORDAHEAD, #const MDB_NORDAHEAD)
    ,(MDB_NOMEMINIT, #const MDB_NOMEMINIT)
    ]

envFlagsArray :: A.UArray MDB_EnvFlag Int
envFlagsArray = A.accumArray (.|.) 0 (minBound, maxBound) envFlags

compileEnvFlags :: [MDB_EnvFlag] -> CUInt
compileEnvFlags = fromIntegral . L.foldl' (.|.) 0 . fmap ((A.!) envFlagsArray)

decompileBitFlags :: [(a,Int)] -> Int -> [a]
decompileBitFlags optFlags n = fmap fst $ L.filter fullMatch optFlags where
    fullMatch (_,f) = (f == (n .&. f))

decompileEnvFlags :: CUInt -> [MDB_EnvFlag]
decompileEnvFlags = decompileBitFlags envFlags . fromIntegral


data MDB_DbFlag
    = MDB_REVERSEKEY
    | MDB_DUPSORT
    | MDB_INTEGERKEY
    | MDB_DUPFIXED
    | MDB_INTEGERDUP
    | MDB_REVERSEDUP
    | MDB_CREATE
    deriving (Eq, Ord, Bounded, A.Ix, Show)

dbFlags :: [(MDB_DbFlag, Int)]
dbFlags =
    [(MDB_REVERSEKEY, #const MDB_REVERSEKEY)
    ,(MDB_DUPSORT, #const MDB_DUPSORT)
    ,(MDB_INTEGERKEY, #const MDB_INTEGERKEY)
    ,(MDB_DUPFIXED, #const MDB_DUPFIXED)
    ,(MDB_INTEGERDUP, #const MDB_INTEGERDUP)
    ,(MDB_REVERSEDUP, #const MDB_REVERSEDUP)
    ,(MDB_CREATE, #const MDB_CREATE)
    ]

dbFlagsArray :: A.UArray MDB_DbFlag Int
dbFlagsArray = A.accumArray (.|.) 0 (minBound,maxBound) dbFlags

compileDBFlags :: [MDB_DbFlag] -> CUInt
compileDBFlags = fromIntegral . L.foldl' (.|.) 0 . fmap ((A.!) dbFlagsArray)

decompileDBFlags :: CUInt -> [MDB_DbFlag]
decompileDBFlags = decompileBitFlags dbFlags . fromIntegral

data MDB_WriteFlag 
    = MDB_NOOVERWRITE
    | MDB_NODUPDATA
    | MDB_CURRENT  
    --  | MDB_RESERVE  -- (needs dedicated function)
    | MDB_APPEND   
    | MDB_APPENDDUP
    --  | MDB_MULTIPLE -- (needs special handling)
    deriving (Eq, Ord, Bounded, A.Ix, Show)


writeFlags :: [(MDB_WriteFlag, Int)]
writeFlags =
    [(MDB_NOOVERWRITE, #const MDB_NOOVERWRITE)
    ,(MDB_NODUPDATA, #const MDB_NODUPDATA)
    ,(MDB_CURRENT, #const MDB_CURRENT)
    -- ,(MDB_RESERVE, #const MDB_RESERVE)
    ,(MDB_APPEND, #const MDB_APPEND)
    ,(MDB_APPENDDUP, #const MDB_APPENDDUP)
    -- ,(MDB_MULTIPLE, #const MDB_MULTIPLE)
    ]

writeFlagsArray :: A.UArray MDB_WriteFlag Int
writeFlagsArray = A.accumArray (.|.) 0 (minBound,maxBound) writeFlags

-- | compiled write flags, corresponding to a [WriteFlag] list. Used
-- because writes are frequent enough that we want to avoid building
-- from a list on a per-write basis.
newtype MDB_WriteFlags = MDB_WriteFlags CUInt

-- | compile a list of write flags. 
compileWriteFlags :: [MDB_WriteFlag] -> MDB_WriteFlags
compileWriteFlags = MDB_WriteFlags . L.foldl' addWF 0 where
    addWF n wf = n .|. fromIntegral (writeFlagsArray A.! wf)

data MDB_cursor_op
    = MDB_FIRST
    | MDB_FIRST_DUP
    | MDB_GET_BOTH
    | MDB_GET_BOTH_RANGE
    | MDB_GET_CURRENT
    | MDB_GET_MULTIPLE
    | MDB_LAST
    | MDB_LAST_DUP
    | MDB_NEXT
    | MDB_NEXT_DUP
    | MDB_NEXT_MULTIPLE
    | MDB_NEXT_NODUP
    | MDB_PREV
    | MDB_PREV_DUP
    | MDB_PREV_NODUP
    | MDB_SET
    | MDB_SET_KEY
    | MDB_SET_RANGE
    deriving (Eq, Ord, Bounded, A.Ix, Show)

cursorOps :: [(MDB_cursor_op, Int)]
cursorOps =
    [(MDB_FIRST, #const MDB_FIRST)
    ,(MDB_FIRST_DUP, #const MDB_FIRST_DUP)
    ,(MDB_GET_BOTH, #const MDB_GET_BOTH)
    ,(MDB_GET_BOTH_RANGE, #const MDB_GET_BOTH_RANGE)
    ,(MDB_GET_CURRENT, #const MDB_GET_CURRENT)
    ,(MDB_GET_MULTIPLE, #const MDB_GET_MULTIPLE)
    ,(MDB_LAST, #const MDB_LAST)
    ,(MDB_LAST_DUP, #const MDB_LAST_DUP)
    ,(MDB_NEXT, #const MDB_NEXT)
    ,(MDB_NEXT_DUP, #const MDB_NEXT_DUP)
    ,(MDB_NEXT_MULTIPLE, #const MDB_NEXT_MULTIPLE)
    ,(MDB_NEXT_NODUP, #const MDB_NEXT_NODUP)
    ,(MDB_PREV, #const MDB_PREV)
    ,(MDB_PREV_DUP, #const MDB_PREV_DUP)
    ,(MDB_PREV_NODUP, #const MDB_PREV_NODUP)
    ,(MDB_SET, #const MDB_SET)
    ,(MDB_SET_KEY, #const MDB_SET_KEY)
    ,(MDB_SET_RANGE, #const MDB_SET_RANGE)
    ]

cursorOpsArray :: A.UArray MDB_cursor_op Int 
cursorOpsArray = A.accumArray (flip const) minBound (minBound,maxBound) cursorOps

cursorOp :: MDB_cursor_op -> (#type MDB_cursor_op)
cursorOp = fromIntegral . (A.!) cursorOpsArray

-- | Error codes from MDB. Note, however, that this API for MDB will mostly
-- use exceptions for any non-successful return codes. This is mostly included
-- because I feel the binding would be incomplete otherwise.
--
-- (The MDB_SUCCESS return value is excluded.)
data MDB_ErrCode
    = MDB_KEYEXIST
    | MDB_NOTFOUND
    | MDB_PAGE_NOTFOUND
    | MDB_CORRUPTED
    | MDB_PANIC
    | MDB_VERSION_MISMATCH
    | MDB_INVALID
    | MDB_MAP_FULL
    | MDB_DBS_FULL
    | MDB_READERS_FULL
    | MDB_TLS_FULL
    | MDB_TXN_FULL
    | MDB_CURSOR_FULL
    | MDB_PAGE_FULL
    | MDB_MAP_RESIZED
    | MDB_INCOMPATIBLE
    | MDB_BAD_RSLOT
    | MDB_BAD_TXN
    | MDB_BAD_VALSIZE
    deriving (Eq, Ord, Bounded, A.Ix, Show)

errCodes :: [(MDB_ErrCode, Int)]
errCodes =
    [(MDB_KEYEXIST, #const MDB_KEYEXIST)
    ,(MDB_NOTFOUND, #const MDB_NOTFOUND)
    ,(MDB_PAGE_NOTFOUND, #const MDB_PAGE_NOTFOUND)
    ,(MDB_CORRUPTED, #const MDB_CORRUPTED)
    ,(MDB_PANIC, #const MDB_PANIC)
    ,(MDB_VERSION_MISMATCH, #const MDB_VERSION_MISMATCH)
    ,(MDB_INVALID, #const MDB_INVALID)
    ,(MDB_MAP_FULL, #const MDB_MAP_FULL)
    ,(MDB_DBS_FULL, #const MDB_DBS_FULL)
    ,(MDB_READERS_FULL, #const MDB_READERS_FULL)
    ,(MDB_TLS_FULL, #const MDB_TLS_FULL)
    ,(MDB_TXN_FULL, #const MDB_TXN_FULL)
    ,(MDB_CURSOR_FULL, #const MDB_CURSOR_FULL)
    ,(MDB_PAGE_FULL, #const MDB_PAGE_FULL)
    ,(MDB_MAP_RESIZED, #const MDB_MAP_RESIZED)
    ,(MDB_INCOMPATIBLE, #const MDB_INCOMPATIBLE)
    ,(MDB_BAD_RSLOT, #const MDB_BAD_RSLOT)
    ,(MDB_BAD_TXN, #const MDB_BAD_TXN)
    ,(MDB_BAD_VALSIZE, #const MDB_BAD_VALSIZE)
    ]

_numToErrVal :: Int -> Either Int MDB_ErrCode
_numToErrVal code = 
    case L.find ((== code) . snd) errCodes of
        Nothing -> Left code
        Just (ec,_) -> Right ec

_throwLMDBErrNum :: String -> CInt -> IO noReturn
_throwLMDBErrNum context errNum = do
    desc <- peekCString (_mdb_strerror errNum)
    throwIO $! LMDB_Error
        { e_context = context
        , e_description = desc
        , e_code = _numToErrVal (fromIntegral errNum)
        }
{-# NOINLINE _throwLMDBErrNum #-}

-- | Allocate an environment object. This doesn't open the environment.
--
-- After creation, but before opening, please use:
-- 
--   mdb_env_set_mapsize 
--   mdb_env_set_maxreaders
--   mdb_env_set_maxdbs
--
-- Then, just after opening, you should create a transaction to open
-- all the databases (MDB_dbi and MDB_dbi' values) your application 
-- will use. 
--
-- The typical use case would then involve keeping all these open 
-- until your application either shuts down or crashes.
-- 
-- In addition to normal LMDB errors, this operation may throw an
-- MDB_VERSION_MISMATCH if the Haskell LMDB bindings don't match
-- the dynamic version. If this happens, you'll need to rebuild the
-- lmdb Haskell package.
mdb_env_create :: IO MDB_env
mdb_env_create = alloca $ \ ppEnv -> 
    lmdb_validate_version_match >>
    _mdb_env_create ppEnv >>= \ rc ->
    if (0 /= rc) then _throwLMDBErrNum "mdb_env_create" rc else
    MDB_env <$> peek ppEnv <*> newEmptyMVar


lmdb_validate_version_match :: IO ()
lmdb_validate_version_match = 
    let vStat = lmdb_version in
    lmdb_dyn_version >>= \ vDyn ->
    unless (versionMatch vStat vDyn) $
        throwIO $! LMDB_Error
            { e_context = "lmdb_validate_version_match"
            , e_description = "Haskell bindings: " ++ show vStat 
                           ++ "\tDynamic library: " ++ show vDyn
            , e_code = Right MDB_VERSION_MISMATCH
            }

-- this match function is a bit relaxed, e.g. it will accept
-- LMDB 0.9.10 with 0.9.8, so long as the first two numbers
-- match. 
versionMatch :: LMDB_Version -> LMDB_Version -> Bool
versionMatch vA vB = matchMajor && matchMinor where
    matchMajor = ((==) `on` v_major) vA vB
    matchMinor = ((==) `on` v_minor) vA vB

-- | open or build a database in the filesystem. The named directory
-- must already exist and be writeable. Before opening, be sure to
-- at least apply `mdb_env_set_mapsize`.
--
-- After opening the environment, you should open the databases:
--
--    Create the environment.
--    Open a transaction.
--    Open all DBI handles the app will need.
--    Commit the transaction.
--    Use those DBI handles in subsequent transactions
-- 
mdb_env_open :: MDB_env -> FilePath -> [MDB_EnvFlag] -> IO ()
mdb_env_open env fp flags = 
    let iFlags = (#const MDB_NOTLS) .|. (compileEnvFlags flags) in
    let unix_mode = (6 * 64 + 6 * 8) in -- mode 0660, read-write for user+group
    withCString fp $ \ cfp ->
        _mdb_env_open (_env_ptr env) cfp iFlags unix_mode >>= \ rc ->
        unless (0 == rc) $
            _throwLMDBErrNum "mdb_env_open" rc

-- | Copy the environment to an empty (but existing) directory.
-- 
-- Note: the LMDB copy operation temporarily grabs the writer mutex.
-- Unfortunately, this greatly complicates the binding to Haskell.
-- This interface, mdb_env_copy, conservatively blocks all writers
-- in the same process for the entire duration of copy. 
--
-- Recommendation: Don't use this function in the same process with
-- writers. Consider use of the `mdb_copy` command line utility if
-- you need hot copies.
--
mdb_env_copy :: MDB_env -> FilePath -> IO ()
mdb_env_copy env fp = 
    runInBoundThread $ 
    bracket_ (_lockEnv env) (_unlockEnv env) $
    withCString fp $ \ cfp ->
        _mdb_env_copy (_env_ptr env) cfp >>= \ rc ->
        unless (0 == rc) (_throwLMDBErrNum "mdb_env_copy" rc)


-- | obtain statistics for environment
mdb_env_stat :: MDB_env -> IO MDB_stat
mdb_env_stat env =
    alloca $ \ pStats ->
        _mdb_env_stat (_env_ptr env) pStats >>= \ rc ->
        if (0 == rc) then peek pStats else
        _throwLMDBErrNum "mdb_env_stat" rc

-- | obtain ad-hoc information about the environment.
mdb_env_info :: MDB_env -> IO MDB_envinfo
mdb_env_info env =
    alloca $ \ pInfo ->
        _mdb_env_info (_env_ptr env) pInfo >>= \ rc ->
        if (0 == rc) then peek pInfo else
        _throwLMDBErrNum "mdb_env_info" rc

-- | Initiate synchronization of environment with disk. However, if
-- the MDB_NOSYNC or MDB_MAPASYNC flags are active, this won't wait
-- for the operation to finish. Cf. mdb_env_sync_flush.
mdb_env_sync :: MDB_env -> IO ()
mdb_env_sync env =
    _mdb_env_sync (_env_ptr env) 0 >>= \ rc ->
    unless (0 == rc) (_throwLMDBErrNum "mdb_env_sync" rc)

-- | Force buffered writes to disk before returning.
mdb_env_sync_flush :: MDB_env -> IO ()
mdb_env_sync_flush env = 
    _mdb_env_sync (_env_ptr env) 1 >>= \ rc ->
    unless (0 == rc) (_throwLMDBErrNum "mdb_env_sync_flush" rc)

-- | Close the environment. The MDB_env object should not be used by
-- any operations during or after closing.
mdb_env_close :: MDB_env -> IO ()
mdb_env_close env = _lockEnv env >> _mdb_env_close (_env_ptr env) 

-- | Set flags for the environment.
mdb_env_set_flags :: MDB_env -> [MDB_EnvFlag] -> IO ()
mdb_env_set_flags env flags = 
    _mdb_env_set_flags (_env_ptr env) (compileEnvFlags flags) 1 >>= \ rc ->
    unless (0 == rc) $ _throwLMDBErrNum "mdb_env_set_flags" rc

-- | Unset flags for the environment.
mdb_env_unset_flags :: MDB_env -> [MDB_EnvFlag] -> IO ()
mdb_env_unset_flags env flags = 
    _mdb_env_set_flags (_env_ptr env) (compileEnvFlags flags) 0 >>= \ rc ->
    unless (0 == rc) $ _throwLMDBErrNum "mdb_env_unset_flags" rc

-- | View the current set of flags for the environment.
mdb_env_get_flags :: MDB_env -> IO [MDB_EnvFlag]
mdb_env_get_flags env = decompileEnvFlags <$> _mdb_env_get_flags_u env

_mdb_env_get_flags_u :: MDB_env -> IO CUInt
_mdb_env_get_flags_u env = alloca $ \ pFlags ->
    _mdb_env_get_flags (_env_ptr env) pFlags >>= \ rc ->
    if (0 == rc) then peek pFlags else
    _throwLMDBErrNum "mdb_env_get_flags" rc

-- | Obtain filesystem path for this environment.
mdb_env_get_path :: MDB_env -> IO FilePath
mdb_env_get_path env = alloca $ \ pPathStr ->
    _mdb_env_get_path (_env_ptr env) pPathStr >>= \ rc ->
    if (0 == rc) then peekCString =<< peek pPathStr else 
    _throwLMDBErrNum "mdb_env_get_path" rc

-- | Set the memory map size, in bytes, for this environment. This 
-- determines the maximum size for the environment and databases, 
-- but typically only a small fraction of the database is in memory
-- at any given moment. 
--
-- It is not a problem to set this to a very large number, hundreds
-- of gigabytes or even terabytes, assuming a sufficiently large 
-- address space. It should be set to a multiple of page size.
--
-- The default map size is 1MB, intentionally set low to force 
-- developers to select something larger.
mdb_env_set_mapsize :: MDB_env -> Int -> IO ()
mdb_env_set_mapsize env nBytes = 
    _mdb_env_set_mapsize (_env_ptr env) (fromIntegral nBytes) >>= \ rc ->
    unless (0 == rc) (_throwLMDBErrNum "mdb_env_set_mapsize" rc)

-- | Set the maximum number of concurrent readers.
mdb_env_set_maxreaders :: MDB_env -> Int -> IO ()
mdb_env_set_maxreaders env nReaders =
    _mdb_env_set_maxreaders (_env_ptr env) (fromIntegral nReaders) >>= \ rc ->
    unless (0 == rc) (_throwLMDBErrNum "mdb_env_set_maxreaders" rc)

-- | Get the maximum number of concurrent readers.
mdb_env_get_maxreaders :: MDB_env -> IO Int
mdb_env_get_maxreaders env = alloca $ \ pCount ->
    _mdb_env_get_maxreaders (_env_ptr env) pCount >>= \ rc ->
    if (0 == rc) then fromIntegral <$> _peekCUInt pCount else
    _throwLMDBErrNum "mdb_env_get_maxreaders" rc

-- | Set the maximum number of named databases. LMDB is designed to
-- support a small handful of databases. 
mdb_env_set_maxdbs :: MDB_env -> Int -> IO ()
mdb_env_set_maxdbs env nDBs = 
    _mdb_env_set_maxdbs (_env_ptr env) (fromIntegral nDBs) >>= \ rc ->
    unless (0 == rc) (_throwLMDBErrNum "mdb_env_set_maxdbs" rc)

-- | Key sizes in LMDB are determined by a compile-time constant,
-- defaulting to 511 bytes. This function returns the maximum.
mdb_env_get_maxkeysize :: MDB_env -> IO Int
mdb_env_get_maxkeysize env = fromIntegral <$> _mdb_env_get_maxkeysize (_env_ptr env)

-- | Check for stale readers, and return number of stale readers cleared.
mdb_reader_check :: MDB_env -> IO Int
mdb_reader_check env = 
    alloca $ \ pCount ->
    _mdb_reader_check (_env_ptr env) pCount >>= \ rc ->
    if (0 == rc) then fromIntegral <$> _peekCInt pCount else
    _throwLMDBErrNum "mdb_reader_check" rc 

-- | Dump entries from reader lock table (for human consumption)
mdb_reader_list :: MDB_env -> IO String
mdb_reader_list env =
    newIORef [] >>= \ rf ->
    let onMsg cs _ = 
            peekCString cs >>= \ msg ->
            modifyIORef rf (msg:) >>
            return 0
    in
    withMsgFunc onMsg $ \ pMsgFunc ->
    _mdb_reader_list (_env_ptr env) pMsgFunc nullPtr >>= \ rc ->
    let toMsg = L.foldl (flip (++)) [] in
    if (0 == rc) then toMsg <$> readIORef rf else
    _throwLMDBErrNum "mdb_reader_list" rc

withMsgFunc :: MDB_msg_func -> (FunPtr MDB_msg_func -> IO a) -> IO a
withMsgFunc f = bracket (wrapMsgFunc f) freeHaskellFunPtr

-- | Begin a new transaction, possibly read-only, with a possible parent.
--
--     mdb_txn_begin env parent bReadOnly
--
-- NOTE: Unless your MDB_env was created with MDB_NOLOCK, it is necessary
-- that read-write transactions be created and completed in one Haskell 
-- 'bound' thread, e.g. via forkOS or runInBoundThread. The bound threads
-- are necessary because LMDB uses OS-level mutexes which track the thread
-- ID of their owning thread.
--
-- This LMDB adapter includes its own MVar mutex to prevent more than one
-- Haskell-level thread from trying to write at the same time.
--
-- The hierarchical transactions are useful for read-write transactions.
-- They allow trying something out then aborting if it doesn't work. But
-- only one child should be active at a time, all in the same OS thread.
--
mdb_txn_begin :: MDB_env -> Maybe MDB_txn -> Bool -> IO MDB_txn
mdb_txn_begin env parent bReadOnly = mask_ $ 
    let bWriteTxn = not bReadOnly in
    let bLockForWrite = bWriteTxn && isNothing parent in

    -- allow only one toplevel write operation at a time.
    when bLockForWrite (_lockEnv env) >>
    let pEnv = _env_ptr env in
    let pParent = maybe nullPtr _txn_ptr parent in
    let iFlags = if bReadOnly then (#const MDB_RDONLY) else 0 in
    let onFailure rc =
            when bLockForWrite (_unlockEnv env) >>
            _throwLMDBErrNum "mdb_txn_begin" rc
    in
    alloca $ \ ppChildTxn ->
        _mdb_txn_begin pEnv pParent iFlags ppChildTxn >>= \ rc ->
        if (0 /= rc) then onFailure rc else
        peek ppChildTxn >>= \ pChildTxn ->
        return $! MDB_txn { _txn_ptr = pChildTxn
                          , _txn_env = env
                          , _txn_rw = bWriteTxn
                          , _txn_p = parent
                          }

-- Haskell-level writer lock for the environment. 
--
-- This is necessary because otherwise multiple Haskell threads on
-- the same OS thread can acquire the same lock (in windows) or 
-- deadlock (in posix systems). LMDB doesn't really support M:N
-- writer threads.
-- 
-- Note: this will also enforce that the caller is operating in a
-- bound thread. So we can only _lockEnv from a bound thread, and
-- we can only _unlockEnv from the same thread.
_lockEnv, _unlockEnv :: MDB_env -> IO ()
_lockErr, _unlockErr :: LMDB_Error
_lockErr = LMDB_Error
    { e_context = "locking LMDB for write in Haskell layer"
    , e_description = "must lock from a 'bound' thread!"
    , e_code = Right MDB_PANIC
    }
_unlockErr = LMDB_Error
    { e_context = "unlock Haskell layer LMDB after write"
    , e_description = "calling thread does not own the lock!"
    , e_code = Right MDB_PANIC
    }

_lockEnv env = do
    safeThread <- isCurrentThreadBound <||> isUnlockedEnv
    unless safeThread (throwIO _lockErr)
    tid <- myThreadId
    putMVar (_env_wlock env) tid
  where
    isUnlockedEnv = hasFlag (#const MDB_NOLOCK) <$> _mdb_env_get_flags_u env
    hasFlag f fs = (f == (f .&. fs))
    getA <||> getB = getA >>= \ a -> if a then return True else getB

_unlockEnv env = 
    myThreadId >>= \ self ->
    let m = (_env_wlock env) in
    mask_ $
        takeMVar m >>= \ owner ->
        unless (self == owner) $
            putMVar m owner >> -- oops!
            throwIO _unlockErr

-- compute whether this transaction should hold the write lock. 
-- If it does, unlock it. Otherwise, return. 
_unlockTxn :: MDB_txn -> IO ()
_unlockTxn txn =
    let bHasLock = _txn_rw txn && isNothing (_txn_p txn) in
    when bHasLock (_unlockEnv (_txn_env txn))

-- | Access environment for a transaction.
mdb_txn_env :: MDB_txn -> MDB_env
mdb_txn_env = _txn_env

-- | Commit a transaction. Don't use the transaction after this.
mdb_txn_commit :: MDB_txn -> IO ()
mdb_txn_commit txn = mask_ $
    _mdb_txn_commit (_txn_ptr txn) >>= \ rc ->
    _unlockTxn txn >>
    unless (0 == rc) (_throwLMDBErrNum "mdb_txn_commit" rc)

-- | Abort a transaction. Don't use the transaction after this.
mdb_txn_abort :: MDB_txn -> IO ()
mdb_txn_abort txn = mask_ $ 
    _mdb_txn_abort (_txn_ptr txn) >> 
    _unlockTxn txn

-- | Abort a read-only transaction, but don't destroy it. 
-- Keep it available for mdb_txn_renew.
mdb_txn_reset :: MDB_txn -> IO ()
mdb_txn_reset txn = _mdb_txn_reset (_txn_ptr txn) 

-- | Renew a read-only transaction that was previously _reset.
mdb_txn_renew :: MDB_txn -> IO ()
mdb_txn_renew txn =
    _mdb_txn_renew (_txn_ptr txn) >>= \ rc ->
    unless (0 == rc) (_throwLMDBErrNum "mdb_txn_renew" rc)


{-

-- I'm hoping to get a patch adding the following function into the main LMDB: 
-- foreign import ccall "lmdb.h mdb_txn_id" _mdb_txn_id :: MDB_txn -> IO MDB_txnid_t 

-}

-- | Open a database that supports user-defined comparisons, but
-- has slightly more FFI overhead for reads and writes.
--
-- LMDB supports a small set of named databases, plus one 'main'
-- database using the null argument for the database name.
mdb_dbi_open :: MDB_txn -> Maybe String -> [MDB_DbFlag] -> IO MDB_dbi
mdb_dbi_open txn dbName flags = MDB_dbi <$> mdb_dbi_open_t txn dbName flags

-- | database statistics
mdb_stat :: MDB_txn -> MDB_dbi -> IO MDB_stat
mdb_stat txn = mdb_stat_t txn . _dbi

-- | review flags from database
mdb_dbi_flags :: MDB_txn -> MDB_dbi -> IO [MDB_DbFlag]
mdb_dbi_flags txn = mdb_dbi_flags_t txn . _dbi

-- | close the database handle.
--
-- Note: the normal use-case for LMDB is to open all the database
-- handles up front, then hold onto them until the application is
-- closed or crashed. In that case, you don't need to bother with
-- closing database handles.
mdb_dbi_close :: MDB_env -> MDB_dbi -> IO ()
mdb_dbi_close env = mdb_dbi_close_t env . _dbi

-- | remove the database and close the handle; don't use MDB_dbi
-- after this
mdb_drop :: MDB_txn -> MDB_dbi -> IO ()
mdb_drop txn = mdb_drop_t txn . _dbi

-- | clear contents of database, reset to empty
mdb_clear :: MDB_txn -> MDB_dbi -> IO ()
mdb_clear txn = mdb_clear_t txn . _dbi

mdb_dbi_open' :: MDB_txn -> Maybe String -> [MDB_DbFlag] -> IO MDB_dbi'
mdb_dbi_open' txn dbName flags = MDB_dbi' <$> mdb_dbi_open_t txn dbName flags

mdb_stat' :: MDB_txn -> MDB_dbi' -> IO MDB_stat
mdb_stat' txn = mdb_stat_t txn . _dbi'

mdb_dbi_flags' :: MDB_txn -> MDB_dbi' -> IO [MDB_DbFlag]
mdb_dbi_flags' txn = mdb_dbi_flags_t txn . _dbi'

mdb_dbi_close' :: MDB_env -> MDB_dbi' -> IO ()
mdb_dbi_close' txn = mdb_dbi_close_t txn . _dbi'

mdb_drop' :: MDB_txn -> MDB_dbi' -> IO ()
mdb_drop' txn = mdb_drop_t txn . _dbi'

mdb_clear' :: MDB_txn -> MDB_dbi' -> IO ()
mdb_clear' txn = mdb_clear_t txn . _dbi'

-- | use a nullable CString
withCStringMaybe :: Maybe String -> (CString -> IO a) -> IO a
withCStringMaybe Nothing f = f nullPtr
withCStringMaybe (Just s) f = withCString s f

mdb_dbi_open_t :: MDB_txn -> Maybe String -> [MDB_DbFlag] -> IO MDB_dbi_t
mdb_dbi_open_t txn dbName flags = -- use string name
    let cdbFlags = compileDBFlags flags in
    alloca $ \ pDBI ->
    withCStringMaybe dbName $ \ cdbName ->
    _mdb_dbi_open (_txn_ptr txn) cdbName cdbFlags pDBI >>= \ rc ->
    if (0 == rc) then peek pDBI else
    _throwLMDBErrNum "mdb_dbi_open" rc

mdb_stat_t :: MDB_txn -> MDB_dbi_t -> IO MDB_stat
mdb_stat_t txn dbi = 
    alloca $ \ pStat ->
    _mdb_stat (_txn_ptr txn) dbi pStat >>= \ rc ->
    if (0 == rc) then peek pStat else
    _throwLMDBErrNum "mdb_stat" rc

mdb_dbi_flags_t :: MDB_txn -> MDB_dbi_t -> IO [MDB_DbFlag] 
mdb_dbi_flags_t txn dbi =
    alloca $ \ pFlags ->
    _mdb_dbi_flags (_txn_ptr txn) dbi pFlags >>= \ rc ->
    if (0 == rc) then decompileDBFlags <$> peek pFlags else
    _throwLMDBErrNum "mdb_dbi_flags" rc

mdb_dbi_close_t :: MDB_env -> MDB_dbi_t -> IO ()
mdb_dbi_close_t env dbi = _mdb_dbi_close (_env_ptr env) dbi

mdb_drop_t :: MDB_txn -> MDB_dbi_t -> IO ()
mdb_drop_t txn dbi = 
    _mdb_drop (_txn_ptr txn) dbi 1 >>= \ rc ->
    unless (0 == rc) (_throwLMDBErrNum "mdb_drop" rc)

mdb_clear_t :: MDB_txn -> MDB_dbi_t -> IO ()
mdb_clear_t txn dbi =
    _mdb_drop (_txn_ptr txn) dbi 0 >>= \ rc ->
    unless (0 == rc) (_throwLMDBErrNum "mdb_clear" rc)

-- | Set a user-defined key comparison function for a database.
mdb_set_compare :: MDB_txn -> MDB_dbi -> FunPtr MDB_cmp_func -> IO ()
mdb_set_compare txn dbi fcmp =
    _mdb_set_compare (_txn_ptr txn) dbi fcmp >>= \ rc ->
    unless (0 == rc) (_throwLMDBErrNum "mdb_set_compare" rc)

-- | Set a user-defined data comparison operator for MDB_DUPSORT databases.
mdb_set_dupsort :: MDB_txn -> MDB_dbi -> FunPtr MDB_cmp_func -> IO ()
mdb_set_dupsort txn dbi fcmp =
    _mdb_set_dupsort (_txn_ptr txn) dbi fcmp >>= \ rc ->
    unless (0 == rc) (_throwLMDBErrNum "mdb_set_dupsort" rc)

-- zero datum
zed :: MDB_val
zed = MDB_val 0 nullPtr

-- | Access a value by key. Returns Nothing if the key is not found.
mdb_get :: MDB_txn -> MDB_dbi -> MDB_val -> IO (Maybe MDB_val)
mdb_get txn dbi key =
    withKVPtrs key zed $ \ pKey pVal ->
    _mdb_get (_txn_ptr txn) dbi pKey pVal >>= \ rc ->
    r_get rc pVal
{-# INLINE mdb_get #-}

r_get :: CInt -> Ptr MDB_val -> IO (Maybe MDB_val)
r_get rc pVal =
    if (0 == rc) then Just <$> peek pVal else
    if ((#const MDB_NOTFOUND) == rc) then return Nothing else
    _throwLMDBErrNum "mdb_get" rc
{-# INLINE r_get #-}

-- | utility function: prepare pointers suitable for mdb_cursor_get.
withKVPtrs :: MDB_val -> MDB_val -> (Ptr MDB_val -> Ptr MDB_val -> IO a) -> IO a
withKVPtrs k v fn =
    allocaBytes (2 * sizeOf k) $ \ pK ->
    let pV = pK `plusPtr` sizeOf k in
    do poke pK k
       poke pV v
       fn pK pV
{-# INLINE withKVPtrs #-}

-- | variation on withKVPtrs with nullable value.
withKVOptPtrs :: MDB_val -> Maybe MDB_val -> (Ptr MDB_val -> Ptr MDB_val -> IO a) -> IO a
withKVOptPtrs k (Just v) fn = withKVPtrs k v fn
withKVOptPtrs k Nothing fn = alloca $ \ pK -> poke pK k >> fn pK nullPtr


-- | Add a (key,value) pair to the database.
--
-- Returns False on MDB_KEYEXIST, and True on MDB_SUCCESS. Any other
-- return value from LMDB results in an exception. The MDB_KEYEXIST
-- result can be returned only if certain write flags are enabled.
mdb_put :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> MDB_val -> MDB_val -> IO Bool
mdb_put wf txn dbi key val =
    withKVPtrs key val $ \ pKey pVal ->
    _mdb_put (_txn_ptr txn) dbi pKey pVal wf >>= \ rc ->
    r_put rc
{-# INLINE mdb_put #-}

r_put :: CInt -> IO Bool
r_put rc =
    if (0 == rc) then return True else
    if ((#const MDB_KEYEXIST) == rc) then return False else
    _throwLMDBErrNum "mdb_put" rc
{-# INLINE r_put #-}

-- | Allocate space for data under a given key. This space must be
-- filled before the write transaction commits. The idea here is to
-- avoid an extra allocation.
--
--     mdb_reserve flags txn dbi key byteCount
--
-- Note: not safe to use with MDB_DUPSORT.
-- Note: MDB_KEYEXIST will result in an exception here.
mdb_reserve :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> MDB_val -> Int -> IO MDB_val
mdb_reserve wf txn dbi key szBytes =
    withKVPtrs key (reserveData szBytes) $ \ pKey pVal ->
    _mdb_put (_txn_ptr txn) dbi pKey pVal (wfReserve wf) >>= \ rc ->
    if (0 == rc) then peek pVal else
    _throwLMDBErrNum "mdb_reserve" rc
{-# INLINE mdb_reserve #-}

wfReserve :: MDB_WriteFlags -> MDB_WriteFlags
wfReserve (MDB_WriteFlags wf) = MDB_WriteFlags ((#const MDB_RESERVE) .|. wf)

reserveData :: Int -> MDB_val
reserveData szBytes = MDB_val (fromIntegral szBytes) nullPtr

-- | Delete a given key, or a specific (key,value) pair in case of
-- MDB_DUPSORT. This function will return False on a MDB_NOTFOUND
-- result, and True on MDB_SUCCESS.
--
-- Note: Ideally, LMDB would match the value even without MDB_DUPSORT.
-- But it doesn't. Under the hood, the data is replaced by a null ptr
-- if MDB_DUPSORT is not enabled (v0.9.10).
mdb_del :: MDB_txn -> MDB_dbi -> MDB_val -> Maybe MDB_val -> IO Bool
mdb_del txn dbi key mbVal =
    withKVOptPtrs key mbVal $ \ pKey pVal ->
    _mdb_del (_txn_ptr txn) dbi pKey pVal >>= \ rc ->
    r_del rc
{-# INLINE mdb_del #-}

r_del :: CInt -> IO Bool
r_del rc =
    if (0 == rc) then return True else
    if ((#const MDB_NOTFOUND) == rc) then return False else
    _throwLMDBErrNum "mdb_del" rc
{-# INLINE r_del #-}

mdb_get' :: MDB_txn -> MDB_dbi' -> MDB_val -> IO (Maybe MDB_val)
mdb_get' txn dbi key =
    withKVPtrs key zed $ \ pKey pVal ->
    _mdb_get' (_txn_ptr txn) dbi pKey pVal >>= \ rc ->
    r_get rc pVal
{-# INLINE mdb_get' #-}

mdb_put' :: MDB_WriteFlags -> MDB_txn -> MDB_dbi' -> MDB_val -> MDB_val -> IO Bool
mdb_put' wf txn dbi key val =
    withKVPtrs key val $ \ pKey pVal ->
    _mdb_put' (_txn_ptr txn) dbi pKey pVal wf >>= \ rc ->
    r_put rc
{-# INLINE mdb_put' #-}

mdb_reserve' :: MDB_WriteFlags -> MDB_txn -> MDB_dbi' -> MDB_val -> Int -> IO MDB_val
mdb_reserve' wf txn dbi key szBytes =
    withKVPtrs key (reserveData szBytes) $ \ pKey pVal ->
    _mdb_put' (_txn_ptr txn) dbi pKey pVal (wfReserve wf) >>= \ rc ->
    if (0 == rc) then peek pVal else
    _throwLMDBErrNum "mdb_reserve" rc
{-# INLINE mdb_reserve' #-}

mdb_del' :: MDB_txn -> MDB_dbi' -> MDB_val -> Maybe MDB_val -> IO Bool
mdb_del' txn dbi key mbVal =
    withKVOptPtrs key mbVal $ \ pKey pVal ->
    _mdb_del' (_txn_ptr txn) dbi pKey pVal >>= \rc ->
    r_del rc
{-# INLINE mdb_del' #-}

-- | compare two values as keys in a database
mdb_cmp :: MDB_txn -> MDB_dbi -> MDB_val -> MDB_val -> IO Ordering
mdb_cmp txn dbi a b =
    withKVPtrs a b $ \ pA pB ->
    _mdb_cmp (_txn_ptr txn) dbi pA pB >>= \ rc ->
    return (compare rc 0)
{-# INLINE mdb_cmp #-}

-- | compare two values as data in an MDB_DUPSORT database
mdb_dcmp :: MDB_txn -> MDB_dbi -> MDB_val -> MDB_val -> IO Ordering
mdb_dcmp txn dbi a b =
    withKVPtrs a b $ \ pA pB ->
    _mdb_dcmp (_txn_ptr txn) dbi pA pB >>= \ rc ->
    return (compare rc 0)
{-# INLINE mdb_dcmp #-}

mdb_cmp' :: MDB_txn -> MDB_dbi' -> MDB_val -> MDB_val -> IO Ordering
mdb_cmp' txn dbi a b =
    withKVPtrs a b $ \ pA pB ->
    _mdb_cmp' (_txn_ptr txn) dbi pA pB >>= \ rc ->
    return (compare rc 0)
{-# INLINE mdb_cmp' #-}

mdb_dcmp' :: MDB_txn -> MDB_dbi' -> MDB_val -> MDB_val -> IO Ordering
mdb_dcmp' txn dbi a b =
    withKVPtrs a b $ \ pA pB ->
    _mdb_dcmp' (_txn_ptr txn) dbi pA pB >>= \ rc ->
    return (compare rc 0)
{-# INLINE mdb_dcmp' #-}

-- | open a cursor for the database.
mdb_cursor_open :: MDB_txn -> MDB_dbi -> IO MDB_cursor
mdb_cursor_open txn dbi =
    alloca $ \ ppCursor ->
    _mdb_cursor_open (_txn_ptr txn) dbi ppCursor >>= \ rc ->
    if (0 /= rc) then _throwLMDBErrNum "mdb_cursor_open" rc else
    peek ppCursor >>= \ pCursor ->
    return $! MDB_cursor
        { _crs_ptr = pCursor
        , _crs_dbi = dbi
        , _crs_txn = txn
        }

mdb_cursor_open' :: MDB_txn -> MDB_dbi' -> IO MDB_cursor'
mdb_cursor_open' txn dbi = 
    alloca $ \ ppCursor ->
    _mdb_cursor_open' (_txn_ptr txn) dbi ppCursor >>= \ rc ->
    if (0 /= rc) then _throwLMDBErrNum "mdb_cursor_open" rc else
    peek ppCursor >>= \ pCursor ->
    return $! MDB_cursor'
        { _crs_ptr' = pCursor
        , _crs_dbi' = dbi
        , _crs_txn' = txn
        }

-- | Low-level mdb_cursor_get operation, with direct control of how
-- pointers to values are allocated, whether an argument is a nullPtr,
-- and so on.
--
-- In this case, False is returned for MDB_NOTFOUND (in which case the
-- cursor should not be moved), and True is returned for MDB_SUCCESS.
-- Any other return value from LMDB will result in an exception.
-- 
-- Depending on the MDB_cursor_op, additional values may be returned
-- via the pointers. At the moment
mdb_cursor_get :: MDB_cursor_op -> MDB_cursor -> Ptr MDB_val -> Ptr MDB_val -> IO Bool
mdb_cursor_get op crs pKey pData = _mdb_cursor_get (_crs_ptr crs) pKey pData (cursorOp op) >>= r_cursor_get
{-# INLINE mdb_cursor_get #-}

r_cursor_get :: CInt -> IO Bool
r_cursor_get rc =
    if(0 == rc) then return True else
    if((#const MDB_NOTFOUND) == rc) then return False else
    _throwLMDBErrNum "mdb_cursor_get" rc
{-# INLINE r_cursor_get #-}

mdb_cursor_get' :: MDB_cursor_op -> MDB_cursor' -> Ptr MDB_val -> Ptr MDB_val -> IO Bool
mdb_cursor_get' op crs pKey pData = _mdb_cursor_get' (_crs_ptr' crs) pKey pData (cursorOp op) >>= r_cursor_get
{-# INLINE mdb_cursor_get' #-}

-- | Low-level 'mdb_cursor_put' operation.
--
-- As with mdb_put, this returns True on MDB_SUCCESS and False for MDB_KEYEXIST,
-- and otherwise throws an exception.
mdb_cursor_put :: MDB_WriteFlags -> MDB_cursor -> MDB_val -> MDB_val -> IO Bool
mdb_cursor_put wf crs key val =
    withKVPtrs key val $ \ pKey pVal -> 
    _mdb_cursor_put (_crs_ptr crs) pKey pVal wf >>= \ rc ->
    r_cursor_put rc
{-# INLINE mdb_cursor_put #-}

r_cursor_put :: CInt -> IO Bool
r_cursor_put rc =
    if(0 == rc) then return True else
    if((#const MDB_KEYEXIST) == rc) then return False else
    _throwLMDBErrNum "mdb_cursor_put" rc
{-# INLINE r_cursor_put #-}

mdb_cursor_put' :: MDB_WriteFlags -> MDB_cursor' -> MDB_val -> MDB_val -> IO Bool
mdb_cursor_put' wf crs key val =
    withKVPtrs key val $ \ pKey pVal ->
    _mdb_cursor_put' (_crs_ptr' crs) pKey pVal wf >>= \ rc ->
    r_cursor_put rc
{-# INLINE mdb_cursor_put' #-}

-- | Delete the value at the cursor. 
mdb_cursor_del :: MDB_WriteFlags -> MDB_cursor -> IO ()
mdb_cursor_del wf crs = _mdb_cursor_del (_crs_ptr crs) wf >>= r_cursor_del
{-# INLINE mdb_cursor_del #-}

r_cursor_del :: CInt -> IO ()
r_cursor_del rc = unless (0 == rc) (_throwLMDBErrNum "mdb_cursor_del" rc)
{-# INLINE r_cursor_del #-}

mdb_cursor_del' :: MDB_WriteFlags -> MDB_cursor' -> IO ()
mdb_cursor_del' wf crs = _mdb_cursor_del' (_crs_ptr' crs) wf >>= r_cursor_del
{-# INLINE mdb_cursor_del' #-}

-- | Close a cursor. don't use after this. In general, cursors should 
-- be closed before their associated transaction is commited or aborted.
mdb_cursor_close :: MDB_cursor -> IO ()
mdb_cursor_close crs = _mdb_cursor_close (_crs_ptr crs)

mdb_cursor_close' :: MDB_cursor' -> IO ()
mdb_cursor_close' crs = _mdb_cursor_close' (_crs_ptr' crs)

-- | Access transaction associated with a cursor.
mdb_cursor_txn :: MDB_cursor -> MDB_txn
mdb_cursor_txn = _crs_txn

mdb_cursor_txn' :: MDB_cursor' -> MDB_txn
mdb_cursor_txn' = _crs_txn'

-- | Access the database associated with a cursor.
mdb_cursor_dbi :: MDB_cursor -> MDB_dbi
mdb_cursor_dbi = _crs_dbi

mdb_cursor_dbi' :: MDB_cursor' -> MDB_dbi'
mdb_cursor_dbi' = _crs_dbi'

-- | count number of duplicate data items at cursor's current location.
mdb_cursor_count :: MDB_cursor -> IO Int
mdb_cursor_count crs = 
    alloca $ \ pCount -> 
    _mdb_cursor_count (_crs_ptr crs) pCount >>= \ rc ->
    if (0 == rc) then fromIntegral <$> _peekSize pCount else
    _throwLMDBErrNum "mdb_cursor_count" rc
{-# INLINE mdb_cursor_count #-}

_peekSize :: Ptr CSize -> IO CSize
_peekSize = peek

mdb_cursor_count' :: MDB_cursor' -> IO Int
mdb_cursor_count' crs = 
    alloca $ \ pCount -> 
    _mdb_cursor_count' (_crs_ptr' crs) pCount >>= \ rc ->
    if (0 == rc) then fromIntegral <$> _peekSize pCount else
    _throwLMDBErrNum "mdb_cursor_count" rc
{-# INLINE mdb_cursor_count' #-}


-- for cursor get...
--  I'm not really sure what I want to do here, not quite yet. 
--  maybe I should write a bunch of individual functions?

{-
foreign import ccall safe "lmdb.h mdb_cursor_get" _mdb_cursor_get :: Ptr MDB_cursor -> Ptr MDB_val -> Ptr MDB_val -> (#type MDB_cursor_op) -> IO CInt
-}

{-
cmpBytesToCmpFn :: (ByteString -> ByteString -> Ord) -> CmpFn
cmpBytesToCmpFn cmp vL vR = do
    lBytes <- valToVolatileByteString vL
    rBytes <- valToVolatileByteString vR
    return $! case cmp lBytes rBytes of
        LT -> -1
        EQ -> 0
        GT -> 1

-- | Create a user-defined comparison funcion over ByteStrings
wrapCmpBytes :: (ByteString -> ByteString -> Ord) -> MDB_cmp_func
wrapCmpBytes = as_MDB_cmp_func . cmpBytesToCmpFn
    
-- | Convert a value to a bytestring in O(1) time. Note, however,
-- that this bytestring refers into a memory-mapped page in the 
-- database, which may be reused after the transaction that obtained
-- the value is dropped. Developers must be careful to ensure the
-- bytestring doesn't stick around in any lazy computations.
--
-- Consider use of the safer, higher level API that will strongly 
-- associate a value with a particular transaction.
valToBytes :: MDB_val -> IO ByteString
valToBytes (MDB_val sz pd) = do
    fpd <- newForeignPtr_ pd
    return $! B.fromForeignPtr fpd 0 (fromIntegral sz)
    
-}


instance Storable MDB_val where
    alignment _ = #{alignment MDB_val}
    sizeOf _ = #{size MDB_val}
    peek ptr = do
        sz <- #{peek MDB_val, mv_size} ptr
        pd <- #{peek MDB_val, mv_data} ptr
        return $! MDB_val sz pd
    poke ptr (MDB_val sz pd) = do
        #{poke MDB_val, mv_size} ptr sz
        #{poke MDB_val, mv_data} ptr pd

instance Storable MDB_stat where
    alignment _ = #{alignment MDB_stat}
    sizeOf _ = #{size MDB_stat}
    peek ptr = do
        psize <- #{peek MDB_stat, ms_psize} ptr
        depth <- #{peek MDB_stat, ms_depth} ptr
        branch_pages <- #{peek MDB_stat, ms_branch_pages} ptr
        leaf_pages <- #{peek MDB_stat, ms_leaf_pages} ptr
        overflow_pages <- #{peek MDB_stat, ms_overflow_pages} ptr
        entries <- #{peek MDB_stat, ms_entries} ptr
        return $! MDB_stat
            { ms_psize = psize
            , ms_depth = depth
            , ms_branch_pages = branch_pages
            , ms_leaf_pages = leaf_pages
            , ms_overflow_pages = overflow_pages
            , ms_entries = entries
            }
    poke ptr val = do
        #{poke MDB_stat, ms_psize} ptr (ms_psize val)
        #{poke MDB_stat, ms_depth} ptr (ms_depth val)
        #{poke MDB_stat, ms_branch_pages} ptr (ms_branch_pages val)
        #{poke MDB_stat, ms_leaf_pages} ptr (ms_leaf_pages val)
        #{poke MDB_stat, ms_overflow_pages} ptr (ms_overflow_pages val)
        #{poke MDB_stat, ms_entries} ptr (ms_entries val)

instance Storable MDB_envinfo where
    alignment _ = #{alignment MDB_envinfo}
    sizeOf _ = #{size MDB_envinfo}
    peek ptr = do
        mapaddr <- #{peek MDB_envinfo, me_mapaddr} ptr
        mapsize <- #{peek MDB_envinfo, me_mapsize} ptr
        last_pgno <- #{peek MDB_envinfo, me_last_pgno} ptr
        last_txnid <- #{peek MDB_envinfo, me_last_txnid} ptr
        maxreaders <- #{peek MDB_envinfo, me_maxreaders} ptr
        numreaders <- #{peek MDB_envinfo, me_numreaders} ptr
        return $! MDB_envinfo 
            { me_mapaddr = mapaddr
            , me_mapsize = mapsize
            , me_last_pgno = last_pgno
            , me_last_txnid = MDB_txnid last_txnid
            , me_maxreaders = maxreaders
            , me_numreaders = numreaders
            }
    poke ptr val = do
        #{poke MDB_envinfo, me_mapaddr} ptr (me_mapaddr val)
        #{poke MDB_envinfo, me_mapsize} ptr (me_mapsize val)
        #{poke MDB_envinfo, me_last_pgno} ptr (me_last_pgno val)
        #{poke MDB_envinfo, me_last_txnid} ptr (_txnid $ me_last_txnid val)
        #{poke MDB_envinfo, me_maxreaders} ptr (me_maxreaders val)
        #{poke MDB_envinfo, me_numreaders} ptr (me_numreaders val)