libmdbx 0.2.0.0 → 0.2.1.0
raw patch · 4 files changed
+176/−66 lines, 4 filesdep +transformersPVP ok
version bump matches the API change (PVP)
Dependencies added: transformers
API changes (from Hackage documentation)
+ Mdbx.Database: getBounds :: (MonadIO m, MonadFail m, MdbxItem k, MdbxItem v) => MdbxEnv -> MdbxDbi -> k -> k -> m (Maybe ((k, v), (k, v)))
Files
- ChangeLog.md +7/−0
- libmdbx.cabal +4/−1
- src/Mdbx/Database.hs +139/−65
- test/Mdbx/DatabaseSpec.hs +26/−0
ChangeLog.md view
@@ -1,3 +1,10 @@+### 0.2.1.0++* Add proper transaction handling for Database module (commit on success but+ also abort on exception).+* Add `getBounds` function to retrieve minimum and maximum key/pairs on a given+ range of keys.+ ### 0.2.0.0 * Add support for setting database geometry.
libmdbx.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: libmdbx-version: 0.2.0.0+version: 0.2.1.0 synopsis: Bindings for libmdbx, an embedded key/value store description: Haskell bindings for [libmdbx](https://github.com/erthink/libmdbx). .@@ -59,6 +59,7 @@ , store >=0.5 && <0.8 , store-core ==0.4.* , text ==1.2.*+ , transformers >=0.5 && <0.7 default-language: Haskell2010 executable libmdbx-exe@@ -78,6 +79,7 @@ , store >=0.5 && <0.8 , store-core ==0.4.* , text ==1.2.*+ , transformers >=0.5 && <0.7 default-language: Haskell2010 test-suite libmdbx-test@@ -104,4 +106,5 @@ , store >=0.5 && <0.8 , store-core ==0.4.* , text ==1.2.*+ , transformers >=0.5 && <0.7 default-language: Haskell2010
src/Mdbx/Database.hs view
@@ -16,6 +16,7 @@ getItems, getRange, getRangePairs,+ getBounds, -- * Save putItem, putItems,@@ -25,11 +26,14 @@ delRange ) where +import Control.Applicative ((<|>))+import Control.Exception (SomeException(..), bracket, catch, throw) import Control.Monad (forM, forM_, void, when) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Fail (MonadFail)+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Data.Function (fix)-import Data.Maybe (catMaybes, fromJust)+import Data.Maybe (catMaybes, fromJust, isJust) import Mdbx.API import Mdbx.Types@@ -41,14 +45,10 @@ -> MdbxDbi -- ^ The database. -> k -- ^ The key to lookup. -> m (Maybe v) -- ^ The matching value, if any.-getItem env dbi key = do- txn <- txnBegin env Nothing [MdbxTxnRdonly]-- resp <- liftIO $ toMdbxVal key $ \mkey -> do+getItem env dbi key = liftIO . doInReadTxn env $ \txn -> do+ toMdbxVal key $ \mkey -> do mval <- itemGet txn dbi mkey mapM fromMdbxVal mval- void $ txnCommit txn- return resp {-| Returns the values associated to a list of keys. Returned length may not match@@ -60,14 +60,12 @@ -> MdbxDbi -- ^ The database. -> [k] -- ^ The keys to lookup. -> m [v] -- ^ The matching values. Length may not match that of keys.-getItems env dbi keys = do- txn <- txnBegin env Nothing [MdbxTxnRdonly]-+getItems env dbi keys = liftIO . doInReadTxn env $ \txn -> do resp <- forM keys $ \key ->- liftIO $ toMdbxVal key $ \mkey -> do+ toMdbxVal key $ \mkey -> do mval <- itemGet txn dbi mkey mapM fromMdbxVal mval- void $ txnCommit txn+ return $ catMaybes resp -- | Returns the list of values whose keys lie between the provided range.@@ -78,12 +76,11 @@ -> k -- ^ The start of the range (inclusive). -> k -- ^ The end of the range (inclusive). -> m [v] -- ^ The matching values.-getRange env dbi start end = do- txn <- txnBegin env Nothing [MdbxTxnRdonly]+getRange env dbi start end = liftIO . doInReadTxn env $ \txn -> do cursor <- cursorOpen txn dbi - pairs <- liftIO $ toMdbxVal start $ \skey ->- liftIO $ toMdbxVal end $ \ekey -> do+ toMdbxVal start $ \skey ->+ toMdbxVal end $ \ekey -> do pair1 <- cursorRange cursor skey flip fix (pair1, []) $ \loop (pair, items) -> do isValid <- pairLEKey txn dbi ekey pair@@ -96,9 +93,6 @@ loop (newPair, val : items) else return (reverse items) - void $ txnCommit txn- return pairs- {-| Returns the list of key/value pairs whose keys lie between the provided range. -}@@ -109,12 +103,11 @@ -> k -- ^ The start of the range (inclusive). -> k -- ^ The end of the range (inclusive). -> m [(k, v)] -- ^ The matching pairs.-getRangePairs env dbi start end = do- txn <- txnBegin env Nothing [MdbxTxnRdonly]+getRangePairs env dbi start end = liftIO . doInReadTxn env $ \txn -> do cursor <- cursorOpen txn dbi - pairs <- liftIO $ toMdbxVal start $ \skey ->- liftIO $ toMdbxVal end $ \ekey -> do+ toMdbxVal start $ \skey ->+ toMdbxVal end $ \ekey -> do pair1 <- cursorRange cursor skey flip fix (pair1, []) $ \loop (pair, items) -> do isValid <- pairLEKey txn dbi ekey pair@@ -129,9 +122,40 @@ loop (newPair, (key, val) : items) else return (reverse items) - void $ txnCommit txn- return pairs+{-|+Returns the minimum and maximum keys, and their respective values, between the+provided key range. +Both start and end keys are inclusive, thus the same key/value pairs will be+returned if they exist. Otherwise, the next\/previous valid key\/value pairs+will be returned respectively.+-}+getBounds+ :: (MonadIO m, MonadFail m, MdbxItem k, MdbxItem v)+ => MdbxEnv -- ^ The environment.+ -> MdbxDbi -- ^ The database.+ -> k -- ^ The start of the range (inclusive).+ -> k -- ^ The end of the range (inclusive).+ -> m (Maybe ((k, v), (k, v))) -- ^ The bounding pairs, if any.+getBounds env dbi start end = liftIO . doInReadTxn env $ \txn -> do+ cursor <- cursorOpen txn dbi++ toMdbxVal start $ \skey ->+ toMdbxVal end $ \ekey -> do+ pairMem1 <- cursorRange cursor skey+ isValid1 <- pairLEKey txn dbi ekey pairMem1+ pair1 <- fetchIfValid isValid1 pairMem1++ pairMem2 <- runMaybeT $ MaybeT (cursorAt cursor ekey) <|> MaybeT (cursorPrev cursor)+ isValid2 <- pairGEKey txn dbi skey pairMem2+ pair2 <- fetchIfValid isValid2 pairMem2++ return $ (,) <$> pair1 <*> pair2+ where+ fromMdbxPairs (mkey, mval) = (,) <$> fromMdbxVal mkey <*> fromMdbxVal mval+ fetchIfValid True pairMem = mapM fromMdbxPairs pairMem+ fetchIfValid _ _ = return Nothing+ -- | Saves the given key/value pair. putItem :: (MonadIO m, MonadFail m, MdbxItem k, MdbxItem v)@@ -140,12 +164,11 @@ -> k -- ^ The key. -> v -- ^ The value. -> m ()-putItem env dbi key item = do- txn <- txnBegin env Nothing []- liftIO $ toMdbxVal key $ \mkey ->- liftIO $ toMdbxVal item $ \mitem ->- itemPut txn dbi mkey mitem []- void $ txnCommit txn+putItem env dbi key item =+ liftIO . doInWriteTxn env $ \txn ->+ toMdbxVal key $ \mkey ->+ toMdbxVal item $ \mitem ->+ itemPut txn dbi mkey mitem [] -- | Saves the given key/value pairs. Runs in a single transaction. putItems@@ -154,13 +177,12 @@ -> MdbxDbi -- ^ The database. -> [(k, v)] -- ^ The list of key/value pairs. -> m ()-putItems env dbi items = do- txn <- txnBegin env Nothing []- forM_ items $ \(key, item) ->- liftIO $ toMdbxVal key $ \mkey ->- liftIO $ toMdbxVal item $ \mitem ->- itemPut txn dbi mkey mitem []- void $ txnCommit txn+putItems env dbi items =+ liftIO . doInWriteTxn env $ \txn ->+ forM_ items $ \(key, item) ->+ toMdbxVal key $ \mkey ->+ toMdbxVal item $ \mitem ->+ itemPut txn dbi mkey mitem [] -- | Deletes the item associated with the given key, if any. delItem@@ -169,11 +191,10 @@ -> MdbxDbi -- ^ The database. -> k -- ^ The key to delete. -> m ()-delItem env dbi key = do- txn <- txnBegin env Nothing []- liftIO $ toMdbxVal key $ \mkey ->- itemDel txn dbi mkey Nothing- void $ txnCommit txn+delItem env dbi key =+ liftIO . doInWriteTxn env $ \txn ->+ liftIO $ toMdbxVal key $ \mkey ->+ itemDel txn dbi mkey Nothing {-| Deletes the items associated with the given keys, if any. Runs in a single@@ -185,12 +206,11 @@ -> MdbxDbi -- ^ The database. -> [k] -- ^ The keys to delete. -> m ()-delItems env dbi keys = do- txn <- txnBegin env Nothing []- forM_ keys $ \key ->- liftIO $ toMdbxVal key $ \mkey ->- itemDel txn dbi mkey Nothing- void $ txnCommit txn+delItems env dbi keys =+ liftIO . doInWriteTxn env $ \txn ->+ forM_ keys $ \key ->+ toMdbxVal key $ \mkey ->+ itemDel txn dbi mkey Nothing -- | Deletes the values whose keys lie between the provided range. delRange@@ -200,28 +220,28 @@ -> k -- ^ The start of the range (inclusive). -> k -- ^ The end of the range (inclusive). -> m ()-delRange env dbi start end = do- txn <- txnBegin env Nothing []- cursor <- cursorOpen txn dbi-- liftIO $ toMdbxVal start $ \skey ->- liftIO $ toMdbxVal end $ \ekey -> do- pair1 <- cursorRange cursor skey- flip fix pair1 $ \loop pair -> do- isValid <- pairLEKey txn dbi ekey pair+delRange env dbi start end =+ liftIO . doInWriteTxn env $ \txn -> do+ cursor <- cursorOpen txn dbi - when isValid $ do- let mkey = fst . fromJust $ pair- itemDel txn dbi mkey Nothing- newPair <- cursorNext cursor+ toMdbxVal start $ \skey ->+ toMdbxVal end $ \ekey -> do+ pair1 <- cursorRange cursor skey+ flip fix pair1 $ \loop pair -> do+ isValid <- pairLEKey txn dbi ekey pair - loop newPair+ when isValid $ do+ let mkey = fst . fromJust $ pair+ itemDel txn dbi mkey Nothing+ newPair <- cursorNext cursor - void $ txnCommit txn+ loop newPair -- Helpers --- | Checks if the key of the key/value pair is lower than the provided key.+{-|+Checks if the key of the key/value pair is lower or equal than the provided key.+-} pairLEKey :: (MonadIO m, MonadFail m) => MdbxTxn -- ^ The active transaction.@@ -231,3 +251,57 @@ -> m Bool -- ^ True if the key/value is lower or equal than the key. pairLEKey txn dbi end Nothing = return False pairLEKey txn dbi end (Just (key, _)) = (<= 0) <$> keyCmp txn dbi key end++{-|+Checks if the key of the key/value pair is greater or equal than the provided+key.+-}+pairGEKey+ :: (MonadIO m, MonadFail m)+ => MdbxTxn -- ^ The active transaction.+ -> MdbxDbi -- ^ The database.+ -> MdbxVal -- ^ The reference key.+ -> Maybe (MdbxVal, MdbxVal) -- ^ The key/value pair to check+ -> m Bool -- ^ True if the key/value is greater or equal than the key.+pairGEKey txn dbi end Nothing = return False+pairGEKey txn dbi end (Just (key, _)) = (>= 0) <$> keyCmp txn dbi key end++-- | Runs the given action in a read only transaction.+doInReadTxn+ :: MdbxEnv+ -> (MdbxTxn -> IO a)+ -> IO a+doInReadTxn env action = doInTxn env Nothing [MdbxTxnRdonly] action++{-|+Runs the given action in a read/write transaction, that will be aborted if an+exception is thrown and committed otherwise.+-}+doInWriteTxn+ :: MdbxEnv+ -> (MdbxTxn -> IO a)+ -> IO a+doInWriteTxn env action = doInTxn env Nothing [] action++{-|+Runs the given action in a transaction with the specified flags and, optionally,+parent transaction. The transaction will be aborted if an exception is thrown,+committed otherwise.+-}+doInTxn+ :: MdbxEnv+ -> Maybe MdbxTxn+ -> [MdbxTxnFlags]+ -> (MdbxTxn -> IO a)+ -> IO a+doInTxn env parentTxn flags action = do+ txn <- txnBegin env parentTxn flags+ handleAny (handleEx txn) $ do+ res <- action txn+ txnCommit txn+ return res+ where+ handleEx txn e = txnAbort txn >> throw e++handleAny :: (SomeException -> IO a) -> IO a -> IO a+handleAny action handler = catch handler action
test/Mdbx/DatabaseSpec.hs view
@@ -173,6 +173,32 @@ getRangePairs env db key2 key3 `shouldReturn` ([(key2, "Value 2"), (key3, "Value 3")] :: [(TestKey, Text)]) getRangePairs env db key1 key3 `shouldReturn` ([(key1, "Value 1"), (key2, "Value 2"), (key3, "Value 3")] :: [(TestKey, Text)]) + it "should insert and retrieve the bounds of pairs of keys" $ \(env, db) -> do+ let key ts = TestKey "Test" 1 ts+ let key0 = key 0+ let key1 = key 1+ let key2 = key 2+ let key3 = key 3+ let key4 = key 4+ let key5 = key 5+ let key6 = key 6+ let key8 = key 8++ putItem env db key1 ("Value 1" :: Text)+ putItem env db key2 ("Value 2" :: Text)+ putItem env db key3 ("Value 3" :: Text)+ putItem env db key4 ("Value 4" :: Text)+ putItem env db key5 ("Value 5" :: Text)+ putItem env db key8 ("Value 8" :: Text)++ getBounds env db key0 key6 `shouldReturn` Just ((key1, "Value 1" :: Text), (key5, "Value 5" :: Text))+ getBounds env db key1 key6 `shouldReturn` Just ((key1, "Value 1" :: Text), (key5, "Value 5" :: Text))+ getBounds env db key1 key5 `shouldReturn` Just ((key1, "Value 1" :: Text), (key5, "Value 5" :: Text))+ getBounds env db key3 key4 `shouldReturn` Just ((key3, "Value 3" :: Text), (key4, "Value 4" :: Text))+ getBounds env db key3 key3 `shouldReturn` Just ((key3, "Value 3" :: Text), (key3, "Value 3" :: Text))+ getBounds env db key0 key0 `shouldReturn` Nothing @((TestKey, Text), (TestKey, Text))+ getBounds env db key6 key6 `shouldReturn` Nothing @((TestKey, Text), (TestKey, Text))+ it "should remove a range of keys" $ \(env, db) -> do let key ts = TestKey "Test" 1 ts