feat(bloomfilter): add salt

Author: wenkokke

bloomfilter/src/Data/BloomFilter/Blocked.hs

@@ -16,6 +16,7 @@
 module Data.BloomFilter.Blocked (
     -- * Types
     Hash,
+    Salt (Salt),
     Hashable,
 
     -- * Immutable Bloom filters
@@ -92,34 +93,35 @@ import           Prelude hiding (elem, notElem)
 -- Example:
 --
 -- @
---filter = create (sizeForBits 16 2) $ \mf -> do
+--filter = create salt (sizeForBits 16 2) $ \mf -> do
 --           insert mf \"foo\"
 --           insert mf \"bar\"
 -- @
 --
 -- Note that the result of the setup function is not used.
-create :: BloomSize
+create :: Salt
+       -> BloomSize
        -> (forall s. (MBloom s a -> ST s ()))  -- ^ setup function
        -> Bloom a
 {-# INLINE create #-}
-create bloomsize body =
+create bloomsalt bloomsize body =
     runST $ do
-      mb <- new bloomsize
+      mb <- new bloomsalt bloomsize
       body mb
       unsafeFreeze mb
 
 {-# INLINEABLE insert #-}
 -- | Insert a value into a mutable Bloom filter.  Afterwards, a
 -- membership query for the same value is guaranteed to return @True@.
 insert :: Hashable a => MBloom s a -> a -> ST s ()
-insert = \ !mb !x -> insertHashes mb (hashes x)
+insert = \ !mb !x -> insertHashes mb (hashes (mbHashSalt mb) x)
 
 {-# INLINE elem #-}
 -- | Query an immutable Bloom filter for membership.  If the value is
 -- present, return @True@.  If the value is not present, there is
 -- /still/ some possibility that @True@ will be returned.
 elem :: Hashable a => a -> Bloom a -> Bool
-elem = \ !x !b -> elemHashes b (hashes x)
+elem = \ !x !b -> elemHashes b (hashes (hashSalt b) x)
 
 -- | Same as 'elem' but with the opposite argument order:
 --
@@ -149,13 +151,14 @@ notElem = \x b -> not (x `elem` b)
 --     @b@ is used as a new seed.
 unfold :: forall a b.
           Hashable a
-       => BloomSize
+       => Salt
+       -> BloomSize
        -> (b -> Maybe (a, b))       -- ^ seeding function
        -> b                         -- ^ initial seed
        -> Bloom a
 {-# INLINE unfold #-}
-unfold bloomsize f k =
-    create bloomsize body
+unfold bloomsalt bloomsize f k =
+    create bloomsalt bloomsize body
   where
     body :: forall s. MBloom s a -> ST s ()
     body mb = loop k
@@ -173,23 +176,26 @@ unfold bloomsize f k =
 -- filt = fromList (policyForBits 10) [\"foo\", \"bar\", \"quux\"]
 -- @
 fromList :: (Foldable t, Hashable a)
-         => BloomPolicy
+         => Salt
+         -> BloomPolicy
          -> t a -- ^ values to populate with
          -> Bloom a
-fromList policy xs =
-    create bsize (\b -> mapM_ (insert b) xs)
+fromList bloomsalt policy xs =
+    create bloomsalt bsize (\b -> mapM_ (insert b) xs)
   where
     bsize = sizeForPolicy policy (length xs)
 
-{-# SPECIALISE deserialise :: BloomSize
+{-# SPECIALISE deserialise :: Salt
+                           -> BloomSize
                            -> (MutableByteArray RealWorld -> Int -> Int -> IO ())
                            -> IO (Bloom a) #-}
 deserialise :: PrimMonad m
-            => BloomSize
+            => Salt
+            -> BloomSize
             -> (MutableByteArray (PrimState m) -> Int -> Int -> m ())
             -> m (Bloom a)
-deserialise bloomsize fill = do
-    mbloom <- stToPrim $ new bloomsize
+deserialise bloomsalt bloomsize fill = do
+    mbloom <- stToPrim $ new bloomsalt bloomsize
     Internal.deserialise mbloom fill
     stToPrim $ unsafeFreeze mbloom
 
@@ -235,7 +241,7 @@ insertMany bloom key n =
         prepareProbes !i !i_w
           | i_w < 0x0f && i < n = do
               k <- key i
-              let !kh = hashes k
+              let !kh = hashes (mbHashSalt bloom) k
               prefetchInsert bloom kh
               P.writePrimArray buf i_w kh
               prepareProbes (i+1) (i_w+1)
@@ -258,7 +264,7 @@ insertMany bloom key n =
           -- (from the read end of the buffer).
           | i < n = do
               k <- key i
-              let !kh = hashes k
+              let !kh = hashes (mbHashSalt bloom) k
               prefetchInsert bloom kh
               P.writePrimArray buf i_w kh
               insertProbe

bloomfilter/src/Data/BloomFilter/Blocked/Internal.hs

@@ -9,16 +9,19 @@
 module Data.BloomFilter.Blocked.Internal (
     -- * Mutable Bloom filters
     MBloom,
+    mbHashSalt,
     new,
     maxSizeBits,
 
     -- * Immutable Bloom filters
     Bloom,
+    hashSalt,
     bloomInvariant,
     size,
 
     -- * Hash-based operations
     Hashes,
+    Salt (Salt),
     hashes,
     insertHashes,
     prefetchInsert,
@@ -52,6 +55,7 @@ import           Data.BloomFilter.Blocked.BitArray (BitArray, BitIx (..),
 import qualified Data.BloomFilter.Blocked.BitArray as BitArray
 import           Data.BloomFilter.Classic.Calc
 import           Data.BloomFilter.Hash
+import           Data.Word (Word64)
 
 -- | The version of the format used by 'serialise' and 'deserialise'. The
 -- format number will change when there is an incompatible change in the
@@ -84,6 +88,7 @@ type MBloom :: Type -> Type -> Type
 data MBloom s a = MBloom {
       mbNumBlocks :: {-# UNPACK #-} !NumBlocks  -- ^ non-zero
     , mbNumHashes :: {-# UNPACK #-} !Int
+    , mbHashSalt  :: {-# UNPACK #-} !Salt
     , mbBitArray  :: {-# UNPACK #-} !(MBitArray s)
     }
 type role MBloom nominal nominal
@@ -100,13 +105,14 @@ instance NFData (MBloom s a) where
 --
 -- The filter size is capped at 'maxSizeBits'.
 --
-new :: BloomSize -> ST s (MBloom s a)
-new BloomSize { sizeBits, sizeHashes } = do
+new :: Salt -> BloomSize -> ST s (MBloom s a)
+new hashSalt BloomSize { sizeBits, sizeHashes } = do
     let numBlocks = bitsToBlocks (max 1 (min maxSizeBits sizeBits))
     mbBitArray <- BitArray.new numBlocks
     pure MBloom {
       mbNumBlocks = numBlocks,
       mbNumHashes = max 1 sizeHashes,
+      mbHashSalt  = hashSalt,
       mbBitArray
     }
 
@@ -174,6 +180,7 @@ type Bloom :: Type -> Type
 data Bloom a = Bloom {
       numBlocks :: {-# UNPACK #-} !NumBlocks  -- ^ non-zero
     , numHashes :: {-# UNPACK #-} !Int
+    , hashSalt  :: {-# UNPACK #-} !Salt
     , bitArray  :: {-# UNPACK #-} !BitArray
     }
   deriving stock Eq
@@ -253,11 +260,12 @@ serialise b@Bloom{bitArray} =
 -- | Create an immutable Bloom filter from a mutable one.  The mutable
 -- filter may be modified afterwards.
 freeze :: MBloom s a -> ST s (Bloom a)
-freeze MBloom { mbNumBlocks, mbNumHashes, mbBitArray } = do
+freeze MBloom { mbNumBlocks, mbNumHashes, mbHashSalt, mbBitArray } = do
     bitArray <- BitArray.freeze mbBitArray
     let !bf = Bloom {
                 numBlocks = mbNumBlocks,
                 numHashes = mbNumHashes,
+                hashSalt = mbHashSalt,
                 bitArray
               }
     assert (bloomInvariant bf) $ pure bf
@@ -266,23 +274,25 @@ freeze MBloom { mbNumBlocks, mbNumHashes, mbBitArray } = do
 -- mutable filter /must not/ be modified afterwards. For a safer creation
 -- interface, use 'freeze' or 'create'.
 unsafeFreeze :: MBloom s a -> ST s (Bloom a)
-unsafeFreeze MBloom { mbNumBlocks, mbNumHashes, mbBitArray } = do
+unsafeFreeze MBloom { mbNumBlocks, mbNumHashes, mbHashSalt, mbBitArray } = do
     bitArray <- BitArray.unsafeFreeze mbBitArray
     let !bf = Bloom {
                 numBlocks = mbNumBlocks,
                 numHashes = mbNumHashes,
+                hashSalt = mbHashSalt,
                 bitArray
               }
     assert (bloomInvariant bf) $ pure bf
 
 -- | Copy an immutable Bloom filter to create a mutable one.  There is
 -- no non-copying equivalent.
 thaw :: Bloom a -> ST s (MBloom s a)
-thaw Bloom { numBlocks, numHashes, bitArray } = do
+thaw Bloom { numBlocks, numHashes, hashSalt, bitArray } = do
     mbBitArray <- BitArray.thaw bitArray
     pure MBloom {
       mbNumBlocks = numBlocks,
       mbNumHashes = numHashes,
+      mbHashSalt = hashSalt,
       mbBitArray
     }
 
@@ -317,9 +327,13 @@ newtype Hashes a = Hashes Hash
   deriving newtype Prim
 type role Hashes nominal
 
+-- | The salt value to be used for hashes.
+newtype Salt = Salt Word64
+  deriving stock (Eq, Show)
+
 {-# INLINE hashes #-}
-hashes :: Hashable a => a -> Hashes a
-hashes = Hashes . hash64
+hashes :: (Hashable a) => Salt -> a -> Hashes a
+hashes = \ (Salt !salt) !x -> Hashes (hashSalt64 salt x)
 
 {-# INLINE blockIxAndBitGen #-}
 -- | The scheme for turning 'Hashes' into block and bit indexes is as follows:

bloomfilter/src/Data/BloomFilter/Classic.hs

@@ -22,6 +22,7 @@ module Data.BloomFilter.Classic (
 
     -- * Types
     Hash,
+    Salt (Salt),
     Hashable,
 
     -- * Immutable Bloom filters
@@ -100,26 +101,27 @@ import           Prelude hiding (elem, notElem, read)
 -- @
 --
 -- Note that the result of the setup function is not used.
-create :: BloomSize
+create :: Salt
+       -> BloomSize
        -> (forall s. (MBloom s a -> ST s ()))  -- ^ setup function
        -> Bloom a
 {-# INLINE create #-}
-create bloomsize body =
+create bloomsalt bloomsize body =
     runST $ do
-      mb <- new bloomsize
+      mb <- new bloomsalt bloomsize
       body mb
       unsafeFreeze mb
 
 -- | Insert a value into a mutable Bloom filter.  Afterwards, a
 -- membership query for the same value is guaranteed to return @True@.
 insert :: Hashable a => MBloom s a -> a -> ST s ()
-insert !mb !x = insertHashes mb (hashes x)
+insert !mb !x = insertHashes mb (hashes (mbHashSalt mb) x)
 
 -- | Query an immutable Bloom filter for membership.  If the value is
 -- present, return @True@.  If the value is not present, there is
 -- /still/ some possibility that @True@ will be returned.
 elem :: Hashable a => a -> Bloom a -> Bool
-elem = \ !x !b -> elemHashes b (hashes x)
+elem = \ !x !b -> elemHashes b (hashes (hashSalt b) x)
 
 -- | Same as 'elem' but with the opposite argument order:
 --
@@ -142,7 +144,7 @@ notElem = \ x b -> not (x `elem` b)
 -- present, return @True@.  If the value is not present, there is
 -- /still/ some possibility that @True@ will be returned.
 read :: Hashable a => MBloom s a -> a -> ST s Bool
-read !mb !x = readHashes mb (hashes x)
+read !mb !x = readHashes mb (hashes (mbHashSalt mb) x)
 
 -- | Build an immutable Bloom filter from a seed value.  The seeding
 -- function populates the filter as follows.
@@ -154,13 +156,14 @@ read !mb !x = readHashes mb (hashes x)
 --     @b@ is used as a new seed.
 unfold :: forall a b.
           Hashable a
-       => BloomSize
+       => Salt
+       -> BloomSize
        -> (b -> Maybe (a, b))       -- ^ seeding function
        -> b                         -- ^ initial seed
        -> Bloom a
 {-# INLINE unfold #-}
-unfold bloomsize f k =
-    create bloomsize body
+unfold bloomsalt bloomsize f k =
+    create bloomsalt bloomsize body
   where
     body :: forall s. MBloom s a -> ST s ()
     body mb = loop k
@@ -180,23 +183,26 @@ unfold bloomsize f k =
 -- filt = fromList (policyForBits 10) [\"foo\", \"bar\", \"quux\"]
 -- @
 fromList :: (Foldable t, Hashable a)
-         => BloomPolicy
+         => Salt
+         -> BloomPolicy
          -> t a -- ^ values to populate with
          -> Bloom a
-fromList policy xs =
-    create bsize (\b -> mapM_ (insert b) xs)
+fromList bsalt policy xs =
+    create bsalt bsize (\b -> mapM_ (insert b) xs)
   where
     bsize = sizeForPolicy policy (length xs)
 
-{-# SPECIALISE deserialise :: BloomSize
+{-# SPECIALISE deserialise :: Salt
+                           -> BloomSize
                            -> (MutableByteArray RealWorld -> Int -> Int -> IO ())
                            -> IO (Bloom a) #-}
 deserialise :: PrimMonad m
-            => BloomSize
+            => Salt
+            -> BloomSize
             -> (MutableByteArray (PrimState m) -> Int -> Int -> m ())
             -> m (Bloom a)
-deserialise bloomsize fill = do
-    mbloom <- stToPrim $ new bloomsize
+deserialise bloomsalt bloomsize fill = do
+    mbloom <- stToPrim $ new bloomsalt bloomsize
     Internal.deserialise mbloom fill
     stToPrim $ unsafeFreeze mbloom