-- | This module provides two interfaces:
--
-- 1. A type-safe interface centered around the 'DBEnv' and 'DB' datatypes. It
-- should only be used with databases that it was used to create.  Rather than
-- the LMDB structure, the database is represented as a collection of mutable
-- references ('DBRef') and mutable lookup tables ('Single' and 'Multi').
--
-- 2. An untyped interface centered around the 'DBS' and 'DBHandle' datatypes.
-- It is useful for operating on arbitrary LMDB environments and debugging.
-- This is the interface used by the @lmdbtool@ utility.
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveFunctor       #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
module Database.LMDB

    ( module Database.LMDB.Macros
    , LMDB_Error(..)

    -- * The Typed DB Monad Interface

    -- ** The Database Evironment
    , DBEnv -- (..)
    , openDBEnv
    , closeDBEnv
    , runDB
    , tryDB
    , unsafeGetDBS

    -- ** Specifying a Transaction
    , DB
    , orElse
    , cases
    , abort
    , dbtrace
    , dbtrac
    , dblift
    , transactionTime
    , withRNG

    -- ** Persistent mutable refs
    , readDBRef
    , writeDBRef

    -- ** Simple key/value tables
    --
    -- | Single-valued maps come in two flavors.  The 'BoundedKey' (or
    -- equivelently, 'BoundedKeyValue') flavor uses a vanilla LMDB table with
    -- keys and values straight-forwardly serialized and keys must adhere to
    -- LMDB limitations (typically a 511 byte maximum).  The 'HashedKey' flavor
    -- performs a 64-bit murmer hash on the key and uses the result as the LMDB
    -- key.  For each hashed key, a list of triples of the form (serialized
    -- key, 32-bit value length, serialized value) is stored which allows the
    -- implementation to account for hash collisions.
    , initSingle
    , testSingle
    , store
    , unstore
    , fetch
    , fetchByPrefix

    -- ** Multi-valued key/value tables
    --
    -- | Multi-valued maps come in three flavors.
    --
    -- The 'BoundedKey' flavor straight-forwardly serializes haskell valued
    -- keys to use LMDB keys.  All values for a given key are stored as a
    -- single LMDB value which consist of the concatenated serialization.  Note
    -- that the 'Binary' serialization instance is assumed to be able to parse
    -- a value from the front of a 'L.ByteString' without consuming the
    -- remaining data.  Keys must meet the LMDB requirements (typically a 511
    -- byte maximum).
    --
    -- The 'BoundedKeyValue' flavor uses LMDB's DUPSORT feature to implement
    -- the multi-map.  Both keys and values are straight forwardly serialized
    -- and both must meet LMDB's rquirements (typically a 511 byte maximum).
    --
    -- The 'HashedKey' flavor is implemented, on disk, exactly like a 'Single'
    -- 'HashedKey' table.  The difference is that 'insert' and 'remove' will
    -- allow multiple values per key.
    , initMulti
    , testMulti
    , insert
    , remove
    , fetchByPrefixMultiple
    , fetchMultiple

    -- ** Timestamps and randomness
    , TimeStamp
    , toSeconds
    , fromSeconds
    , Period(..)
    , addPeriod
    , currentTime
    , RNG(..)
    , makeGen
#if defined(VERSION_crypto_random)
    , getRandomBytes
#endif

    -- * The Untyped DBS Interface

    -- ** Public interface.
    -- *** Environments
    , DBS
    -- , dbsEnv
    , withDBSDo
    , withManyDBSDo
    , withDBSCreateIfMissing
    , initDBS
    , openDBS
    , shutDownDBS 
    -- **** Already open?
    , isOpenEnv
    , listEnv
    , isOpenEnv'
    , listEnv'
    -- **** High Level Functions
    --
    -- | These functions are similar to the operations facilitated by
    --   the @lmdbtool@ utility. The unticked variants which open and
    --   close the environment are provided for when you don't want to
    --   keep it open. (See '<#HLAF Self-contained functions>'). (anchor #HLF#)
    , listTables'
    , deleteTable'
    , createTable'
    , clearTable'
    , newTable'
    , insertKey'
    , deleteKey'
    , lookupVal'
    , toList'
    , keysOf'
    , valsOf'
    -- *** Tables
    , DBHandle
    , createDB
    , createAppendDB
    , newTbl
    , openDB
    , openAppendDB
    , createDupSortDB
    , createAppendDupDB
    , openDupSortDB
    , openAppendDupDB
    , unnamedDB
    , closeDB
    -- **** Editing tables
    , dropDB
    , delete
    , add
    -- **** Table properties
    , lengthDB
    -- *** Unsafe Functions
    --
    -- |   These functions may result in dangling pointers if not used with care.
    --
    , unsafeFetch
    , unsafeFetchW
    , unsafeDumpToList
    , unsafeDumpToListOp

    -- ** Internal Functions
    --
    -- |  These functions expose aspects of the interface that are subject to change.
    --    They are provided, but please prefer the public interface.
    --
    , internalGetDBFlags
    , internalOpenDB
    , openAppendDBFlags
    -- * Self-contained functions
    --
    -- | These functions use file paths and names as parameters.
    --   They do all the work of opening and closing the environment.
    --   They are similar to the commands of the  @lmdbtool@ utility
    --   (If you prefer to leave the environment open use functions under
    --   the heading <#HLF Higher Level Functions>.) #HLAF#
    --
    , listTables
    , listTablesCreateIfMissing
    , deleteTable
    , createTable
    , clearTable
    , newTable
    , insertKey
    , deleteKey
    , lookupVal
    , toList
    , keysOf
    , valsOf
    , copyTable
    -- * Global MVars
    -- | This is originally from the global-variables package, but it's not maintained.
    --   Open LMDB Enironments are in a hashtable stored in "LMDB Environments" MVar.
    --   They're only exported for my experimenting convenience.
    --   Consider these internal and highly subject to change or move to separate module.
    , declareMVar
    , HashTable
    ) where

import System.FilePath
import System.Directory
import Control.Concurrent (myThreadId, ThreadId(..))
import Database.LMDB.Raw
import Data.ByteString.Internal
import qualified Data.ByteString.Char8 as S
import Foreign.ForeignPtr hiding (addForeignPtrFinalizer)
import Foreign.Concurrent
import Foreign.Ptr
import Data.Word
import Foreign.C.Types
import Control.Exception
import System.DiskSpace
import Foreign.Storable
import Control.Monad
import Control.Applicative
import Control.Monad.Loops
import Foreign.Marshal.Alloc
import Data.IORef
import Control.Concurrent.MVar
-- import Data.Global
import System.IO.Unsafe
import qualified Data.HashTable.IO as H
import Data.String
import Data.Typeable
import qualified Data.HashTable.Class as Class
import qualified Data.HashTable.ST.Basic as Basic
-- import Control.Monad.Primitive
--import Control.Monad.Extra
import Control.DeepSeq (force)


-- Imports from Joe's interface
-- no attempt to remove redundancy
import           Control.Exception
import qualified Control.Concurrent.STM as STM
import Control.Concurrent.STM.TVar
import Control.Concurrent.MVar
import Control.Monad
import Database.LMDB.Raw
import Control.Applicative
import Control.DeepSeq
import           System.DiskSpace                  (getAvailSpace)
import Data.Data
import Data.Traversable (Traversable, traverse)
import Data.List (foldl1',partition)
-- import qualified Data.ByteString                   as S
import qualified Data.ByteString.Char8 as Char8
import qualified Data.ByteString.Internal          as S
import qualified Data.ByteString.Lazy as L
import Data.Int
import Data.Binary (encode,decode,Binary)
import Data.Binary.Get (runGet)
import Data.Bits
#ifdef NOHOURGLASS
import Data.Time -- UTCTime
import Data.Time.Clock.POSIX (posixSecondsToUTCTime,utcTimeToPOSIXSeconds)
#else
import Foreign.C.Types (CTime(..))
import Data.Hourglass (Period(..))
import qualified Data.Hourglass as Hourglass
import qualified System.Hourglass as Hourglass
#endif
import Data.Tuple
import Data.Word
import Data.Maybe
import Control.DeepSeq
import qualified Data.Generics.Aliases             as Generics
import qualified Data.Generics.Schemes             as Generics
import           Foreign.C.Types                   (CSize, CULong (..))
-- import           Foreign.ForeignPtr
import qualified Foreign.Concurrent
import           Foreign.Ptr
import System.IO.Unsafe (unsafePerformIO)
import Data.Global.Internal
import Language.Haskell.TH
import qualified Data.Digest.Murmur64 as Murmur
#if MIN_VERSION_base(4,8,0)
import Foreign.Marshal hiding (void)
#else
import Foreign.Marshal.Safe hiding (void)
#endif
import Foreign.Storable
import           System.IO.Unsafe                  (unsafeInterleaveIO)
import Database.LMDB.Macros
import Database.LMDB.Raw.Types
import Crypto.Random
import Control.Arrow (second, (***))
import Database.LMDB.BinaryUtil
import PackUtf8

-- | This type alias comes in two flavors depending on the build settings.  By
-- default, it will refer to Vincent Hanquez's 'Data.Hourglass.DateTime', but
-- if the "hourglass" build flag is disabled, it will instead be
-- 'Data.Time.UTCTime'.
--
-- Either way, you can use 'toSeconds' and 'fromSeconds' to convert to and from
-- an 'Int64' count of seconds since the epoch.
#ifdef NOHOURGLASS
type TimeStamp = UTCTime
data Period = Period { peroidYears :: !Int
                     , periodMonths :: !Int
                     , peroidDays :: !Int
                     }
toSeconds :: TimeStamp -> Int64
toSeconds utc = round $ utcTimeToPOSIXSeconds utc

fromSeconds :: Int64 -> TimeStamp
fromSeconds s = posixSecondsToUTCTime (realToFrac s)

currentTime :: IO TimeStamp
currentTime = getCurrentTime
#else
type TimeStamp = Hourglass.DateTime

toSeconds :: TimeStamp -> Int64
toSeconds vincentTime = t
  where (Hourglass.Elapsed (Hourglass.Seconds t)) = Hourglass.timeGetElapsed vincentTime

fromSeconds :: Int64 -> TimeStamp
fromSeconds t = Hourglass.timeFromElapsed (Hourglass.Elapsed (Hourglass.Seconds t))

currentTime :: IO TimeStamp
currentTime = Hourglass.dateCurrent
#endif


dputStrLn :: String -> IO ()
#ifdef DEBUG
dputStrLn str = putStrLn ("(DEBUG) " ++ str)
#else
dputStrLn str = return ()
#endif

newtype HTable s k v = HT (Basic.HashTable s k v) deriving Typeable

type HashTable k v = H.IOHashTable HTable k v

deriving instance Class.HashTable (HTable)


-- | DBS
--
-- The acronym 'DBS' stands for Database System.  The idea is we have a generic
-- handle for initializing and closing down your database system regardless of
-- whether it is actually MySQL or LDMB or whatever. In the language of LMDB,
-- this is called an "environment", and this type can be thought of as a handle
-- to your "LMDB Database Environment".
data DBS = DBS { dbsEnv :: MDB_env
               , dbDir :: FilePath
               , dbsIsOpen :: MVar Bool
               } deriving Typeable

-- | DBHandle
--
-- Unlike DBS, this is a handle to one specific database within the environment.
-- Here, "Database" means a simple key-value store, and nothing more grand.
--
-- This is an opaque type, but internally it contains a reference to an environment
-- so functions dealing with databases do not need to pass an environment handle 
-- (DBS type) as an explicit parameter.
data DBHandle = DBH { dbhEnv :: (MDB_env, MVar Bool)
                    , dbhDBI :: MDB_dbi 
                    , compiledWriteFlags :: MDB_WriteFlags
                    , dbhIsOpen :: MVar Bool
                    }

-- | withDBSDo 
--
--      dir - directory containing data.mdb, or an
--            existing empty directory if creating
--            a new environment
--
--      action - function which takes a DBS and preforms
--               various operations on it's contained 
--               databases.
--
-- Shorthand for @bracket (initDBS dir) shutDownDBS action@
withDBSDo :: FilePath -> (DBS -> IO a) -> IO a
withDBSDo dir action = bracket (initDBS dir) shutDownDBS action

-- | like 'withDBSDo' but opens many environments at once
withManyDBSDo :: [FilePath] -> ([DBS] -> IO a) -> IO a
withManyDBSDo dirs action =
    bracket (mapM initDBS dirs)
            (mapM shutDownDBS)
            action

withDBSCreateIfMissing dir action = do
    createDirectoryIfMissing True dir
    withDBSDo dir action

foreign import ccall getPageSizeKV :: CULong

declareMVar "LMDB Environments"  h = _registryMVar
declareMVar s _ = error ("ERROR: Cannot fectch global MVar named " ++ show s)

{-# NOINLINE _registryMVar #-}
_registryMVar = unsafePerformIO $ (H.new >>= newMVar) :: MVar (HashTable ByteString DBS)
-- The above unsafePerformIO hack global reference could equivalently be declared using
-- a macro from Data.Global.Internal like so:
--
-- declare [t|MVar (HashTable ByteString DBS)|]
--         [| H.new >>= newMVar |]
--         "_registryMVar"

-- | Is this 'Filepath' a currently open LMDB Environment?
isOpenEnv :: FilePath -> IO Bool
isOpenEnv = isOpenEnv' . packUtf8

-- | Get list of open environments, using 'FilePath' type
listEnv = map unpackUtf8 <$> listEnv'

-- | Given a path encoded as a utf8 bytestring, does the current process have it as a currently open LMDB Environment?
isOpenEnv' :: S.ByteString -> IO Bool
isOpenEnv' dir = do
    h <- H.new :: IO (HashTable S.ByteString DBS)
    let registryMVar = declareMVar "LMDB Environments" h
    registry <- readMVar registryMVar
    result <- H.lookup registry dir
    case result of
        Nothing -> return False
        Just (DBS _ _ mvar) -> readMVar mvar

-- | Get list of open environment paths as Utf8 encoded ByteStrings
listEnv' :: IO [S.ByteString]
listEnv' = do
    h <- H.new :: IO (HashTable S.ByteString DBS)
    let registryMVar = declareMVar "LMDB Environments" h
    registry <- readMVar registryMVar 
    es <- H.toList registry 
    (stillOpen,closed) <- partitionM (readMVar . dbsIsOpen . snd) es
    mapM_ (H.delete registry . fst) closed
    return $ map fst stillOpen
    where
        -- | A version of 'partition' that works with a monadic predicate.
        --
        -- > partitionM (Just . even) [1,2,3] == Just ([2], [1,3])
        -- > partitionM (const Nothing) [1,2,3] == Nothing
        partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])
        partitionM f [] = return ([], [])
        partitionM f (x:xs) = do
            res <- f x
            (as,bs) <- partitionM f xs
            return ([x | res]++as, [x | not res]++bs)

-- | initDBS
--
--      dir - directory containing data.mdb, or an
--            existing empty directory if creating
--            a new environment
--
-- Start up and initialize whatever engine(s) provide access to the 
-- environment specified by the given path. 
initDBS :: FilePath -> IO DBS
initDBS dir = 
  initDBSOptions
            -- path to lmdb environment
            dir 

            -- maxreaders, I chose this arbitrarily.
            -- The vcache package doesn't set it.
            (Just 1000) 

            -- LDMB is designed to support a small handful of databases.
            -- i choose 10 (arbitarily) as maxdbs
            -- The vcache package uses 5
            (Just 10)

            [{-todo?(options)-}]

initDBSOptions :: FilePath -> Maybe Int -> Maybe Int -> [MDB_EnvFlag] -> IO DBS
initDBSOptions dir mbMaxReader mbMaxDb options = do
    h <- H.new :: IO (HashTable S.ByteString DBS)
    let registryMVar = declareMVar "LMDB Environments" h
    registry <- takeMVar registryMVar -- lock registry
    mbAlreadyOpen <- H.lookup registry (packUtf8 dir)
    case mbAlreadyOpen of
        Just dbs@(DBS env _ mvar) -> do
            isOpen <- readMVar mvar
            if isOpen then do 
                        putMVar registryMVar registry -- unlock registry
                        return dbs
                      else do
                        (env',_) <- newEnv dir (Just mvar)
                        putMVar registryMVar registry -- unlock registry
                        return (dbs {dbsEnv = env' })
        Nothing -> do
            (env',mvar') <- newEnv dir Nothing
            let retv = DBS env' dir mvar'
            H.insert registry (packUtf8 dir) retv
            putMVar registryMVar registry -- unlock registry
            return retv
    where
        newEnv dir maybeMVar = do
            tid <- myThreadId
            env <- mdb_env_create 

            -- I tried to ask for pagesize, but it segfaults
            -- stat <- mdb_env_stat env 
            -- putStrLn "InitDBS after stat"

            -- mapsize can be very large, but should be a multiple of pagesize
            -- the haskell bindings take an Int, so I just use maxBound::Int
            space <- getAvailSpace dir
            let pagesize :: Int
                pagesize = fromIntegral $ getPageSizeKV
                mapsize1  = maxBound - rem maxBound pagesize
                mapsize2  = fromIntegral $ space - rem (space - (500*1024)) (fromIntegral pagesize)
                mapsize  = min mapsize1 mapsize2
            mdb_env_set_mapsize env mapsize

            case mbMaxReader of
                -- maxreaders, I chose this arbitrarily.
                Just x  -> mdb_env_set_maxreaders env x
                -- The vcache package doesn't set it, so I'll comment it out for now
                Nothing -> return ()

            -- LDMB is designed to support a small handful of databases.
            -- The vcache package uses 5
            case mbMaxDb of
                -- i choose x (arbitarily) as maxdbs
                Just x -> mdb_env_set_maxdbs env 10 
                -- i choose 10 (arbitarily) as maxdbs
                Nothing -> mdb_env_set_maxdbs env 10 

            mdb_env_open env dir options
            case maybeMVar of
                Nothing -> do
                    isopen <- newMVar True
                    return (env, isopen)
                Just mvar -> do
                    modifyMVar_ mvar (const $ return True) 
                    return (env, mvar)


-- | openDBS - shouldn't really need this
--
--  This is a no op in the case the environment is open, otherwise
--  it calls 'initDBS'.
openDBS :: DBS -> IO DBS
openDBS x@(DBS env dir isopenmvar) = do
    isopen <- readMVar isopenmvar
    if (not isopen) 
        then do
            putStrLn ("OPENING dbs: " ++ dir)
            initDBS dir
        else return x


-- | shutDownDBS environment 
--
-- Shutdown whatever engines were previously started in order
-- to access the set of databases represented by 'environment'.
shutDownDBS :: DBS -> IO ()
shutDownDBS (DBS env dir emvar)= do
    open <- takeMVar emvar
    if open 
        then do
            --modifyMVar_ emvar (return . const False)
            mdb_env_close env
            putMVar emvar False
        else putMVar emvar open

-- | Like 'openDB', but specify LMDB flags.
--  This function is considered internal because it exposes the MDB_DbFlag type.
--  Consider using 'openDupSortDB' or 'createDupSortDB' ...
internalOpenDB :: [MDB_DbFlag] -> DBS -> ByteString -> IO DBHandle
internalOpenDB flags (DBS env dir eMvar) name = do 
    e <- readMVar eMvar
    if e 
       then bracket (mdb_txn_begin env Nothing False)
                    (mdb_txn_commit)
                    $ \txn -> do
                             db <- mdb_dbi_open txn (Just (S.unpack name)) flags
                             isopen <- newMVar True
                             return $ DBH (env,eMvar) db (compileWriteFlags []) isopen
       else isShutdown 
    where isShutdown = error ("Cannot open '" ++ S.unpack name ++ "' due to environment being shutdown.") 

-- | unnamedDB dbs
-- get implicit main ‘database’.
unnamedDB ::  DBS -> IO DBHandle
unnamedDB (DBS env dir eMvar) = do 
    e <- readMVar eMvar
    if e 
       then bracket (mdb_txn_begin env Nothing False)
                    (mdb_txn_commit)
                    $ \txn -> do
                             db <- mdb_dbi_open txn Nothing flags
                             isopen <- newMVar True
                             return $ DBH (env,eMvar) db (compileWriteFlags []) isopen
       else isShutdown 
    where isShutdown = error ("Cannot open unamed db due to environment being shutdown.") 
          flags = []

-- | createDB db name
-- Opens the specified named database, creating one if it does not exist.
createDB ::  DBS -> ByteString -> IO DBHandle
createDB = internalOpenDB [MDB_CREATE]

-- | createAppendDB db name
-- Like 'createDB' but the data comparison function is set to always return 1
createAppendDB ::  DBS -> ByteString -> IO DBHandle
createAppendDB dbs name = openAppendDBFlags [MDB_CREATE] dbs name

-- | createDupSortDB db name
-- Like 'createDB' but the database is flagged DUPSORT
createDupSortDB ::  DBS -> ByteString -> IO DBHandle
createDupSortDB = internalOpenDB [MDB_CREATE, MDB_DUPSORT]

-- | createAppendDupDB db name
-- Like 'createDupSortDB' but the data comparison function is set to always return 1
createAppendDupDB ::  DBS -> ByteString -> IO DBHandle
createAppendDupDB dbs name = openAppendDBFlags [MDB_CREATE,MDB_DUPSORT] dbs name

bracketIfOpen mvar init close action = do
    b <- readMVar mvar
    if b then (bracket init close action)
         else (error "bracketIfOpen")

-- | openDB db name
-- Open a named database.
openDB ::  DBS -> ByteString -> IO DBHandle
openDB = internalOpenDB []

-- | openAppendDB db name
-- Open a named database with comparison function set to @\_ _ -> 1@.
openAppendDB ::  DBS -> ByteString -> IO DBHandle
openAppendDB dbs name = openAppendDBFlags [] dbs name

-- | openDupSortDB db name
-- Like 'openDB' but DUPSORT specified.
openDupSortDB ::  DBS -> ByteString -> IO DBHandle
openDupSortDB = internalOpenDB [MDB_DUPSORT]

-- | openAppendDupDB db name
-- Like 'openDupSortDB' but the data comparison function is set to always return 1
openAppendDupDB ::  DBS -> ByteString -> IO DBHandle
openAppendDupDB dbs name = openAppendDBFlags [MDB_DUPSORT] dbs name

-- | openAppendDBFlags
--  Like 'internalOpenDB' but sets the comparison function to always return 1.
--  This function is considered internal because it exposes the MDB_DbFlag type.
--  Consider using 'openAppendDupDB' or 'createAppendDupDB' ...
openAppendDBFlags :: [MDB_DbFlag] -> DBS -> ByteString -> IO DBHandle
openAppendDBFlags flags dbs name = do
    handle@(DBH (env,mvar0) dbi flags mvar1) <- internalOpenDB flags dbs name
    compare <- wrapCmpFn (\_ _ -> return 1)
    bracketIfOpen mvar0 (mdb_txn_begin env Nothing False)
            mdb_txn_commit
            (\txn -> mdb_set_dupsort txn dbi compare)
    return handle

-- openDBForCopy db name
-- Like 'openAppendDupDB' but with explicit flags, and comparsion function
openDBForCopy ::  DBS -> ByteString -> [MDB_DbFlag] -> FunPtr MDB_cmp_func -> IO DBHandle
openDBForCopy dbs name flags compare = do
    handle@(DBH (env,mvar0) dbi flags mvar1) <- internalOpenDB flags dbs name
    bracketIfOpen mvar0 (mdb_txn_begin env Nothing False)
            mdb_txn_commit
            (\txn -> mdb_set_dupsort txn dbi compare)
    return handle

-- | closeDB db name
-- Close the database.
closeDB :: DBHandle -> IO ()
closeDB (DBH (env,eMvar) dbi writeflags mvar) = do
    eOpen <- readMVar eMvar
    if eOpen
      then do
        dbisopen <- readMVar mvar
        when (dbisopen) $ do
            modifyMVar_ mvar (return . const False)
            mdb_dbi_close env dbi
      else error ("Cannot close database due to environment being already shutdown.") 

-- | get the flags associated with a table
--  This function is considered internal because it exposes the MDB_DbFlag type.
internalGetDBFlags :: DBHandle -> IO [MDB_DbFlag]
internalGetDBFlags (DBH (env,eMvar) dbi writeflags mvar) = do
    eOpen <- readMVar eMvar
    if eOpen
      then do
        dbisopen <- readMVar mvar
        if dbisopen
            then bracket (mdb_txn_begin env Nothing False)
                         (mdb_txn_commit)
                         (\txn -> mdb_dbi_flags txn dbi)
            else return []
      else return []


-- | unsafeFetch dbhandle key - lookup a key in the database
--
--      dbhandle - Database in which to perform lookup
--      key      - key to look up
--
-- IF the key is not found, then return Nothing, otherwise
-- return Just (value,finalizer) where:
--
--      value     - ByteString backed by ForiegnPtr whose finalizer
--                  commits the transaction
--      finalizer - IO action which commits the transaction. Call it only if
--                  you are sure the ByteString is no longer needed. 
--                  NOTE: GHC will commit the transaction anyway, so it isn't 
--                  necessary to ever call this at all.
--
-- Warning: The ByteString is backed by a ForeignPtr which will become
-- invalid when the transaction is committed. Be sure it is not accessed
-- in any of the following 3 scenarios:
--
--      1) the environment is closed  (after call to 'shutDownDBS', 'closeDBEnv')
--      2) the database is closed (after call to 'closeDB')
--      3) the provided finalizer was called
--
--
-- If you use this within a bracket or bracket-implicit function such as
-- withDBSDo or runDB then be sure to ensure all strings escaping the bracket
-- are copies created with 'Data.ByteString.copy'. LMDB was actually designed
-- with the use case in mind that environments and a few tables from each are
-- left open indefinitely or until just before the process terminates. So long
-- as there are not too many tables, there is little penalty.
--
unsafeFetch :: DBHandle -> ByteString -> IO (Maybe (ByteString, IO()) )
unsafeFetch = unsafeFetchInternal True

-- | like 'unsafeFetch' but you might poke into the byte strings? anyway
--   this opens a write transaction, so locks writers until the strings
--   are finalized. If you do want to write directly into the bytestring,
--   be sure the database is opened with MDB_WRITEMAP flag. Since LMDB
--   is copy on write, it should still be transactional.
unsafeFetchW = unsafeFetchInternal False

unsafeFetchInternal :: Bool -> DBHandle -> ByteString -> IO (Maybe (ByteString, IO()) )
unsafeFetchInternal isReadOnly = \(DBH (env,eMvar) dbi _ mvar) key -> do
    txn <- mdb_txn_begin env Nothing isReadOnly
    let (fornptr,offs,len) = toForeignPtr key
    mabVal <- withForeignPtr fornptr $ \ptr -> 
                mdb_get txn dbi $ MDB_val (fromIntegral len) (ptr `plusPtr` offs)
    case mabVal of
        Nothing -> do
                mdb_txn_commit txn
                return Nothing
        Just (MDB_val size ptr)  -> do
            fptr <- newForeignPtr_ ptr
            let commitTransaction = do dputStrLn ("Finalizing (fetch " ++ S.unpack key ++")")
                                       oEnv <- readMVar eMvar
                                       when oEnv $ do

           -- Potential optimizing, I use takeMVar/putMVar to avoid a race condition
           -- which may result committing a transaction on a dropped table... However,
           -- I'm not sure there is actually any harm if we just let that go. We could
           -- use _mdb_txn_commit
           -- directly instead of the wrapper, and ignore the error if it occurs.
           -- Note also* Empirically, i've never actualy seen this race condition happen,
           -- and it may be impossible for some reason i do not understand.
           --
                                           oDB <- takeMVar mvar -- readMVAr mvar
                                           -- closing a db aborts transactions, and that
                                           -- implies they are closed already,
                                           -- so only commit if our flag says "Open"
                                           when oDB $ mdb_txn_commit txn
                                           putMVar mvar oDB

            addForeignPtrFinalizer fptr commitTransaction 
            return . Just $ (fromForeignPtr fptr 0  (fromIntegral size), finalizeForeignPtr fptr)

-- | lengthDB db - returns the number of (key,value) entries in provided database.
lengthDB (DBH (env,_) dbi writeflags mvar) =  -- todo check mvars
    bracket 
            (mdb_txn_begin env Nothing False)
            (mdb_txn_commit)
            $ \txn -> fmap ms_entries $ mdb_stat txn dbi

-- | drop db - delete a database
dropDB (DBH (env,_) dbi writeflags mvar) =  -- todo check mvars
    bracket 
            (mdb_txn_begin env Nothing False)
            (mdb_txn_commit)
            $ \txn -> mdb_drop txn dbi

-- | delete db key 
--
-- Delete the key in the database. Return False if 
-- the key is not found.
delete :: DBHandle -> ByteString -> IO Bool
delete (DBH (env,mv0) dbi writeflags mvar) key = do --todo check environment mvar
    bracketIfOpen mv0
            (mdb_txn_begin env Nothing False)
            (mdb_txn_commit)
            $ \txn -> do
                let (fornptr,offs,len) = toForeignPtr key
                mabVal <- withForeignPtr fornptr $ \ptr -> do
                    let key' = MDB_val (fromIntegral len) (ptr `plusPtr` offs)
                    mdb_get txn dbi key'
                maybe (return False) 
                      (\val -> do
                                let (fornptr',offs',len') = toForeignPtr key
                                withForeignPtr fornptr $ \ptr' ->
                                    let key' = MDB_val (fromIntegral len') (ptr' `plusPtr` offs')
                                        in mdb_del txn dbi key' (Just val))
                      mabVal

-- | add db key value
-- Store a key-value pair in the database. Returns False
-- if the key already existed.
add :: DBHandle -> ByteString -> ByteString -> IO Bool
add (DBH (env,mv0) dbi writeflags _) key val =  -- todo check mvars
    bracketIfOpen mv0
            (mdb_txn_begin env Nothing False)
            (mdb_txn_commit) $ \txn ->
        let (kp,koff,klen) = toForeignPtr key
            (vp,voff,vlen) = toForeignPtr val
            in withForeignPtr kp $ \kptr -> withForeignPtr vp $ \vptr -> do
                let key' = MDB_val (fromIntegral klen) (kptr `plusPtr` koff)
                    val' = MDB_val (fromIntegral vlen) (vptr `plusPtr` voff)
                mdb_put writeflags txn dbi key' val'

-- | unsafeDumpToList 
--
--      db - Database
--    
-- Returns (kvs,finalize):
--
--      kvs - a lazy association list of ByteStrings with the (key,value)-
--            pairs from `db`
--
--      finalize - action which commits the transaction. Call it only if
--                 you are sure the ByteStrings are no longer needed. 
--                 NOTE: GHC will commit the transaction anyway, so it isn't 
--                 necessary to ever call this at all.
--
-- Ordinarily, the transaction remains open until all ForeignPtr's are
-- finalized. If you are concerned that an open transaction is a waste
-- of resources and that GHC will not finalize the strings promptly,
-- then you may use the provided finalizer to close the transaction
-- immediately.
--
-- Warning: ByteStrings are backed by ForeignPtr's which become invalid when
-- the transaction is committed. Be sure they are not accessed in any of the
-- following 3 scenarios:
--
--      1) the environment is closed 
--      2) the database is closed
--      3) the provided finalizer was called
--
unsafeDumpToList :: DBHandle -> IO ([(ByteString, ByteString)],IO ())
unsafeDumpToList dbs  = unsafeDumpToListOp MDB_NEXT dbs

unsafeDumpToListOp :: MDB_cursor_op -> DBHandle -> IO ([(ByteString, ByteString)],IO ())
unsafeDumpToListOp flag (DBH (env,emvar) dbi _ mvar) = do
    txn <- mdb_txn_begin env Nothing False
    cursor <- mdb_cursor_open txn dbi
    ref <- newMVar (0::Int)
    let finalizer = do
            modifyMVar_ ref (return . subtract 1) -- (\x -> (x,x-1)) 
            r <- readMVar ref
            dputStrLn ("Finalizing #" ++ show r)
            when (r == 0) $ do
                oEnv <- readMVar emvar
                when oEnv $ do
                   oDB <- readMVar mvar
                   when oDB $ mdb_txn_commit txn
        finalizeAll = do
           dputStrLn "finalizeAll"
           modifyMVar_ ref (return . const (-1)) 
           oEnv <- readMVar emvar
           oDB <- readMVar mvar
           when (not oDB || not oEnv) $ 
            error "ERROR finalizer returned from unsafeDumpToList was manually called after closeDB/shutDownDBS."
           mdb_txn_commit txn
    xs <- unfoldWhileM (\(_,b) -> b) $ alloca $ \pkey -> alloca $ \pval -> do
        bFound <- mdb_cursor_get flag cursor pkey pval 
        if bFound 
            then do
                MDB_val klen kp <- peek pkey
                MDB_val vlen vp <- peek pval
                fkp <- newForeignPtr_ kp
                fvp <- newForeignPtr_ vp
                modifyMVar_ ref (return . (+2))
                addForeignPtrFinalizer fkp finalizer
                addForeignPtrFinalizer fvp finalizer
                return ([ (fromForeignPtr fkp 0 (fromIntegral klen)
                         ,fromForeignPtr fvp 0 (fromIntegral vlen) ) ], bFound)
            else return ([], bFound)
    mdb_cursor_close cursor
    return $ (concatMap fst xs,finalizeAll)

listTables x = withDBSDo x $ \dbs -> do
    db <- unnamedDB dbs
    (keysVals,final) <- unsafeDumpToListOp MDB_NEXT_NODUP db
    let keys = map (S.copy . fst) keysVals
    force keys `seq` final 
    return keys

listTables' dbs = bracket (unnamedDB dbs) closeDB $ \db -> do
    (keysVals,final) <- unsafeDumpToListOp MDB_NEXT_NODUP db
    let keys = map (S.copy . fst) keysVals
    force keys `seq` final 
    return keys

listTablesCreateIfMissing x = withDBSCreateIfMissing x $ \dbs -> do
    db <- unnamedDB dbs
    (keysVals,final) <- unsafeDumpToListOp MDB_NEXT_NODUP db
    let keys = map (S.copy . fst) keysVals
    force keys `seq` final 
    return keys

deleteTable x n = withDBSDo x $ \dbs -> do
    DBH (env,_) dbi _ mvar <- openDB dbs n
    bracket (mdb_txn_begin env Nothing False)
            mdb_txn_commit
            (\txn -> mdb_drop txn dbi)

deleteTable' dbs n = bracket (openDB dbs n) closeDB $ \(DBH (env,_) dbi _ mvar) -> 
    bracket (mdb_txn_begin env Nothing False)
            mdb_txn_commit
            (\txn -> mdb_drop txn dbi)
    
createTable x n = withDBSCreateIfMissing x $ \dbs -> createDB dbs n
createTable' dbs n = createDB dbs n

clearTable x n = withDBSDo x $ \dbs -> do
    DBH (env,_) dbi _ mvar <- openDB dbs n
    bracket (mdb_txn_begin env Nothing False)
            mdb_txn_commit
            (\txn -> mdb_clear txn dbi)

clearTable' dbs n = bracket (openDB dbs n) closeDB $ \(DBH (env,_) dbi _ mvar) -> 
    bracket (mdb_txn_begin env Nothing False)
            mdb_txn_commit
            (\txn -> mdb_clear txn dbi)

insertKey x n k v = withDBSCreateIfMissing x $ \dbs -> do
    d <- createDB dbs n
    add d k v

insertKey' dbs n k v = bracket (createDB dbs n) closeDB $ \d -> add d k v

deleteKey x n k = withDBSDo x $ \dbs -> do
    d <- openDB dbs n
    delete d k 

deleteKey' dbs n k = bracket (openDB dbs n) closeDB $ \d -> delete d k

lookupVal x n k = withDBSDo x $ \dbs -> do
    d <- openDB dbs n
    mb <- unsafeFetch d k
    case mb of
        Just (val,final) -> do
            let x = S.copy val
            force x `seq` final
            return (Just x)
        Nothing -> return Nothing

lookupVal' dbs n k = bracket (openDB dbs n) closeDB $ \d -> do
    mb <- unsafeFetch d k
    case mb of
        Just (val,final) -> do
            let x = S.copy val
            force x `seq` final
            return (Just x)
        Nothing -> return Nothing

toList x n = withDBSDo x $ \dbs -> do
    d <- openDB dbs n
    (xs,final) <- unsafeDumpToList d
    let ys   = map copy xs
        copy (x,y) = (S.copy x, S.copy y)
    force ys `seq` final 
    return ys

toList' dbs n = bracket (openDB dbs n) closeDB $ \d -> do
    (xs,final) <- unsafeDumpToList d
    let ys   = map copy xs
        copy (x,y) = (S.copy x, S.copy y)
    force ys `seq` final 
    return ys

keysOf x n = withDBSDo x $ \dbs -> do
    d <- openDB dbs n
    (keysVals,final) <- unsafeDumpToList d
    let keys = map (S.copy . fst) keysVals
    force keys `seq` final 
    return keys

keysOf' dbs n = bracket (openDB dbs n) closeDB $ \d -> do
    (keysVals,final) <- unsafeDumpToList d
    let keys = map (S.copy . fst) keysVals
    force keys `seq` final 
    return keys

valsOf x n = withDBSDo x $ \dbs -> do
    d <- openDB dbs n
    (keysVals,final) <- unsafeDumpToList d
    let vals = map (S.copy . snd) keysVals
    force vals `seq` final 
    return vals

valsOf' dbs n = bracket (openDB dbs n) closeDB $ \d -> do
    (keysVals,final) <- unsafeDumpToList d
    let vals = map (S.copy . snd) keysVals
    force vals `seq` final 
    return vals

-- | Copy a table (LMDB database) from one environment to another or
--   copy a table to a different table within an environment.
--
--   If this is to create a new environment, you may need to create
--   an empty directory first.
--
--  Parameters:
--      bAllowDuplicates - True to set comparision function to 1,
--                         thereby preserving order and allowing 
--                         duplicate key pairs. Usually
--                         you don't want this. But you probably
--                         do if you used 'openAppendDupDB'.
--      
--      dir1 tbl1   - Source environment(path) and table name
--      dir2 tbl2   - Destination environment(path) and table name
--
--  Returns:
--      [(bReplaced,(key,val)] -> list of all keys and values inserted
--                                paired with a boolean flag indicating
--                                if the key was already in the destination.
copyTable :: Bool -> FilePath -> S.ByteString -> FilePath -> S.ByteString -> IO [(Bool, (S.ByteString, S.ByteString))]
copyTable bAllowDuplicates dir1 tbl dir2 tbl2 | dir1 /= dir2 = withManyDBSDo [dir1,dir2] $ \[dbs1,dbs2] -> do
    d <- openDB dbs1 tbl
    flag <- internalGetDBFlags d
    let (<>) = S.append
    -- S.putStrLn (tbl <> S.pack " FLAGS(1): " <> S.pack (show flag))
    compare <- wrapCmpFn (\_ _ -> return 1)
    d2 <- if bAllowDuplicates then openDBForCopy dbs2 tbl2 (MDB_CREATE:flag) compare
                              else internalOpenDB (MDB_CREATE:flag) dbs2 tbl2
    (xs,final) <- unsafeDumpToList d
    let ys   = map copy xs
        copy (x,y) = (S.copy x, S.copy y)
    bools <- mapM (\(k,v) -> add d2 k v) ys
    return (zip bools ys)
copyTable bAllowDuplicates dir1 tbl dir2 tbl2 | dir1 == dir2 && (tbl /= tbl2 || bAllowDuplicates) = withDBSDo dir1 $ \dbs -> do
    d <- openDB dbs tbl
    flag <- internalGetDBFlags d
    let (<>) = S.append
    -- S.putStrLn (tbl <> S.pack " FLAGS(2): " <> S.pack (show flag))
    compare <- wrapCmpFn (\_ _ -> return 1)
    d2 <- if bAllowDuplicates then openDBForCopy dbs tbl2 (MDB_CREATE:flag) compare
                              else internalOpenDB (MDB_CREATE:flag) dbs tbl2
    (xs,final) <- unsafeDumpToList d
    let ys   = map copy xs
        copy (x,y) = (S.copy x, S.copy y)
    bools <- mapM (\(k,v) -> add d2 k v) ys
    return (zip bools ys)
copyTable False dir1 tbl dir2 tbl2 | dir1 == dir2 && tbl == tbl2 = do
    xs <- toList dir1 tbl
    return $ zip (repeat False) xs

------------------------------------------
--  Static Typed Database Interface

-- | Monad representing a database transaction
--
-- If the user avoids the 'Monad' bind operation and restricts himself to the
-- 'Applicative' and 'cases' interface, then the following will be
-- automatically detected:
--
--  * whether or not the transaction requires write-access
--
--  * whether or not the transaction requires entropy
--
--  * whether or not the transaction must be supplied a time-stamp
--
-- If '>>=' is used, then 'runDB' will meet all three of those conditions
-- regardless if they are actually necessary.
data DB a = DB
    { dbFlags :: !Word8 -- three bit flags, 1 - uses write permission, 2 - uses timestamp, 4 - uses entropy
    , dbOperation :: DBParams -> MDB_txn -> IO (Either LMDB_Error a)
    }
 deriving Functor

data DBParams = DBParams
    { dbtime :: TimeStamp
    , dbRNG :: MVar RNG
    }

dbRequiresWrite :: DB a -> Bool
dbRequiresWrite a = dbFlags a .&. 1 /= 0

dbRequiresStamp :: DB a -> Bool
dbRequiresStamp a = dbFlags a .&. 2 /= 0

instance Applicative DB where
    pure x = DB 0 $ \_ _ -> return $ Right x
    f <*> a = DB (dbFlags f .|. dbFlags a) $ \stamp txn -> do
        ef <- dbOperation f stamp txn
        case ef of
            Left er -> return $ Left er
            Right ff -> do
                ea <- dbOperation a stamp txn
                case ea of
                    Left er -> return $ Left er
                    Right aa -> return $ Right $ ff aa

instance Monad DB where
    return x = pure x
    a >> b = fmap (flip const) a <*> b

    -- The monad >>= operation forces use of a read/write transaction.
    -- Use the Applicative interface for read-only.
    a >>= f = DB 7 $ \stamp txn -> do
        ea <- dbOperation a stamp txn
        case ea of
            Left er -> return $ Left er
            Right aa -> dbOperation (f aa) stamp txn

-- | Obtain a time-stamp for the current transaction.  Note that repeated calls
-- to this within a single transaction will always return the same value.
--
-- Note that this timestamp is, unfortunately, the time a transaction is
-- *started*.  Transactions needn't actually be completed in the same order
-- that they are started.  A transaction cannot obtain it's own completion
-- time.
transactionTime :: DB TimeStamp
transactionTime = DB 2 $ \DBParams {dbtime=stamp} _ -> return $ Right stamp

-- | This function adjusts a 'TimeStamp' using a human-friendly time delta.  It
-- is useful for checking expiration dates or freshness requirements for
-- cryptographic signatures.
addPeriod :: TimeStamp -> Period -> TimeStamp
addPeriod now period =
#ifdef NOHOURGLASS
    let now' = utcToLocalTime utc now
        day0 = localDay now'
        Period y m d = period
        day1 = addDays (fromIntegral d)
                $ addGregorianMonthsClip (fromIntegral m)
                $ addGregorianYearsClip (fromIntegral y) day0
        end_stamp = localTimeToUTC utc (now' { localDay = day1 })
#else
    let end_date = Hourglass.dateAddPeriod (Hourglass.dtDate now) period -- Period years months days
        end_stamp = Hourglass.DateTime end_date $ Hourglass.dtTime now
#endif
    in end_stamp


dbError :: String -> String -> LMDB_Error
dbError ctx message = LMDB_Error ctx message (Right MDB_INVALID)


-- | Like STM\'s 'Control.Monad.STM.retry', but with a failure message.
abort :: String -> DB a
abort message = DB 0 $ \_ _ -> return $ Left er
 where
    er = dbError "aborted" message

-- | This is similar to STM\'s 'Control.Monad.STM.orElse'. It is often used to
-- handle lookup failures for 'Single' and 'Multi' tables.
orElse :: DB a -> DB a -> DB a
orElse a b = DB (dbFlags a .|. dbFlags b) $ \stamp txn -> do
    -- Note: orElse needs to use a subtransaction unless the expression
    --  is read-only.
    txn' <- if dbRequiresWrite a
                then mdbTry $ mdb_txn_begin (mdb_txn_env txn) (Just txn) False
                else return $ Right txn
    either (return . Left) (withTxn stamp txn) txn'
 where
    withTxn stamp txn txn' = do
        ea <- handle (return . Left) $ dbOperation a stamp txn'
        if dbRequiresWrite a
            then case ea of
                    Left _ -> do mdb_txn_abort txn'
                                 dbOperation b stamp txn
                    Right x -> do mdb_txn_commit txn'
                                  return $ Right x
            else either (const $ dbOperation b stamp txn) (return . Right) ea

-- | A common situation is to perform an if/then branch based on the results of
-- prior 'DB' operations.  Since 'Bool' implements 'Bounded' and 'Enum', we can
-- use 'cases' to evaluate both possibilities ahead of time (before any
-- database operations are performed) and determine that in all cases, the
-- transaction remains read-only.  Thus the write flag needn't be specified for
-- the underlying LMDB transaction.
--
-- This function is called "cases" because it provides control functionality
-- similar to a case ... of ... expression.  The second argument might be
-- elegantly specified using the \"LambdaCase\" haskell syntax.
--
-- The astute reader will notice that its type is similar to that of '>>=' but
-- with restrictions that the input implement 'Bounded' and 'Enum'.  This
-- similarity is intentional.  Use this instead of '>>=' if you want to avoid
-- setting the write-acces, entropy, and timestamp flags unneccessarily.
cases :: forall a x. (Bounded a, Enum a) => DB a -> (a -> DB x) -> DB x
cases toggle op = DB flags $ \stamp txn -> do
    ei <- dbOperation toggle stamp txn
    either (return . Left) (\a -> dbOperation (op a) stamp txn) ei
 where
    flags = foldl1' (.|.) $ map (dbFlags . op) posibilities
    posibilities = [minBound .. maxBound] :: [a]


buildByteString :: MDB_val -> IO S.ByteString
buildByteString (MDB_val size ptr) = do
    fptr <- newForeignPtr_ ptr
    return $ S.fromForeignPtr fptr 0 (fromIntegral size)

-- arguments:
--
-- [ bs ]     Input bytestring to argument: action.
--
-- [ decode ] Post-process each result of action.
--
-- [ action ] Operation on MDB_val to container of MDB_vals.
--
-- Note: Any lazy-IO is destroyed here by invoking 'traverse'.
withMDB :: forall f a. Traversable f => S.ByteString -> (S.ByteString -> a) -> (MDB_val -> IO (f MDB_val)) -> IO (f a)
withMDB bs decodeS action = do
    let (fptr,offset,len) = S.toForeignPtr bs
    withForeignPtr fptr $ \ptr -> do
        mb <- action (MDB_val (fromIntegral len) (ptr `plusPtr` offset))
        traverse decodeMDB mb
 where
    decodeMDB :: MDB_val -> IO a
    decodeMDB (MDB_val len ptr) = do
        fptr <- newForeignPtr_ ptr
        return $ decodeS $ S.fromForeignPtr fptr 0 (fromIntegral len)

withMDB_ :: S.ByteString -> (MDB_val -> IO a) -> IO a
withMDB_ bs action = do
    let (fptr,offset,len) = S.toForeignPtr bs
    withForeignPtr fptr $ \ptr -> do
        action (MDB_val (fromIntegral len) (ptr `plusPtr` offset))


-- | Read a 'DBRef' value from a database.
--
-- If the database is new or this value has never been written, then the
-- transaction will fail.
--
-- A global 'DBRef' can be declared using the template-haskell 'database'
-- macro.  For example, to decare a boolean reference named "myref", use the
-- following:
--
-- > database [d| myref = xxx :: DBRef Bool |]
--
readDBRef :: Binary a => DBRef a -> DB a
readDBRef (DBRef keyname dbivar) = DB 0 $ \_ txn -> do
    dbi <- performAtomicIO dbivar $ mdb_dbi_open txn Nothing []
    maybe (Left $ dbError "readDBRef" "bad reference")
          Right
       <$> withMDB keyname decodeStrict (mdb_get txn dbi)

-- | Write a 'DBRef'' value to a database.
--
-- If the database is new or this value has never been written, then the
-- 'DBRef' entry will be created in the database.  See 'readDBRef' for how to
-- declare a 'DBRef' variable for use with this function.
writeDBRef :: Binary a => DBRef a -> a -> DB ()
writeDBRef (DBRef keyname dbivar) val = DB 1 $ \_ txn -> do
    dbi <- performAtomicIO dbivar $ mdb_dbi_open txn Nothing []
    let flags  = compileWriteFlags [] -- TODO: ?
    _ <- withMDB_ keyname $ \key -> do
        let (fptr,offset,len) = S.toForeignPtr $ encodeStrict val
        withForeignPtr fptr $ \ptr -> do
            let valmdb = MDB_val (fromIntegral len) (ptr `plusPtr` offset)
            mdb_put flags txn dbi key valmdb
    return $ Right ()

-- | Lookup a value from a given key using a table created by 'initSingle'.
-- The transaction will fail if the key does not exist in the table.
fetch :: forall f k v. (Eq k, Binary k, Binary v, FlavorKind f) => Single f k v -> k -> DB v
fetch (Single dbname dbivar) k =
    case flavor (Proxy :: Proxy f) of
        BoundedKey      -> DB 0 $ \_ txn -> _bounded txn
        BoundedKeyValue -> DB 0 $ \_ txn -> _bounded txn
        HashedKey       -> DB 0 $ \_ txn -> _hashed txn
 where
    _bounded txn = do
            dbi <- performAtomicIO dbivar $ mdb_dbi_open txn (Just $ dbname) []
            maybe (Left $ dbError "fetch" "key not found")
                  Right
               <$> withMDB (encodeStrict k) decodeStrict (mdb_get txn dbi)
    _hashed txn = do
            dbi <- performAtomicIO dbivar $ mdb_dbi_open txn (Just $ dbname) []
            let encodedKey = encode k
                w = Murmur.asWord64 $ Murmur.hash64 encodedKey
            mb <- with w $ \pw -> do
                let mdbkey = MDB_val 8 (castPtr pw)
                mbs <- mdb_get txn dbi mdbkey >>= traverse buildByteString
                return $ mbs >>= runGet (findForKey k) . L.fromChunks . (:[])
            maybe (Left $ dbError "fetch" "key not found")
                  Right
                   <$> return mb

findMatchHashed :: forall v. Binary v
                => L.ByteString -> MDB_cursor -> Ptr MDB_val -> Ptr MDB_val -> MDB_cursor_op -> IO (Maybe v)
findMatchHashed encodedKey cursor pkey pval cursor_opt = do
    bFound <- mdb_cursor_get cursor_opt cursor pkey pval
    if not bFound
        then return Nothing
        else do
            -- MDB_val klen kp <- peek pkey
            MDB_val vlen vp <- peek pval
            -- fkp <- newForeignPtr_ kp
            fvp <- newForeignPtr_ vp
            -- Values are stored as (S.ByteString,valueType)
            --  so that we can handle hash collisions.
            let -- hkey = S.fromForeignPtr fkp 0 (fromIntegral klen)
                (key,val) = decodeStrict $ S.fromForeignPtr fvp 0 (fromIntegral vlen)
            -- TODO: Should we use Eq instead of L.ByteString comparision?
            if L.fromChunks [key] == encodedKey -- encode (key :: k) == encodedKey
                then return $ Just val
                else findMatchHashed encodedKey cursor pkey pval MDB_NEXT_DUP

-- | Remove a key/value pair from a table that was created with 'initSingle'.
unstore :: forall f k v. (Eq k, Binary k, Binary v, FlavorKind f) => Single f k v  -> k -> DB ()
unstore (Single dbname dbivar) k =
    case flavor (Proxy :: Proxy f) of
        BoundedKey      -> DB 1 $ _del_bounded dbname dbivar k Nothing []
        BoundedKeyValue -> DB 1 $ _del_bounded dbname dbivar k Nothing []
        HashedKey       -> DB 1 $ _del_hashed dbname dbivar k Nothing

_del_bounded ::
    (Binary k, Eq k) =>
    MapName -> TVar (Pending MDB_dbi) -> k -> Maybe MDB_val -> [MDB_DbFlag]
        -> DBParams -> MDB_txn -> IO (Either a1 ())
_del_bounded dbname dbivar k mbval flags _ txn = do
            dbi <- performAtomicIO dbivar $ mdb_dbi_open txn (Just $ dbname) flags
            _ <- withMDB_ (encodeStrict k) $ \key -> do
                    mdb_del txn dbi key mbval
            return $ Right ()

_del_hashed ::
    (Binary k, Eq k) =>
    MapName -> TVar (Pending MDB_dbi) -> k -> Maybe S.ByteString
        -> DBParams -> MDB_txn -> IO (Either a ())
_del_hashed dbname dbivar k mbval _ txn = do
            dbi <- performAtomicIO dbivar $ mdb_dbi_open txn (Just $ dbname) []
            let encodedKey = encode k
                w = Murmur.asWord64 $ Murmur.hash64 encodedKey
            with w $ \pw -> do
                let key = MDB_val 8 (castPtr pw)
                mbs <- mdb_get txn dbi key >>= traverse buildByteString
                case runGet (splitKeyChunks k) $ L.fromChunks $ maybeToList mbs of
                    []  -> {- case mbval of -}
                            {- Nothing  -> -} void $ mdb_del txn dbi key Nothing
                            {- Just val -> void $ withMDB_ val (mdb_del txn dbi key . Just) -}
                    kvs -> do
                        let isKeeper = case mbval of
                                        Nothing -> \(k', _)  -> k'/=k
                                        Just v  -> \(k', v') -> k'/=k || v'/=L.fromChunks [v]
                            (keepers,losers) = partition isKeeper kvs
                            bs = L.concat $ map snd $ keepers
                        when (not $ null losers) $ do
                            if L.null bs
                              then void $ mdb_del txn dbi key Nothing
                              else withMDB_ (S.concat $ L.toChunks bs) $ \val -> do
                                void $ mdb_put (compileWriteFlags []) txn dbi key val
            return (Right ())


-- | Store a key/value pair into a table.  If the key already existed, it will
-- be overwritten.  See 'initSingle' for how to declare a table of type
-- 'Single'.
store :: forall f k v. (Eq k, Binary k, Binary v, FlavorKind f) => Single f k v -> k -> v -> DB ()
store (Single dbname dbivar) k val =
    case flavor (Proxy :: Proxy f) of
        BoundedKey      -> DB 1 $ \_ txn -> _bounded txn
        BoundedKeyValue -> DB 1 $ \_ txn -> _bounded txn
        HashedKey       -> DB 1 $ \_ txn -> _hashed txn
 where
    _bounded txn = do
            dbi <- performAtomicIO dbivar $ mdb_dbi_open txn (Just $ dbname) []
            let flags  = compileWriteFlags [] -- TODO: ?
            _ <- withMDB_ (encodeStrict k) $ \key -> do
                let (fptr,offset,len) = S.toForeignPtr $ encodeStrict val
                withForeignPtr fptr $ \ptr -> do
                    let valmdb = MDB_val (fromIntegral len) (ptr `plusPtr` offset)
                    mdb_put flags txn dbi key valmdb
            return $ Right ()

    _hashed txn = do
            dbi <- performAtomicIO dbivar $ mdb_dbi_open txn (Just $ dbname) []
            let flags  = compileWriteFlags [] -- TODO: ?
                encodedKey = encode k
                w = Murmur.asWord64 $ Murmur.hash64 encodedKey
            with w $ \pw -> do
                let key = MDB_val 8 (castPtr pw)
                mbs <- mdb_get txn dbi key >>= traverse buildByteString
                let bs = L.fromChunks (maybeToList mbs)
                    kvs = runGet (splitKeyChunks k) bs
                    dups = filter (\(storedk,_) -> storedk==k) kvs
                when (null dups) $ do
                    let (fptr,offset,len) = S.toForeignPtr $ S.concat $ L.toChunks $ appendKeyValue bs k val
                    withForeignPtr fptr $ \ptr -> do
                        let valmdb = MDB_val (fromIntegral len) (ptr `plusPtr` offset)
                        void $ mdb_put flags txn dbi key valmdb
                return $ Right ()

-- | This is the multi-map equivlent of 'fetch'.  It returns the list of values
-- associated with a given key.  Unlike 'fetch', this function does not fail
-- the transaction when the key has no associations in the table.  Instead, it
-- returns an empty list.
fetchMultiple :: forall f k v. (Eq k, Binary k, Binary v, FlavorKind f) => Multi f k v -> k -> DB [v]
fetchMultiple (Multi dbname dbivar) k =
    case flavor (Proxy :: Proxy f) of
        BoundedKeyValue -> DB 0 $ \_ txn -> dupsortFetch dbname dbivar txn k
        BoundedKey ->  DB 0 $ \_ txn -> do
            dbi <- performAtomicIO dbivar $ mdb_dbi_open txn (Just $ dbname) []
            maybe (Right [])
                  Right
               <$> withMDB (encodeStrict k) (runGet getMany . L.fromChunks . (:[]) ) (mdb_get txn dbi)
        HashedKey -> DB 0 $ \_ txn -> do
            dbi <- performAtomicIO dbivar $ mdb_dbi_open txn (Just $ dbname) []
            let encodedKey = encode k
                w = Murmur.asWord64 $ Murmur.hash64 encodedKey
            vs <- with w $ \pw -> do
                let mdbkey = MDB_val 8 (castPtr pw)
                mbs <- mdb_get txn dbi mdbkey >>= traverse buildByteString
                return $ maybeToList mbs >>= runGet (findManyForKey k) . L.fromChunks . (:[])
            return $ Right vs

dupsortFetch :: forall k v. (Eq k, Binary k, Binary v) => MapName -> TVar (Pending MDB_dbi) -> MDB_txn -> k -> IO (Either LMDB_Error [v])
dupsortFetch dbname dbivar txn k = do
    dbi <- performAtomicIO dbivar $ mdb_dbi_open txn (Just $ dbname) [MDB_DUPSORT]
    let encodedKey = encode k
        (fptr,offset,len) = S.toForeignPtr $ S.concat $ L.toChunks encodedKey
    withForeignPtr fptr $ \ptr -> do
        cursor <- mdb_cursor_open txn dbi
        alloca $ \pkey -> alloca $ \pval -> do
            poke pkey $ MDB_val (fromIntegral len) (ptr `plusPtr` offset)
            Right <$> findMatch encodedKey cursor pkey pval MDB_FIRST_DUP
 where
    decodeValue fvp vlen =
        -- TODO: should be using 'unsafePackCStringLen' here.
        Just $ decodeStrict $ S.fromForeignPtr fvp 0 (fromIntegral vlen)

    findMatch :: forall v. Binary v => L.ByteString -> MDB_cursor -> Ptr MDB_val -> Ptr MDB_val -> MDB_cursor_op -> IO [v]
    findMatch encodedKey cursor pkey pval cursor_opt = do
        bFound <- mdb_cursor_get cursor_opt cursor pkey pval
        if not bFound
            then do
                -- TODO: ensure the cursor is closed; maybe do without lazy IO.
                mdb_cursor_close cursor
                return []
             else do
                MDB_val vlen vp <- peek pval
                fvp <- newForeignPtr_ vp
                maybe (findMatch encodedKey cursor pkey pval MDB_NEXT_DUP)
                      (\val -> do
                        vals <- unsafeInterleaveIO $ findMatch encodedKey cursor pkey pval MDB_NEXT_DUP
                        return (val : vals))
                    $ decodeValue fvp vlen


-- | Associate a value with a given key in a multi-map table.  The table should
-- first have been created with 'initMulti'.  This is the multi-map equivelent
-- of the single-map 'store'.  There is currently no multi-map equevelent for
-- 'unstore'.  TODO: implement a method for removing items from a multi-map.
insert :: forall f k v. (Eq k, Binary k, Binary v, FlavorKind f) => Multi f k v -> k -> v -> DB ()
insert (Multi dbname dbivar) k val =
    case flavor (Proxy :: Proxy f) of
        BoundedKey ->  DB 1 $ \_ txn -> do
            dbi <- performAtomicIO dbivar $ mdb_dbi_open txn (Just $ dbname) []
            withMDB_ (encodeStrict k) $ \key -> do
                mbs <- mdb_get txn dbi key >>= traverse (fmap (L.fromChunks . (:[])) . buildByteString)
                let xbs :: [(v,L.ByteString)]
                    xbs = maybe [] (runGet getManyChunks) mbs
                    encoded = encode val
                    dups = filter (\(_,storedv) -> storedv==encoded) xbs
                when (null dups) $ do
                    let newval = maybe encoded (`L.append` encoded) $ mbs
                        (fptr,offset,len) = S.toForeignPtr $ S.concat $ L.toChunks newval
                    withForeignPtr fptr $ \ptr -> do
                        let valmdb = MDB_val (fromIntegral len) (ptr `plusPtr` offset)
                        void $ mdb_put (compileWriteFlags []) txn dbi key valmdb
            return $ Right ()

        BoundedKeyValue -> DB 1 $ \_ txn -> do
            dbi <- performAtomicIO dbivar $ mdb_dbi_open txn (Just $ dbname) [MDB_DUPSORT]
            let flags  = compileWriteFlags [] -- TODO: ?
            _ <- withMDB_ (encodeStrict k) $ \key -> do
                let (fptr,offset,len) = S.toForeignPtr $ encodeStrict val
                withForeignPtr fptr $ \ptr -> do
                    let valmdb = MDB_val (fromIntegral len) (ptr `plusPtr` offset)
                    mdb_put flags txn dbi key valmdb
            return $ Right ()

        HashedKey -> DB 1 $ \_ txn -> do
            dbi <- performAtomicIO dbivar $ mdb_dbi_open txn (Just $ dbname) []
            let flags  = compileWriteFlags [] -- TODO: ?
                encodedKey = encode k
                w = Murmur.asWord64 $ Murmur.hash64 encodedKey
            with w $ \pw -> do
                let key = MDB_val 8 (castPtr pw)
                mbs <- mdb_get txn dbi key >>= traverse buildByteString
                let bs = L.fromChunks (maybeToList mbs)
                    kvs = runGet (splitKeyChunks k) bs
                    encoded = encode val
                    dups = filter (\(storedk,storedv) -> storedk==k && storedv==encoded ) kvs
                when (null dups) $ do
                    let (fptr,offset,len) = S.toForeignPtr $ S.concat $ L.toChunks $ appendKeyValue bs k val
                    withForeignPtr fptr $ \ptr -> do
                        let valmdb = MDB_val (fromIntegral len) (ptr `plusPtr` offset)
                        void $ mdb_put flags txn dbi key valmdb
                return $ Right ()

-- | Remove a key/value pair from a table that was created with 'initMulti'.
--
-- If 'Nothing' is specified for the value, then all values associated with the
-- given key will be removed.  Otherwise, only matching values will be removed.
remove :: forall f k v. (Eq k, Binary k, Binary v, FlavorKind f) => Multi f k v -> k -> Maybe v -> DB ()
remove (Multi dbname dbivar) k mbval =
    case flavor (Proxy :: Proxy f) of
        BoundedKey      -> case mbval of
            Nothing  -> DB 1 $ _del_bounded dbname dbivar k Nothing []
            Just val -> DB 1 $ \params txn -> do
                dbi <- performAtomicIO dbivar $ mdb_dbi_open txn (Just $ dbname) []
                withMDB_ (encodeStrict k) $ \key -> do
                    mbs <- mdb_get txn dbi key >>= traverse (fmap (L.fromChunks . (:[])) . buildByteString)
                    let xbs :: [(v,L.ByteString)]
                        xbs = maybe [] (runGet getManyChunks) mbs
                        encoded = encode val
                        keepers = filter (\(_,storedv) -> storedv/=encoded) xbs
                    case keepers of
                        [] -> _del_bounded dbname dbivar k Nothing [] params txn
                        ks -> withMDB_ (L.toStrict $ L.concat $ map snd ks) $ \valmdb -> do
                                void $ mdb_put (compileWriteFlags []) txn dbi key valmdb
                                return $ Right ()

        BoundedKeyValue -> case mbval of
            Nothing  -> DB 1 $ _del_bounded dbname dbivar k Nothing [MDB_DUPSORT]
            Just val -> DB 1 $ \params txn -> do
                withMDB_ (encodeStrict val) $ \valmdb -> do
                    _del_bounded dbname dbivar k (Just valmdb) [MDB_DUPSORT] params txn

        HashedKey       -> case mbval of
            Nothing  -> DB 1 $ _del_hashed dbname dbivar k Nothing
            Just val -> DB 1 $ _del_hashed dbname dbivar k (Just $ encodeStrict val)

-- | Create an empty multi-map table.  Use the 'database' template-haskell
-- macro to declare a table like so:
--
-- > databaes [d| public_bindings = xxx :: Multi 'BoundedKey Nickname RawCertificate |]
--
-- The above example would declare a variable "public_bindings" that refers to
-- a table associates a list of "RawCertificate" values with a given "Nickname"
-- The 'BoundedKey' 'DBFlavor' indicates that keys will serialized and used
-- directly and must meet the (usually 511-byte) conditions that LMDB imposes.
initMulti :: forall f k v. FlavorKind f => Multi f k v -> DB ()
initMulti (Multi dbname dbivar) = DB 1 $ \_ txn -> do
    let flags = case flavor (Proxy :: Proxy f) of
                    BoundedKeyValue -> [MDB_CREATE,MDB_DUPSORT]
                    _               -> [MDB_CREATE]
    _ <- performAtomicIO dbivar $ mdb_dbi_open txn (Just $ dbname) flags
    return $ Right ()

-- | Create an empty lookup table within a database.  The table needs to be
-- declared using the 'database' template-haskell macro.  For example,
--
-- > database [d| freshness = xxx :: Single 'HashedKey RawCertificate Int64 |]
--
-- The above example would declare a variable "freshness" that refers to a
-- table that obtains 64-bit integer values given a value of type
-- 'RawCertificate'.  The 'HashedKey' 'DBFlavor' indicates that keys will
-- actually be hashed for efficency of lookups and to work-around LMDB's
-- hard-coded maximum length.
initSingle :: forall f k v. FlavorKind f => Single f k v -> DB ()
initSingle (Single dbname dbivar) = DB 1 $ \params txn -> do
    let flags = case flavor (Proxy :: Proxy f) of
                    BoundedKey      -> [MDB_CREATE]
                    BoundedKeyValue -> [MDB_CREATE]
                    HashedKey       -> [MDB_CREATE]
    _ <- performAtomicIO dbivar $ mdb_dbi_open txn (Just $ dbname) flags
    return $ Right ()

-- | Fail the transaction if the given table does not exist.  It is assumed the
-- table, if it exists, was created by 'initMulti'.
testMulti :: forall f k v. FlavorKind f => Multi f k v -> DB ()
testMulti (Multi dbname dbivar) = DB 1 $ \_ txn -> do
    -- TODO: Should we handle exception and return Left ?
    let flags = case flavor (Proxy :: Proxy f) of
                    BoundedKeyValue -> [MDB_DUPSORT]
                    _               -> []
    _ <- performAtomicIO dbivar $ mdb_dbi_open txn (Just $ dbname) flags
    return $ Right ()

-- | Fail the transaction if the specified table does not exist.  See
-- 'initSingle' for how to declare a table using the 'database' macro.
--
-- This method is handy for validating a database is ready to use with your
-- application without having to go to the trouble of attempting a 'fetch'.
testSingle :: forall f k v. FlavorKind f => Single f k v -> DB ()
testSingle (Single dbname dbivar) = DB 1 $ \_ txn -> do
    -- TODO: Should we handle exception and return Left ?
    let flags = case flavor (Proxy :: Proxy f) of
                    BoundedKey      -> []
                    BoundedKeyValue -> []
                    HashedKey       -> []
    _ <- performAtomicIO dbivar $ mdb_dbi_open txn (Just $ dbname) flags
    return $ Right ()



-- don't export
mdbTry :: IO a -> IO (Either LMDB_Error a)
mdbTry action = handle (return . Left)
                       (fmap Right action)


-- | An opague type representing an open database.
data DBEnv = DBEnv DBS (MVar RNG)

-- | Use this to ignore database layout and insert and lookup
--   arbitrary byte strings with 'insertKey\'' and 'lookupVal\''
unsafeGetDBS :: DBEnv -> IO DBS
unsafeGetDBS (DBEnv dbs _) = return dbs

-- | Open a database.  The current design is limited in that data represented
-- by 'DBRef', 'Single', and 'Multi' are assumed to be associated with only a
-- single active 'DBEnv' so care must be taken if multiple databases are
-- opened.
--
-- The 'Maybe' argument indicates a path to a "noise" file which is used to
-- seed a pseudo-RNG en lieu of using true system entropy for the
-- 'getRandomBytes' interface of the 'DB' transactions.  This is useful for
-- making tests reproducable.
--
-- Note that it is neccessary to invoke 'closeDBEnv' to flush writes and
-- clean-up when you are finished with the database.
openDBEnv :: FilePath -> Maybe FilePath -> IO DBEnv
openDBEnv path mbnoise = do
        dbsEnv <-
          initDBSOptions
            -- path to lmdb environment
            path
            -- maxreaders, I chose this arbitrarily.
            -- The vcache package doesn't set it, so I'll comment it out for now
            -- mdb_env_set_maxreaders env 10000
            Nothing -- 10000
            -- LDMB is designed to support a small handful of databases.
            -- i choose 12 (arbitarily) as maxdbs
            -- The vcache package uses 5
            (Just 12)
            -- LMDB Environment flags
            []

        g <- makeGen mbnoise
        gv <- newMVar g
        return $ DBEnv dbsEnv gv


-- | Close a database.
closeDBEnv :: DBEnv -> IO ()
closeDBEnv (DBEnv (DBS env dir emvar) _) = do
    open <- takeMVar emvar
    if open
        then do
            _ <- mdbTry $ mdb_env_close env
            putMVar emvar False
        else putMVar emvar open


-- | Run a single atomic transaction on an open database.  If something goes
-- wrong, an 'LMDB_Error' value will be returned.
runDB :: (NFData a, Data a) => DBEnv -> DB a -> IO (Either LMDB_Error a)
runDB env action = tryDB env Left Right action


-- | 'runDB' is implemented using this lower-level interface.  It handles the
-- error and success cases before returning to the caller.  The arguments are
-- as follows:
--
--  [ onError ]   - compute result when transaction fails.
--
--  [ onSuccess ] - compute result on bytestring-evacuated result of
--  transaction.
--
--  [ db_action ] - transaction (with pre-evacuation computations done via
--  fmap).
--
tryDB :: (NFData a, Data a) => DBEnv -> (LMDB_Error -> x) -> (a -> x) -> DB a -> IO x
tryDB (DBEnv (DBS env _ _) gv) onError onSuccess db_action = do
    etxn <- mdbTry $ mdb_txn_begin env Nothing (not $ dbRequiresWrite db_action)
    either (return . onError) (withTxn gv) etxn
 where
    withTxn gv txn = do
        stamp <- if (dbRequiresStamp db_action)
                    then currentTime
                    else return $ error "BUG: unknown transaction time!"
        fin <- newIORef (const $ return ())
        ei <- handle (return . Left)
                     (dbOperation db_action (DBParams { dbtime=stamp, dbRNG=gv }) txn)
        result <- either (return . onError) (fmap onSuccess . copyByteStrings) ei
        either (const $ mdb_txn_abort) (const $ mdb_txn_commit) ei txn
        readIORef fin >>= ($ either Just (const Nothing) ei)
        return result

    copyByteStrings :: ( NFData v
                       , Data v
                       , Applicative f) => v -> f v
    copyByteStrings v = v' `deepseq` pure v'
     where
        v' = Generics.everywhere (Generics.mkT S.copy) v

-- | The 'RNG' type comes in two flavors depending on build settings.  By
-- default, it will be a wrapper on 'Crypto.Random.SystemDRG' or
-- 'Crypto.Random.ChaChaDRG' (supplied by the cryptonite package) depending on
-- whether randomness or repeatable pseudo randomness is selected (the noise
-- file argument to 'openDBEnv').
--
-- If the 'cryptonite' build flag is disabled, however, it is simply an alias
-- for 'Crypto.Random.SystemRNG' (supplied by the crypto-random package).  This
-- type handles both system entropy and pseudo-randomness via a noise file.
#if defined(VERSION_crypto_random)
type RNG = SystemRNG

makeGen :: Maybe FilePath -> IO RNG
makeGen noisefile = do
    pool <- fromMaybe Crypto.Random.createEntropyPool $ do
        path <- noisefile
        Just $ createTestEntropyPool `fmap` S.readFile path
    return (cprgCreate pool :: SystemRNG)

getRandomBytes :: Int -> DB S.ByteString
getRandomBytes n = withRNG (\g -> withRandomBytes g n id)

#else
newtype RNG = RNG (Either SystemDRG ChaChaDRG)
instance DRG RNG where
    randomBytesGenerate n (RNG g) =
        either (second (RNG . Left ) . randomBytesGenerate n)
               (second (RNG . Right) . randomBytesGenerate n) g

makeGen :: Maybe FilePath -> IO RNG
makeGen noisefile = do
    drg <- fromMaybe (Left <$> getSystemDRG) $ do
        path <- noisefile
        Just $ Right . drgNewTest . decodeSeed <$> L.readFile path
    return $ RNG drg
 where
    decodeSeed :: L.ByteString -> (Word64, Word64, Word64, Word64, Word64)
    decodeSeed bs | L.null bs = (0,0,0,0,0)
                  | otherwise = decode $  L.cycle bs

instance MonadRandom DB where
    getRandomBytes n = DB 4 $ \DBParams { dbRNG=rngv } _ -> do
        bs <- modifyMVar rngv (return . swap . randomBytesGenerate n)
        return $ Right bs

#endif

-- | This is only for backward compatibility if the 'Crypto.Random.MonadRandom'
-- class is unavailable (the "cryptonite" build flag was disabled).  It may be
-- used to make use of the 'DBEnv' \'s random generator, which is either system
-- entropy or a pseudo-random algorithm seeded by a noise file.  See
-- 'openDBEnv'.  The internal 'RNG' state will be appropriately mutated.
--
-- Using this, or the 'Crypto.Random.MonadRandom' interface, marks a
-- transaction as requiring entropy.  Entropy is never used internally by this
-- library, but the 'Monad' bind operation will mark a transaction as requiring
-- it.  To avoid that (and to enable read-only transaction when possible),
-- avoid using '>>='.
withRNG :: (RNG -> (a,RNG)) -> DB a
withRNG f = DB 4 $ \DBParams { dbRNG=rngv } _ -> do
    a <- modifyMVar rngv (return . swap . f)
    return $ Right a

-- | Output a debug message.
dbtrace :: String -> DB ()
dbtrace str = DB 0 $ \_ _ -> putStrLn str >> return (Right ())

-- | Output a debug message, without new line.
dbtrac :: String -> DB ()
dbtrac str = DB 0 $ \_ _ -> putStr str >> return (Right ())

-- | Perform an IO action from within a transaction.  Note that this is unsafe
-- and very bad practice. It is provided mainly for temporary hacks and
-- debuging.  This function is effectively 'Control.Monad.IO.Class.liftIO' for
-- the 'DB' monad.
dblift :: IO a -> DB a
dblift action = DB 0 $ \_ _ -> fmap Right action

-- | This fetches multiple key/value pairs from a table created by
-- 'initSingle'.  The given 'S.ByteString' is a common prefix of the serialized
-- keys whose values are of interest.
fetchByPrefix :: forall f k v. (Eq k, Binary k, Binary v) => Single 'BoundedKey k v -> S.ByteString -> DB [(k,v)]
fetchByPrefix (Single dbname dbivar) start  = DB 0 $ \_ txn -> do
    dbi <- performAtomicIO dbivar $ mdb_dbi_open txn Nothing []
    fmap (fmap (map $ decodeStrict *** decodeStrict)) $ getRange txn dbi start

-- | This is the multi-map equivelent of 'fetchByPrefix'.
fetchByPrefixMultiple :: forall f k v. (Eq k, Binary k, Binary v) => Multi 'BoundedKey k v -> S.ByteString -> DB [(k,v)]
fetchByPrefixMultiple (Multi dbname dbivar) start  = DB 0 $ \_ txn -> do
    dbi <- performAtomicIO dbivar $ mdb_dbi_open txn Nothing []
    fmap (fmap (concatMap (\(k,v) -> map ((,) $ decodeStrict k) $ runGet getMany $ L.fromChunks [v])))
        $ getRange txn dbi start


-- | TODO: Don't export this.  This is a helper to fetchByPrefix* functions.
getRange :: MDB_txn -> MDB_dbi -> S.ByteString -> IO (Either LMDB_Error [(S.ByteString,S.ByteString)])
getRange txn dbi start = do
        ei <- handle (return . Left)
                     $ Right <$> mdb_cursor_open txn dbi
        case ei of
            Left e -> return $ Left e
            Right cursor -> do
                -- Hack: ForeignPtr is created just to attach a finalizer to the
                -- cursor.  LMDB docs say it is okay to close the cursor either
                -- before or after the transaction closes, but that the cursor
                -- must be explicitly closed.  Therefore, it should be alright
                -- to leave the timing up to the garbage collector.
                fptr <- mallocForeignPtr :: IO (ForeignPtr Word8)
                Foreign.Concurrent.addForeignPtrFinalizer fptr
                        $ mdb_cursor_close cursor
                unsafeInterleaveIO
                 $ alloca $ \pkey ->
                   alloca $ \pval -> do
                    handle (return . Left) $ do
                        let (fptr,offset,len) = S.toForeignPtr start
                        withForeignPtr fptr $ \ptr -> do
                            let start_mdb = MDB_val (fromIntegral len) (ptr `plusPtr` offset)
                            poke pkey start_mdb
                            xs <- uncons MDB_SET_RANGE (fptr,cursor) pkey pval
                            -- I'm using seq to force the head of the list to
                            -- prevent start_mdb from escaping the
                            -- withForeignPtr scope.  I'm actually not sure if
                            -- this is neccessary.
                            return $ Right $ length (take 1 xs) `seq` xs
 where
    uncons :: MDB_cursor_op
            -> (ForeignPtr Word8, MDB_cursor)
            -> Ptr MDB_val
            -> Ptr MDB_val
            -> IO [(S.ByteString,S.ByteString)]
    uncons cop (ptr,cursor) pkey pval = do
        is_found <- mdb_cursor_get cop cursor pkey pval
        if is_found
            then do
                MDB_val klen kp <- peek pkey
                MDB_val vlen vp <- peek pval
                fkp <- newForeignPtr_ kp
                fvp <- newForeignPtr_ vp
                let key = S.fromForeignPtr fkp 0 (fromIntegral klen)
                    val = S.fromForeignPtr fvp 0 (fromIntegral vlen)
                xs <- unsafeInterleaveIO $ uncons MDB_NEXT (ptr,cursor) pkey pval
                return $ (key,val):xs
            else do
                -- We finalize the ptr to close the cursor.  Because the ptr is
                -- used here and in the other branch of the if statement, we
                -- can be sure that the ptr will not go out of scope before we
                -- are done with the cursor.  If the lazy list is truncated,
                -- the cursor will still be closed eventually due to the
                -- pointer's finalizer.
                finalizeForeignPtr ptr
                return []

-- | like 'newTbl' but use default flags
newTable' dbs k = newTbl dbs k []

-- | like 'newTbl' but use default flags and opens and closes the environment
--   named by the first parameter. The other parameter is both the prefix to the
--   table name and the key in the "_counters" table. _counters will also be
--   created if it does not already exist.

newTable x k = withDBSDo x $ \dbs -> (S.copy . snd <$> newTbl dbs k [])

-- | Create a new table with a name prefixed by the given string and open it
--   with the given flags. This function also creates and uses a table called
--   "_counters" which holds the 32 bit counter that is incremented each time
--   you call this with the same prefix string. The incremented counter is
--   appended to the prefix provided to give the actual name of the new table.
--
--   Returns: A pair, the first element is a handle to the table, the second is
--   the table name.
--
--   LMDB keeps a slot vector which has to be copied on write transactions, and
--   is scanned linearly on table opens. The maximum number of open tables is
--   the size of that slot vector. Defaults are 10 if you used initDBS to make
--   the environmet and 12 if you used openDBEnv. The size of this vector
--   determines how many tables you can have open at a time. So be sure to call
--   closeDB as soon as you can. If you do not, then both the @_counters@
--   table and the freshly created table are left open by this function, thus
--   filling 2 more slots on first call, and 1 more for each later call.

newTbl :: DBS -> ByteString -> [MDB_DbFlag] -> IO (DBHandle,ByteString)
newTbl dbs counterkey flags =
  bracket
    (mdb_txn_begin (dbsEnv dbs) Nothing False)
    (mdb_txn_commit) $ \txn -> do
        let (fptr,offs,len) = toForeignPtr counterkey
        ctrTbl <- mdb_dbi_open txn (Just "_counters") [MDB_CREATE]--,MDB_WRITEMAP]
        tblname <- withForeignPtr fptr $ \ ptr -> do
          let key = MDB_val (fromIntegral len) (ptr `plusPtr` offs)
          mbVal <- mdb_get txn ctrTbl key
          let writeflags = compileWriteFlags []
          case mbVal of
            Nothing -> do -- no counter, so create it as 0
                with (0::Word64) $ \zero' ->
                    -- reserve 4 bytes for a Word32, pad another 4 bytes for future byteswap-adaptations to big endian machines
                    mdb_reserve writeflags txn ctrTbl key 8
                    -- if MDB_WRITEMAP, then memory is not initialized to 0.
                    -- let zero = MDB_val 4 (castPtr zero')
                    --     in mdb_put writeflags txn ctrTbl key zero
                -- let cntstr = S.pack (show (0::Word32))
                return counterkey
            Just (MDB_val size ptr) -> do
                count'0ld <- peek (castPtr ptr) :: IO Word64
                ---- detected endian change, so ByteSwap and continue
                let count'old = -- maybe its better to just have an endianness flag?
                     if count'0ld > fromIntegral (maxBound::Word32)
                         then (byteSwap64 count'0ld)
                         else count'0ld
                with (count'old +1) $ \pcount ->
                    let count = MDB_val 8 (castPtr pcount)
                        in mdb_put writeflags txn ctrTbl key count
                -- WARNING no check that size=4
                -- poke (castPtr ptr) count -- requires MDB_WRITEMAP
                let cntstr = S.pack (show count'old)
                return (S.append counterkey cntstr)
        -- now create the new table
        retdbi <- mdb_dbi_open txn (Just (unpackUtf8 tblname)) (MDB_CREATE:flags)
        b <- newMVar True
        let retdh = DBH { dbhEnv = (dbsEnv dbs, dbsIsOpen dbs)
                        , dbhDBI = retdbi :: MDB_dbi
                        , compiledWriteFlags = compileWriteFlags []:: MDB_WriteFlags
                        , dbhIsOpen = b:: MVar Bool
                        }
        return (retdh,tblname)