feat(lsm-tree-tests): add salt

Author: wenkokke

test/Database/LSMTree/Class/Common.hs

@@ -5,6 +5,8 @@ module Database.LSMTree.Class.Common (
   , IsSession (..)
   , SessionArgs (..)
   , withSession
+  , testSalt
+  , testSessionSalt
   , module Types
   ) where
 
@@ -17,6 +19,7 @@ import           Database.LSMTree as Types (IOLike, Range (..), SerialiseKey,
                      SerialiseValue, SnapshotLabel (..), SnapshotName,
                      UnionCredits (..), UnionDebt (..))
 import qualified Database.LSMTree as R
+import           Database.LSMTree.Internal.Paths (SessionSalt (..))
 import           System.FS.API (FsPath, HasFS)
 import           System.FS.BlockIO.API (HasBlockIO)
 
@@ -77,6 +80,12 @@ withSession seshArgs = bracket (openSession seshArgs) closeSession
   Real instance
 -------------------------------------------------------------------------------}
 
+testSalt :: R.Salt
+testSalt = 4
+
+testSessionSalt :: SessionSalt
+testSessionSalt = SessionSalt testSalt
+
 instance IsSession R.Session where
     data SessionArgs R.Session m where
       SessionArgs ::
@@ -85,7 +94,7 @@ instance IsSession R.Session where
         -> SessionArgs R.Session m
 
     openSession (SessionArgs hfs hbio dir) = do
-       R.openSession nullTracer hfs hbio dir
+       R.openSession nullTracer hfs hbio testSalt dir
     closeSession = R.closeSession
     deleteSnapshot = R.deleteSnapshot
     listSnapshots = R.listSnapshots

test/Test/Database/LSMTree/Generators.hs

@@ -7,6 +7,7 @@ import           Data.Coerce (Coercible, coerce)
 import qualified Data.Map.Strict as Map
 import qualified Data.Vector.Primitive as VP
 import           Data.Word (Word64, Word8)
+import           Database.LSMTree.Class.Common (testSessionSalt)
 import           Database.LSMTree.Extras (showPowersOf)
 import           Database.LSMTree.Extras.Generators
 import           Database.LSMTree.Extras.MergingRunData
@@ -162,7 +163,7 @@ prop_withRunDoesntLeak hfs hbio rd = do
     let path = FS.mkFsPath ["something-1"]
     let fsPaths = RunFsPaths path (RunNumber 0)
     FS.createDirectory hfs path
-    withRunAt hfs hbio (runParams indexType) fsPaths rd $ \_run -> do
+    withRunAt hfs hbio testSessionSalt (runParams indexType) fsPaths rd $ \_run -> do
       pure (QC.property True)
 
 prop_withMergingRunDoesntLeak ::
@@ -175,7 +176,7 @@ prop_withMergingRunDoesntLeak hfs hbio mrd = do
     let path = FS.mkFsPath ["something-2"]
     FS.createDirectory hfs path
     counter <- newUniqCounter 0
-    withMergingRun hfs hbio resolveVal (runParams indexType) path counter mrd $
+    withMergingRun hfs hbio resolveVal testSessionSalt (runParams indexType) path counter mrd $
       \_mr -> do
         pure (QC.property True)
 
@@ -191,7 +192,7 @@ prop_withMergingTreeDoesntLeak hfs hbio mrd = do
     let path = FS.mkFsPath ["something-3"]
     FS.createDirectory hfs path
     counter <- newUniqCounter 0
-    withMergingTree hfs hbio resolveVal (runParams indexType) path counter mrd $
+    withMergingTree hfs hbio resolveVal testSessionSalt (runParams indexType) path counter mrd $
       \_tree -> do
         pure (QC.property True)
 

test/Test/Database/LSMTree/Internal.hs

@@ -16,6 +16,7 @@ import qualified Data.Map.Strict as Map
 import           Data.Maybe (isJust, mapMaybe)
 import qualified Data.Vector as V
 import           Data.Word
+import           Database.LSMTree.Class.Common (testSalt)
 import           Database.LSMTree.Extras.Generators ()
 import           Database.LSMTree.Internal.BlobRef
 import           Database.LSMTree.Internal.Config
@@ -58,7 +59,7 @@ newSession ::
 newSession (Positive (Small bufferSize)) es =
     ioProperty $
     withTempIOHasBlockIO "newSession" $ \hfs hbio ->
-    withSession nullTracer hfs hbio (FS.mkFsPath []) $ \session ->
+    withSession nullTracer hfs hbio testSalt (FS.mkFsPath []) $ \session ->
       withTable session conf (updates const es')
   where
     conf = testTableConfig {
@@ -73,9 +74,9 @@ restoreSession ::
 restoreSession (Positive (Small bufferSize)) es =
     ioProperty $
     withTempIOHasBlockIO "restoreSession" $ \hfs hbio -> do
-      withSession nullTracer hfs hbio (FS.mkFsPath []) $ \session1 ->
+      withSession nullTracer hfs hbio testSalt (FS.mkFsPath []) $ \session1 ->
         withTable session1 conf (updates const es')
-      withSession nullTracer hfs hbio (FS.mkFsPath []) $ \session2 ->
+      withSession nullTracer hfs hbio testSalt (FS.mkFsPath []) $ \session2 ->
         withTable session2 conf (updates const es')
   where
     conf = testTableConfig {
@@ -86,8 +87,8 @@ restoreSession (Positive (Small bufferSize)) es =
 sessionDirLocked :: Property
 sessionDirLocked = ioProperty $
     withTempIOHasBlockIO "sessionDirLocked" $ \hfs hbio -> do
-      bracket (openSession nullTracer hfs hbio (FS.mkFsPath [])) closeSession $ \_sesh1 ->
-        bracket (try @SessionDirLockedError $ openSession nullTracer hfs hbio (FS.mkFsPath [])) tryCloseSession $ \case
+      bracket (openSession nullTracer hfs hbio testSalt (FS.mkFsPath [])) closeSession $ \_sesh1 ->
+        bracket (try @SessionDirLockedError $ openSession nullTracer hfs hbio testSalt (FS.mkFsPath [])) tryCloseSession $ \case
           Left (ErrSessionDirLocked _dir) -> pure ()
           x -> assertFailure $ "Opening a session twice in the same directory \
                               \should fail with an ErrSessionDirLocked error, but \
@@ -97,15 +98,15 @@ sessionDirCorrupted :: Assertion
 sessionDirCorrupted =
   withTempIOHasBlockIO "sessionDirCorrupted" $ \hfs hbio -> do
     FS.createDirectory hfs (FS.mkFsPath ["unexpected-directory"])
-    bracket (try @SessionDirCorruptedError (openSession nullTracer hfs hbio (FS.mkFsPath []))) tryCloseSession $ \case
+    bracket (try @SessionDirCorruptedError (openSession nullTracer hfs hbio testSalt (FS.mkFsPath []))) tryCloseSession $ \case
       Left (ErrSessionDirCorrupted _dir) -> pure ()
       x -> assertFailure $ "Restoring a session in a directory with a wrong \
                            \layout should fail with a ErrSessionDirCorrupted, but \
                            \it returned this instead: " <> showLeft "Session" x
 
 sessionDirDoesNotExist :: Assertion
 sessionDirDoesNotExist = withTempIOHasBlockIO "sessionDirDoesNotExist" $ \hfs hbio -> do
-  bracket (try @SessionDirDoesNotExistError (openSession nullTracer hfs hbio (FS.mkFsPath ["missing-dir"]))) tryCloseSession $ \case
+  bracket (try @SessionDirDoesNotExistError (openSession nullTracer hfs hbio testSalt (FS.mkFsPath ["missing-dir"]))) tryCloseSession $ \case
       Left (ErrSessionDirDoesNotExist _dir) -> pure ()
       x -> assertFailure $ "Opening a session in a non-existent directory should \
                            \fail with a ErrSessionDirDoesNotExist error, but it \
@@ -140,7 +141,7 @@ prop_roundtripCursor ::
   -> Property
 prop_roundtripCursor lb ub kops = ioProperty $
     withTempIOHasBlockIO "prop_roundtripCursor" $ \hfs hbio -> do
-      withSession nullTracer hfs hbio (FS.mkFsPath []) $ \sesh -> do
+      withSession nullTracer hfs hbio testSalt (FS.mkFsPath []) $ \sesh -> do
         withTable sesh conf $ \t -> do
           updates resolve (coerce kops) t
           fromCursor <- withCursor resolve (toOffsetKey lb) t $ \c ->

test/Test/Database/LSMTree/Internal/BloomFilter.hs

@@ -24,6 +24,7 @@ import           Test.Tasty (TestTree, testGroup)
 import           Test.Tasty.QuickCheck hiding ((.&.))
 
 import qualified Data.BloomFilter.Blocked as Bloom
+import           Database.LSMTree.Class.Common (testSalt, testSessionSalt)
 import           Database.LSMTree.Internal.BloomFilter
 import           Database.LSMTree.Internal.Serialise (SerialisedKey,
                      serialiseKey)
@@ -52,7 +53,7 @@ roundtrip_prop (Positive (Small hfN)) (Positive bits) ws =
   where
     sz  = Bloom.BloomSize { sizeBits   = limitBits bits,
                          sizeHashes = hfN }
-    lhs = Bloom.create theRandomSalt sz (\b -> mapM_ (Bloom.insert b) ws)
+    lhs = Bloom.create sz testSalt (\b -> mapM_ (Bloom.insert b) ws)
     bs  = LBS.toStrict (bloomFilterToLBS lhs)
 
 limitBits :: Int -> Int
@@ -116,7 +117,7 @@ prop_bloomQueries :: FPR
                   -> Property
 prop_bloomQueries (FPR fpr) filters keys =
     let filters' :: [Bloom SerialisedKey]
-        filters' = map (Bloom.fromList (Bloom.policyForFPR fpr)
+        filters' = map (Bloom.fromList (Bloom.policyForFPR fpr) testSalt
                         . map (\(Small k) -> serialiseKey k))
                        filters
 
@@ -152,5 +153,4 @@ prop_bloomQueries (FPR fpr) filters keys =
         referenceResults
        ===
         map (\(RunIxKeyIx rix kix) -> (rix, kix))
-            (VP.toList (bloomQueries (V.fromList filters')
-                                     (V.fromList keys')))
+            (VP.toList (bloomQueries testSessionSalt (V.fromList filters') (V.fromList keys')))

test/Test/Database/LSMTree/Internal/Lookup.hs

@@ -40,6 +40,7 @@ import qualified Data.Vector as V
 import qualified Data.Vector.Primitive as VP
 import qualified Data.Vector.Unboxed as VU
 import           Data.Word
+import           Database.LSMTree.Class.Common (testSessionSalt)
 import           Database.LSMTree.Extras
 import           Database.LSMTree.Extras.Generators
 import           Database.LSMTree.Extras.RunData (RunData (..),
@@ -141,7 +142,7 @@ prop_bloomQueriesModel dats =
     blooms = fmap snd3 runs
     lookupss = concatMap lookups $ getSmallList dats
     real  = map (\(RunIxKeyIx rix kix) -> (rix,kix)) $ VP.toList $
-            bloomQueries (V.fromList blooms) (V.fromList lookupss)
+            bloomQueries testSessionSalt (V.fromList blooms) (V.fromList lookupss)
     model = bloomQueriesModel (fmap Map.keysSet runDatas) lookupss
 
 -- | A bloom filter is a probablistic set that can return false positives, but
@@ -204,6 +205,7 @@ prop_prepLookupsModel dats = real === model
           ks = V.fromList lookupss
       (kixs, ioops) <- prepLookups
                          arena
+                         testSessionSalt
                          (V.map snd3 rs)
                          (V.map thrd3 rs)
                          (V.map fst3 rs) ks
@@ -245,6 +247,7 @@ prop_inMemRunLookupAndConstruction dat =
       (kixs, ioops) <- let r = V.singleton (runWithHandle run)
                        in  prepLookups
                              arena
+                             testSessionSalt
                              (V.map snd3 r)
                              (V.map thrd3 r)
                              (V.map fst3 r)
@@ -332,6 +335,7 @@ prop_roundtripFromWriteBufferLookupIO (SmallList dats) =
         hbio
         arenaManager
         resolveV
+        testSessionSalt
         wb wbblobs
         runs
         (V.map (\(DeRef r) -> Run.runFilter   r) runs)
@@ -374,7 +378,7 @@ withWbAndRuns hfs hbio indexType (wbdat:rundats) action =
       let wb = WB.fromMap wbkops
       let rds = map (RunData . runData) rundats
       counter <- newUniqCounter 1
-      withRuns hfs hbio (runParams indexType) (FS.mkFsPath []) counter rds $
+      withRuns hfs hbio testSessionSalt (runParams indexType) (FS.mkFsPath []) counter rds $
         \runs ->
           action wb wbblobs (V.fromList runs)
 
@@ -443,7 +447,7 @@ mkTestRun dat = (rawPages, b, ic)
 
     -- one-shot run construction
     (pages, b, ic) = runST $ do
-      racc <- Run.new nentries (RunAllocFixed 10) Index.Ordinary
+      racc <- Run.new nentries (RunAllocFixed 10) testSessionSalt Index.Ordinary
       let kops = Map.toList dat
       psopss <- traverse (uncurry (Run.addKeyOp racc)) kops
       (mp, _ , b', ic', _) <- Run.unsafeFinalise racc

test/Test/Database/LSMTree/Internal/Merge.hs

@@ -9,6 +9,7 @@ import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (isJust)
 import qualified Data.Vector as V
+import           Database.LSMTree.Class.Common (testSessionSalt)
 import           Database.LSMTree.Extras
 import           Database.LSMTree.Extras.RunData
 import qualified Database.LSMTree.Internal.BlobFile as BlobFile
@@ -81,13 +82,13 @@ prop_MergeDistributes ::
 prop_MergeDistributes fs hbio mergeType stepSize (SmallList rds) = do
     let path = FS.mkFsPath []
     counter <- newUniqCounter 0
-    withRuns fs hbio runParams path counter rds' $ \runs -> do
+    withRuns fs hbio testSessionSalt runParams path counter rds' $ \runs -> do
       let stepsNeeded = sum (map (Map.size . unRunData) rds)
 
       fsPathLhs <- RunFsPaths path . uniqueToRunNumber <$> incrUniqCounter counter
       (stepsDone, lhs) <- mergeRuns fs hbio mergeType stepSize fsPathLhs runs
       let runData = RunData $ mergeWriteBuffers mergeType $ fmap unRunData rds'
-      withRun fs hbio runParams path counter runData $ \rhs -> do
+      withRun fs hbio testSessionSalt runParams path counter runData $ \rhs -> do
 
         (lhsSize, lhsFilter, lhsIndex, lhsKOps,
          lhsKOpsFileContent, lhsBlobFileContent) <- getRunContent lhs
@@ -159,7 +160,7 @@ prop_AbortMerge fs hbio mergeType (Positive stepSize) (SmallList wbs) = do
     let path = FS.mkFsPath []
     let pathOut = RunFsPaths path (RunNumber 0)
     counter <- newUniqCounter 1
-    withRuns fs hbio runParams path counter wbs' $ \runs -> do
+    withRuns fs hbio testSessionSalt runParams path counter wbs' $ \runs -> do
       mergeToClose <- makeInProgressMerge pathOut runs
       traverse_ Merge.abort mergeToClose
 
@@ -172,7 +173,7 @@ prop_AbortMerge fs hbio mergeType (Positive stepSize) (SmallList wbs) = do
     wbs' = fmap serialiseRunData wbs
 
     makeInProgressMerge path runs =
-      Merge.new fs hbio runParams mergeType resolveVal
+      Merge.new fs hbio testSessionSalt runParams mergeType resolveVal
                 path (V.fromList runs) >>= \case
         Nothing -> pure Nothing  -- not in progress
         Just merge -> do
@@ -199,11 +200,11 @@ mergeRuns ::
      [Ref (Run.Run IO h)] ->
      IO (Int, Ref (Run.Run IO h))
 mergeRuns fs hbio mergeType (Positive stepSize) fsPath runs = do
-    Merge.new fs hbio runParams mergeType resolveVal
+    Merge.new fs hbio testSessionSalt runParams mergeType resolveVal
               fsPath (V.fromList runs)
       >>= \case
         Just m  -> Merge.stepsToCompletionCounted m stepSize
-        Nothing -> (,) 0 <$> unsafeCreateRunAt fs hbio runParams fsPath
+        Nothing -> (,) 0 <$> unsafeCreateRunAt fs hbio testSessionSalt runParams fsPath
                                (RunData Map.empty)
 
 type SerialisedEntry = Entry.Entry SerialisedValue SerialisedBlob

test/Test/Database/LSMTree/Internal/MergingTree.hs

@@ -13,6 +13,7 @@ import           Data.Map (Map)
 import qualified Data.Map as Map
 import           Data.Traversable (for)
 import qualified Data.Vector as V
+import           Database.LSMTree.Class.Common (testSessionSalt)
 import           Database.LSMTree.Extras (showPowersOf10)
 import           Database.LSMTree.Extras.MergingRunData
 import           Database.LSMTree.Extras.MergingTreeData
@@ -126,7 +127,7 @@ prop_lookupTree ::
 prop_lookupTree hfs hbio keys mtd = do
     let path = FS.mkFsPath []
     counter <- newUniqCounter 0
-    withMergingTree hfs hbio resolveVal runParams path counter mtd $ \tree -> do
+    withMergingTree hfs hbio resolveVal testSessionSalt runParams path counter mtd $ \tree -> do
       arenaManager <- newArenaManager
       withActionRegistry $ \reg -> do
         res <- fetchBlobs =<< lookupsIO reg arenaManager tree
@@ -169,6 +170,7 @@ prop_lookupTree hfs hbio keys mtd = do
             hbio
             mgr
             resolveVal
+            testSessionSalt
             runs
             (fmap (\(DeRef r) -> Run.runFilter   r) runs)
             (fmap (\(DeRef r) -> Run.runIndex    r) runs)
@@ -229,7 +231,7 @@ prop_supplyCredits hfs hbio threshold credits mtd = do
     FS.createDirectory hfs setupPath
     FS.createDirectory hfs (FS.mkFsPath ["active"])
     counter <- newUniqCounter 0
-    withMergingTree hfs hbio resolveVal runParams setupPath counter mtd $ \tree -> do
+    withMergingTree hfs hbio resolveVal testSessionSalt runParams setupPath counter mtd $ \tree -> do
       (MR.MergeDebt initialDebt, _) <- remainingMergeDebt tree
       props <- for credits $ \c -> do
         (MR.MergeDebt debt, _) <- remainingMergeDebt tree
@@ -238,7 +240,7 @@ prop_supplyCredits hfs hbio threshold credits mtd = do
             pure $ property True
           else do
             leftovers <-
-              supplyCredits hfs hbio resolveVal runParams threshold root counter tree c
+              supplyCredits hfs hbio resolveVal testSessionSalt runParams threshold root counter tree c
             (MR.MergeDebt debt', _) <- remainingMergeDebt tree
             pure $
               -- semi-useful, but mainly tells us in how many steps we supplied

test/Test/Database/LSMTree/Internal/Readers.hs

@@ -44,6 +44,7 @@ import           Test.Tasty (TestTree, testGroup)
 import           Test.Tasty.QuickCheck
 import           Test.Util.Orphans ()
 
+import           Database.LSMTree.Class.Common (testSessionSalt)
 import           Test.QuickCheck.StateModel
 import           Test.QuickCheck.StateModel.Lockstep
 import qualified Test.QuickCheck.StateModel.Lockstep.Defaults as Lockstep
@@ -453,7 +454,7 @@ runIO act lu = case act of
           wb <- WB.fromMap <$> traverse (traverse (WBB.addBlob hfs wbblobs)) kops
           pure $ Readers.FromWriteBuffer wb wbblobs
         FromRunData rd -> do
-          r <- unsafeCreateRun hfs hbio runParams (FS.mkFsPath []) counter $ serialiseRunData rd
+          r <- unsafeCreateRun hfs hbio testSessionSalt runParams (FS.mkFsPath []) counter $ serialiseRunData rd
           pure $ Readers.FromRun r
         FromReadersData ty rds -> do
           Readers.FromReaders ty <$> traverse (fromSourceData hfs hbio counter) rds

test/Test/Database/LSMTree/Internal/Run.hs

@@ -14,6 +14,7 @@ import           Data.Coerce (coerce)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (fromJust)
 import qualified Data.Primitive.ByteArray as BA
+import           Database.LSMTree.Class.Common (testSessionSalt)
 import           Database.LSMTree.Extras.RunData
 import           Database.LSMTree.Internal.BlobRef (BlobSpan (..))
 import qualified Database.LSMTree.Internal.CRC32C as CRC
@@ -106,7 +107,7 @@ testSingleInsert sessionRoot key val mblob =
     -- flush write buffer
     let e = case mblob of Nothing -> Insert val; Just blob -> InsertWithBlob val blob
         wb = Map.singleton key e
-    withRunAt fs hbio runParams (simplePath 42) (RunData wb) $ \_ -> do
+    withRunAt fs hbio testSessionSalt runParams (simplePath 42) (RunData wb) $ \_ -> do
       -- check all files have been written
       let activeDir = sessionRoot
       bsKOps <- BS.readFile (activeDir </> "42.keyops")
@@ -188,7 +189,7 @@ prop_WriteNumEntries ::
   -> RunData SerialisedKey SerialisedValue SerialisedBlob
   -> IO Property
 prop_WriteNumEntries fs hbio wb@(RunData m) =
-    withRunAt fs hbio runParams (simplePath 42) wb' $ \run -> do
+    withRunAt fs hbio testSessionSalt runParams (simplePath 42) wb' $ \run -> do
       let !runSize = Run.size run
 
       pure . labelRunData wb' $
@@ -206,7 +207,7 @@ prop_WriteAndOpen ::
   -> RunData SerialisedKey SerialisedValue SerialisedBlob
   -> IO Property
 prop_WriteAndOpen fs hbio wb =
-    withRunAt fs hbio runParams (simplePath 1337) (serialiseRunData wb) $ \written ->
+    withRunAt fs hbio testSessionSalt runParams (simplePath 1337) (serialiseRunData wb) $ \written ->
     withActionRegistry $ \reg -> do
       let paths = Run.runFsPaths written
           paths' = paths { runNumber = RunNumber 17}
@@ -268,7 +269,7 @@ prop_WriteRunEqWriteWriteBuffer hfs hbio rd = do
   let rdPaths = simplePath 1337
   let rdKOpsFile = Paths.runKOpsPath rdPaths
   let rdBlobFile = Paths.runBlobPath rdPaths
-  withRunAt hfs hbio runParams rdPaths srd $ \_run -> do
+  withRunAt hfs hbio testSessionSalt runParams rdPaths srd $ \_run -> do
     -- Serialise run data as write buffer:
     let f (SerialisedValue x) (SerialisedValue y) = SerialisedValue (x <> y)
     let inPaths = WrapRunFsPaths $ simplePath 1111