module Lmdb.Connection where
import Database.LMDB.Raw
import Lmdb.Types
import Lmdb.Internal
import Data.Word
import Foreign.Storable
import Data.Coerce
import Data.Functor
import Data.Bits
import Control.Concurrent (runInBoundThread,isCurrentThreadBound)
import Data.Bool (bool)
import System.IO (withFile,IOMode(ReadMode))
import Foreign.C.Types (CSize(..))
import Foreign.Ptr (Ptr,plusPtr)
import Foreign.Marshal.Alloc (allocaBytes,alloca)
import Control.Monad
import Control.Exception (finally, bracketOnError)
withCursor ::
Transaction e
-> Database k v
-> (Cursor e k v -> IO a)
-> IO a
withCursor (Transaction txn) (Database dbi settings) f = do
cur <- mdb_cursor_open_X txn dbi
a <- f (Cursor cur settings)
mdb_cursor_close_X cur
return a
withMultiCursor ::
Transaction e
-> MultiDatabase k v
-> (MultiCursor e k v -> IO a)
-> IO a
withMultiCursor (Transaction txn) (MultiDatabase dbi settings) f = do
cur <- mdb_cursor_open_X txn dbi
a <- f (MultiCursor cur settings)
mdb_cursor_close_X cur
return a
withAbortableTransaction ::
ModeBool e
=> Environment e
-> (Transaction e -> IO (Maybe a))
-> IO (Maybe a)
withAbortableTransaction e@(Environment env) f = do
let isReadOnly = modeIsReadOnly e
txn <- mdb_txn_begin env Nothing isReadOnly
ma <- f (Transaction txn)
case ma of
Nothing -> do
mdb_txn_abort txn
return Nothing
Just a -> do
mdb_txn_commit txn
return (Just a)
withTransaction ::
ModeBool e
=> Environment e
-> (Transaction e -> IO a)
-> IO a
withTransaction e@(Environment env) f = do
let isReadOnly = modeIsReadOnly e
bool runInBoundThread id isReadOnly $ bracketOnError
(mdb_txn_begin env Nothing isReadOnly)
mdb_txn_abort
$ \txn -> do
a <- f (Transaction txn)
mdb_txn_commit txn
return a
withNestedTransaction ::
Environment 'ReadWrite
-> Transaction 'ReadWrite
-> (Transaction 'ReadWrite -> IO a)
-> IO a
withNestedTransaction e@(Environment env) (Transaction parentTxn) f = do
txn <- mdb_txn_begin env (Just parentTxn) True
a <- f (Transaction txn)
mdb_txn_commit txn
return a
openDatabase ::
ModeBool e
=> Transaction e
-> Maybe String
-> DatabaseSettings k v
-> IO (Database k v)
openDatabase t@(Transaction txn) name settings = do
let rwOpts = if modeIsReadOnly t then [] else [MDB_CREATE]
(keySafeFfi, keyExtraCmd, sortOpts) = case settings of
DatabaseSettings keySort _ keyDec _ _ -> case keySort of
SortNative s -> (,,) False (\_ -> return ()) $ case s of
NativeSortLexographic -> []
NativeSortLexographicBackward -> [MDB_REVERSEKEY]
NativeSortInteger -> [MDB_INTEGERKEY]
SortCustom s -> customSortConfig True keyDec t s
opts = rwOpts ++ sortOpts
dbi <- mdb_dbi_open_X keySafeFfi txn name opts
keyExtraCmd dbi
return (Database dbi settings)
customSortConfig :: Bool -> Decoding a -> Transaction e -> CustomSort a -> (Bool, DbiByFfi -> IO (), [MDB_DbFlag])
customSortConfig isKey (Decoding decode) (Transaction txn) s = (,,) True (\dbiOuter -> case dbiOuter of
DbiSafe dbi -> case s of
CustomSortUnsafe f -> setCmp txn dbi f
CustomSortSafe f -> (setCmp txn dbi =<<) $ wrapCmpFn $ \aPtr bPtr -> do
MDB_val aSize aData <- peek aPtr
MDB_val bSize bData <- peek bPtr
a <- decode aSize aData
b <- decode bSize bData
return $ case f a b of
GT -> 1
EQ -> 0
LT -> (1)
DbiUnsafe _ -> fail "customSortConfig: logical error in sorting. Open an issue if this happens."
) []
where setCmp = if isKey then mdb_set_compare else mdb_set_dupsort
openMultiDatabase ::
ModeBool e
=> Transaction e
-> Maybe String
-> MultiDatabaseSettings k v
-> IO (MultiDatabase k v)
openMultiDatabase t@(Transaction txn) name settings = do
let rwOpts = if modeIsReadOnly t then [] else [MDB_CREATE]
(keySafeFfi,keyExtraCmd,keySortOpts) = case settings of
MultiDatabaseSettings keySort _ _ keyDec _ _ -> case keySort of
SortNative s -> (,,) False (\_ -> return ()) $ case s of
NativeSortLexographic -> []
NativeSortLexographicBackward -> [MDB_REVERSEKEY]
NativeSortInteger -> [MDB_INTEGERKEY]
SortCustom s -> customSortConfig True keyDec t s
(valSafeFfi,valExtraCmd,valSortOpts) = case settings of
MultiDatabaseSettings _ valSort _ _ _ valDec -> case valSort of
SortNative s -> (,,) False (\_ -> return ()) $ case s of
NativeSortLexographic -> []
NativeSortLexographicBackward -> [MDB_REVERSEDUP]
NativeSortInteger -> [MDB_INTEGERDUP]
SortCustom s -> customSortConfig False valDec t s
multiOpts = case settings of
MultiDatabaseSettings _ _ _ _ valEnc _ -> case valEnc of
EncodingVariable _ -> []
EncodingMachineWord _ -> [MDB_DUPFIXED]
EncodingFixed _ _ -> [MDB_DUPFIXED]
baseOpts = [MDB_DUPSORT]
safeFfi = keySafeFfi || valSafeFfi
opts = rwOpts ++ keySortOpts ++ valSortOpts ++ multiOpts ++ baseOpts
dbi <- mdb_dbi_open_X safeFfi txn name opts
keyExtraCmd dbi
valExtraCmd dbi
return (MultiDatabase dbi settings)
withDatabase ::
ModeBool e
=> Environment e
-> Transaction e
-> Maybe String
-> DatabaseSettings k v
-> (Database k v -> IO a)
-> IO a
withDatabase env txn mname settings f = do
dbi <- openDatabase txn mname settings
finally (f dbi) (closeDatabase env dbi)
withMultiDatabase ::
ModeBool e
=> Environment e
-> Transaction e
-> Maybe String
-> MultiDatabaseSettings k v
-> (MultiDatabase k v -> IO a)
-> IO a
withMultiDatabase env txn mname settings f = do
dbi <- openMultiDatabase txn mname settings
finally (f dbi) (closeMultiDatabase env dbi)
initializeReadOnlyEnvironment ::
Int
-> Int
-> Int
-> FilePath
-> IO (Environment 'ReadOnly)
initializeReadOnlyEnvironment =
initializeEnvironmentInternal [MDB_RDONLY]
withReadOnlyEnvironment ::
Int
-> Int
-> Int
-> FilePath
-> (Environment 'ReadOnly -> IO a)
-> IO a
withReadOnlyEnvironment a b c d f = do
env <- initializeReadOnlyEnvironment a b c d
finally (f env) (closeEnvironment env)
initializeReadWriteEnvironment ::
Int
-> Int
-> Int
-> FilePath
-> IO (Environment 'ReadWrite)
initializeReadWriteEnvironment = initializeEnvironmentInternal []
initializeEnvironmentInternal ::
[MDB_EnvFlag]
-> Int
-> Int
-> Int
-> FilePath
-> IO (Environment e)
initializeEnvironmentInternal flags maxSize maxReaders maxDbs dir =
runInBoundThread $ do
env <- mdb_env_create
mdb_env_set_mapsize env maxSize
mdb_env_set_maxreaders env maxReaders
mdb_env_set_maxdbs env maxDbs
mdb_env_open env dir flags
return (Environment env)
closeDatabase :: Environment e -> Database k v -> IO ()
closeDatabase (Environment env) (Database dbi _) =
mdb_dbi_close_X env dbi
closeMultiDatabase :: Environment e -> MultiDatabase k v -> IO ()
closeMultiDatabase (Environment env) (MultiDatabase dbi _) =
mdb_dbi_close_X env dbi
closeEnvironment :: Environment e -> IO ()
closeEnvironment (Environment env) =
runInBoundThread $ mdb_env_close env
makeSettings ::
Sort s k
-> Codec s k
-> Codec sv v
-> DatabaseSettings k v
makeSettings sort (Codec kEnc kDec) (Codec vEnc vDec) =
DatabaseSettings sort kEnc kDec vEnc vDec
makeMultiSettings ::
Sort sk k
-> Sort sv v
-> Codec sk k
-> Codec sv v
-> MultiDatabaseSettings k v
makeMultiSettings ksort vsort (Codec kEnc kDec) (Codec vEnc vDec) =
MultiDatabaseSettings ksort vsort kEnc kDec vEnc vDec
readonly :: Transaction 'ReadWrite -> Transaction 'ReadOnly
readonly = coerce
readonlyEnvironment :: Environment 'ReadWrite -> Environment 'ReadOnly
readonlyEnvironment = coerce