feat(lsm-tree): add salt

Author: wenkokke

lsm-tree.cabal

@@ -593,6 +593,7 @@ library
     , lsm-tree:control
     , lsm-tree:kmerge
     , primitive               ^>=0.9
+    , random                  ^>=1.0      || ^>=1.1      || ^>=1.2 || ^>=1.3
     , text                    ^>=2.1.1
     , utf8-string             ^>=1.0
     , vector                  ^>=0.13

src/Database/LSMTree.hs

@@ -101,6 +101,9 @@ module Database.LSMTree (
   toSnapshotName,
   SnapshotLabel (..),
 
+  -- * Session Configuration #session_configuration#
+  Salt,
+
   -- * Table Configuration #table_configuration#
   TableConfig (
     confMergePolicy,
@@ -242,7 +245,7 @@ import           Database.LSMTree.Internal.Serialise.Class (SerialiseKey (..),
 import           Database.LSMTree.Internal.Snapshot (SnapshotLabel (..))
 import           Database.LSMTree.Internal.Types (BlobRef (..), Cursor (..),
                      ResolveAsFirst (..), ResolveValue (..),
-                     ResolveViaSemigroup (..), Session (..), Table (..),
+                     ResolveViaSemigroup (..), Salt, Session (..), Table (..),
                      resolveAssociativity, resolveCompatibility,
                      resolveValidOutput)
 import           Database.LSMTree.Internal.Unsafe (BlobRefInvalidError (..),
@@ -263,6 +266,7 @@ import           System.FS.API (FsPath, HasFS (..), MountPoint (..), mkFsPath)
 import           System.FS.BlockIO.API (HasBlockIO (..), defaultIOCtxParams)
 import           System.FS.BlockIO.IO (ioHasBlockIO, withIOHasBlockIO)
 import           System.FS.IO (HandleIO, ioHasFS)
+import           System.Random (randomIO)
 
 --------------------------------------------------------------------------------
 -- Usage Notes
@@ -426,6 +430,7 @@ Throws the following exceptions:
     Tracer IO LSMTreeTrace ->
     HasFS IO HandleIO ->
     HasBlockIO IO HandleIO ->
+    Salt ->
     FsPath ->
     (Session IO -> IO a) ->
     IO a
@@ -436,12 +441,14 @@ withSession ::
   Tracer m LSMTreeTrace ->
   HasFS m h ->
   HasBlockIO m h ->
+  -- | The session salt.
+  Salt ->
   -- | The session directory.
   FsPath ->
   (Session m -> m a) ->
   m a
-withSession tracer hasFS hasBlockIO sessionDir action = do
-  Internal.withSession tracer hasFS hasBlockIO sessionDir (action . Session)
+withSession tracer hasFS hasBlockIO sessionSalt sessionDir action = do
+  Internal.withSession tracer hasFS hasBlockIO sessionSalt sessionDir (action . Session)
 
 -- | Variant of 'withSession' that is specialised to 'IO' using the real filesystem.
 withSessionIO ::
@@ -453,8 +460,9 @@ withSessionIO tracer sessionDir action = do
   let mountPoint = MountPoint sessionDir
   let sessionDirFsPath = mkFsPath []
   let hasFS = ioHasFS mountPoint
+  sessionSalt <- randomIO
   withIOHasBlockIO hasFS defaultIOCtxParams $ \hasBlockIO ->
-    withSession tracer hasFS hasBlockIO sessionDirFsPath action
+    withSession tracer hasFS hasBlockIO sessionSalt sessionDirFsPath action
 
 {- |
 Open a session from a session directory.
@@ -480,7 +488,7 @@ Throws the following exceptions:
     Tracer IO LSMTreeTrace ->
     HasFS IO HandleIO ->
     HasBlockIO IO HandleIO ->
-    -- \| The session directory.
+    Salt ->
     FsPath ->
     IO (Session IO)
   #-}
@@ -490,26 +498,29 @@ openSession ::
   Tracer m LSMTreeTrace ->
   HasFS m h ->
   HasBlockIO m h ->
+  -- | The session salt.
+  Salt ->
   -- | The session directory.
   FsPath ->
   m (Session m)
-openSession tracer hasFS hasBlockIO sessionDir =
-  Session <$> Internal.openSession tracer hasFS hasBlockIO sessionDir
+openSession tracer hasFS hasBlockIO sessionSalt sessionDir =
+  Session <$> Internal.openSession tracer hasFS hasBlockIO sessionSalt sessionDir
 
 -- | Variant of 'openSession' that is specialised to 'IO' using the real filesystem.
 openSessionIO ::
   Tracer IO LSMTreeTrace ->
-  -- \| The session directory.
+  -- | The session directory.
   FilePath ->
   IO (Session IO)
 openSessionIO tracer sessionDir = do
   let mountPoint = MountPoint sessionDir
   let sessionDirFsPath = mkFsPath []
   let hasFS = ioHasFS mountPoint
+  sessionSalt <- randomIO
   let acquireHasBlockIO = ioHasBlockIO hasFS defaultIOCtxParams
   let releaseHasBlockIO HasBlockIO{close} = close
   bracketOnError acquireHasBlockIO releaseHasBlockIO $ \hasBlockIO ->
-    openSession tracer hasFS hasBlockIO sessionDirFsPath
+    openSession tracer hasFS hasBlockIO sessionSalt sessionDirFsPath
 
 {- |
 Close a session.

src/Database/LSMTree/Internal/BloomFilter.hs

@@ -48,6 +48,7 @@ import qualified Database.LSMTree.Internal.Vector as P
 import qualified Database.LSMTree.Internal.StrictArray as P
 #endif
 
+import           Database.LSMTree.Internal.Paths (SessionSalt (..))
 import           Prelude hiding (filter)
 
 -- Bulk query
@@ -108,17 +109,18 @@ type ResIx = Int -- Result index
 -- number of keys but this is grown if needed (using a doubling strategy).
 --
 bloomQueries ::
-     V.Vector (Bloom SerialisedKey)
+     SessionSalt
+  -> V.Vector (Bloom SerialisedKey)
   -> V.Vector SerialisedKey
   -> VP.Vector RunIxKeyIx
-bloomQueries !filters !keys
+bloomQueries _sessionSalt !filters !keys
   | V.null filters || V.null keys = VP.empty
-bloomQueries !filters !keys =
+bloomQueries !sessionSalt !filters !keys =
     runST (bloomQueries_loop1 filters' keyhashes)
   where
     filters'  = toFiltersArray filters
     keyhashes = P.generatePrimArray (V.length keys) $ \i ->
-                  Bloom.hashes (V.unsafeIndex keys i)
+                  Bloom.hashesWithSalt (getSessionSalt sessionSalt) (V.unsafeIndex keys i)
 
 -- loop over all keys
 bloomQueries_loop1 ::
@@ -220,15 +222,16 @@ bloomFilterVersion = 1 + fromIntegral Bloom.formatVersion
 
 bloomFilterToLBS :: Bloom a -> LBS.ByteString
 bloomFilterToLBS bf =
-    let (size, ba, off, len) = Bloom.serialise bf
-     in header size <> byteArrayToLBS ba off len
+    let (size, salt, ba, off, len) = Bloom.serialise bf
+     in header size salt <> byteArrayToLBS ba off len
   where
-    header Bloom.BloomSize { sizeBits, sizeHashes } =
-        -- creates a single 16 byte chunk
-        B.toLazyByteStringWith (B.safeStrategy 16 B.smallChunkSize) mempty $
+    header Bloom.BloomSize { sizeBits, sizeHashes } salt =
+        -- creates a single 24 byte chunk
+        B.toLazyByteStringWith (B.safeStrategy 24 B.smallChunkSize) mempty $
              B.word32Host bloomFilterVersion
           <> B.word32Host (fromIntegral sizeHashes)
           <> B.word64Host (fromIntegral sizeBits)
+          <> B.word64Host salt
 
     byteArrayToLBS :: P.ByteArray -> Int -> Int -> LBS.ByteString
     byteArrayToLBS ba off len =
@@ -250,11 +253,12 @@ bloomFilterFromFile ::
   -> m (Bloom a)
 bloomFilterFromFile hfs h = do
     header <- rethrowEOFError "Doesn't contain a header" $
-              hGetByteArrayExactly hfs h 16
+              hGetByteArrayExactly hfs h 24
 
     let !version = P.indexByteArray header 0 :: Word32
         !nhashes = P.indexByteArray header 1 :: Word32
         !nbits   = P.indexByteArray header 1 :: Word64
+        !salt    = P.indexByteArray header 2 :: Word64
 
     when (version /= bloomFilterVersion) $ throwFormatError $
       if byteSwap32 version == bloomFilterVersion
@@ -274,6 +278,7 @@ bloomFilterFromFile hfs h = do
           Bloom.sizeBits   = fromIntegral nbits,
           Bloom.sizeHashes = fromIntegral nhashes
         }
+        salt
         (\buf off len ->
             rethrowEOFError "bloom filter file too short" $
               void $ hGetBufExactly hfs

src/Database/LSMTree/Internal/Lookup.hs

@@ -43,6 +43,7 @@ import           Database.LSMTree.Internal.Index (Index)
 import qualified Database.LSMTree.Internal.Index as Index (search)
 import           Database.LSMTree.Internal.Page (PageSpan (..), getNumPages,
                      pageSpanSize, unPageNo)
+import           Database.LSMTree.Internal.Paths (SessionSalt)
 import           Database.LSMTree.Internal.RawBytes (RawBytes (..))
 import qualified Database.LSMTree.Internal.RawBytes as RB
 import           Database.LSMTree.Internal.RawPage
@@ -61,13 +62,14 @@ import           System.FS.BlockIO.API
 -- associated with each 'IOOp'.
 prepLookups ::
      Arena s
+  -> SessionSalt
   -> V.Vector (Bloom SerialisedKey)
   -> V.Vector Index
   -> V.Vector (Handle h)
   -> V.Vector SerialisedKey
   -> ST s (VP.Vector RunIxKeyIx, V.Vector (IOOp s h))
-prepLookups arena blooms indexes kopsFiles ks = do
-  let !rkixs = bloomQueries blooms ks
+prepLookups arena sessionSalt blooms indexes kopsFiles ks = do
+  let !rkixs = bloomQueries sessionSalt blooms ks
   !ioops <- indexSearches arena indexes kopsFiles ks rkixs
   pure (rkixs, ioops)
 
@@ -110,6 +112,7 @@ type LookupAcc m h = V.Vector (Maybe (Entry SerialisedValue (WeakBlobRef m h)))
        HasBlockIO IO h
     -> ArenaManager RealWorld
     -> ResolveSerialisedValue
+    -> SessionSalt
     -> WB.WriteBuffer
     -> Ref (WBB.WriteBufferBlobs IO h)
     -> V.Vector (Ref (Run IO h))
@@ -125,6 +128,7 @@ lookupsIOWithWriteBuffer ::
   => HasBlockIO m h
   -> ArenaManager (PrimState m)
   -> ResolveSerialisedValue
+  -> SessionSalt
   -> WB.WriteBuffer
   -> Ref (WBB.WriteBufferBlobs m h)
   -> V.Vector (Ref (Run m h)) -- ^ Runs @rs@
@@ -133,10 +137,10 @@ lookupsIOWithWriteBuffer ::
   -> V.Vector (Handle h) -- ^ The file handles to the key\/value files inside @rs@
   -> V.Vector SerialisedKey
   -> m (LookupAcc m h)
-lookupsIOWithWriteBuffer !hbio !mgr !resolveV !wb !wbblobs !rs !blooms !indexes !kopsFiles !ks =
+lookupsIOWithWriteBuffer !hbio !mgr !resolveV !sessionSalt !wb !wbblobs !rs !blooms !indexes !kopsFiles !ks =
     assert precondition $
     withArena mgr $ \arena -> do
-      (rkixs, ioops) <- ST.stToIO $ prepLookups arena blooms indexes kopsFiles ks
+      (rkixs, ioops) <- ST.stToIO $ prepLookups arena sessionSalt blooms indexes kopsFiles ks
       ioress <- submitIO hbio ioops
       intraPageLookupsWithWriteBuffer resolveV wb wbblobs rs ks rkixs ioops ioress
   where
@@ -152,6 +156,7 @@ lookupsIOWithWriteBuffer !hbio !mgr !resolveV !wb !wbblobs !rs !blooms !indexes
        HasBlockIO IO h
     -> ArenaManager RealWorld
     -> ResolveSerialisedValue
+    -> SessionSalt
     -> V.Vector (Ref (Run IO h))
     -> V.Vector (Bloom SerialisedKey)
     -> V.Vector Index
@@ -168,16 +173,17 @@ lookupsIO ::
   => HasBlockIO m h
   -> ArenaManager (PrimState m)
   -> ResolveSerialisedValue
+  -> SessionSalt
   -> V.Vector (Ref (Run m h)) -- ^ Runs @rs@
   -> V.Vector (Bloom SerialisedKey) -- ^ The bloom filters inside @rs@
   -> V.Vector Index -- ^ The indexes inside @rs@
   -> V.Vector (Handle h) -- ^ The file handles to the key\/value files inside @rs@
   -> V.Vector SerialisedKey
   -> m (LookupAcc m h)
-lookupsIO !hbio !mgr !resolveV !rs !blooms !indexes !kopsFiles !ks =
+lookupsIO !hbio !mgr !resolveV !sessionSalt !rs !blooms !indexes !kopsFiles !ks =
     assert precondition $
     withArena mgr $ \arena -> do
-      (rkixs, ioops) <- ST.stToIO $ prepLookups arena blooms indexes kopsFiles ks
+      (rkixs, ioops) <- ST.stToIO $ prepLookups arena sessionSalt blooms indexes kopsFiles ks
       ioress <- submitIO hbio ioops
       intraPageLookupsOn resolveV (V.map (const Nothing) ks) rs ks rkixs ioops ioress
   where

src/Database/LSMTree/Internal/Merge.hs

@@ -35,6 +35,7 @@ import           Data.Traversable (for)
 import qualified Data.Vector as V
 import           Database.LSMTree.Internal.BlobRef (RawBlobRef)
 import           Database.LSMTree.Internal.Entry
+import           Database.LSMTree.Internal.Paths (SessionSalt)
 import           Database.LSMTree.Internal.Readers (Readers)
 import qualified Database.LSMTree.Internal.Readers as Readers
 import           Database.LSMTree.Internal.Run (Run)
@@ -153,6 +154,7 @@ instance IsMergeType TreeMergeType where
      IsMergeType t
   => HasFS IO h
   -> HasBlockIO IO h
+  -> SessionSalt
   -> RunParams
   -> t
   -> ResolveSerialisedValue
@@ -165,13 +167,14 @@ new ::
      (IsMergeType t, MonadMask m, MonadSTM m, MonadST m)
   => HasFS m h
   -> HasBlockIO m h
+  -> SessionSalt
   -> RunParams
   -> t
   -> ResolveSerialisedValue
   -> Run.RunFsPaths
   -> V.Vector (Ref (Run m h))
   -> m (Maybe (Merge t m h))
-new hfs hbio runParams mergeType mergeResolve targetPaths runs = do
+new hfs hbio sessionSalt runParams mergeType mergeResolve targetPaths runs = do
     let sources = Readers.FromRun <$> V.toList runs
     mreaders <- Readers.new mergeResolve Readers.NoOffsetKey sources
     -- TODO: Exception safety! If Readers.new fails after already creating some
@@ -180,7 +183,7 @@ new hfs hbio runParams mergeType mergeResolve targetPaths runs = do
     for mreaders $ \mergeReaders -> do
       -- calculate upper bounds based on input runs
       let numEntries = V.foldMap' Run.size runs
-      mergeBuilder <- Builder.new hfs hbio runParams targetPaths numEntries
+      mergeBuilder <- Builder.new hfs hbio sessionSalt runParams targetPaths numEntries
       mergeState <- newMutVar $! Merging
       pure Merge {
           mergeIsLastLevel = isLastLevel mergeType