diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Robert Leslie (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Robert Leslie nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,7 @@ + +Simple Haskell API for LMDB +=========================== + +This is a simple API for the [Lightning Memory-mapped Database][LMDB]. + + [LMDB]: https://symas.com/lightning-memory-mapped-database/ diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lmdb-simple.cabal b/lmdb-simple.cabal new file mode 100644 --- /dev/null +++ b/lmdb-simple.cabal @@ -0,0 +1,86 @@ + +name: lmdb-simple +version: 0.1.0.0 + +synopsis: Simple API for LMDB + +description: This package provides a simple API for using the + Lightning Memory-mapped Database (LMDB). + +homepage: https://github.com/verement/lmdb-simple#readme +bug-reports: https://github.com/verement/lmdb-simple/issues + +license: BSD3 +license-file: LICENSE + +author: Rob Leslie +maintainer: rob@mars.org +copyright: © 2017 Robert Leslie + +stability: experimental +category: Database + +build-type: Simple +cabal-version: >=1.10 + +extra-source-files: README.md + stack.yaml + test/env/.keep + +source-repository head + type: git + location: https://github.com/verement/lmdb-simple.git + +library + hs-source-dirs: src + + exposed-modules: Database.LMDB.Simple + Database.LMDB.Simple.Extra + Database.LMDB.Simple.View + other-modules: Database.LMDB.Simple.Internal + + build-depends: base >= 4.7 && < 5 + , binary >= 0.8 + , bytestring + , lmdb >= 0.2 + ghc-options: -Wall -Wno-name-shadowing -Wno-unused-do-bind + default-language: Haskell2010 + default-extensions: Trustworthy + other-extensions: ConstraintKinds + KindSignatures + TypeFamilies + +test-suite sample + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: sample.hs + build-depends: base + , lmdb-simple + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +test-suite hspec + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: hspec.hs + other-modules: Database.LMDB.SimpleSpec + Harness + build-depends: base + , hspec + , lmdb-simple + , QuickCheck + ghc-options: -Wall -Wno-unused-do-bind + -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +benchmark criterion + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: criterion.hs + other-modules: Harness + build-depends: base + , criterion + , lmdb-simple + ghc-options: -Wall -Wno-name-shadowing + -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 diff --git a/src/Database/LMDB/Simple.hs b/src/Database/LMDB/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Database/LMDB/Simple.hs @@ -0,0 +1,331 @@ + +{-# LANGUAGE ConstraintKinds #-} + +{-| +Module : Database.LMDB.Simple +Description : Simple Haskell API for LMDB +Copyright : © 2017 Robert Leslie +License : BSD3 +Maintainer : rob@mars.org +Stability : experimental + +This module provides a simple Haskell API for the + +(LMDB). + +Example usage: + +@ +module Main where + +import Database.LMDB.Simple +import Control.Monad (forM_) + +main = do + env <- openEnvironment "myenv" defaultLimits + db <- readOnlyTransaction env $ getDatabase Nothing :: IO (Database String Int) + + transaction env $ + forM_ [("one",1),("two",2),("three",3)] $ \\(k,v) -> put db k (Just v) + + print =<< readOnlyTransaction env (get db "two") -- Just 2 + print =<< readOnlyTransaction env (get db "nine") -- Nothing +@ + +Additional functions for querying and modifying LMDB databases are provided in +"Database.LMDB.Simple.Extra". For an option to access LMDB databases from pure +code, see "Database.LMDB.Simple.View". +-} + +module Database.LMDB.Simple + ( -- * Environments + Environment + , Limits (..) + , defaultLimits + , openEnvironment + , openReadWriteEnvironment + , openReadOnlyEnvironment + , clearStaleReaders + + -- * Transactions + , Transaction + , transaction + , readWriteTransaction + , readOnlyTransaction + , nestTransaction + , abort + , AbortedTransaction + + -- * Databases + , Database + , getDatabase + , get + , put + , clear + + -- * Access modes + , ReadWrite + , ReadOnly + , Mode + , SubMode + ) where + +import Prelude hiding + ( lookup + ) + +import Control.Concurrent + ( runInBoundThread + ) + +import Control.Exception + ( Exception + , throwIO + , try + , tryJust + , bracketOnError + ) + +import Control.Monad + ( guard + , void + ) + +import Data.Binary + ( Binary + ) + +import Database.LMDB.Raw + ( LMDB_Error (LMDB_Error, e_code) + , MDB_EnvFlag (MDB_NOSUBDIR, MDB_RDONLY) + , MDB_DbFlag (MDB_CREATE) + , mdb_env_create + , mdb_env_open + , mdb_env_set_mapsize + , mdb_env_set_maxdbs + , mdb_env_set_maxreaders + , mdb_dbi_open' + , mdb_txn_begin + , mdb_txn_commit + , mdb_txn_abort + , mdb_txn_env + , mdb_clear' + , mdb_reader_check + ) + +import Database.LMDB.Simple.Internal + ( ReadWrite + , ReadOnly + , Mode + , SubMode + , Environment (Env) + , Transaction (Txn) + , Database (Db) + , isReadOnlyEnvironment + , isReadOnlyTransaction + , isReadWriteTransaction + ) + +import qualified Database.LMDB.Simple.Internal as Internal + +import Foreign.C + ( Errno (Errno) + , eNOTDIR + ) + +-- | LMDB environments have various limits on the size and number of databases +-- and concurrent readers. +data Limits = Limits + { mapSize :: Int -- ^ memory map size, in bytes (also the maximum size + -- of all databases) + , maxDatabases :: Int -- ^ maximum number of named databases + , maxReaders :: Int -- ^ maximum number of concurrent 'ReadOnly' + -- transactions (also the number of slots in the lock + -- table) + } + +-- | The default limits are 1 MiB map size, 0 named databases, and 126 +-- concurrent readers. These can be adjusted freely, and in particular the +-- 'mapSize' may be set very large (limited only by available address +-- space). However, LMDB is not optimized for a large number of named +-- databases so 'maxDatabases' should be kept to a minimum. +-- +-- The default 'mapSize' is intentionally small, and should be changed to +-- something appropriate for your application. It ought to be a multiple of +-- the OS page size, and should be chosen as large as possible to accommodate +-- future growth of the database(s). Once set for an environment, this limit +-- cannot be reduced to a value smaller than the space already consumed by the +-- environment, however it can later be increased. +-- +-- If you are going to use any named databases then you will need to change +-- 'maxDatabases' to the number of named databases you plan to use. However, +-- you do not need to change this field if you are only going to use the +-- single main (unnamed) database. +defaultLimits :: Limits +defaultLimits = Limits + { mapSize = 1024 * 1024 -- 1 MiB + , maxDatabases = 0 + , maxReaders = 126 + } + +-- | Open an LMDB environment in either 'ReadWrite' or 'ReadOnly' mode. The +-- 'FilePath' argument may be either a directory or a regular file, but it +-- must already exist. If a regular file, an additional file with "-lock" +-- appended to the name is used for the reader lock table. +-- +-- Note that an environment must have been opened in 'ReadWrite' mode at least +-- once before it can be opened in 'ReadOnly' mode. +-- +-- An environment opened in 'ReadOnly' mode may still modify the reader lock +-- table (except when the filesystem is read-only, in which case no locks are +-- used). +openEnvironment :: Mode mode => FilePath -> Limits -> IO (Environment mode) +openEnvironment path limits = do + env <- mdb_env_create + + mdb_env_set_mapsize env (mapSize limits) + mdb_env_set_maxdbs env (maxDatabases limits) + mdb_env_set_maxreaders env (maxReaders limits) + + let environ = Env env :: Mode mode => Environment mode + flags = [MDB_RDONLY | isReadOnlyEnvironment environ] + + r <- tryJust (guard . isNotDirectoryError) $ mdb_env_open env path flags + case r of + Left _ -> mdb_env_open env path (MDB_NOSUBDIR : flags) + Right _ -> return () + + return environ + + where isNotDirectoryError :: LMDB_Error -> Bool + isNotDirectoryError LMDB_Error { e_code = Left code } + | Errno (fromIntegral code) == eNOTDIR = True + isNotDirectoryError _ = False + +-- | Convenience function for opening an LMDB environment in 'ReadWrite' +-- mode; see 'openEnvironment' +openReadWriteEnvironment :: FilePath -> Limits -> IO (Environment ReadWrite) +openReadWriteEnvironment = openEnvironment + +-- | Convenience function for opening an LMDB environment in 'ReadOnly' +-- mode; see 'openEnvironment' +openReadOnlyEnvironment :: FilePath -> Limits -> IO (Environment ReadOnly) +openReadOnlyEnvironment = openEnvironment + +-- | Check for stale entries in the reader lock table, and return the number +-- of entries cleared. +clearStaleReaders :: Environment mode -> IO Int +clearStaleReaders (Env env) = mdb_reader_check env + +-- | Perform a top-level transaction in either 'ReadWrite' or 'ReadOnly' +-- mode. A transaction may only be 'ReadWrite' if the environment is also +-- 'ReadWrite' (enforced by the 'SubMode' constraint). +-- +-- Once completed, the transaction will be committed and the result +-- returned. An exception will cause the transaction to be implicitly aborted. +-- +-- Note that there may be several concurrent 'ReadOnly' transactions (limited +-- only by the 'maxReaders' field of the 'Limits' argument given to +-- 'openEnvironment'), but there is at most one active 'ReadWrite' +-- transaction, which is forced to run in a bound thread, and is protected by +-- an internal mutex. +-- +-- In general, long-lived transactions should be avoided. 'ReadOnly' +-- transactions prevent reuse of database pages freed by newer 'ReadWrite' +-- transactions, and thus the database can grow quickly. 'ReadWrite' +-- transactions prevent other 'ReadWrite' transactions, since writes are +-- serialized. +transaction :: (Mode tmode, SubMode emode tmode) + => Environment emode -> Transaction tmode a -> IO a +transaction (Env env) tx@(Txn tf) + | isReadOnlyTransaction tx = run True + | otherwise = runInBoundThread (run False) + where run readOnly = + bracketOnError (mdb_txn_begin env Nothing readOnly) mdb_txn_abort $ + \txn -> tf txn >>= \result -> mdb_txn_commit txn >> return result + +-- | The exception type thrown when a (top-level) transaction is explicitly +-- aborted +data AbortedTransaction = AbortedTransaction + +instance Show AbortedTransaction where + showsPrec _ AbortedTransaction = showString "aborted transaction" + +instance Exception AbortedTransaction + +-- | Convenience function for performing a top-level 'ReadWrite' transaction; +-- see 'transaction' +readWriteTransaction :: Environment ReadWrite + -> Transaction ReadWrite a -> IO a +readWriteTransaction = transaction + +-- | Convenience function for performing a top-level 'ReadOnly' transaction; +-- see 'transaction' +readOnlyTransaction :: Environment mode + -> Transaction ReadOnly a -> IO a +readOnlyTransaction = transaction + +-- | Nest a transaction within the current 'ReadWrite' transaction. +-- Transactions may be nested to any level. +-- +-- If the nested transaction is aborted, 'Nothing' is returned. Otherwise, the +-- nested transaction is committed and the result is returned in a 'Just' +-- value. (The overall effect of a nested transaction depends on whether the +-- parent transaction is ultimately committed.) +-- +-- An exception will cause the nested transaction to be implicitly aborted. +nestTransaction :: Transaction ReadWrite a -> Transaction ReadWrite (Maybe a) +nestTransaction tx@(Txn tf) = Txn $ run (isReadOnlyTransaction tx) + where run ro ptxn = let env = mdb_txn_env ptxn in maybeAborted $ + bracketOnError (mdb_txn_begin env (Just ptxn) ro) mdb_txn_abort $ + \ctxn -> tf ctxn >>= \result -> mdb_txn_commit ctxn >> return result + + maybeAborted :: IO a -> IO (Maybe a) + maybeAborted io = either + (\e -> let _ = e :: AbortedTransaction in Nothing) Just <$> try io + +-- | Explicitly abort the current transaction, nullifying its effects on the +-- LMDB environment. No further actions will be performed within the current +-- transaction. +-- +-- In a nested transaction, this causes the child transaction to return +-- 'Nothing' to its parent. In a top-level transaction, this throws an +-- 'AbortedTransaction' exception, which can be caught. +abort :: Transaction mode a +abort = Txn $ \_ -> throwIO AbortedTransaction + +-- | Retrieve a database handle from the LMDB environment. The database may be +-- specified by name, or 'Nothing' can be used to specify the main (unnamed) +-- database for the environment. If a named database is specified, it must +-- already exist, or it will be created if the transaction is 'ReadWrite'. +-- +-- There are a limited number of named databases you may use in an +-- environment, set by the 'maxDatabases' field of the 'Limits' argument given +-- to 'openEnvironment'. By default ('defaultLimits') this number is zero, so +-- you must specify another limit in order to use any named databases. +-- +-- You should not use both named and unnamed databases in the same +-- environment, because the unnamed database is used internally to store +-- entries for each named database. +-- +-- You can (and should) retain the database handle returned by this action for +-- use in future transactions. +getDatabase :: Mode mode => Maybe String -> Transaction mode (Database k v) +getDatabase name = tx + where tx = Txn $ \txn -> Db (mdb_txn_env txn) <$> mdb_dbi_open' txn name flags + flags = [MDB_CREATE | isReadWriteTransaction tx] + +-- | Lookup a key in a database and return the corresponding value, or return +-- 'Nothing' if the key does not exist in the database. +get :: (Binary k, Binary v) => Database k v -> k -> Transaction mode (Maybe v) +get = Internal.get + +-- | Insert the given key/value pair into a database, or delete the key from +-- the database if 'Nothing' is given for the value. +put :: (Binary k, Binary v) + => Database k v -> k -> Maybe v -> Transaction ReadWrite () +put db key = maybe (void $ Internal.delete db key) (Internal.put db key) + +-- | Delete all key/value pairs from a database, leaving the database empty. +clear :: Database k v -> Transaction ReadWrite () +clear (Db _ dbi) = Txn $ \txn -> mdb_clear' txn dbi diff --git a/src/Database/LMDB/Simple/Extra.hs b/src/Database/LMDB/Simple/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Database/LMDB/Simple/Extra.hs @@ -0,0 +1,296 @@ + +-- | This module exports many functions for querying and modifying LMDB +-- databases using common idioms (albeit in monadic form). + +module Database.LMDB.Simple.Extra + ( -- * Query + null + , size + , member + , notMember + , lookup + , findWithDefault + + -- * Modification + + -- ** Insertion + , insert + , insertWith + , insertWithKey + , insertLookupWithKey + + -- ** Delete/Update + , delete + , adjust + , adjustWithKey + , update + , updateWithKey + , updateLookupWithKey + , alter + + -- * Folds + , foldr + , foldl + , foldrWithKey + , foldlWithKey + , foldDatabaseWithKey + + -- * Conversion + , elems + , keys + , toList + ) where + +import Prelude hiding + ( foldl + , foldr + , lookup + , null + ) + +import Control.Monad + ( void + ) + +import Data.Binary + ( Binary + ) + +import Data.Maybe + ( fromMaybe + , isJust + ) + +import Database.LMDB.Raw + ( MDB_stat (ms_entries) + , MDB_val + , MDB_cursor_op (MDB_SET) + , MDB_cursor' + , MDB_WriteFlags + , mdb_stat' + , mdb_cursor_get' + , mdb_cursor_put' + , mdb_cursor_del' + ) + +import Database.LMDB.Simple.Internal + ( ReadWrite + , Transaction (Txn) + , Database (Db) + , forEachForward + , forEachReverse + , marshalOut + , peekVal + , withCursor + , defaultWriteFlags + , overwriteFlags + ) +import qualified Database.LMDB.Simple.Internal as Internal + +import Foreign + ( alloca + , nullPtr + , with + ) + +-- | Lookup the value at a key in the database. +-- +-- The function will return the corresponding value as @('Just' value)@, or +-- 'Nothing' if the key isn't in the database. +lookup :: (Binary k, Binary v) => k -> Database k v -> Transaction mode (Maybe v) +lookup = flip Internal.get + +-- | The expression @('findWithDefault' def k db)@ returns the value at key +-- @k@ or returns default value @def@ when the key is not in the database. +findWithDefault :: (Binary k, Binary v) + => v -> k -> Database k v -> Transaction mode v +findWithDefault def key db = fromMaybe def <$> lookup key db + +-- | Is the database empty? +null :: Database k v -> Transaction mode Bool +null (Db _ dbi) = Txn $ \txn -> do + stat <- mdb_stat' txn dbi + return (ms_entries stat == 0) + +-- | The number of entries in the database. +size :: Database k v -> Transaction mode Int +size (Db _ dbi) = Txn $ \txn -> do + stat <- mdb_stat' txn dbi + return (fromIntegral $ ms_entries stat) + +-- | Is the key a member of the database? See also 'notMember'. +member :: Binary k => k -> Database k v -> Transaction mode Bool +member key db = isJust <$> Internal.get' db key + +-- | Is the key not a member of the database? See also 'member'. +notMember :: Binary k => k -> Database k v -> Transaction mode Bool +notMember key db = not <$> member key db + +-- | Insert a new key and value in the database. If the key is already present +-- in the database, the associated value is replaced with the supplied +-- value. 'insert' is equivalent to @'insertWith' 'const'@. +insert :: (Binary k, Binary v) => k -> v -> Database k v + -> Transaction ReadWrite () +insert key value db = Internal.put db key value + +-- | Insert with a function, combining new value and old value. @'insertWith' +-- f key value db@ will insert the pair @(key, value)@ into @db@ if key does +-- not exist in the database. If the key does exist, the function will insert +-- the pair @(key, f new_value old_value)@. +insertWith :: (Binary k, Binary v) => (v -> v -> v) -> k -> v -> Database k v + -> Transaction ReadWrite () +insertWith f = insertWithKey (const f) + +-- | Insert with a function, combining key, new value and old +-- value. @'insertWithKey' f key value db@ will insert the pair @(key, value)@ +-- into @db@ if key does not exist in the database. If the key does exist, the +-- function will insert the pair @(key, f key new_value old_value)@. Note that +-- the key passed to @f@ is the same key passed to 'insertWithKey'. +insertWithKey :: (Binary k, Binary v) => (k -> v -> v -> v) -> k -> v + -> Database k v -> Transaction ReadWrite () +insertWithKey f key value = void . insertLookupWithKey f key value + +-- | Combines insert operation with old value retrieval. The monadic action +-- @('insertLookupWithKey' f k x db)@ returns the same value as @('lookup' k +-- db)@ but has the same effect as @('insertWithKey' f k x db)@. +insertLookupWithKey :: (Binary k, Binary v) => (k -> v -> v -> v) -> k -> v + -> Database k v -> Transaction ReadWrite (Maybe v) +insertLookupWithKey f key value (Db _ dbi) = Txn $ \txn -> + withCursor txn dbi $ \cursor -> marshalOut key $ \kval -> + with kval $ \kptr -> alloca $ \vptr -> do + found <- mdb_cursor_get' MDB_SET cursor kptr vptr + if found + then do oldValue <- peekVal vptr + cursorPut cursor overwriteFlags kval (f key value oldValue) + return (Just oldValue) + else do cursorPut cursor defaultWriteFlags kval value + return Nothing + + where cursorPut :: Binary v => MDB_cursor' -> MDB_WriteFlags -> MDB_val -> v + -> IO Bool + cursorPut cursor writeFlags kval value = marshalOut value $ \vval -> + mdb_cursor_put' writeFlags cursor kval vval + +-- | Return all elements of the database in the order of their keys. +elems :: Binary v => Database k v -> Transaction mode [v] +elems = foldr (:) [] + +-- | Return all keys of the database in the order they are stored on disk. +keys :: Binary k => Database k v -> Transaction mode [k] +keys (Db _ dbi) = Txn $ \txn -> + alloca $ \kptr -> + forEachForward txn dbi kptr nullPtr [] $ \rest -> + (:) <$> peekVal kptr <*> rest + +-- | Convert the database to a list of key/value pairs. Note that this will +-- make a copy of the entire database in memory. +toList :: (Binary k, Binary v) => Database k v -> Transaction mode [(k, v)] +toList = foldrWithKey (\k v -> ((k, v) :)) [] + +-- | Fold the values in the database using the given right-associative binary +-- operator. +foldr :: Binary v => (v -> b -> b) -> b -> Database k v -> Transaction mode b +foldr f z (Db _ dbi) = Txn $ \txn -> + alloca $ \vptr -> + forEachForward txn dbi nullPtr vptr z $ \rest -> + f <$> peekVal vptr <*> rest + +-- | Fold the keys and values in the database using the given +-- right-associative binary operator. +foldrWithKey :: (Binary k, Binary v) + => (k -> v -> b -> b) -> b -> Database k v -> Transaction mode b +foldrWithKey f z (Db _ dbi) = Txn $ \txn -> + alloca $ \kptr -> + alloca $ \vptr -> + forEachForward txn dbi kptr vptr z $ \rest -> + f <$> peekVal kptr <*> peekVal vptr <*> rest + +-- | Fold the values in the database using the given left-associative binary +-- operator. +foldl :: Binary v => (a -> v -> a) -> a -> Database k v -> Transaction mode a +foldl f z (Db _ dbi) = Txn $ \txn -> + alloca $ \vptr -> + forEachReverse txn dbi nullPtr vptr z $ \rest -> + flip f <$> peekVal vptr <*> rest + +-- | Fold the keys and values in the database using the given left-associative +-- binary operator. +foldlWithKey :: (Binary k, Binary v) + => (a -> k -> v -> a) -> a -> Database k v -> Transaction mode a +foldlWithKey f z (Db _ dbi) = Txn $ \txn -> + alloca $ \kptr -> + alloca $ \vptr -> + forEachReverse txn dbi kptr vptr z $ \rest -> + (\k v a -> f a k v) <$> peekVal kptr <*> peekVal vptr <*> rest + +-- | Fold the keys and values in the database using the given monoid. +foldDatabaseWithKey :: (Monoid m, Binary k, Binary v) + => (k -> v -> m) -> Database k v -> Transaction mode m +foldDatabaseWithKey f = foldrWithKey (\k v a -> f k v `mappend` a) mempty + +-- | Delete a key and its value from the database. If the key was not present +-- in the database, this returns 'False'; otherwise it returns 'True'. +delete :: Binary k => k -> Database k v -> Transaction ReadWrite Bool +delete = flip Internal.delete + +-- | Update a value at a specific key with the result of the provided +-- function. When the key is not a member of the database, this returns +-- 'False'; otherwise it returns 'True'. +adjust :: (Binary k, Binary v) => (v -> v) -> k + -> Database k v -> Transaction ReadWrite Bool +adjust f = adjustWithKey (const f) + +-- | Adjust a value at a specific key. When the key is not a member of the +-- database, this returns 'False'; otherwise it returns 'True'. +adjustWithKey :: (Binary k, Binary v) => (k -> v -> v) -> k + -> Database k v -> Transaction ReadWrite Bool +adjustWithKey f = updateWithKey (\k v -> Just $ f k v) + +-- | The monadic action @('update' f k db)@ updates the value @x@ at @k@ (if +-- it is in the database). If @(f x)@ is 'Nothing', the element is deleted. If +-- it is @('Just' y)@, the key @k@ is bound to the new value @y@. +update :: (Binary k, Binary v) => (v -> Maybe v) -> k + -> Database k v -> Transaction ReadWrite Bool +update f = updateWithKey (const f) + +-- | The monadic action @('updateWithKey' f k db)@ updates the value @x@ at +-- @k@ (if it is in the database). If @(f k x)@ is 'Nothing', the element is +-- deleted. If it is @('Just' y)@, the key @k@ is bound to the new value @y@. +updateWithKey :: (Binary k, Binary v) => (k -> v -> Maybe v) -> k + -> Database k v -> Transaction ReadWrite Bool +updateWithKey f key db = isJust <$> updateLookupWithKey f key db + +-- | Lookup and update. See also 'updateWithKey'. The function returns changed +-- value, if it is updated. Returns the original key value if the database +-- entry is deleted. +updateLookupWithKey :: (Binary k, Binary v) => (k -> v -> Maybe v) -> k + -> Database k v -> Transaction ReadWrite (Maybe v) +updateLookupWithKey f = alterWithKey (maybe Nothing . f) + +-- | The monadic action @('alter' f k db)@ alters the value @x@ at @k@, or +-- absence thereof. 'alter' can be used to insert, delete, or update a value +-- in a database. +alter :: (Binary k, Binary v) => (Maybe v -> Maybe v) -> k + -> Database k v -> Transaction ReadWrite () +alter f key db = void $ alterWithKey (const f) key db + +alterWithKey :: (Binary k, Binary v) => (k -> Maybe v -> Maybe v) -> k + -> Database k v -> Transaction ReadWrite (Maybe v) +alterWithKey f key (Db _ dbi) = Txn $ \txn -> + withCursor txn dbi $ \cursor -> marshalOut key $ \kval -> + with kval $ \kptr -> alloca $ \vptr -> do + found <- mdb_cursor_get' MDB_SET cursor kptr vptr + if found + then peekVal vptr >>= \oldValue -> do + let old = Just oldValue + case f key old of + new@(Just newValue) -> marshalOut newValue $ \vval -> + mdb_cursor_put' overwriteFlags cursor kval vval >> + return new + Nothing -> mdb_cursor_del' defaultWriteFlags cursor >> + return old + else case f key Nothing of + new@(Just newValue) -> marshalOut newValue $ \vval -> + mdb_cursor_put' defaultWriteFlags cursor kval vval >> + return new + Nothing -> return Nothing diff --git a/src/Database/LMDB/Simple/Internal.hs b/src/Database/LMDB/Simple/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Database/LMDB/Simple/Internal.hs @@ -0,0 +1,230 @@ + +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilies #-} + +module Database.LMDB.Simple.Internal + ( ReadWrite + , ReadOnly + , Mode + , SubMode + , Environment (..) + , Transaction (..) + , Database (..) + , isReadOnlyEnvironment + , isReadOnlyTransaction + , isReadWriteTransaction + , marshalOut + , marshalIn + , peekVal + , forEachForward + , forEachReverse + , withCursor + , defaultWriteFlags + , overwriteFlags + , get + , get' + , put + , delete + ) where + +import Control.Exception + ( assert + , bracket + ) + +import Control.Monad + ( (>=>) + , foldM + ) + +import Control.Monad.IO.Class + ( MonadIO (liftIO) + ) + +import Data.Binary + ( Binary + , encode + , decode + ) + +import Data.ByteString + ( packCStringLen + ) +import qualified Data.ByteString as BS + +import Data.ByteString.Unsafe + ( unsafeUseAsCStringLen + ) + +import Data.ByteString.Lazy + ( toChunks + , toStrict + , fromStrict + ) +import qualified Data.ByteString.Lazy as BSL + +import Data.Word + ( Word8 + ) + +import Database.LMDB.Raw + ( MDB_env + , MDB_txn + , MDB_dbi' + , MDB_val (MDB_val) + , MDB_cursor' + , MDB_cursor_op (MDB_FIRST, MDB_LAST, MDB_NEXT, MDB_PREV) + , MDB_WriteFlag (MDB_CURRENT) + , MDB_WriteFlags + , mdb_cursor_open' + , mdb_cursor_close' + , mdb_cursor_get' + , mdb_get' + , mdb_reserve' + , mdb_del' + , compileWriteFlags + ) + +import Foreign + ( Ptr + , castPtr + , peek + , plusPtr + , copyBytes + ) + +import GHC.Exts (Constraint) + +data ReadWrite +data ReadOnly + +class Mode mode where + isReadOnlyMode :: mode -> Bool + +instance Mode ReadWrite where + isReadOnlyMode _ = False + +instance Mode ReadOnly where + isReadOnlyMode _ = True + +type family SubMode a b :: Constraint where + SubMode a ReadWrite = a ~ ReadWrite + SubMode a ReadOnly = () + +-- | An LMDB environment is a directory or file on disk that contains one or +-- more databases, and has an associated (reader) lock table. +newtype Environment mode = Env MDB_env + +isReadOnlyEnvironment :: Mode mode => Environment mode -> Bool +isReadOnlyEnvironment = isReadOnlyMode . mode + where mode :: Environment mode -> mode + mode = undefined + +-- | An LMDB transaction is an atomic unit for reading and/or changing one or +-- more LMDB databases within an environment, during which the transaction has +-- a consistent view of the databases and is unaffected by any other +-- transaction. The effects of a transaction can either be committed to the +-- LMDB environment atomically, or they can be rolled back with no observable +-- effect on the environment if the transaction is aborted. +-- +-- Transactions may be 'ReadWrite' or 'ReadOnly', however LMDB enforces a +-- strict single-writer policy so only one top-level 'ReadWrite' transaction +-- may be active at any time. +-- +-- This API models transactions using a 'Transaction' monad. This monad has a +-- 'MonadIO' instance so it is possible to perform arbitrary I/O within a +-- transaction using 'liftIO'. However, such 'IO' actions are not atomic and +-- cannot be rolled back if the transaction is aborted, so use with care. +newtype Transaction mode a = Txn (MDB_txn -> IO a) + +isReadOnlyTransaction :: Mode mode => Transaction mode a -> Bool +isReadOnlyTransaction = isReadOnlyMode . mode + where mode :: Transaction mode a -> mode + mode = undefined + +isReadWriteTransaction :: Mode mode => Transaction mode a -> Bool +isReadWriteTransaction = not . isReadOnlyTransaction + +instance Functor (Transaction mode) where + fmap f (Txn tf) = Txn $ \txn -> fmap f (tf txn) + +instance Applicative (Transaction mode) where + pure x = Txn $ \_ -> pure x + Txn tff <*> Txn tf = Txn $ \txn -> tff txn <*> tf txn + +instance Monad (Transaction mode) where + Txn tf >>= f = Txn $ \txn -> tf txn >>= \r -> let Txn tf' = f r in tf' txn + +instance MonadIO (Transaction mode) where + liftIO io = Txn $ const io + +-- | A database maps arbitrary keys to values. This API uses the 'Binary' +-- class to serialize keys and values for LMDB to store on disk. +data Database k v = Db MDB_env MDB_dbi' + +peekVal :: Binary v => Ptr MDB_val -> IO v +peekVal = peek >=> marshalIn + +marshalIn :: Binary v => MDB_val -> IO v +marshalIn (MDB_val len ptr) = + decode . fromStrict <$> packCStringLen (castPtr ptr, fromIntegral len) + +marshalOut :: Binary v => v -> (MDB_val -> IO a) -> IO a +marshalOut value f = + unsafeUseAsCStringLen (toStrict $ encode value) $ \(ptr, len) -> + f $ MDB_val (fromIntegral len) (castPtr ptr) + +copyLazyBS :: BSL.ByteString -> Ptr Word8 -> Int -> IO () +copyLazyBS lbs ptr rem = + foldM copyBS (ptr, rem) (toChunks lbs) >>= \(_, 0) -> return () + + where copyBS :: (Ptr Word8, Int) -> BS.ByteString -> IO (Ptr Word8, Int) + copyBS (ptr, rem) bs = unsafeUseAsCStringLen bs $ \(bsp, len) -> + assert (len <= rem) $ copyBytes ptr (castPtr bsp) len >> + return (ptr `plusPtr` len, rem - len) + +forEach :: MDB_cursor_op -> MDB_cursor_op + -> MDB_txn -> MDB_dbi' -> Ptr MDB_val -> Ptr MDB_val + -> a -> (IO a -> IO a) -> IO a +forEach first next txn dbi kptr vptr acc f = + withCursor txn dbi $ cursorGet first acc + + where cursorGet op acc cursor = do + found <- mdb_cursor_get' op cursor kptr vptr + if found + then f (cursorGet next acc cursor) + else pure acc + +forEachForward, forEachReverse :: MDB_txn -> MDB_dbi' + -> Ptr MDB_val -> Ptr MDB_val + -> a -> (IO a -> IO a) -> IO a +forEachForward = forEach MDB_FIRST MDB_NEXT +forEachReverse = forEach MDB_LAST MDB_PREV + +withCursor :: MDB_txn -> MDB_dbi' -> (MDB_cursor' -> IO a) -> IO a +withCursor txn dbi = bracket (mdb_cursor_open' txn dbi) mdb_cursor_close' + +defaultWriteFlags, overwriteFlags :: MDB_WriteFlags +defaultWriteFlags = compileWriteFlags [] +overwriteFlags = compileWriteFlags [MDB_CURRENT] + +get :: (Binary k, Binary v) => Database k v -> k -> Transaction mode (Maybe v) +get db key = get' db key >>= + maybe (return Nothing) (liftIO . fmap Just . marshalIn) + +get' :: Binary k => Database k v -> k -> Transaction mode (Maybe MDB_val) +get' (Db _ dbi) key = Txn $ \txn -> marshalOut key $ mdb_get' txn dbi + +put :: (Binary k, Binary v) + => Database k v -> k -> v -> Transaction ReadWrite () +put (Db _ dbi) key value = Txn $ \txn -> + marshalOut key $ \kval -> do + let bs = encode value + sz = fromIntegral (BSL.length bs) + MDB_val len ptr <- mdb_reserve' defaultWriteFlags txn dbi kval sz + let len' = fromIntegral len + assert (len' == sz) $ copyLazyBS bs ptr len' + +delete :: Binary k => Database k v -> k -> Transaction ReadWrite Bool +delete (Db _ dbi) key = Txn $ \txn -> + marshalOut key $ \kval -> mdb_del' txn dbi kval Nothing diff --git a/src/Database/LMDB/Simple/View.hs b/src/Database/LMDB/Simple/View.hs new file mode 100644 --- /dev/null +++ b/src/Database/LMDB/Simple/View.hs @@ -0,0 +1,227 @@ + +{-| This module provides a read-only 'View' for an LMDB database at a single +point in time. Because the view is unchanging, it can be used within pure +code. Behind the scenes, data is accessed from the underlying LMDB memory map. + +Each 'View' internally keeps open a read-only transaction in the LMDB +environment (consuming a slot in the lock table), so their use should be +minimized and generally short-lived. The transaction should be closed +automatically when the 'View' is garbage collected, but the timing is not +guaranteed. +-} + +module Database.LMDB.Simple.View + ( -- * Creating + View + , getView + + -- * Operators + , (!) + , (!?) + + -- * Query + , null + , size + , member + , notMember + , lookup + , findWithDefault + + -- * Folds + , foldr + , foldl + , foldrWithKey + , foldlWithKey + , foldViewWithKey + + -- * Conversion + , elems + , keys + , toList + ) where + +import Prelude hiding + ( foldl + , foldr + , lookup + , null + ) + +import Control.Concurrent.MVar + ( MVar + , newMVar + , mkWeakMVar + , takeMVar + , tryReadMVar + ) + +import Control.Monad + ( (>=>) + ) + +import Data.Binary + ( Binary + ) + +import Database.LMDB.Raw + ( MDB_txn + , MDB_dbi' + , mdb_txn_begin + , mdb_txn_commit + , mdb_get' + , mdb_stat' + , ms_entries + ) + +import Database.LMDB.Simple + ( Database + ) + +import Database.LMDB.Simple.Internal + ( Database (Db) + , forEachForward + , forEachReverse + , marshalOut + , marshalIn + , peekVal + ) + +import Data.Maybe + ( fromMaybe + , isJust + ) + +import Foreign + ( alloca + , nullPtr + ) + +import System.IO.Unsafe + ( unsafePerformIO + ) + +-- | A 'View' behaves much like a 'Data.Map.Map', except in the way it is +-- created. A @'View' k v@ maps keys @k@ to values @v@. +newtype View k v = View (MVar (MDB_txn, MDB_dbi')) + +-- | Create and return a read-only 'View' for the given LMDB database. +-- Internally, a read-only transaction is opened and kept alive until the +-- 'View' is garbage collected. +getView :: Database k v -> IO (View k v) +getView (Db env dbi) = do + txn <- mdb_txn_begin env Nothing True + var <- newMVar (txn, dbi) + mkWeakMVar var $ finalize var + return (View var) + + where finalize :: MVar (MDB_txn, MDB_dbi') -> IO () + finalize = takeMVar >=> mdb_txn_commit . fst + +{-# NOINLINE viewIO #-} +viewIO :: View k v -> ((MDB_txn, MDB_dbi') -> IO a) -> a +viewIO (View var) f = unsafePerformIO $ + tryReadMVar var >>= maybe (fail "finalized txn") (f >=> seq var . return) + +-- | Is the view empty? +null :: View k v -> Bool +null view = viewIO view $ \(txn, dbi) -> do + stat <- mdb_stat' txn dbi + return (ms_entries stat == 0) + +-- | The number of elements in the view. +size :: View k v -> Int +size view = viewIO view $ \(txn, dbi) -> do + stat <- mdb_stat' txn dbi + return (fromIntegral $ ms_entries stat) + +-- | Is the key a member of the view? See also 'notMember'. +member :: Binary k => k -> View k v -> Bool +member key view = viewIO view $ \(txn, dbi) -> + marshalOut key $ \kval -> isJust <$> mdb_get' txn dbi kval + +-- | Is the key not a member of the view? See also 'member'. +notMember :: Binary k => k -> View k v -> Bool +notMember key view = not (member key view) + +-- | Find the value at a key. Calls 'error' when the element can not be found. +(!) :: (Binary k, Binary v) => View k v -> k -> v +view ! key = fromMaybe notFoundError $ lookup key view + where notFoundError = error "View.!: given key is not found in the database" +infixl 9 ! + +-- | Find the value at a key. Returns 'Nothing' when the element can not be found. +(!?) :: (Binary k, Binary v) => View k v -> k -> Maybe v +(!?) = flip lookup +infixl 9 !? + +-- | Lookup the value at a key in the view. +-- +-- The function will return the corresponding value as @('Just' value)@, or +-- 'Nothing' if the key isn't in the view. +lookup :: (Binary k, Binary v) => k -> View k v -> Maybe v +lookup key view = viewIO view $ \(txn, dbi) -> marshalOut key $ + mdb_get' txn dbi >=> maybe (return Nothing) (fmap Just . marshalIn) + +-- | The expression @('findWithDefault' def k view)@ returns the value at key +-- @k@ or returns default value @def@ when the key is not in the view. +findWithDefault :: (Binary k, Binary v) => v -> k -> View k v -> v +findWithDefault def key = fromMaybe def . lookup key + +-- | Fold the values in the view using the given right-associative binary +-- operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@. +foldr :: Binary v => (v -> b -> b) -> b -> View k v -> b +foldr f z view = viewIO view $ \(txn, dbi) -> + alloca $ \vptr -> + forEachForward txn dbi nullPtr vptr z $ \rest -> + f <$> peekVal vptr <*> rest + +-- | Fold the keys and values in the view using the given right-associative +-- binary operator, such that @'foldrWithKey' f z == 'Prelude.foldr' +-- ('uncurry' f) z . 'toList'@. +foldrWithKey :: (Binary k, Binary v) + => (k -> v -> b -> b) -> b -> View k v -> b +foldrWithKey f z view = viewIO view $ \(txn, dbi) -> + alloca $ \kptr -> + alloca $ \vptr -> + forEachForward txn dbi kptr vptr z $ \rest -> + f <$> peekVal kptr <*> peekVal vptr <*> rest + +-- | Fold the values in the view using the given left-associative binary +-- operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@. +foldl :: Binary v => (a -> v -> a) -> a -> View k v -> a +foldl f z view = viewIO view $ \(txn, dbi) -> + alloca $ \vptr -> + forEachReverse txn dbi nullPtr vptr z $ \rest -> + flip f <$> peekVal vptr <*> rest + +-- | Fold the keys and values in the view using the given left-associative +-- binary operator, such that @'foldlWithKey' f z == 'Prelude.foldl' (\\z' +-- (kx, x) -> f z' kx x) z . 'toList'@. +foldlWithKey :: (Binary k, Binary v) + => (a -> k -> v -> a) -> a -> View k v -> a +foldlWithKey f z view = viewIO view $ \(txn, dbi) -> + alloca $ \kptr -> + alloca $ \vptr -> + forEachReverse txn dbi kptr vptr z $ \rest -> + (\k v a -> f a k v) <$> peekVal kptr <*> peekVal vptr <*> rest + +-- | Fold the keys and values in the view using the given monoid. +foldViewWithKey :: (Monoid m, Binary k, Binary v) + => (k -> v -> m) -> View k v -> m +foldViewWithKey f = foldrWithKey (\k v a -> f k v `mappend` a) mempty + +-- | Return all elements of the view in the order of their keys. +elems :: Binary v => View k v -> [v] +elems = foldr (:) [] + +-- | Return all keys of the view in the order they are stored in the +-- underlying LMDB database. +keys :: Binary k => View k v -> [k] +keys view = viewIO view $ \(txn, dbi) -> + alloca $ \kptr -> + forEachForward txn dbi kptr nullPtr [] $ \rest -> + (:) <$> peekVal kptr <*> rest + +-- | Convert the view to a list of key/value pairs. +toList :: (Binary k, Binary v) => View k v -> [(k, v)] +toList = foldrWithKey (\k v -> ((k, v) :)) [] diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,66 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# resolver: +# name: custom-snapshot +# location: "./custom-snapshot.yaml" +resolver: lts-9.0 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# extra-dep: true +# subdirs: +# - auto-update +# - wai +# +# A package marked 'extra-dep: true' will only be built if demanded by a +# non-dependency (i.e. a user package), and its test suites and benchmarks +# will not be run. This is useful for tweaking upstream packages. +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver +# (e.g., acme-missiles-0.3) +extra-deps: [] + +# Override default flag values for local packages and extra-deps +flags: {} + +# Extra package databases containing global packages +extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.5" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/test/Database/LMDB/SimpleSpec.hs b/test/Database/LMDB/SimpleSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/LMDB/SimpleSpec.hs @@ -0,0 +1,54 @@ + +module Database.LMDB.SimpleSpec + ( spec + ) where + +import Control.Monad (forM, forM_) +import Database.LMDB.Simple +import Database.LMDB.Simple.Extra +import Harness +import Test.Hspec + +spec :: Spec +spec = do + (env, db) <- runIO setup + + describe "basic operations" $ do + it "inserts and counts entries" $ + transaction env + ( do forM_ [1..100] $ \i -> put db i (Just $ show i) + size db + ) `shouldReturn` 100 + + it "retrieves entries" $ + readOnlyTransaction env (forM [1..100] $ \i -> get db i) + `shouldReturn` map (Just . show) [1 :: Int .. 100] + + it "deletes entries" $ + transaction env (put db 50 Nothing >> (,) <$> get db 50 <*> size db) + `shouldReturn` (Nothing, 99) + + describe "transactions" $ do + it "aborts" $ + transaction env (put db 0 (Just "zero") >> abort) + `shouldThrow` (const True :: Selector AbortedTransaction) + + it "rolls back" $ + readOnlyTransaction env (get db 0) + `shouldReturn` Nothing + + it "aborts nested transactions" $ + transaction env + ( do put db 1 (Just "one") + nestTransaction $ put db 2 (Just "two") >> abort + ) `shouldReturn` (Nothing :: Maybe ()) + + it "rolls back nested transactions" $ + readOnlyTransaction env ((,) <$> get db 1 <*> get db 2) + `shouldReturn` (Just "one", Just "2") + + it "commits nested transactions" $ + transaction env + ( do nestTransaction (put db 3 $ Just "three") + get db 3 + ) `shouldReturn` Just "three" diff --git a/test/Harness.hs b/test/Harness.hs new file mode 100644 --- /dev/null +++ b/test/Harness.hs @@ -0,0 +1,19 @@ + +module Harness + ( setup + ) where + +import Database.LMDB.Simple + +setup :: IO (Environment ReadWrite, Database Int String) +setup = do + env <- openEnvironment "test/env" defaultLimits + { mapSize = 1024 * 1024 * 1024 + , maxDatabases = 4 + } + db <- transaction env $ do + db <- getDatabase Nothing + clear db + return db + + return (env, db) diff --git a/test/criterion.hs b/test/criterion.hs new file mode 100644 --- /dev/null +++ b/test/criterion.hs @@ -0,0 +1,30 @@ + +module Main where + +import Criterion.Main +import Database.LMDB.Simple +import Harness + +import Control.Monad (forM, forM_) + +main :: IO () +main = do + (env, db) <- setup + defaultMain + [ bench ("insertion of " ++ elements) $ whnfIO (insertion env db) + , bench ("retrieval of " ++ elements) $ nfIO (retrieval env db) + ] + +n :: Int +n = 10000 + +elements :: String +elements = show n ++ " elements" + +insertion :: Environment ReadWrite -> Database Int String -> IO () +insertion env db = transaction env $ do + clear db + forM_ [1..n] $ \i -> put db i (Just $ show i) + +retrieval :: Environment mode -> Database Int String -> IO [Maybe String] +retrieval env db = readOnlyTransaction env $ forM [1..n] $ \i -> get db i diff --git a/test/env/.keep b/test/env/.keep new file mode 100644 --- /dev/null +++ b/test/env/.keep diff --git a/test/hspec.hs b/test/hspec.hs new file mode 100644 --- /dev/null +++ b/test/hspec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/sample.hs b/test/sample.hs new file mode 100644 --- /dev/null +++ b/test/sample.hs @@ -0,0 +1,17 @@ + +module Main where + +import Database.LMDB.Simple +import Control.Monad (forM_) + +main :: IO () +main = do + env <- openEnvironment "test/env" defaultLimits + db <- readOnlyTransaction env $ getDatabase Nothing :: IO (Database String Int) + + transaction env $ do + clear db + forM_ [("one",1),("two",2),("three",3)] $ \(k,v) -> put db k (Just v) + + print =<< readOnlyTransaction env (get db "two") -- Just 2 + print =<< readOnlyTransaction env (get db "nine") -- Nothing