rocksdb-haskell-jprupp 2.6.2 → 2.6.3
raw patch · 8 files changed
+779/−401 lines, 8 filesdep +containersPVP ok
version bump matches the API change (PVP)
Dependencies added: containers
API changes (from Hackage documentation)
Files
- CHANGELOG.md +18/−0
- README.md +20/−2
- rocksdb-haskell-jprupp.cabal +2/−1
- src/Database/RocksDB.hs +1/−1
- src/Database/RocksDB/Base.hs +8/−8
- src/Database/RocksDB/Internal.hs +9/−8
- src/Database/RocksDB/Iterator.hs +6/−5
- test/Spec.hs +715/−376
CHANGELOG.md view
@@ -1,3 +1,21 @@+## 2.6.3++ * Documentation only; the library behaves as in 2.6.2.+ * References in the Haddock that named both a type and its constructor, such+ as `DB` and `Config`, now say that they mean the type, and two that named+ nothing in scope are fixed: the documentation builds without warnings about+ ambiguous or unresolved identifiers.+ * The documentation of `withIter` said to set a snapshot in the read options,+ which the API has no way to do. It now says how: create the iterator from+ the `DB` that `withSnapshot` provides.+ * Remove an unused import.+ * The test suite grows from 17 tests to 51. It now covers deletes, batches,+ `withSnapshot`, iteration backwards, empty keys and values, binary data,+ and the errors of opening a database, none of which had a test. Six of the+ tests are QuickCheck properties that compare the database with a `Map`+ after random writes. The suite also compiles without warnings.+ * A badge in the README shows the state of CI on `master`.+ ## 2.6.2 * Build the Bloom filters that `bloomFilter` asks for. The bits per key were
README.md view
@@ -1,8 +1,11 @@ # rocksdb-haskell-jprupp [![Hackage][hackage-badge]][hackage]+[![CI][ci-badge]][ci] [![License: BSD-3-Clause][license-badge]][license] +[ci]: https://github.com/jprupp/rocksdb-haskell/actions/workflows/ci.yml+[ci-badge]: https://github.com/jprupp/rocksdb-haskell/actions/workflows/ci.yml/badge.svg?branch=master [hackage]: https://hackage.haskell.org/package/rocksdb-haskell-jprupp [hackage-badge]: https://img.shields.io/hackage/v/rocksdb-haskell-jprupp.svg [license]: https://github.com/jprupp/rocksdb-haskell/blob/master/LICENSE@@ -181,7 +184,7 @@ ```yaml extra-deps:- - rocksdb-haskell-jprupp-2.6.2+ - rocksdb-haskell-jprupp-2.6.3 ``` With `stack --nix`, add RocksDB to the Nix packages:@@ -530,7 +533,22 @@ generates. The tests are in `test/Spec.hs` and use [hspec](https://hspec.github.io/) and-QuickCheck. Each test runs against a fresh database in a temporary directory.+QuickCheck. Each test runs against a fresh database in a temporary directory,+so they need RocksDB installed and nothing else. There are two kinds:++- **Examples** pin down one behaviour each: what a function returns, when it+ throws, what a setting changes in the files RocksDB writes. A test of a+ setting checks an effect that can be observed, such as the size of the+ filter blocks, because a wrong binding can do nothing without failing.+- **Properties** apply random writes to the database and to a `Map`, and+ require that every way of reading the database agrees with the map: point+ reads, `multiGet`, iteration in both directions, seeks, snapshots and+ column families. The keys are short and drawn from the bytes a binding is+ most likely to mishandle, zero and 255, so that operations often meet on+ the same key.++`destroy` and `repair` have no tests: they take the `Options` of the C API,+which this package gives no way to create. ### Contributing
rocksdb-haskell-jprupp.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: rocksdb-haskell-jprupp-version: 2.6.2+version: 2.6.3 synopsis: Haskell bindings for RocksDB description: See README at <https://github.com/jprupp/rocksdb-haskell#readme> category: Database, FFI@@ -58,6 +58,7 @@ , async , base >=4.9 && <5 , bytestring+ , containers , data-default , directory , hspec
src/Database/RocksDB.hs view
@@ -42,7 +42,7 @@ -- Serialization is a separate concern. -- -- * __Memory you can bound.__ RocksDB keeps a lot of memory outside the Haskell--- heap. 'Config' exposes the settings that put a ceiling on it, because an+-- heap. t'Config' exposes the settings that put a ceiling on it, because an -- indexer that grows until the machine runs out of memory is not usable. -- -- This is the only module that needs to be imported. It re-exports
src/Database/RocksDB/Base.hs view
@@ -17,7 +17,7 @@ -- and 'createIterator' exist for cases where the lifetime of a resource cannot -- be expressed as a scope. ----- A 'DB' handle is safe to use from many threads at once.+-- A t'DB' handle is safe to use from many threads at once. module Database.RocksDB.Base ( -- * Exported Types@@ -58,7 +58,7 @@ ) where import Control.Exception-import Control.Monad (forM, when, (>=>))+import Control.Monad (forM, when) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.ByteString.Internal (ByteString (..))@@ -125,7 +125,7 @@ -- families must be opened with 'withDBCF'. -- -- Opening is expensive and a database can only be opened by one process at a--- time, so open it once at program start and share the 'DB' between threads for+-- time, so open it once at program start and share the t'DB' between threads for -- the life of the program. withDB :: FilePath -> Config -> (DB -> IO a) -> IO a withDB path config f =@@ -152,12 +152,12 @@ -- -- The second argument configures the database and its default column family. -- The third argument lists the other column families by name, each with its own--- 'Config'. Their handles are stored in 'columnFamilies', in the same order.+-- t'Config'. Their handles are stored in 'columnFamilies', in the same order. -- -- If the database directory is empty, a new database is created along with all -- the listed column families. Otherwise the existing database is opened with -- those column families; if some of them do not exist yet, the open fails unless--- 'createMissingColumnFamilies' is set in the database 'Config'. RocksDB also+-- 'createMissingColumnFamilies' is set in the database t'Config'. RocksDB also -- requires every column family that exists in the database to be listed. -- -- The handle and all column family handles are released when the function@@ -247,9 +247,9 @@ } -- | Run an action with a snapshot of the database.--- The 'DB' object is not valid after the action ends.+-- The t'DB' object is not valid after the action ends. ----- The 'DB' passed to the action reads from a consistent point-in-time view of+-- The t'DB' passed to the action reads from a consistent point-in-time view of -- the database: 'get', 'multiGet' and iterators created from it do not see -- writes made after the snapshot was taken. Writes through it still go to the -- live database.@@ -263,7 +263,7 @@ bracket (createSnapshot db) releaseSnapshot (f . fst) -- | Manually create an unmanaged snapshot.--- The returned 'DB' has 'readOpts' configured for the snapshot.+-- The returned t'DB' has 'readOpts' configured for the snapshot. -- Use 'releaseSnapshot' to release both the snapshot and its read options. createSnapshot :: DB -> IO (DB, Snapshot) createSnapshot db@DB{rocksDB = db_ptr} = do
src/Database/RocksDB/Internal.hs view
@@ -8,7 +8,7 @@ -- Stability : experimental -- Portability : non-portable ----- Internal types and helpers shared by the other modules. The 'DB' and 'Config'+-- Internal types and helpers shared by the other modules. The t'DB' and t'Config' -- types are re-exported by "Database.RocksDB"; everything else is an -- implementation detail. @@ -86,8 +86,9 @@ -- ^ check data aggressively and stop early on any -- corruption , createMissingColumnFamilies :: !Bool- -- ^ create the column families passed to 'withDBCF'- -- that an existing database does not have yet+ -- ^ create the column families passed to+ -- 'Database.RocksDB.withDBCF' that an existing+ -- database does not have yet , maxFiles :: !(Maybe Int) -- ^ maximum number of files RocksDB keeps open -- ('Nothing': RocksDB default, unlimited)@@ -140,7 +141,7 @@ , maxTotalWalSize = Nothing } --- | Create RocksDB options from a 'Config' and pass them to a function. The+-- | Create RocksDB options from a t'Config' and pass them to a function. The -- options are destroyed when it returns. withOptions :: Config -> (Options -> IO a) -> IO a withOptions = withOptionsCache Nothing@@ -270,22 +271,22 @@ boolToCBool False = 0 {-# INLINE boolToCBool #-} --- | Convert a 'CSize' to an 'Int'.+-- | Convert a t'CSize' to an 'Int'. cSizeToInt :: CSize -> Int cSizeToInt = fromIntegral {-# INLINE cSizeToInt #-} --- | Convert an 'Int' to a 'CSize'.+-- | Convert an 'Int' to a t'CSize'. intToCSize :: Int -> CSize intToCSize = fromIntegral {-# INLINE intToCSize #-} --- | Convert an 'Int' to a 'CInt'.+-- | Convert an 'Int' to a t'CInt'. intToCInt :: Int -> CInt intToCInt = fromIntegral {-# INLINE intToCInt #-} --- | Convert a 'CInt' to an 'Int'.+-- | Convert a t'CInt' to an 'Int'. cIntToInt :: CInt -> Int cIntToInt = fromIntegral {-# INLINE cIntToInt #-}
src/Database/RocksDB/Iterator.hs view
@@ -87,8 +87,9 @@ -- | Create 'Iterator' and use it. -- -- Note that an 'Iterator' creates a snapshot of the database implicitly, so--- updates written after the iterator was created are not visible. You may,--- however, specify an older 'Snapshot' in the 'ReadOptions'.+-- updates written after the iterator was created are not visible. To read+-- from an older 'Snapshot' instead, create the iterator from the t'DB' that+-- 'Database.RocksDB.withSnapshot' provides: its 'readOpts' carry the snapshot. -- -- Iterator should not be used after computation ends. withIter :: DB -> (Iterator -> IO a) -> IO a@@ -155,10 +156,10 @@ Nothing -> c_rocksdb_create_iterator rocks_db ro -- | Manually create unmanaged iterator, over the default column family or over--- a column family if one is given. It uses the 'readOpts' of the 'DB', so if--- the 'DB' comes from 'Database.RocksDB.withSnapshot' it reads from that+-- a column family if one is given. It uses the 'readOpts' of the t'DB', so if+-- the t'DB' comes from 'Database.RocksDB.withSnapshot' it reads from that -- snapshot. It must be released with 'destroyIterator', and must not outlive--- the 'DB'.+-- the t'DB'. createIterator :: DB -> Maybe ColumnFamily -> IO Iterator createIterator DB{rocksDB = rocks_db, readOpts = read_opts} mcf = throwErrnoIfNull "create_iterator" $ case mcf of
test/Spec.hs view
@@ -1,376 +1,715 @@-{-# LANGUAGE BinaryLiterals #-}-{-# LANGUAGE ImportQualifiedPost #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}--import Control.Concurrent-import Control.Concurrent.Async-import Control.Monad-import Data.ByteString.Char8 qualified as C-import Data.Default (def)-import Data.Maybe-import Database.RocksDB-import System.IO.Temp-import Test.Hspec-import Text.Printf--conf :: Config-conf =- def- { createIfMissing = True,- errorIfExists = True,- bloomFilter = True,- prefixLength = Just 3- }--withTestDBCF :: [String] -> (DB -> IO a) -> IO 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 "Multi-get" $ do- it "reads many keys at once, in order, with missing ones" $ \db -> do- let one = head (columnFamilies db)- forM_ [1 .. 100 :: Int] $ \i -> do- put db (C.pack (show i)) (C.pack ("v" <> show i))- putCF db one (C.pack (show i)) (C.pack ("one" <> show i))- let keys = map (C.pack . show) [50, 0, 1, 100, 101, 50 :: Int]- multiGet db keys- `shouldReturn` [Just "v50", Nothing, Just "v1", Just "v100", Nothing, Just "v50"]- multiGetCF db one keys- `shouldReturn` [Just "one50", Nothing, Just "one1", Just "one100", Nothing, Just "one50"]- multiGet db [] `shouldReturn` []- ks <- forM [1 .. 2000 :: Int] $ \i -> return (C.pack (show (i `mod` 150)))- let expected k- | read (C.unpack k) `elem` [1 .. 100 :: Int] = Just ("v" <> k)- | otherwise = Nothing- multiGet db ks `shouldReturn` map expected ks- 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 -- Invalid iterator stays invalid- iterKey itr `shouldReturn` Nothing- iterValue itr `shouldReturn` Nothing- describe "Snapshots" $ do- it "getCF and iterator see same data during concurrent writes" $ \db -> do- let cf = head $ columnFamilies db- -- Initial data- putCF db cf "key1" "val1"- putCF db cf "key2" "val2"- putCF db cf "key3" "val3"-- -- Create snapshot- (snapDB, snap) <- createSnapshot db-- -- Start writer thread modifying the same keys- started <- newEmptyMVar- writerThread <- forkIO $ do- putMVar started ()- let loop n- | n > 100 = pure ()- | otherwise = do- let suffix = C.pack $ "-v" <> show n- putCF db cf "key1" ("val1" <> suffix)- putCF db cf "key2" ("val2" <> suffix)- putCF db cf "key3" ("val3" <> suffix)- threadDelay 500- loop (n + 1 :: Int)- loop (0 :: Int)-- takeMVar started- threadDelay 1000 -- Let writer get going-- -- Read via getCF on snapshot- v1 <- getCF snapDB cf "key1"- threadDelay 10000- v2 <- getCF snapDB cf "key2"- threadDelay 10000- v3 <- getCF snapDB cf "key3"-- -- Read via iterator on same snapshot (using the same column family)- iterEntries <- withIterCF snapDB cf $ \itr -> do- iterFirst itr- let collect acc = do- valid <- iterValid itr- if valid- then do- mentry <- iterEntry itr- iterNext itr- collect (mentry : acc)- else pure (reverse acc)- catMaybes <$> collect []-- -- Clean up- killThread writerThread- releaseSnapshot (snapDB, snap)-- -- Verify: getCF and iterator see the same original values- v1 `shouldBe` Just "val1"- v2 `shouldBe` Just "val2"- v3 `shouldBe` Just "val3"- iterEntries `shouldBe` [("key1", "val1"), ("key2", "val2"), ("key3", "val3")]-- it "withIterSnap sees snapshot data" $ \db -> do- put db "a" "1"- put db "b" "2"- (_, snap) <- createSnapshot db- -- Modify after snapshot- put db "a" "modified"- put db "c" "3"- -- Iterator with explicit snapshot should see original data- entries <- withIterSnap db (Just snap) $ \itr -> do- iterFirst itr- let collect acc = do- valid <- iterValid itr- if valid- then do- mentry <- iterEntry itr- iterNext itr- collect (mentry : acc)- else pure (reverse acc)- catMaybes <$> collect []- entries `shouldBe` [("a", "1"), ("b", "2")]-- it "withIterSnapCF sees snapshot data on column family" $ \db -> do- let cf = head $ columnFamilies db- putCF db cf "x" "100"- putCF db cf "y" "200"- (_, snap) <- createSnapshot db- -- Modify after snapshot- putCF db cf "x" "modified"- putCF db cf "z" "300"- -- Iterator with explicit snapshot on CF- entries <- withIterSnapCF db (Just snap) cf $ \itr -> do- iterFirst itr- let collect acc = do- valid <- iterValid itr- if valid- then do- mentry <- iterEntry itr- iterNext itr- collect (mentry : acc)- else pure (reverse acc)- catMaybes <$> collect []- entries `shouldBe` [("x", "100"), ("y", "200")]-- it "createIteratorSnap with manual management" $ \db -> do- put db "m" "10"- put db "n" "20"- (_, snap) <- createSnapshot db- put db "m" "changed"- -- Manual iterator creation with snapshot- (itr, mReadOpts) <- createIteratorSnap db (Just snap) Nothing- iterFirst itr- k1 <- iterKey itr- v1 <- iterValue itr- iterNext itr- k2 <- iterKey itr- v2 <- iterValue itr- destroyIterator itr- forM_ mReadOpts destroyReadOpts- (k1, v1) `shouldBe` (Just "m", Just "10")- (k2, v2) `shouldBe` (Just "n", Just "20")- describe "Write buffers" $ do- it "flushes small memtables and keeps the data" $ \_ -> do- let small =- conf- { writeBufferSize = Just (64 * 1024),- dbWriteBufferSize = Just (256 * 1024)- }- cfConf = small {dbWriteBufferSize = Nothing}- key :: Int -> C.ByteString- key i = C.pack (printf "k%07d" i)- value = C.replicate 100 'v'- withSystemTempDirectory "rocksdb-tests-wb" $ \path ->- withDBCF path small [("one", cfConf), ("two", cfConf)] $ \db -> do- let [one, two] = columnFamilies db- forM_ [1 .. 20000] $ \i -> do- put db (key i) value- putCF db one (key i) value- putCF db two (key i) value- get db (key 1) `shouldReturn` Just value- getCF db one (key 10000) `shouldReturn` Just value- getCF db two (key 20000) `shouldReturn` Just value- files <- getProperty db SSTables- files `shouldSatisfy` maybe False (not . C.null)- describe "Bloom filters" $ do- it "are built for a family that asks for one, and only for it" $ \_ ->- withSystemTempDirectory "rocksdb-tests-bloom" $ \path -> do- let open = def {createIfMissing = True, createMissingColumnFamilies = True}- families = [("with", def {bloomFilter = True}), ("without", def)]- key :: Int -> C.ByteString- key i = C.pack (printf "k%07d" i)- -- bytes of filter blocks in the table files of a family- filters d cf =- getPropertyCF d cf (PropertyName "rocksdb.aggregated-table-properties")- >>= maybe (fail "no table properties") (return . tableProperty "filter block size")- both d = case columnFamilies d of- [a, b] -> return (a, b)- _ -> fail "expected two column families"- withDBCF path open families $ \db -> do- (with, without) <- both db- forM_ [1 .. 5000] $ \i -> putCF db with (key i) "value" >> putCF db without (key i) "value"- -- opening the database again moves what was written from the- -- write-ahead log to table files, which is where filters are- withDBCF path open families $ \db -> do- (with, without) <- both db- -- ten bits for each of the 5000 keys is 6250 bytes- filters db with >>= (`shouldSatisfy` maybe False (> 5000))- filters db without `shouldReturn` Just 0- getCF db with (key 2500) `shouldReturn` Just "value"- getCF db with "absent" `shouldReturn` Nothing- describe "Approximate sizes" $ do- it "estimates the space used by a range of keys" $ \_ ->- withSystemTempDirectory "rocksdb-tests-sizes" $ \path -> do- let open = def {createIfMissing = True}- key :: Int -> C.ByteString- key i = C.pack (printf "k%07d" i)- withDB path open $ \db ->- forM_ [1 .. 5000] $ \i -> put db (key i) (C.pack (printf "%0100d" i))- -- sizes are those of table files; see the test of Bloom filters- withDB path open $ \db -> do- approximateSize db (key 1, key 5000) >>= (`shouldSatisfy` (> 0))- approximateSize db ("x", "y") `shouldReturn` 0- describe "Properties" $ do- it "reports memory use, per database and per column family" $ \db -> do- let one = head (columnFamilies db)- isNumber = maybe False (\v -> not (C.null v) && C.all (`elem` ['0' .. '9']) v)- forM_ [1 .. 1000 :: Int] $ \i -> putCF db one (C.pack (show i)) "value"- mem <- getPropertyCF db one CurSizeAllMemTables- mem `shouldSatisfy` isNumber- mem `shouldSatisfy` maybe False ((> 0) . read . C.unpack)- getProperty db EstimateTableReadersMem >>= (`shouldSatisfy` isNumber)- getProperty db BlockCacheUsage >>= (`shouldSatisfy` isNumber)- getProperty db (PropertyName "rocksdb.num-immutable-mem-table")- >>= (`shouldSatisfy` isNumber)- getProperty db (PropertyName "rocksdb.no-such-property")- `shouldReturn` Nothing- it "shares one block cache, holding index and filter blocks" $ \_ -> do- let size = 8 * 1024 * 1024- cached =- conf- { errorIfExists = False,- blockCacheSize = Just size,- cacheIndexAndFilterBlocks = True,- writeBufferSize = Just (64 * 1024)- }- key :: Int -> C.ByteString- key i = C.pack (printf "k%07d" i)- value = C.replicate 100 'v'- capacity d cf =- maybe (getProperty d p) (\c -> getPropertyCF d c p) cf- where- p = PropertyName "rocksdb.block-cache-capacity"- withSystemTempDirectory "rocksdb-tests-cache" $ \path -> do- withDBCF path cached [("one", cached)] $ \db -> do- let one = head (columnFamilies db)- forM_ [1 .. 20000] $ \i -> putCF db one (key i) value- withDBCF path cached [("one", cached)] $ \db -> do- let one = head (columnFamilies db)- capacity db Nothing `shouldReturn` Just (C.pack (show size))- capacity db (Just one) `shouldReturn` Just (C.pack (show size))- multiGetCF db one (map key [1, 10000, 20000])- `shouldReturn` replicate 3 (Just value)- usage <- getProperty db BlockCacheUsage- usage `shouldSatisfy` maybe False ((> 0) . (read :: String -> Int) . C.unpack)- it "opens with a bound on the write-ahead log" $ \_ ->- withSystemTempDirectory "rocksdb-tests-wal" $ \path ->- withDBCF path conf {maxTotalWalSize = Just (1024 * 1024)} [("one", conf)] $ \db -> do- put db "key" "value"- get db "key" `shouldReturn` Just "value"- describe "Column families" $ do- it "adds a column family to an existing database" $ \_ ->- withSystemTempDirectory "rocksdb-tests-newcf" $ \path -> do- let open = conf {errorIfExists = False}- withDBCF path open [("one", open)] $ \db -> put db "key" "value"- withDBCF path open {createMissingColumnFamilies = True} [("one", open), ("two", open)] $ \db -> do- get db "key" `shouldReturn` Just "value"- let two = columnFamilies db !! 1- putCF db two "new" "cf"- getCF db two "new" `shouldReturn` Just "cf"---- | A number in the text of the @rocksdb.aggregated-table-properties@--- property, which reads @name=value; name=value; ...@.-tableProperty :: C.ByteString -> C.ByteString -> Maybe Int-tableProperty name text =- listToMaybe- [ n- | field <- C.split ';' text,- let (k, v) = C.break (== '=') (C.dropWhile (== ' ') field),- k == name,- Just (n, _) <- [C.readInt (C.drop 1 v)]- ]+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++-- |+-- Tests of "Database.RocksDB" against a real RocksDB, in temporary+-- directories.+--+-- There are two kinds of test here, because the bindings can go wrong in two+-- ways:+--+-- * Examples, which pin down one behaviour each: what a function returns, when+-- it throws, what a setting changes in the files RocksDB writes. Several+-- exist because a binding was once wrong without anything failing, so they+-- check an effect that can be observed rather than that a call returns.+--+-- * Properties, which run random sequences of writes against the database and+-- against a 'Map', and require that the two agree however they are read.+-- They find what nobody thought to write an example for: empty keys and+-- values, bytes that C would take for the end of a string, a delete of a key+-- that was never there, the order of iteration.+--+-- Every test opens its own database, so tests do not depend on each other or+-- on the order they run in.+module Main (main) where++import Control.Concurrent+import Control.Concurrent.Async+import Control.Exception (bracket)+import Control.Monad+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.ByteString.Char8 qualified as C+import Data.Default (def)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe+import Database.RocksDB+import System.IO.Temp+import Test.Hspec+import Test.Hspec.QuickCheck (modifyMaxSuccess, prop)+import Test.QuickCheck hiding (Property)+import Test.QuickCheck qualified as QC+import Text.Printf++main :: IO ()+main = hspec $ do+ around (withTunedDB ["one", "two", "tree"]) tunedSpec+ around withPlainDB plainSpec+ openingSpec+ tuningSpec+ modifyMaxSuccess (const 50) modelSpec++-------------------------------------------------------------------------------+-- Databases to test against+-------------------------------------------------------------------------------++-- | A configuration with a Bloom filter and a prefix extractor, as a program+-- tuned for point lookups would have. The older tests run against it.+tuned :: Config+tuned =+ def+ { createIfMissing = True,+ errorIfExists = True,+ bloomFilter = True,+ prefixLength = Just 3+ }++-- | The defaults, creating the database. Tests that iterate over the whole+-- database use it, since a prefix extractor changes what a seek promises.+plain :: Config+plain = def {createIfMissing = True}++-- | Run a test in a temporary directory that is deleted afterwards.+withTempPath :: (FilePath -> IO a) -> IO a+withTempPath = withSystemTempDirectory "rocksdb-tests"++-- | A new 'tuned' database with the given column families.+withTunedDB :: [String] -> (DB -> IO a) -> IO a+withTunedDB cfs go =+ withTempPath $ \path -> withDBCF path tuned (map (,tuned) cfs) go++-- | A new 'plain' database with one column family besides the default.+withPlainDB :: (DB -> IO a) -> IO a+withPlainDB go =+ withTempPath $ \path ->+ withDBCF path plain {createMissingColumnFamilies = True} [("other", plain)] go++-------------------------------------------------------------------------------+-- Helpers+-------------------------------------------------------------------------------++-- | The first column family of a database opened with some.+firstFamily :: DB -> IO ColumnFamily+firstFamily db = case columnFamilies db of+ cf : _ -> return cf+ [] -> fail "the database has no column families"++-- | The column families of a database opened with exactly two.+twoFamilies :: DB -> IO (ColumnFamily, ColumnFamily)+twoFamilies db = case columnFamilies db of+ [a, b] -> return (a, b)+ cfs -> fail ("expected two column families, got " <> show (length cfs))++-- | A key that sorts by its number.+key :: Int -> ByteString+key = C.pack . printf "k%07d"++-- | The entries from where the iterator is until it stops being valid, moving+-- it with the given step: 'iterNext' to read forwards, 'iterPrev' backwards.+scan :: (Iterator -> IO ()) -> Iterator -> IO [(ByteString, ByteString)]+scan step itr = do+ valid <- iterValid itr+ if valid+ then do+ entry <- iterEntry itr+ step itr+ maybe id (:) entry <$> scan step itr+ else return []++-- | Every entry the iterator can reach, in ascending order of key. Fails if+-- the iterator stopped because of an error rather than at the end.+forwards :: Iterator -> IO [(ByteString, ByteString)]+forwards itr = do+ iterFirst itr+ entries <- scan iterNext itr+ iterGetError itr `shouldReturn` Nothing+ return entries++-- | Every entry the iterator can reach, in descending order of key.+backwards :: Iterator -> IO [(ByteString, ByteString)]+backwards itr = do+ iterLast itr+ entries <- scan iterPrev itr+ iterGetError itr `shouldReturn` Nothing+ return entries++-- | Whether a property value is a number greater than zero.+positive :: Maybe ByteString -> Bool+positive = maybe False (maybe False ((> 0) . fst) . C.readInt)++-- | A number in the text of the @rocksdb.aggregated-table-properties@+-- property, which reads @name=value; name=value; ...@.+tableProperty :: ByteString -> ByteString -> Maybe Int+tableProperty name text =+ listToMaybe+ [ n+ | field <- C.split ';' text,+ let (k, v) = C.break (== '=') (C.dropWhile (== ' ') field),+ k == name,+ Just (n, _) <- [C.readInt (C.drop 1 v)]+ ]++-------------------------------------------------------------------------------+-- Examples against a tuned database+-------------------------------------------------------------------------------++tunedSpec :: SpecWith DB+tunedSpec = 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 column families" $ \db -> do+ two <- firstFamily 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 "Multi-get" $ do+ it "reads many keys at once, in order, with missing ones" $ \db -> do+ one <- firstFamily db+ forM_ [1 .. 100 :: Int] $ \i -> do+ put db (C.pack (show i)) (C.pack ("v" <> show i))+ putCF db one (C.pack (show i)) (C.pack ("one" <> show i))+ let keys = map (C.pack . show) [50, 0, 1, 100, 101, 50 :: Int]+ multiGet db keys+ `shouldReturn` [Just "v50", Nothing, Just "v1", Just "v100", Nothing, Just "v50"]+ multiGetCF db one keys+ `shouldReturn` [Just "one50", Nothing, Just "one1", Just "one100", Nothing, Just "one50"]+ multiGet db [] `shouldReturn` []+ -- more keys than fit in one small buffer, most of them repeated+ let numbers = map (`mod` 150) [1 .. 2000 :: Int]+ expected i+ | i >= 1 && i <= 100 = Just (C.pack ("v" <> show i))+ | otherwise = Nothing+ multiGet db (map (C.pack . show) numbers) `shouldReturn` map expected numbers+ describe "Multithreading" $ do+ it "stores and retrieves items from multiple threads" $ \db -> do+ let val i = C.pack $ printf "val_%04d" i+ indices = [0 .. 9999] :: [Int]+ forConcurrently_ indices $ \i -> put db (key i) (val i)+ mapConcurrently (get db . key) indices `shouldReturn` map (Just . val) indices+ describe "Iterators on a tuned database" $ do+ it "retrieves entries written from many threads, in order" $ \db -> do+ let val i = C.pack $ printf "val_%03d" i+ indices = [0 .. 999] :: [Int]+ kvs = [(key i, val i) | i <- indices]+ forConcurrently_ kvs $ uncurry (put db)+ kvs' <- withIter db $ \itr -> do+ iterSeek itr (key 500)+ scan iterNext itr+ kvs' `shouldBe` drop 500 kvs+ it "seeks to the first key with a prefix" $ \db -> do+ forM_ ["aaa1", "aaa2", "bbb1", "bbb2", "ccc1"] $ \k -> put db k ("v" <> k)+ withIter db $ \itr -> do+ iterSeek itr "bbb"+ iterEntry itr `shouldReturn` Just ("bbb1", "vbbb1")+ iterNext itr+ iterEntry itr `shouldReturn` Just ("bbb2", "vbbb2")+ describe "Properties" $ do+ it "reports memory use, per database and per column family" $ \db -> do+ one <- firstFamily db+ let isNumber = maybe False (\v -> not (C.null v) && C.all (`elem` ['0' .. '9']) v)+ forM_ [1 .. 1000] $ \i -> putCF db one (key i) "value"+ mem <- getPropertyCF db one CurSizeAllMemTables+ mem `shouldSatisfy` isNumber+ mem `shouldSatisfy` positive+ getProperty db EstimateTableReadersMem >>= (`shouldSatisfy` isNumber)+ getProperty db BlockCacheUsage >>= (`shouldSatisfy` isNumber)+ getProperty db (PropertyName "rocksdb.num-immutable-mem-table")+ >>= (`shouldSatisfy` isNumber)+ getProperty db (PropertyName "rocksdb.no-such-property")+ `shouldReturn` Nothing++-------------------------------------------------------------------------------+-- Examples against a plain database+-------------------------------------------------------------------------------++plainSpec :: SpecWith DB+plainSpec = do+ describe "Keys and values" $ do+ it "overwrites a value" $ \db -> do+ put db "k" "first"+ put db "k" "second"+ get db "k" `shouldReturn` Just "second"+ it "tells an empty value from an absent key" $ \db -> do+ put db "empty" ""+ get db "empty" `shouldReturn` Just ""+ get db "absent" `shouldReturn` Nothing+ multiGet db ["empty", "absent"] `shouldReturn` [Just "", Nothing]+ it "keeps bytes that C takes for the end of a string" $ \db -> do+ -- keys and values cross to C with their lengths, not as C strings+ let k = "a\0b"+ v = BS.pack [0, 255, 0, 10, 0]+ put db k v+ put db "a" "short"+ get db k `shouldReturn` Just v+ get db "a" `shouldReturn` Just "short"+ withIter db forwards `shouldReturn` [("a", "short"), (k, v)]+ it "stores a value of several megabytes" $ \db -> do+ let big = BS.replicate (4 * 1024 * 1024) 7+ put db "big" big+ get db "big" `shouldReturn` Just big+ describe "Deletes" $ do+ it "removes a key" $ \db -> do+ put db "k" "v"+ delete db "k"+ get db "k" `shouldReturn` Nothing+ withIter db forwards `shouldReturn` []+ it "accepts a key that is not there" $ \db -> do+ delete db "never written"+ get db "never written" `shouldReturn` Nothing+ it "removes a key from one column family only" $ \db -> do+ other <- firstFamily db+ put db "k" "default"+ putCF db other "k" "other"+ deleteCF db other "k"+ getCF db other "k" `shouldReturn` Nothing+ get db "k" `shouldReturn` Just "default"+ delete db "k"+ putCF db other "k" "again"+ get db "k" `shouldReturn` Nothing+ getCF db other "k" `shouldReturn` Just "again"+ describe "Batches" $ do+ it "applies puts and deletes across column families" $ \db -> do+ other <- firstFamily db+ put db "old" "v"+ putCF db other "old" "v"+ write+ db+ [ Put "a" "1",+ PutCF other "b" "2",+ Del "old",+ DelCF other "old"+ ]+ withIter db forwards `shouldReturn` [("a", "1")]+ withIterCF db other forwards `shouldReturn` [("b", "2")]+ it "applies operations in order" $ \db -> do+ write db [Put "k" "first", Put "k" "second", Put "gone" "v", Del "gone", Del "back", Put "back" "v"]+ withIter db forwards `shouldReturn` [("back", "v"), ("k", "second")]+ it "accepts an empty batch" $ \db -> do+ write db []+ withIter db forwards `shouldReturn` []+ it "writes a large batch" $ \db -> do+ let kvs = [(key i, C.pack (show i)) | i <- [1 .. 20000]]+ write db (map (uncurry Put) kvs)+ withIter db forwards `shouldReturn` kvs+ describe "Iterators" $ do+ it "is invalid on an empty database" $ \db ->+ withIter db $ \itr -> do+ iterFirst itr+ iterValid itr `shouldReturn` False+ iterLast itr+ iterValid itr `shouldReturn` False+ iterSeek itr "hello"+ iterKey itr `shouldReturn` Nothing+ iterValue itr `shouldReturn` Nothing+ iterEntry itr `shouldReturn` Nothing+ iterGetError itr `shouldReturn` Nothing+ it "walks back and forth" $ \db -> do+ put db "a" "aaa"+ put db "b" "bbb"+ put db "c" "ccc"+ withIter db $ \itr -> do+ iterSeek itr "b"+ iterEntry itr `shouldReturn` Just ("b", "bbb")+ iterNext itr+ iterEntry itr `shouldReturn` Just ("c", "ccc")+ iterNext itr -- after the last entry+ iterValid itr `shouldReturn` False+ iterKey itr `shouldReturn` Nothing+ iterValue itr `shouldReturn` Nothing+ iterPrev itr -- it cannot come back+ iterKey itr `shouldReturn` Nothing+ iterValue itr `shouldReturn` Nothing+ withIter db $ \itr -> do+ iterSeek itr "b"+ iterPrev itr+ iterEntry itr `shouldReturn` Just ("a", "aaa")+ iterPrev itr -- before the first entry+ iterValid itr `shouldReturn` False+ iterNext itr -- an invalid iterator stays invalid+ iterKey itr `shouldReturn` Nothing+ iterValue itr `shouldReturn` Nothing+ it "reads everything in both directions" $ \db -> do+ let kvs = [(key i, C.pack (show i)) | i <- [1 .. 100]]+ forM_ kvs $ uncurry (put db)+ withIter db forwards `shouldReturn` kvs+ withIter db backwards `shouldReturn` reverse kvs+ it "seeks to the next key when the one sought is absent" $ \db -> do+ forM_ [10, 20, 30] $ \i -> put db (key i) "v"+ withIter db $ \itr -> do+ iterSeek itr (key 15)+ iterKey itr `shouldReturn` Just (key 20)+ iterSeek itr (key 30)+ iterKey itr `shouldReturn` Just (key 30)+ iterSeek itr (key 31)+ iterValid itr `shouldReturn` False+ it "does not see writes made after it was created" $ \db -> do+ put db "a" "1"+ withIter db $ \itr -> do+ put db "b" "2"+ delete db "a"+ forwards itr `shouldReturn` [("a", "1")]+ withIter db forwards `shouldReturn` [("b", "2")]+ it "stays within its column family" $ \db -> do+ other <- firstFamily db+ put db "d" "default"+ putCF db other "o" "other"+ withIter db forwards `shouldReturn` [("d", "default")]+ withIterCF db other forwards `shouldReturn` [("o", "other")]+ it "can be created and destroyed by hand" $ \db -> do+ put db "a" "1"+ bracket (createIterator db Nothing) destroyIterator forwards+ `shouldReturn` [("a", "1")]+ describe "Snapshots" $ do+ it "hides later writes and deletes from every kind of read" $ \db -> do+ other <- firstFamily db+ put db "a" "1"+ put db "b" "2"+ putCF db other "x" "100"+ withSnapshot db $ \snap -> do+ put db "a" "changed"+ delete db "b"+ put db "c" "3"+ putCF db other "x" "changed"+ get snap "a" `shouldReturn` Just "1"+ multiGet snap ["a", "b", "c"] `shouldReturn` [Just "1", Just "2", Nothing]+ getCF snap other "x" `shouldReturn` Just "100"+ withIter snap forwards `shouldReturn` [("a", "1"), ("b", "2")]+ withIterCF snap other forwards `shouldReturn` [("x", "100")]+ bracket (createIterator snap Nothing) destroyIterator forwards+ `shouldReturn` [("a", "1"), ("b", "2")]+ withIter db forwards `shouldReturn` [("a", "changed"), ("c", "3")]+ it "writes through a snapshot to the live database" $ \db ->+ withSnapshot db $ \snap -> do+ put snap "k" "v"+ get snap "k" `shouldReturn` Nothing+ get db "k" `shouldReturn` Just "v"+ it "agrees between point reads and iterators during concurrent writes" $ \db -> do+ cf <- firstFamily db+ let keys = ["key1", "key2", "key3"]+ original = [(k, "original") | k <- keys]+ forM_ original $ uncurry (putCF db cf)+ bracket (createSnapshot db) releaseSnapshot $ \(snap, _) -> do+ started <- newEmptyMVar+ let writer n = do+ forM_ keys $ \k -> putCF db cf k (C.pack ("v" <> show (n :: Int)))+ when (n == 0) $ putMVar started ()+ threadDelay 500+ writer (n + 1)+ withAsync (writer 0) $ \_ -> do+ takeMVar started+ forM_ original $ \(k, v) -> do+ getCF snap cf k `shouldReturn` Just v+ threadDelay 5000+ withIterCF snap cf forwards `shouldReturn` original+ it "pins iterators to a snapshot given to them" $ \db -> do+ other <- firstFamily db+ put db "a" "1"+ put db "b" "2"+ putCF db other "x" "100"+ bracket (createSnapshot db) releaseSnapshot $ \(_, snap) -> do+ put db "a" "modified"+ put db "c" "3"+ putCF db other "x" "modified"+ putCF db other "z" "300"+ -- the live handle, with the snapshot passed to the iterator+ withIterSnap db (Just snap) forwards `shouldReturn` [("a", "1"), ("b", "2")]+ withIterSnapCF db (Just snap) other forwards `shouldReturn` [("x", "100")]+ -- without one, they read the database as it is now+ withIterSnap db Nothing forwards+ `shouldReturn` [("a", "modified"), ("b", "2"), ("c", "3")]+ withIterSnapCF db Nothing other forwards+ `shouldReturn` [("x", "modified"), ("z", "300")]+ it "pins an iterator created by hand, which owns its read options" $ \db -> do+ put db "m" "10"+ put db "n" "20"+ bracket (createSnapshot db) releaseSnapshot $ \(_, snap) -> do+ put db "m" "changed"+ let create = createIteratorSnap db (Just snap) Nothing+ destroy' (itr, opts) = destroyIterator itr >> forM_ opts destroyReadOpts+ bracket create destroy' $ \(itr, opts) -> do+ opts `shouldSatisfy` isJust+ forwards itr `shouldReturn` [("m", "10"), ("n", "20")]+ bracket (createIteratorSnap db Nothing Nothing) destroy' $ \(itr, opts) -> do+ opts `shouldSatisfy` isNothing+ forwards itr `shouldReturn` [("m", "changed"), ("n", "20")]++-------------------------------------------------------------------------------+-- Opening and closing+-------------------------------------------------------------------------------++openingSpec :: Spec+openingSpec = describe "Opening" $ do+ it "keeps the data when the database is closed and opened again" $+ withTempPath $ \path -> do+ withDB path plain $ \db -> put db "key" "value" >> delete db "gone"+ withDB path plain $ \db -> do+ get db "key" `shouldReturn` Just "value"+ withIter db forwards `shouldReturn` [("key", "value")]+ it "throws if the database is missing and may not be created" $+ withTempPath $ \path ->+ withDB path def (\_ -> return ()) `shouldThrow` anyIOException+ it "throws if the database exists and must not" $+ withTempPath $ \path -> do+ withDB path plain $ \_ -> return ()+ withDB path plain {errorIfExists = True} (\_ -> return ())+ `shouldThrow` anyIOException+ it "throws if the database is already open" $+ withTempPath $ \path ->+ withDB path plain $ \_ ->+ withDB path plain (\_ -> return ()) `shouldThrow` anyIOException+ it "closes the database when the function throws" $+ withTempPath $ \path -> do+ withDB path plain (\db -> put db "k" "v" >> ioError (userError "stop"))+ `shouldThrow` anyIOException+ -- the lock is released, and what was written is there+ withDB path plain $ \db -> get db "k" `shouldReturn` Just "v"+ it "throws if a column family of the database is left out" $+ withTempPath $ \path -> do+ let create = plain {createMissingColumnFamilies = True}+ withDBCF path create [("one", plain)] $ \_ -> return ()+ withDB path plain (\_ -> return ()) `shouldThrow` anyIOException+ it "throws if a column family is missing and may not be created" $+ withTempPath $ \path -> do+ withDB path plain $ \_ -> return ()+ withDBCF path plain [("one", plain)] (\_ -> return ())+ `shouldThrow` anyIOException+ it "adds a column family to an existing database" $+ withTempPath $ \path -> do+ let create = plain {createMissingColumnFamilies = True}+ withDBCF path create [("one", plain)] $ \db -> do+ one <- firstFamily db+ put db "key" "value"+ putCF db one "key" "one"+ withDBCF path create [("one", plain), ("two", plain)] $ \db -> do+ (one, two) <- twoFamilies db+ get db "key" `shouldReturn` Just "value"+ getCF db one "key" `shouldReturn` Just "one"+ getCF db two "key" `shouldReturn` Nothing+ putCF db two "new" "cf"+ getCF db two "new" `shouldReturn` Just "cf"+ it "gives the column families in the order they were asked for" $+ withTempPath $ \path -> do+ let create = plain {createMissingColumnFamilies = True}+ withDBCF path create [("one", plain), ("two", plain)] $ \db -> do+ (one, two) <- twoFamilies db+ putCF db one "name" "one"+ putCF db two "name" "two"+ withDBCF path plain [("two", plain), ("one", plain)] $ \db -> do+ (two, one) <- twoFamilies db+ getCF db one "name" `shouldReturn` Just "one"+ getCF db two "name" `shouldReturn` Just "two"++-------------------------------------------------------------------------------+-- Settings, checked by their effect+-------------------------------------------------------------------------------++tuningSpec :: Spec+tuningSpec = describe "Tuning" $ do+ it "flushes small memtables and keeps the data" $ do+ let small =+ tuned+ { writeBufferSize = Just (64 * 1024),+ dbWriteBufferSize = Just (256 * 1024)+ }+ cfConf = small {dbWriteBufferSize = Nothing}+ value = C.replicate 100 'v'+ withTempPath $ \path ->+ withDBCF path small [("one", cfConf), ("two", cfConf)] $ \db -> do+ (one, two) <- twoFamilies db+ forM_ [1 .. 20000] $ \i -> do+ put db (key i) value+ putCF db one (key i) value+ putCF db two (key i) value+ get db (key 1) `shouldReturn` Just value+ getCF db one (key 10000) `shouldReturn` Just value+ getCF db two (key 20000) `shouldReturn` Just value+ -- the memtables are far smaller than the data, so it is in files+ files <- getProperty db SSTables+ files `shouldSatisfy` maybe False (not . C.null)+ it "builds Bloom filters for a family that asks for one, and only for it" $+ withTempPath $ \path -> do+ let open = plain {createMissingColumnFamilies = True}+ families = [("with", def {bloomFilter = True}), ("without", def)]+ tableProps = PropertyName "rocksdb.aggregated-table-properties"+ -- bytes of filter blocks in the table files of a family+ filters d cf =+ getPropertyCF d cf tableProps+ >>= maybe (fail "no table properties") (return . tableProperty "filter block size")+ withDBCF path open families $ \db -> do+ (with, without) <- twoFamilies db+ forM_ [1 .. 5000] $ \i -> do+ putCF db with (key i) "value"+ putCF db without (key i) "value"+ -- opening the database again moves what was written from the+ -- write-ahead log to table files, which is where filters are+ withDBCF path open families $ \db -> do+ (with, without) <- twoFamilies db+ -- ten bits for each of the 5000 keys is 6250 bytes+ filters db with >>= (`shouldSatisfy` maybe False (> 5000))+ filters db without `shouldReturn` Just 0+ getCF db with (key 2500) `shouldReturn` Just "value"+ getCF db with "absent" `shouldReturn` Nothing+ it "estimates the space used by a range of keys" $+ withTempPath $ \path -> do+ withDB path plain $ \db ->+ forM_ [1 .. 5000] $ \i -> put db (key i) (C.pack (printf "%0100d" i))+ -- sizes are those of table files; see the test of Bloom filters+ withDB path plain $ \db -> do+ approximateSize db (key 1, key 5000) >>= (`shouldSatisfy` (> 0))+ approximateSize db ("x", "y") `shouldReturn` 0+ it "shares one block cache, holding index and filter blocks" $ do+ let size = 8 * 1024 * 1024 :: Int+ cached =+ tuned+ { errorIfExists = False,+ blockCacheSize = Just size,+ cacheIndexAndFilterBlocks = True,+ writeBufferSize = Just (64 * 1024)+ }+ value = C.replicate 100 'v'+ capacity = PropertyName "rocksdb.block-cache-capacity"+ withTempPath $ \path -> do+ withDBCF path cached [("one", cached)] $ \db -> do+ one <- firstFamily db+ forM_ [1 .. 20000] $ \i -> putCF db one (key i) value+ withDBCF path cached [("one", cached)] $ \db -> do+ one <- firstFamily db+ getProperty db capacity `shouldReturn` Just (C.pack (show size))+ getPropertyCF db one capacity `shouldReturn` Just (C.pack (show size))+ multiGetCF db one (map key [1, 10000, 20000])+ `shouldReturn` replicate 3 (Just value)+ getProperty db BlockCacheUsage >>= (`shouldSatisfy` positive)+ it "opens with a bound on the write-ahead log" $+ withTempPath $ \path ->+ withDBCF path tuned {maxTotalWalSize = Just (1024 * 1024)} [("one", tuned)] $ \db -> do+ put db "key" "value"+ get db "key" `shouldReturn` Just "value"+ it "works with few open files and paranoid checks" $+ withTempPath $ \path -> do+ let strict =+ plain+ { maxFiles = Just 20,+ paranoidChecks = True,+ writeBufferSize = Just (64 * 1024)+ }+ kvs = [(key i, C.replicate 100 'v') | i <- [1 .. 20000]]+ withDB path strict $ \db -> forM_ kvs $ uncurry (put db)+ withDB path strict $ \db -> withIter db forwards `shouldReturn` kvs++-------------------------------------------------------------------------------+-- Properties: the database against a Map+-------------------------------------------------------------------------------++-- | A write to the default column family.+data Op+ = Set ByteString ByteString+ | Unset ByteString+ deriving (Show)++-- | Short keys over four bytes, so that random operations often meet on the+-- same key. The bytes are the ones a binding is most likely to mishandle: zero,+-- which ends a C string, and 255, which is negative as a signed @char@ and+-- must still sort last.+genKey :: Gen ByteString+genKey = do+ n <- choose (0, 3)+ BS.pack <$> vectorOf n (elements [0, 1, 97, 255])++-- | Values of any bytes, often empty.+genValue :: Gen ByteString+genValue = do+ n <- frequency [(1, return 0), (4, choose (1, 24))]+ BS.pack <$> vectorOf n arbitrary++genOps :: Gen [Op]+genOps = listOf $ frequency [(3, Set <$> genKey <*> genValue), (1, Unset <$> genKey)]++-- | Random operations, shrinking a failure to the fewest that still fail.+forAllOps :: (Testable p) => ([Op] -> p) -> QC.Property+forAllOps = forAllShrink genOps (shrinkList (const []))++opKey :: Op -> ByteString+opKey (Set k _) = k+opKey (Unset k) = k++-- | What the database should hold after the operations, in order.+model :: [Op] -> Map ByteString ByteString+model = foldl apply Map.empty+ where+ apply m (Set k v) = Map.insert k v m+ apply m (Unset k) = Map.delete k m++-- | Apply the operations one write at a time.+runOps :: DB -> [Op] -> IO ()+runOps db = mapM_ run+ where+ run (Set k v) = put db k v+ run (Unset k) = delete db k++-- | The operations as one atomic batch.+batchOf :: [Op] -> [BatchOp]+batchOf = map op+ where+ op (Set k v) = Put k v+ op (Unset k) = Del k++-- | Require that every way of reading the default column family agrees with+-- the map: iteration in both directions, in the order of the map's keys, and+-- point reads of the given keys.+shouldHold :: DB -> [ByteString] -> Map ByteString ByteString -> IO ()+shouldHold db keys m = do+ withIter db forwards `shouldReturn` Map.toAscList m+ withIter db backwards `shouldReturn` Map.toDescList m+ forM_ keys $ \k -> get db k `shouldReturn` Map.lookup k m+ multiGet db keys `shouldReturn` map (`Map.lookup` m) keys++-- | A new database with only the default column family, for one test case.+inNewDB :: (DB -> IO ()) -> QC.Property+inNewDB go = ioProperty $ withTempPath $ \path -> withDB path plain go++modelSpec :: Spec+modelSpec = describe "Agreement with a Map" $ do+ prop "after single writes" $+ forAllOps $ \ops -> inNewDB $ \db -> do+ runOps db ops+ shouldHold db (map opKey ops) (model ops)+ prop "after one batch" $+ forAllOps $ \ops -> inNewDB $ \db -> do+ write db (batchOf ops)+ shouldHold db (map opKey ops) (model ops)+ prop "after the database is closed and opened again" $+ forAllOps $ \ops -> ioProperty $ withTempPath $ \path -> do+ withDB path plain $ \db -> runOps db ops+ withDB path plain $ \db -> shouldHold db (map opKey ops) (model ops)+ prop "in a column family, leaving the default one alone" $+ forAllOps $ \ops -> forAllOps $ \others -> ioProperty $ withPlainDB $ \db -> do+ other <- firstFamily db+ runOps db ops+ forM_ others $ \o -> case o of+ Set k v -> putCF db other k v+ Unset k -> deleteCF db other k+ shouldHold db (map opKey (ops <> others)) (model ops)+ withIterCF db other forwards `shouldReturn` Map.toAscList (model others)+ let keys = map opKey (ops <> others)+ multiGetCF db other keys `shouldReturn` map (`Map.lookup` model others) keys+ prop "when seeking: the first key not below the one sought" $+ forAllOps $ \ops -> forAll (listOf genKey) $ \targets -> inNewDB $ \db -> do+ runOps db ops+ withIter db $ \itr -> forM_ targets $ \target -> do+ iterSeek itr target+ iterEntry itr `shouldReturn` Map.lookupGE target (model ops)+ prop "through a snapshot, whatever is written afterwards" $+ forAllOps $ \earlier -> forAllOps $ \later -> inNewDB $ \db -> do+ let keys = map opKey (earlier <> later)+ runOps db earlier+ withSnapshot db $ \snap -> do+ runOps db later+ shouldHold snap keys (model earlier)+ shouldHold db keys (model (earlier <> later))