diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/rocksdb-haskell-jprupp.cabal b/rocksdb-haskell-jprupp.cabal --- a/rocksdb-haskell-jprupp.cabal +++ b/rocksdb-haskell-jprupp.cabal @@ -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 category: Database, FFI @@ -58,6 +58,7 @@ , async , base >=4.9 && <5 , bytestring + , containers , data-default , directory , hspec diff --git a/src/Database/RocksDB.hs b/src/Database/RocksDB.hs --- a/src/Database/RocksDB.hs +++ b/src/Database/RocksDB.hs @@ -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 diff --git a/src/Database/RocksDB/Base.hs b/src/Database/RocksDB/Base.hs --- a/src/Database/RocksDB/Base.hs +++ b/src/Database/RocksDB/Base.hs @@ -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 diff --git a/src/Database/RocksDB/Internal.hs b/src/Database/RocksDB/Internal.hs --- a/src/Database/RocksDB/Internal.hs +++ b/src/Database/RocksDB/Internal.hs @@ -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 #-} diff --git a/src/Database/RocksDB/Iterator.hs b/src/Database/RocksDB/Iterator.hs --- a/src/Database/RocksDB/Iterator.hs +++ b/src/Database/RocksDB/Iterator.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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))