diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/libmdbx.cabal b/libmdbx.cabal --- a/libmdbx.cabal +++ b/libmdbx.cabal @@ -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 diff --git a/src/Mdbx/Database.hs b/src/Mdbx/Database.hs --- a/src/Mdbx/Database.hs +++ b/src/Mdbx/Database.hs @@ -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 diff --git a/test/Mdbx/DatabaseSpec.hs b/test/Mdbx/DatabaseSpec.hs --- a/test/Mdbx/DatabaseSpec.hs +++ b/test/Mdbx/DatabaseSpec.hs @@ -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