rocksdb-haskell-jprupp 2.1.5 → 2.1.6
raw patch · 6 files changed
+216/−168 lines, 6 filesdep −string-conversionsPVP ok
version bump matches the API change (PVP)
Dependencies removed: string-conversions
API changes (from Hackage documentation)
Files
- CHANGELOG.md +5/−0
- rocksdb-haskell-jprupp.cabal +3/−4
- src/Database/RocksDB/Base.hs +2/−3
- src/Database/RocksDB/Iterator.hs +98/−100
- test/Spec.hs +108/−0
- test/tests.hs +0/−61
CHANGELOG.md view
@@ -1,3 +1,8 @@+## 2.1.6++ * Refactor memory use further.+ * Improve tests.+ ## 2.1.5 * Fix errors not releasing memory.
rocksdb-haskell-jprupp.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 7e9a6be0b5ec766b502a4a03665778ca9fd0e9b17df4f5da3f902cb7631111be+-- hash: 980f107d02562d992868728e11392b8fdba57955009c1531d95928a54247f8de name: rocksdb-haskell-jprupp-version: 2.1.5+version: 2.1.6 synopsis: Haskell bindings for RocksDB description: See README at <https://github.com/jprupp/rocksdb-haskell#readme> category: Database, FFI@@ -51,7 +51,7 @@ test-suite spec type: exitcode-stdio-1.0- main-is: tests.hs+ main-is: Spec.hs other-modules: Paths_rocksdb_haskell_jprupp hs-source-dirs:@@ -66,6 +66,5 @@ , hspec , resourcet , rocksdb-haskell-jprupp- , string-conversions , unliftio default-language: Haskell2010
src/Database/RocksDB/Base.hs view
@@ -284,9 +284,8 @@ then return Nothing else do vlen <- peek vlen_ptr- res <- Just <$> BS.packCStringLen (val_ptr, cSizeToInt vlen)- freeCString val_ptr- return res+ res <- BU.unsafePackMallocCStringLen (val_ptr, cSizeToInt vlen)+ return $ Just res delete :: MonadIO m => DB -> ByteString -> m () delete db = deleteCommon db Nothing
src/Database/RocksDB/Iterator.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ImportQualifiedPost #-}+ -- | -- Module : Database.RocksDB.Iterator -- Copyright : (c) 2012-2013 The leveldb-haskell Authors@@ -9,42 +10,39 @@ -- Portability : non-portable -- -- Iterating over key ranges.---- module Database.RocksDB.Iterator- ( Iterator- , withIter- , withIterCF- , iter- , iterCF- , iterator- , createIterator- , destroyIterator- , iterEntry- , iterFirst- , iterGetError- , iterKey- , iterLast- , iterNext- , iterPrev- , iterSeek- , iterValid- , iterValue- ) where+ ( Iterator,+ withIter,+ withIterCF,+ iter,+ iterCF,+ iterator,+ createIterator,+ destroyIterator,+ iterEntry,+ iterFirst,+ iterGetError,+ iterKey,+ iterLast,+ iterNext,+ iterPrev,+ iterSeek,+ iterValid,+ iterValue,+ )+where -import Control.Monad (when)-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Unsafe as BU-import Database.RocksDB.C-import Database.RocksDB.Internal-import Foreign-import Foreign.C.Error (throwErrnoIfNull)-import Foreign.C.String (CString, peekCString)-import Foreign.C.Types (CSize)-import UnliftIO-import UnliftIO.Resource+import Data.ByteString (ByteString)+import Data.ByteString qualified as B+import Data.ByteString.Unsafe qualified as BU+import Database.RocksDB.C+import Database.RocksDB.Internal+import Foreign+import Foreign.C.Error (throwErrnoIfNull)+import Foreign.C.String (CString)+import Foreign.C.Types (CSize)+import UnliftIO+import UnliftIO.Resource -- | Create 'Iterator' and use it. --@@ -53,10 +51,10 @@ -- however, specify an older 'Snapshot' in the 'ReadOptions'. -- -- Iterator should not be used after computation ends.-withIter :: MonadUnliftIO m => DB -> (Iterator -> m a) -> m a+withIter :: (MonadUnliftIO m) => DB -> (Iterator -> m a) -> m a withIter db = withIterCommon db Nothing -withIterCF :: MonadUnliftIO m => DB -> ColumnFamily -> (Iterator -> m a) -> m a+withIterCF :: (MonadUnliftIO m) => DB -> ColumnFamily -> (Iterator -> m a) -> m a withIterCF db cf = withIterCommon db (Just cf) -- | Variation on 'iterator' below.@@ -66,60 +64,64 @@ iterCF :: (MonadIO m, MonadResource m) => DB -> ColumnFamily -> m Iterator iterCF db cf = iterator db (Just cf) -withIterCommon :: MonadUnliftIO m- => DB- -> Maybe ColumnFamily- -> (Iterator -> m a)- -> m a-withIterCommon DB{rocksDB = rocks_db, readOpts = read_opts} mcf =- bracket create_iterator destroy_iterator+withIterCommon ::+ (MonadUnliftIO m) =>+ DB ->+ Maybe ColumnFamily ->+ (Iterator -> m a) ->+ m a+withIterCommon DB {rocksDB = rocks_db, readOpts = read_opts} mcf =+ bracket create_iterator destroy_iterator where destroy_iterator = liftIO . c_rocksdb_iter_destroy create_iterator = liftIO $- throwErrnoIfNull "create_iterator" $ case mcf of+ throwErrnoIfNull "create_iterator" $ case mcf of Just cf -> c_rocksdb_create_iterator_cf rocks_db read_opts cf Nothing -> c_rocksdb_create_iterator rocks_db read_opts -- | Iterator is not valid outside of 'ResourceT' context.-iterator :: (MonadIO m, MonadResource m)- => DB -> Maybe ColumnFamily -> m Iterator+iterator ::+ (MonadIO m, MonadResource m) =>+ DB ->+ Maybe ColumnFamily ->+ m Iterator iterator db mcf =- snd <$> allocate (createIterator db mcf) destroyIterator+ snd <$> allocate (createIterator db mcf) destroyIterator -- | Manually create unmanaged iterator.-createIterator :: MonadIO m => DB -> Maybe ColumnFamily -> m Iterator-createIterator DB{rocksDB = rocks_db, readOpts = read_opts} mcf = liftIO $- throwErrnoIfNull "create_iterator" $ case mcf of- Just cf -> c_rocksdb_create_iterator_cf rocks_db read_opts cf- Nothing -> c_rocksdb_create_iterator rocks_db read_opts+createIterator :: (MonadIO m) => DB -> Maybe ColumnFamily -> m Iterator+createIterator DB {rocksDB = rocks_db, readOpts = read_opts} mcf = liftIO $+ throwErrnoIfNull "create_iterator" $ case mcf of+ Just cf -> c_rocksdb_create_iterator_cf rocks_db read_opts cf+ Nothing -> c_rocksdb_create_iterator rocks_db read_opts -- | Destroy unmanaged iterator.-destroyIterator :: MonadIO m => Iterator -> m ()+destroyIterator :: (MonadIO m) => Iterator -> m () destroyIterator = liftIO . c_rocksdb_iter_destroy -- | An iterator is either positioned at a key/value pair, or not valid. This -- function returns /true/ iff the iterator is valid.-iterValid :: MonadIO m => Iterator -> m Bool+iterValid :: (MonadIO m) => Iterator -> m Bool iterValid iter_ptr = liftIO $ do- x <- c_rocksdb_iter_valid iter_ptr- return (x /= 0)+ x <- c_rocksdb_iter_valid iter_ptr+ return (x /= 0) -- | Position at the first key in the source that is at or past target. The -- iterator is /valid/ after this call iff the source contains an entry that -- comes at or past target.-iterSeek :: MonadIO m => Iterator -> ByteString -> m ()+iterSeek :: (MonadIO m) => Iterator -> ByteString -> m () iterSeek iter_ptr key = liftIO $- BU.unsafeUseAsCStringLen key $ \(key_ptr, klen) ->+ BU.unsafeUseAsCStringLen key $ \(key_ptr, klen) -> c_rocksdb_iter_seek iter_ptr key_ptr (intToCSize klen) -- | Position at the first key in the source. The iterator is /valid/ after this -- call iff the source is not empty.-iterFirst :: MonadIO m => Iterator -> m ()+iterFirst :: (MonadIO m) => Iterator -> m () iterFirst = liftIO . c_rocksdb_iter_seek_to_first -- | Position at the last key in the source. The iterator is /valid/ after this -- call iff the source is not empty.-iterLast :: MonadIO m => Iterator -> m ()+iterLast :: (MonadIO m) => Iterator -> m () iterLast = liftIO . c_rocksdb_iter_seek_to_last -- | Moves to the next entry in the source. After this call, 'iterValid' is@@ -128,10 +130,8 @@ -- If the iterator is not valid, this function does nothing. Note that this is a -- shortcoming of the C API: an 'iterPrev' might still be possible, but we can't -- determine if we're at the last or first entry.-iterNext :: MonadIO m => Iterator -> m ()-iterNext iter_ptr = liftIO $ do- valid <- c_rocksdb_iter_valid iter_ptr- when (valid /= 0) $ c_rocksdb_iter_next iter_ptr+iterNext :: (MonadIO m) => Iterator -> m ()+iterNext iter_ptr = liftIO $ c_rocksdb_iter_next iter_ptr -- | Moves to the previous entry in the source. After this call, 'iterValid' is -- /true/ iff the iterator was not positioned at the first entry in the source.@@ -139,57 +139,55 @@ -- If the iterator is not valid, this function does nothing. Note that this is a -- shortcoming of the C API: an 'iterNext' might still be possible, but we can't -- determine if we're at the last or first entry.-iterPrev :: MonadIO m => Iterator -> m ()-iterPrev iter_ptr = liftIO $ do- valid <- c_rocksdb_iter_valid iter_ptr- when (valid /= 0) $ c_rocksdb_iter_prev iter_ptr+iterPrev :: (MonadIO m) => Iterator -> m ()+iterPrev iter_ptr = liftIO $ c_rocksdb_iter_prev iter_ptr -- | Return the key for the current entry if the iterator is currently -- positioned at an entry, ie. 'iterValid'.-iterKey :: MonadIO m => Iterator -> m (Maybe ByteString)-iterKey = liftIO . flip iterString c_rocksdb_iter_key+iterKey :: (MonadIO m) => Iterator -> m (Maybe ByteString)+iterKey it = liftIO $ iterString it c_rocksdb_iter_key -- | Return the value for the current entry if the iterator is currently -- positioned at an entry, ie. 'iterValid'.-iterValue :: MonadIO m => Iterator -> m (Maybe ByteString)-iterValue = liftIO . flip iterString c_rocksdb_iter_value+iterValue :: (MonadIO m) => Iterator -> m (Maybe ByteString)+iterValue it = liftIO $ iterString it c_rocksdb_iter_value -- | Return the current entry as a pair, if the iterator is currently positioned -- at an entry, ie. 'iterValid'.-iterEntry :: MonadIO m => Iterator -> m (Maybe (ByteString, ByteString))+iterEntry :: (MonadIO m) => Iterator -> m (Maybe (ByteString, ByteString)) iterEntry it = liftIO $ do- mkey <- iterKey it- mval <- iterValue it- return $ (,) <$> mkey <*> mval+ mkey <- iterKey it+ mval <- iterValue it+ return $ (,) <$> mkey <*> mval -- | Check for errors -- -- Note that this captures somewhat severe errors such as a corrupted database.-iterGetError :: MonadIO m => Iterator -> m (Maybe ByteString)-iterGetError iter_ptr = liftIO . alloca $ \err_ptr -> do- poke err_ptr nullPtr- c_rocksdb_iter_get_error iter_ptr err_ptr- erra <- peek err_ptr- if erra == nullPtr- then return Nothing- else do- err <- peekCString erra- return $ Just (BC.pack err)+iterGetError :: (MonadIO m) => Iterator -> m (Maybe ByteString)+iterGetError iter_ptr = liftIO $ alloca $ \err_ptr -> do+ poke err_ptr nullPtr+ c_rocksdb_iter_get_error iter_ptr err_ptr+ err_str <- peek err_ptr+ if err_str == nullPtr+ then return Nothing+ else Just <$> BU.unsafePackMallocCString err_str -- -- Internal -- -iterString :: Iterator- -> (Iterator -> Ptr CSize -> IO CString)- -> IO (Maybe ByteString)-iterString iter_ptr f =- c_rocksdb_iter_valid iter_ptr >>= \case- 0 -> return Nothing- _ -> alloca $ \len_ptr ->- f iter_ptr len_ptr >>= \ptr ->- if ptr == nullPtr- then return Nothing- else do- len <- peek len_ptr- Just <$> BS.packCStringLen (ptr, cSizeToInt len)+iterString ::+ Iterator ->+ (Iterator -> Ptr CSize -> IO CString) ->+ IO (Maybe ByteString)+iterString it f = do+ valid <- iterValid it+ if valid+ then alloca $ \len_ptr -> do+ str_ptr <- f it len_ptr+ if str_ptr == nullPtr+ then return Nothing+ else do+ len <- peek len_ptr+ Just <$> B.packCStringLen (str_ptr, cSizeToInt len)+ else return Nothing
+ test/Spec.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++import Control.Monad+import Data.ByteString.Char8 qualified as C+import Data.Default (def)+import Data.Maybe+import Database.RocksDB+import Test.Hspec+import Text.Printf+import UnliftIO++conf :: Config+conf =+ def+ { createIfMissing = True,+ errorIfExists = True,+ bloomFilter = True,+ prefixLength = Just 3+ }++withTestDBCF :: (MonadUnliftIO m) => [String] -> (DB -> m a) -> m a+withTestDBCF cfs go =+ withSystemTempDirectory "rocksdb-tests-cf" $ \path ->+ withDBCF path conf (map (,conf) cfs) go++main :: IO ()+main = do+ hspec $ around (withTestDBCF ["one", "two", "tree"]) $ do+ describe "Database" $ do+ it "puts and gets an item" $ \db -> do+ put db "aaa" "zzz"+ get db "aaa" `shouldReturn` Just "zzz"+ it "puts and gets from different type families" $ \db -> do+ let two = head $ columnFamilies db+ put db "aaa_key" "aaa_value"+ get db "aaa_key" `shouldReturn` Just "aaa_value"+ getCF db two "aaa_key" `shouldReturn` Nothing+ putCF db two "two_key" "two_value"+ getCF db two "two_key" `shouldReturn` Just "two_value"+ get db "two_key" `shouldReturn` Nothing+ describe "Multithreading" $ do+ it "stores and retrieve items from multiple threads" $ \db -> do+ let key i = C.pack $ printf "key_%04d" i+ val i = C.pack $ printf "val_%04d" i+ indices = [0 .. 9999] :: [Int]+ keys = map key indices+ vals = map val indices+ kvs = zip keys vals+ was <- mapM (\(k, v) -> async $ put db k v) kvs+ mapM_ wait was+ ras <- mapM (async . get db) keys+ mapM wait ras `shouldReturn` map Just vals+ describe "Iterators" $ do+ it "retrieves entries using iterators" $ \db -> do+ let key i = C.pack $ printf "key_%03d" i+ val i = C.pack $ printf "val_%03d" i+ indices = [0 .. 999] :: [Int]+ keys = map key indices+ vals = map val indices+ kvs = zip keys vals+ was <- mapM (\(k, v) -> async $ put db k v) kvs+ mapM_ wait was+ kvs' <- withIter db $ \itr -> do+ let start = keys !! 500+ iterSeek itr start+ fmap catMaybes $ replicateM 500 $ do+ mkv <- iterEntry itr+ iterNext itr+ return mkv+ kvs' `shouldBe` drop 500 kvs+ it "walks back and forth" $ \db -> do+ withIter db $ \itr -> do+ iterSeek itr "hello"+ iterKey itr `shouldReturn` Nothing+ iterValue itr `shouldReturn` Nothing+ iterEntry itr `shouldReturn` Nothing+ put db "a" "aaa"+ put db "b" "bbb"+ put db "c" "ccc"+ withIter db $ \itr -> do+ iterSeek itr "b"+ iterKey itr `shouldReturn` Just "b"+ iterValue itr `shouldReturn` Just "bbb"+ iterNext itr+ iterKey itr `shouldReturn` Just "c"+ iterValue itr `shouldReturn` Just "ccc"+ iterNext itr -- After the last entry+ iterKey itr `shouldReturn` Nothing+ iterValue itr `shouldReturn` Nothing+ iterPrev itr -- It can't come back+ iterKey itr `shouldReturn` Nothing+ iterValue itr `shouldReturn` Nothing+ withIter db $ \itr -> do+ iterSeek itr "b"+ iterKey itr `shouldReturn` Just "b"+ iterValue itr `shouldReturn` Just "bbb"+ iterPrev itr+ iterKey itr `shouldReturn` Just "a"+ iterValue itr `shouldReturn` Just "aaa"+ iterPrev itr -- Invalid before lowest key+ iterKey itr `shouldReturn` Nothing+ iterValue itr `shouldReturn` Nothing+ iterNext itr -- But it remembers previous position+ iterKey itr `shouldReturn` Just "b"+ iterValue itr `shouldReturn` Just "bbb"
− test/tests.hs
@@ -1,61 +0,0 @@-{-# LANGUAGE BinaryLiterals #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}--module Main where--import Data.Default (def)-import Data.String.Conversions-import Database.RocksDB-import Test.Hspec (describe, hspec, it, shouldReturn)-import UnliftIO--conf :: Config-conf = def { createIfMissing = True- , errorIfExists = True- , bloomFilter = True- , prefixLength = Just 3- }--withTestDB :: MonadUnliftIO m => FilePath -> (DB -> m a) -> m a-withTestDB path =- withDB path conf--withTestDBCF :: MonadUnliftIO m => FilePath -> [String] -> (DB -> m a) -> m a-withTestDBCF path cfs =- withDBCF path conf (map (,conf) cfs)--main :: IO ()-main = do- hspec $ do- describe "Database engine" $ do- it "should put items into the database and retrieve them" $- withSystemTempDirectory "rocksdb1" $ \path ->- withTestDB path $ \db -> do- put db "zzz" "zzz"- get db "zzz" `shouldReturn` Just "zzz"- it "should store and retrieve items from different column families" $- withSystemTempDirectory "rocksdbcf1" $ \path ->- withTestDBCF path ["two"] $ \db -> do- let two = head $ columnFamilies db- put db "one" "one"- get db "one" `shouldReturn` Just "one"- getCF db two "one" `shouldReturn` Nothing- putCF db two "two" "two"- getCF db two "two" `shouldReturn` Just "two"- get db "two" `shouldReturn` Nothing- describe "Multiple concurrent threads" $ do- it "should be able to put and retrieve items" $- withSystemTempDirectory "rocksdb2" $ \path ->- withTestDB path $ \db -> do- let str = cs . show- key i = "key" <> str i- val i = "val" <> str i- indices = [1..500] :: [Int]- keys = map key indices- vals = map val indices- kvs = zip keys vals- as1 <- mapM (\(k, v) -> async $ put db k v) kvs- mapM_ wait as1- as2 <- mapM (async . get db) keys- mapM wait as2 `shouldReturn` map Just vals