unagi-bloomfilter (empty) → 0.1.0.0
raw patch · 8 files changed
+1898/−0 lines, 8 filesdep +QuickCheckdep +atomic-primopsdep +basesetup-changed
Dependencies added: QuickCheck, atomic-primops, base, bytestring, containers, criterion, deepseq, hashabler, primitive, random, text, unagi-bloomfilter, unordered-containers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- benchmarks/Main.hs +293/−0
- core-example/Main.hs +8/−0
- src/Control/Concurrent/BloomFilter.hs +26/−0
- src/Control/Concurrent/BloomFilter/Internal.hs +720/−0
- tests/Main.hs +675/−0
- unagi-bloomfilter.cabal +144/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Brandon Simmons++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Brandon Simmons nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmarks/Main.hs view
@@ -0,0 +1,293 @@+{-# LANGUAGE CPP , OverloadedStrings #-}+module Main where+# ifdef ASSERTIONS_ON+# error "Sorry, please reconfigure without -finstrumented so that we turn off assertions in library code."+# endif++import Criterion.Main+import Control.DeepSeq+import Control.Monad+import Control.Concurrent+import qualified Data.Text as T++import Control.Concurrent.BloomFilter.Internal+import qualified Control.Concurrent.BloomFilter as Bloom+import Data.Hashabler++import qualified Data.Set as Set+import qualified Data.HashSet as HashSet++-- import System.IO.Unsafe(unsafePerformIO)+import System.Random++-- TODO comparisons with:+-- - pure Set+-- - best in class Int (or other specialized) hash map or trie+-- - general hashmap (of Hashable things)+-- - the above, wrapped in an IORef or MVar++main :: IO ()+main = do+ assertionsOn <- assertionCanary+ when assertionsOn $+ putStrLn $ "!!! WARNING !!! assertions are enabled in library code and may result in "+ ++"slower than realistic benchmarks. Try configuring without -finstrumented"++ procs <- getNumCapabilities+ if procs < 2 + then putStrLn "!!! WARNING !!!: Some benchmarks are only valid if more than 1 core is available"+ else return ()+ + b_5_20 <- Bloom.new (SipKey 1 1) 5 20+ b_13_20 <- Bloom.new (SipKey 1 1) 13 20 -- needs 128++ -- This has 0.3% fpr for 10000 elements, so I think can be fairly compared+ b_text <- Bloom.new (SipKey 11 22) 3 12+ let txt = "orange" :: T.Text++ let g = mkStdGen 8973459+ chars = randoms g :: [Char]+ fakeWords = go chars+ go :: [Char] -> [String]+ go [] = error "noninfinite list"+ go (s:ss) = let (a,as) = splitAt 3 ss+ (b,bs) = splitAt 5 as+ (c,cs) = splitAt 5 bs+ (d,ds) = splitAt 6 cs+ (e,es) = splitAt 8 ds+ in [s]:a:b:c:d:e:(go es)++ let textWords10k = map T.pack $ take 10000 fakeWords+ (wds5k_0, wds5k_1) = splitAt 5000 textWords10k+ deepseq textWords10k $ return ()++ let hashset10 = HashSet.fromList $ take 10 textWords10k+ let hashset100 = HashSet.fromList $ take 100 textWords10k+ let hashset10000 = HashSet.fromList $ take 10000 textWords10k+ let set10 = Set.fromList $ take 10 textWords10k+ let set100 = Set.fromList $ take 100 textWords10k+ let set10000 = Set.fromList $ take 10000 textWords10k+ +++ defaultMain [+ bgroup "internals" [+ bench "membershipWordAndBits64" $ nf (membershipWordAndBits64 (Hash64 1)) b_5_20+ , bench "membershipWordAndBits128" $ nf (membershipWordAndBits128 (Hash128 1 1)) b_13_20+ ],++ -- For comparing cache behavior with perf, against below:+ bgroup "HashSet" $+ [ bench "10K insert" $ whnf (HashSet.fromList) textWords10k ],+ bgroup "Set" $+ [ bench "10K insert" $ whnf (Set.fromList) textWords10k ],++ bgroup "different sizes" $+ let benches b = [+ bench "10K inserts" $ whnfIO $ manyInserts b textWords10k+ , bench "10K lookups" $ whnfIO $ manyLookups b textWords10k+ ]+ in+ [ env (Bloom.new (SipKey 11 22) 3 12) $ \ ~b -> + bgroup "4096" (benches b)+ , env (Bloom.new (SipKey 11 22) 3 14) $ \ ~b -> + bgroup "16384" (benches b)+ , env (Bloom.new (SipKey 11 22) 3 16) $ \ ~b -> + bgroup "65536" (benches b)+ , env (Bloom.new (SipKey 11 22) 3 20) $ \ ~b -> + bgroup "1MB" (benches b)+ , env (Bloom.new (SipKey 11 22) 3 24) $ \ ~b -> + bgroup "8MB" (benches b)+ , env (Bloom.new (SipKey 11 22) 3 27) $ \ ~b -> + bgroup "64MB" (benches b)+ ]+ , bgroup "different sizes (concurrency)" $+ {-+ -- TODO factor out cost of 'new' in some better way:+ [ env (Bloom.new (SipKey 11 22) 3 12) $ \ ~b -> + bench "bigInsertLookup 15k ops" $ whnfIO (largeInsertQueryBench b wds5k_0 wds5k_1)++ , env (Bloom.new (SipKey 11 22) 3 12) $ \ ~b -> + bench "bigInsertLookup 15k ops across two threads (4096)" $ whnfIO (largeInsertQueryBenchTwoThreads b 5000 wds5k_0 wds5k_1)+ , env (Bloom.new (SipKey 11 22) 3 14) $ \ ~b -> + bench "bigInsertLookup 15k ops across two threads (16384)" $ whnfIO (largeInsertQueryBenchTwoThreads b 5000 wds5k_0 wds5k_1)+ , env (Bloom.new (SipKey 11 22) 3 16) $ \ ~b -> + bench "bigInsertLookup 15k ops across two threads (65536)" $ whnfIO (largeInsertQueryBenchTwoThreads b 5000 wds5k_0 wds5k_1)+ , env (Bloom.new (SipKey 11 22) 3 20) $ \ ~b -> + bench "bigInsertLookup 15k ops across two threads (1MB)" $ whnfIO (largeInsertQueryBenchTwoThreads b 5000 wds5k_0 wds5k_1)+ , env (Bloom.new (SipKey 11 22) 3 24) $ \ ~b -> + bench "bigInsertLookup 15k ops across two threads (8MB)" $ whnfIO (largeInsertQueryBenchTwoThreads b 5000 wds5k_0 wds5k_1)+ , env (Bloom.new (SipKey 11 22) 3 27) $ \ ~b -> + bench "bigInsertLookup 15k ops across two threads (64MB)" $ whnfIO (largeInsertQueryBenchTwoThreads b 5000 wds5k_0 wds5k_1)+ -}+ let benches b = [+ bench "10K inserts, across 2 threads" $ whnfIO $ manyInsertsTwoThreads b wds5k_0 wds5k_1+ , bench "10K lookups, across 2 threads" $ whnfIO $ manyLookupsTwoThreads b wds5k_0 wds5k_1+ ]+ in+ [ env (Bloom.new (SipKey 11 22) 3 12) $ \ ~b -> + bgroup "4096" (benches b)+ , env (Bloom.new (SipKey 11 22) 3 14) $ \ ~b -> + bgroup "16384" (benches b)+ , env (Bloom.new (SipKey 11 22) 3 16) $ \ ~b -> + bgroup "65536" (benches b)+ , env (Bloom.new (SipKey 11 22) 3 20) $ \ ~b -> + bgroup "1MB" (benches b)+ , env (Bloom.new (SipKey 11 22) 3 24) $ \ ~b -> + bgroup "8MB" (benches b)+ , env (Bloom.new (SipKey 11 22) 3 27) $ \ ~b -> + bgroup "64MB" (benches b)+ ]+ , bgroup "lookup insert" [+ bench "siphash64_1_3 for comparison" $ whnf (siphash64_1_3 (SipKey 1 1)) (1::Int)++ -- best case, with no cache effects (I think):+ , bench "lookup (64)" $ whnfIO (Bloom.lookup b_5_20 (1::Int))+ , bench "lookup x10 (64)" $ nfIO (mapM_ (Bloom.lookup b_5_20) [1..10])+ , bench "lookup x100 (64)" $ nfIO (mapM_ (Bloom.lookup b_5_20) [1..100])+ , bench "lookup (128)" $ whnfIO (Bloom.lookup b_13_20 (1::Int))+ , bench "lookup x10 (128)" $ nfIO (mapM_ (Bloom.lookup b_13_20) [1..10])+ , bench "lookup x100 (128)" $ nfIO (mapM_ (Bloom.lookup b_13_20) [1..100])++ , bench "insert (64)" $ whnfIO (Bloom.insert b_5_20 (1::Int))+ , bench "insert x10 (64)" $ nfIO (mapM_ (Bloom.insert b_5_20) [1..10])+ , bench "insert x100 (64)" $ nfIO (mapM_ (Bloom.insert b_5_20) [1..100])+ , bench "insert (128)" $ whnfIO (Bloom.insert b_13_20 (1::Int))+ , bench "insert x10 (128)" $ nfIO (mapM_ (Bloom.insert b_13_20) [1..10])+ , bench "insert x100 (128)" $ nfIO (mapM_ (Bloom.insert b_13_20) [1..100])++ ],+ bgroup "comparisons micro" [+ bench "(just siphash64_1_3 on txt for below)" $ whnf (siphash64_1_3 (SipKey 1 1)) ("orange"::T.Text)+ , bench "Bloom.insert (64)" $ whnfIO (Bloom.insert b_text txt)+ {- I was concerned that the above might not be valid (perhaps the+ - hashing of the Text value was getting reused?), but the following+ - convinced me it's all right; we can see differences in size of input+ - string reflected in all these benchmarks. I believe bloomInsertPure1+ - reflects the inability to inline Hashable instance machinery (since+ - it must remain polymorphic.+ , bench "Bloom.insert (64)(validation1)" $ whnf (bloomInsertPure1 b_text) txt+ , bench "Bloom.insert (64)(validation2)" $ whnf (bloomInsertPure2 b_text) txt+ , bench "Bloom.insert (64)(validation3)" $ whnfIO (Bloom.insert b_text "ora")+ , bench "Bloom.insert (64)(validation4)" $ whnf (bloomInsertPure1 b_text) "ora"+ , bench "Bloom.insert (64)(validation5)" $ whnf (bloomInsertPure2 b_text) "ora"+ , bench "(validation orange)" $ whnf (siphash64_1_3 (SipKey 1 1)) ("orange"::T.Text)+ , bench "(validation ora)" $ whnf (siphash64_1_3 (SipKey 1 1)) ("ora"::T.Text)+ -}++ , bench "Set.insert into 10" $ whnf (\t-> Set.insert t set10) txt+ , bench "Set.insert into 100" $ whnf (\t-> Set.insert t set100) txt+ , bench "Set.insert into 10000" $ whnf (\t-> Set.insert t set10000) txt++ , bench "HashSet.insert into 10" $ whnf (\t-> HashSet.insert t hashset10) txt+ , bench "HashSet.insert into 100" $ whnf (\t-> HashSet.insert t hashset100) txt+ , bench "HashSet.insert into 10000" $ whnf (\t-> HashSet.insert t hashset10000) txt++ , bench "Bloom.lookup (64)" $ whnfIO (Bloom.lookup b_text txt)++ , bench "Set.member of 10" $ whnf (\t-> Set.member t set10) txt+ , bench "Set.member of 100" $ whnf (\t-> Set.member t set100) txt+ , bench "Set.member of 10000" $ whnf (\t-> Set.member t set10000) txt++ , bench "HashSet.member of 10" $ whnf (\t-> HashSet.member t hashset10) txt+ , bench "HashSet.member of 100" $ whnf (\t-> HashSet.member t hashset100) txt+ , bench "HashSet.member of 10000" $ whnf (\t-> HashSet.member t hashset10000) txt+ ],+ bgroup "comparisons big" [+ ],+ -- TODO large random lookup and insert benchmark, comparing with single-thread and then with work split.+ -- make this how we compare as well?+ -- Do this for various types of elements++ bgroup "combining and creation" [+ -- These timings can be subtracted from union timings:+ bench "new 14" $ whnfIO $ Bloom.new (SipKey 1 1) 3 14+ , bench "new 20" $ whnfIO $ Bloom.new (SipKey 1 1) 3 20++ , bench "unionInto (14 -> 14)" $ whnfIO $ unionBench 14 14+ , bench "unionInto (20 -> 14)" $ whnfIO $ unionBench 20 14 -- 20 is 6x+ , bench "unionInto (20 -> 20)" $ whnfIO $ unionBench 20 20+ ]+ ]++unionBench :: Int -> Int -> IO ()+unionBench bigl littlel = do+ b1 <- Bloom.new (SipKey 1 1) 3 bigl+ b2 <- Bloom.new (SipKey 1 1) 3 littlel+ b1 `Bloom.unionInto` b2+++instance NFData (BloomFilter a) where+ rnf _ = ()++{-+-- TODO fix both of these and compare with Set/HashSet (wrapped in IORef or MVar for second)+largeInsertQueryBench :: Bloom.BloomFilter T.Text -> [T.Text] -> [T.Text] -> IO ()+largeInsertQueryBench b payload antipayload = do+ forM_ payload $ Bloom.insert b+ forM_ (zip payload antipayload) $ \(x,y)-> do+ --- can't test, since we're re-using bloom:+ _xOk <- Bloom.lookup b x+ _yOk <- Bloom.lookup b y -- usually False+ -- unless (xOk) $ error "largeInsertQueryBench"+ return ()++largeInsertQueryBenchTwoThreads :: Bloom.BloomFilter T.Text -> Int -> [T.Text] -> [T.Text] -> IO ()+largeInsertQueryBenchTwoThreads b length_payload payload antipayload = do+ t0 <- newEmptyMVar+ t1 <- newEmptyMVar+ let (payload0,payload1) = splitAt (length_payload `div` 2) payload+ let (antipayload0,antipayload1) = splitAt (length_payload `div` 2) antipayload++ let go pld antpld v = do+ forM_ pld $ Bloom.insert b+ forM_ (zip pld antpld) $ \(x,y)-> do+ _xOk <- Bloom.lookup b x+ _yOk <- Bloom.lookup b y -- usually False+ -- unless (xOk) $ error "largeInsertQueryBench"+ return ()+ putMVar v ()+ void $ forkIO $ go payload0 antipayload0 t0+ void $ forkIO $ go payload1 antipayload1 t1+ takeMVar t0 >> takeMVar t1+ -}+++-- These are mostly to check cache behavior, and I don't expect it to matter+-- whether a bloom filter was already "filled with elements" or not.+manyInserts :: Bloom.BloomFilter T.Text -> [T.Text] -> IO ()+manyInserts b payload = do+ forM_ payload (void . Bloom.insert b)++manyLookups :: Bloom.BloomFilter T.Text -> [T.Text] -> IO ()+manyLookups b payload = do+ forM_ payload (void . Bloom.lookup b)++manyInsertsTwoThreads :: Bloom.BloomFilter T.Text -> [T.Text] -> [T.Text] -> IO ()+manyInsertsTwoThreads b payload0 payload1 = do+ t0 <- newEmptyMVar+ t1 <- newEmptyMVar+ let go pld v = manyInserts b pld >> putMVar v ()+ void $ forkIO $ go payload0 t0+ void $ forkIO $ go payload1 t1+ takeMVar t0 >> takeMVar t1++manyLookupsTwoThreads :: Bloom.BloomFilter T.Text -> [T.Text] -> [T.Text] -> IO ()+manyLookupsTwoThreads b payload0 payload1 = do+ t0 <- newEmptyMVar+ t1 <- newEmptyMVar+ let go pld v = manyLookups b pld >> putMVar v ()+ void $ forkIO $ go payload0 t0+ void $ forkIO $ go payload1 t1+ takeMVar t0 >> takeMVar t1+++{-+-- So we can use whnf, and make sure hashes aren't being cached+{-# NOINLINE bloomInsertPure1 #-}+bloomInsertPure1 :: Hashable a => BloomFilter a -> a -> Bool+bloomInsertPure1 b = unsafePerformIO . Bloom.insert b++bloomInsertPure2 :: Hashable a => BloomFilter a -> a -> Bool+bloomInsertPure2 b = unsafePerformIO . Bloom.insert b+-}
+ core-example/Main.hs view
@@ -0,0 +1,8 @@+module Main(main) where++import qualified Control.Concurrent.BloomFilter as Bloom++main = do+ b_5_20 <- Bloom.new (Bloom.SipKey 1 1) 5 20+ p <- Bloom.lookup b_5_20 (1::Int)+ print p
+ src/Control/Concurrent/BloomFilter.hs view
@@ -0,0 +1,26 @@+module Control.Concurrent.BloomFilter (+{- | A thread-safe mutable bloom filter. Some additional functionality for+ advanced users is exposed in "Control.Concurrent.BloomFilter.Internal".+ -}+ BloomFilter()+ , BloomFilterException(..)+ -- * Creation+ , new+ , SipKey(..)+ -- * Operations+ , insert+ , lookup+ -- ** Copying and Combining+ , unionInto+ , intersectionInto+ , clone+ -- * Serialization+ , serialize+ , deserialize+ -- * Utilities+ , fpr++ ) where++import Control.Concurrent.BloomFilter.Internal+import Prelude hiding (lookup)
+ src/Control/Concurrent/BloomFilter/Internal.hs view
@@ -0,0 +1,720 @@+{-# LANGUAGE BangPatterns, RecordWildCards, CPP, ScopedTypeVariables, DeriveDataTypeable #-}+module Control.Concurrent.BloomFilter.Internal (+{- | Some additional unsafe, low-level, and internal functions are exposed here+ for advanced users. The API should remain stable, except that functions may+ be added and no promises are made about the internals of the 'BloomFilter'+ type itself.+ -}+ new+ , BloomFilter(..)+ , BloomFilterException(..)+ , insert+ , lookup+ , unionInto+ , intersectionInto+ , clone+ , SipKey(..)+ , fpr++ , serialize+ , unsafeSerialize+ , deserialize+ , deserializeByteArray++# ifdef EXPORT_INTERNALS+ -- * Internal functions exposed for testing; you shouldn't see these+ , membershipWordAndBits64, membershipWordAndBits128+ , maskLog2wRightmostBits+ , log2w+ , wordSizeInBits+ , uncheckedSetBit+ , isHash64Enough+ , log2lFromArraySize+ , assertionCanary+ , bytes64, unbytes64+# endif+ )+ where+++import Data.Bits hiding (unsafeShiftL, unsafeShiftR)+import qualified Data.Bits as BitsHidden+import qualified Data.Primitive.ByteArray as P+import Data.ByteString.Internal+import GHC.ForeignPtr+import Foreign.ForeignPtr+import Foreign.Storable(peekElemOff)+import Data.Primitive.MachDeps+import Data.Primitive.Types(Addr(..))+import Control.Monad.Primitive(RealWorld)+import Data.Atomics+import Data.Hashabler+import Control.Exception+import Data.Typeable(Typeable)+import Control.Monad+import Data.Word(Word64, Word8)+import Prelude hiding (lookup)++-- Future operations:+-- - memory-mapped bloomfilter for durability (which of ACID do we get?). See 'vector-mmap' package?+-- - allow opening mmap-ed file directly from serialized form?+-- - approximating number of items, and size of union and intersection+-- - freezing/pure/ST interface (e.g. Data.BloomFilter)+-- - API: +-- - only allow writes in ST (copying for each write is awful)+-- - provide a fromList that uses ST, for convenience+-- - querying and combining can be regural pure interface (Semigroup)+-- +-- - bulk reads and writes, for performance: (especially good for pure interface fromList, etc.+-- fromList implementation possibilities:+-- 1 - allocate new+-- - unsafeInsert all into new (possibly prefetching next block)+-- - non-threadsafe union with previous+-- 2 - hash and sort (as list or something)+-- - memcpy previous+-- - unsafeInsert in order into new+-- 3 - memcpy previous+-- - unsafeInsert new, manually prefetching next.+-- - re-order hashes for in-order cache line access (benchmark this)+-- - consider prefetching+-- - combine inter-word reads and writes.+-- - consider a Scalable Bloom Filter -type approach (or variant):+-- - CAS of linked list of filters+-- - possible linearizability issues.+-- - other operations become tricker or not doable.+--+--+-- Future typed interface:+-- - parameterize by length, or at least have separate Bloom64 (faster, uses only 64-bit hashes) and Bloom128 functions.+-- - new takes a type-level nat regardless of whether we carry that around in a parameter+-- - parameterize by k (no big deal being static)+-- - for sipkey: +-- - use NullaryTypeClasses or some more clever solution+-- "The configurations problem is to propagate run-time preferences+-- throughout a program, allowing multiple concurrent configuration sets+-- to coexist safely under statically guaranteed separation..."+-- TODO is this relevant for the other type-level params we imagine?+-- TODO can the two be complimentary?: use a singleton class, but instantiate it dynamically with reflection? per:https://www.schoolofhaskell.com/user/thoughtpolice/using-reflection#dynamically-constructing-type-class-instances+-- - Or use a type lit that corresponds to an environment variable, and tag+-- - the user could shoot himself in the foot by changing the environment and break this scheme+-- but that's probably okay.+-- - what if user wants to pass it as a command line arg or something? Is this equally compatible with windows?+--+-- - `new` variant that ensures fast 64-bit version.+-- - deserializing, will have type ... -> Either String (BloomFilter x y z a)+-- - we can always check equality of value level nats by doing natVal when deserializing++++-- TODO: expose functions that would allow users to shard inserts and lookups+-- and use non-atomic write. e.g. maybe an unsafeInsert (non-threadsafe+-- write) as well as functions that take a user-supplied hash directly. ++++-- | A mutable bloom filter representing a set of 'Hashable' values of type @a@.+--+-- A bloom filter is a set-like probabilistic hash-based data structure.+-- Elements can be 'insert'-ed and 'lookup'-ed again. The bloom filter+-- takes a constant amount of memory regardless of the size and number of+-- elements inserted, however as the bloom filter \"grows\" the likelihood of+-- false-positives being returned by 'lookup' increases. 'fpr' can be used to+-- estimate the expected false-positive rate.+data BloomFilter a = BloomFilter { key :: !SipKey+ , k :: !Int+ , hash64Enough :: Bool+ -- ^ if we need no more than 64-bits we can use the faster 'siphash64_1_3'+ , l_minus1 :: !Word64+ , log2l :: !Int+ , arr :: !(P.MutableByteArray RealWorld)+ }+++-- | Exceptions that may be thrown by operations in this library.+newtype BloomFilterException = BloomFilterException String+ deriving (Show, Typeable)++instance Exception BloomFilterException++throwBloom :: String -> IO a+throwBloom = throwIO . BloomFilterException++-- | Create a new bloom filter of elements of type @a@ with the given hash key+-- and parameters. 'fpr' can be useful for calculating the @k@ parameter, or+-- determining a good filter size.+--+-- The parameters must satisfy the following conditions, otherwise a+-- 'BloomFilterException' will be thrown:+--+-- - @k > 0@+-- - @log2l >= 0 && log2l <= wordSizeInBits@+-- - @log2l + k*(logBase 2 wordSizeInBits) <= 128@+--+-- In addition, performance on 64-bit machines will be best when+-- @log2l + k*(logBase 2 wordSizeInBits) <= 64@ where we require only 64 hash+-- bits for each element. (Performance on 32-bit machines will be worse in all+-- cases, as we're doing 64-bit arithmetic.)+--+-- Example: on a 32-bit machine, the following produces a ~4KB bloom filter of+-- @2^10@ 32-bit words, using 3 bits per element:+--+-- @+-- do key <- read <$> getEnv "THE_SECRET_KEY"+-- Bloom.new key 3 10+-- @+new :: SipKey+ -- ^ The secret key to be used for hashing values for this bloom filter.+ -> Int+ -- ^ @k@: Number of independent bits of @w@ to which we map an element. 3 is a good choice.+ -> Int+ -- ^ @log2l@: The size of the filter, in machine words, as a power of 2. e.g. @3@ means @2^3@ or @8@ machine words.+ -> IO (BloomFilter a)+new key k log2l = do+ -- In typed interface all of these conditions hold:+ let !hash64Enough = isHash64Enough log2l k+ checkParamInvariants k log2l++ (arr, sizeDataBytes) <- newBloomArr log2l+ P.fillByteArray arr 0 sizeDataBytes (0x00)++ return $ BloomFilter { l_minus1 = (2^log2l)-1, .. }++-- factored out for deserialization:+checkParamInvariants :: Int -> Int -> IO ()+checkParamInvariants k log2l = do+ unless (k > 0) $+ throwBloom "in 'new', k must be > 0"+ unless (log2l >= 0) $+ throwBloom "in 'new', log2l must be >= 0"++-- We leave a buffer at the end of the data portion of the filter large enough+-- to store metadata for serialization, so we don't have to do any copying for+-- ser/deser. But we don't concern ourselves with populating or maintaining+-- metadata except during our serialization and deserialization routines; that+-- memory may be dirty.+newBloomArr :: Int -> IO (P.MutableByteArray RealWorld, Int)+newBloomArr log2l = do+ let !sizeDataBytes = sIZEOF_INT `uncheckedShiftL` log2l+ -- aligned: we assume atomic reads (no word tearing):+ -- pinned: for performance, and so we can "serialize" to bytestring without+ -- copying, and do other future FFI stuff+ arr <- P.newAlignedPinnedByteArray (sizeDataBytes+sIZEOF_METADATA) aLIGNMENT_INT+ return (arr,sizeDataBytes)++log2lFromArraySize :: Int{-bytes-} -> IO Int+log2lFromArraySize sz = + either throwBloom return $ do+ let dataSzBytes = sz - sIZEOF_METADATA+ log2lFloat = logBase 2 ((fromIntegral dataSzBytes / fromIntegral sIZEOF_INT) :: Float)+ log2l = floor log2lFloat+ unless (dataSzBytes >= sIZEOF_INT) $ Left "Array is not large enough to be a serialized bloom filter"+ unless (fromIntegral log2l == log2lFloat) $ Left "Array is an unexpected size for a serialized bloom filter"+ return log2l+ +++membershipWordAndBits64 :: Hash64 a -> BloomFilter a -> (Int, Int)+{-# INLINE membershipWordAndBits64 #-}+membershipWordAndBits64 !(Hash64 h) = \ !(BloomFilter{ .. }) ->+ assert (isHash64Enough log2l k) $+ -- From right: take all member bits, then take membership word. NOTE: for+ -- union on different size filters to work we must not e.g. take the+ -- leftmost log2l bits; we need lower-order bits to be the same between the+ -- two filters.+ let !memberWord = fromIntegral $+ l_minus1 .&. (h `uncheckedShiftR` fromIntegral (k*log2w))+ !wordToOr = fst $ setKMemberBits 0x00 k h++ in (memberWord, wordToOr)++membershipWordAndBits128 :: Hash128 a -> BloomFilter a -> (Int, Int)+{-# INLINE membershipWordAndBits128 #-}+membershipWordAndBits128 (Hash128 h_0 h_1) = \(BloomFilter{ .. }) ->+ assert (not $ isHash64Enough log2l k) $+ -- Isolate member word by taking from lowest bits of h_0, take member bits+ -- starting from right of h_1, possibly using leftmost from h_0 which we+ -- splice onto the end as we shift and consume h_1:+ let !memberWord = fromIntegral $ l_minus1 .&. h_0+ !bitsReqd_h_0 = k*log2w - 64++ !wordToOr =+ if bitsReqd_h_0 <= 0+ then fst $ setKMemberBits 0x00 k h_1+ else -- we'll shift right just enough so we can OR with the last bit of h_1 shifted right:+ let !bitsReqd_h_0_withOffs = bitsReqd_h_0 + (64 `rem` log2w)+ !h_0_alignedMasked =+ -- clear right:+ (h_0 `uncheckedShiftR` (64 - bitsReqd_h_0)) -- n.b. conditional guards shift+ -- align at offset:+ `uncheckedShiftL` (64 - bitsReqd_h_0_withOffs)+ !initialKToTake = bitsReqd_h_0_withOffs `quot` log2w+ (!wordToOrPart0, !h_1_shifted) = setKMemberBits 0x00 initialKToTake h_1++ in assert (initialKToTake > 0) $+ fst $ setKMemberBits wordToOrPart0 (k-initialKToTake) (h_1_shifted.|.h_0_alignedMasked)++ in (memberWord, wordToOr)++++setKMemberBits :: Int -> Int -> Word64 -> (Int, Word64)+{-# INLINE setKMemberBits #-}+setKMemberBits !wd 0 h' = (wd, h')+setKMemberBits !wd !k' !h' =+ -- possible cast to 32-bit Int but we only need rightmost 5 or 6 bits:+ let !memberBit = fromIntegral h' .&. maskLog2wRightmostBits+ in setKMemberBits (wd `uncheckedSetBit` memberBit) (k'-1) (h' `uncheckedShiftR` log2w)++++membershipWordAndBitsFor :: (Hashable a)=> BloomFilter a -> a -> (Int, Int)+{-# INLINE membershipWordAndBitsFor #-}+membershipWordAndBitsFor bloom@(BloomFilter{..}) a+ | hash64Enough = membershipWordAndBits64 (siphash64_1_3 key a) bloom+ | otherwise = membershipWordAndBits128 (siphash128 key a) bloom+++-- True if we can get enough hash bits from a Word64, and a runtime check+-- sanity check of our arguments to 'new'. This is probably in "enough for+-- anyone" territory currently:+isHash64Enough :: Int -> Int -> Bool+{-# INLINE isHash64Enough #-}+isHash64Enough log2l k =+ let bitsReqd = log2l + k*log2w+ in if bitsReqd > 128+ then throw $ BloomFilterException "The passed parameters require over the maximum of 128 hash bits supported. Make sure: (log2l + k*(logBase 2 wordSizeInBits)) <= 128"+ else if (log2l > wordSizeInBits)+ then throw $ BloomFilterException "You asked for (log2l > 64). We have no way to address memory in that range, and anyway that's way too big."+ else bitsReqd <= 64++maskLog2wRightmostBits :: Int -- 2^log2w - 1+maskLog2wRightmostBits | sIZEOF_INT == 8 = 63+ | otherwise = 31++wordSizeInBits :: Int+wordSizeInBits = sIZEOF_INT * 8++log2w :: Int -- logBase 2 wordSizeInBits+log2w | sIZEOF_INT == 8 = 6+ | otherwise = 5++uncheckedSetBit :: Int -> Int -> Int+{-# INLINE uncheckedSetBit #-}+uncheckedSetBit x i = x .|. (1 `uncheckedShiftL` i)++uncheckedShiftR :: (Num a, FiniteBits a, Ord a) => a -> Int -> a+{-# INLINE uncheckedShiftR #-}+uncheckedShiftR a = \x->+ assert (a >= 0) $ -- make sure we don't smear sign w/ a bad fromIntegral cast+ assert (x < finiteBitSize a) $+ assert (x >= 0) $+ a `BitsHidden.unsafeShiftR` x+uncheckedShiftL :: (Num a, FiniteBits a, Ord a) => a -> Int -> a+{-# INLINE uncheckedShiftL #-}+uncheckedShiftL a = \x->+ assert (a >= 0) $+ assert (x < finiteBitSize a) $+ assert (x >= 0) $+ a `BitsHidden.unsafeShiftL` x+++-- | /O(size_of_element)/. Atomically insert a new element into the bloom+-- filter.+--+-- This returns 'True' if the element /did not exist/ before the insert, and+-- 'False' if the element did already exist (subject to false-positives; see+-- 'lookup'). Note that this is reversed from @lookup@.+insert :: Hashable a=> BloomFilter a -> a -> IO Bool+{-# INLINE insert #-}+insert bloom@(BloomFilter{..}) = \a-> do+ let (!memberWord, !wordToOr) = membershipWordAndBitsFor bloom a+ oldWord <- fetchOrIntArray arr memberWord wordToOr+ return $! (oldWord .|. wordToOr) /= oldWord++-- | /O(size_of_element)/. Look up the value in the bloom filter, returning+-- 'True' if the element is possibly in the set, and 'False' if the element is+-- /certainly not/ in the set.+--+-- The likelihood that this returns 'True' on an element that was not+-- previously 'insert'-ed depends on the parameters the filter was created+-- with, and the number of elements already inserted. The 'fpr' function can+-- help you estimate this.+lookup :: Hashable a=> BloomFilter a -> a -> IO Bool+{-# INLINE lookup #-}+lookup bloom@(BloomFilter{..}) = \a-> do+ let (!memberWord, !wordToOr) = membershipWordAndBitsFor bloom a+ existingWord <- P.readByteArray arr memberWord+ return $! (existingWord .|. wordToOr) == existingWord+++++-- | /O(l_src+l_target)/. Write all elements in the first bloom filter into the+-- second. This operation is lossless; ignoring writes to the source bloom+-- filter that happen during this operation (see below), the target bloom+-- filter will be identical to the filter produced had the elements been+-- inserted into the target originally.+--+-- The source and target must have been created with the same key and+-- @k@-value. In addition the target must not be larger (i.e. the @l@-value)+-- than the source, /and/ they must both use 128/64 bit hashes. This throws a+-- 'BloomFilterException' when those constraints are not met.+--+-- This operation is not linearizable with respect to 'insert'-type operations;+-- elements being written to the source bloomfilter during this operation may+-- or may not make it into the target "at random".+unionInto :: BloomFilter a -- ^ Source, left unmodified.+ -> BloomFilter a -- ^ Target, receiving elements from source.+ -> IO ()+unionInto = combine fetchOrIntArray++++-- | /O(l_src+l_target)/. Make @target@ the intersection of the source and+-- target sets. This operation is "lossy" in that the false positive ratio of+-- target after the operation may be higher than if the elements forming the+-- intersection had been 'insert'-ed directly into target.+--+-- The constraints and comments re. linearizability in 'unionInto' also apply+-- here.+intersectionInto :: BloomFilter a -- ^ Source, left unmodified.+ -> BloomFilter a -- ^ Target, receiving elements from source.+ -> IO ()+intersectionInto = combine fetchAndIntArray+++-- internal+combine :: (P.MutableByteArray RealWorld -> Int -> Int -> IO x)+ -> BloomFilter a -> BloomFilter a -> IO ()+{-# INLINE combine #-}+combine f = \src target -> do+ unless (key src == key target) $ throwBloom $+ "SipKey of the source BloomFilter does not match target"+ unless (k src == k target) $ throwBloom $+ "k of the source BloomFilter does not match target"+ unless (log2l src >= log2l target) $ throwBloom $+ "log2l of the source BloomFilter is smaller than the target"+ unless (hash64Enough src == hash64Enough target) $ throwBloom $+ "either the source or target BloomFilter requires 128 hash bits while the other requires 64"++ let target_l_minus1 = fromIntegral $ l_minus1 target+ src_l_minus1 = fromIntegral $ l_minus1 src++ -- unless source and target are the same size we must "shrink" source to+ -- size of target onto an intermediate array first (necessary to support+ -- the AND for intersection, and also faster because it uses fewer atomic+ -- primops onto target):+ srcArrShrunk <-+ if target_l_minus1 == src_l_minus1+ then return (arr src)+ else assert (target_l_minus1 < src_l_minus1) $ do+ (srcArrShrunk, sizeDataBytes) <- newBloomArr $ log2l target+ -- initialize new array with an efficient copy of first chunk from+ -- source:+ P.copyMutableByteArray srcArrShrunk 0 (arr src) 0 sizeDataBytes++ forM_ [(target_l_minus1+1).. src_l_minus1] $ \srcWordIx -> do+ let !targetWordIx = srcWordIx .&. target_l_minus1+ srcWord <- P.readByteArray (arr src) srcWordIx+ assert (targetWordIx <= target_l_minus1) $+ nonatomicFetchOrIntArray srcArrShrunk targetWordIx srcWord++ assert (P.sizeofMutableByteArray srcArrShrunk ==+ P.sizeofMutableByteArray (arr target)) $+ return srcArrShrunk++ forM_ [0.. target_l_minus1] $ \ix -> do+ srcWord <- P.readByteArray srcArrShrunk ix+ f (arr target) ix srcWord++-- | Create a copy of the input @BloomFilter@.+--+-- This operation is not linearizable with respect to 'insert'-type operations;+-- elements being written to the source bloomfilter during this operation may+-- or may not make it into the target "at random".+clone :: BloomFilter a -> IO (BloomFilter a)+clone BloomFilter{..} = do+ (arrCopy, sizeDataBytes) <- newBloomArr log2l+ P.copyMutableByteArray arrCopy 0 arr 0 sizeDataBytes+ return $ + BloomFilter { arr = arrCopy, .. }+++nonatomicFetchOrIntArray :: P.MutableByteArray RealWorld -> Int -> Int -> IO Int+nonatomicFetchOrIntArray ar ix wd = do+ !before <- P.readByteArray ar ix+ P.writeByteArray ar ix (before .|. wd)+ return before+++{-+-- This is the corrected equation from 'Supplementary File: A Comment on “Fast+-- Bloom Filters and Their Generalization”'. Unfortunately since we're going to need to approximate factorial even to calculate this.+-- compute this without moving into log space and probably approximating the+-- factorials which might defeat the purpose of using this more accurate+-- function to begin with.+fpr :: Int -- ^ @n@: Number of elements in filter+ -> Int -- ^ @l@: Size of filter, in machine words+ -> Int -- ^ @k@: Number of bits to map an element to+ -> Float+fpr nI lI kI =+ let w = 64 -- TODO word-size in bits+ n = fromIntegral nI+ l = fromIntegral lI+ k = fromIntegral kI+ in summation 0 n $ \x->+ (combination n x) *+ ((1/l) ** x) *+ ((1 - (1/l)) ** (n-x)) *+ (factorial w / (w ** k*(x+1)) ) *+ (summation 1 w $ \i->+ (summation 1 i $ \j->+ ((j ** k*x) * i**k) /+ (factorial (w-i) * factorial j * factorial (i-j))+ )+ )+-}++-- This is my attempt at translating the FPR equation from "Fast Bloom Filters+-- and their Generalizations" with the following modifications:+-- - calculations within summation performed in log space+-- - use Stirling's approximation of factorial for larger `n`+-- - scale `n` and `l` together for large `n`; the paper graphs FPR against+-- this ratio so I guess this is justified, and it seems to work.++-- | An estimate of the false-positive rate for a bloom-1 filter. For a filter+-- with the provided parameters and having @n@ elements, the value returned+-- here is the percentage, over the course of many queries for elements /not/ in+-- the filter, of those queries which would be expected to return an incorrect+-- @True@ result.+--+-- This function is slow but the complexity is bounded and can accept inputs of+-- any size.+fpr :: Int -- ^ @n@: Number of elements in filter+ -> Int -- ^ @l@: Size of filter, in machine words+ -> Int -- ^ @k@: Number of bits to map an element to+ -> Int -- ^ @w@: word-size in bits (e.g. 32 or 64)+ -> Double+fpr nI lI kI wI =+ summation 0 n $ \x->+ e ** (+ (logCombination n x) ++ (x * (negate $ log l)) ++ ((n-x) * (log(l-1) - log l)) ++ (k* log(1 - ((1 - (1/w)) ** (x*k))))+ )++ where+ n = min 32000 (fromIntegral nI)+ l = fromIntegral lI * (n/fromIntegral nI)++ k = fromIntegral kI+ w = fromIntegral wI+ e = exp 1+ -- / x \+ -- log \ y /+ logCombination x y+ | y <= x = logFactorial x - (logFactorial y + logFactorial (x - y))+ | otherwise = log 0 -- TODO okay?++ logFactorial x+ -- TODO memoize in array:+ | x <= 500 = sum $ map log [1..x]+ -- else use Stirling's approximation when error doesn't seem to affect+ | otherwise = x * log x - x + log (sqrt (2*pi*x))++ summation low hi = sum . \f-> map f [low..hi]++++-- ------------------------------------------------------------------+-- Serialization+-- ------------------------------------------------------------------+++-- For now we just prepare to throw an error if the +sIZEOF_METADATA, mETADATA_WORDS :: Int+sIZEOF_METADATA = 8*mETADATA_WORDS+mETADATA_WORDS = 8++sERIALIZATION_VERSION :: Word64+sERIALIZATION_VERSION = 0+ ++-- Return metadata for serialization from the ADT+metadataBytes :: StableHashable a=> BloomFilter a -> [Word8]+metadataBytes bl@BloomFilter{..} = + let keyHash = hashSipKey key+ bs = + [ sERIALIZATION_VERSION -- serialization format version+ , tpHashOf bl -- for verifying we deserialize to the correct element type+ , hashWord64 keyHash -- for verifying key (we don't wish to store it)+ , tpHashOf keyHash -- ensures sanity of the hashing of our key+ , fromIntegral wordSizeInBits+ , fromIntegral k + , fromIntegral log2l + , 0x0000 -- some padding for the hell of it; we can make the above more compact later too, if we want forward compatibility.+ ] >>= bytes64+ in assert (length bs == sIZEOF_METADATA) $+ bs++-- A client may be concerned about keeping her SipKey secret; we have two decent options: +-- 1. store the key in the serialized bloom filter, and force the user to use encryption+-- 2. make the user handle managing keys, and store a hash of the key to+-- ensure sanity when the user provides the key again for deserialization+-- We've chosen (2), mostly because if we omit the key the filter is completely+-- opaque and secure, and we wish to experiment with mmap which a user of+-- encryption couldn't use if they wanted to make sure their key never landed+-- on disk.+--+-- We hash the key with itself and presume (read "hope") that this doesn't leak+-- any information about the key:+hashSipKey :: SipKey -> Hash64 (Word64, Word64)+hashSipKey k@(SipKey w0 w1) = siphash64 k (w0, w1)++populateMetadata :: StableHashable a=> BloomFilter a -> IO ()+populateMetadata b@BloomFilter{..} = do+ let !sizeDataBytes = sIZEOF_INT `uncheckedShiftL` log2l+ assert (P.sizeofMutableByteArray arr == sizeDataBytes + sIZEOF_METADATA) $ return ()+ forM_ (zip [sizeDataBytes..] $ metadataBytes b) $ + uncurry (P.writeByteArray arr)++-- | Serialize a bloom filter to a strict @ByteString@, which can be+-- 'deserialize'-ed once again. Only a hash of the 'SipKey' is stored in the+-- serialized format.+--+-- This operation is not linearizable with respect to 'insert'-type operations;+-- elements being written to the source bloomfilter during this operation may+-- or may not make it into the serialized @ByteString@ "at random".+serialize :: StableHashable a=> BloomFilter a -> IO ByteString+serialize bl = clone bl >>= unsafeSerialize++-- | Serialize a bloom filter to a strict @ByteString@, which can be+-- 'deserialize'-ed once again. Only a hash of the 'SipKey' is stored in the+-- serialized format. This operation is very fast and does no copying.+--+-- This is unsafe in that the source @BloomFilter@ must not be modified after+-- this operation, otherwise the ByteString will change, breaking referential+-- transparency. Use 'serialize' if uncertain.+unsafeSerialize :: StableHashable a=> BloomFilter a -> IO ByteString+unsafeSerialize b@BloomFilter{..} = do+ populateMetadata b+ let addr = (\(Addr x)-> x) $ P.mutableByteArrayContents arr+ arr' = (\(P.MutableByteArray x) -> x) arr+ return $ + PS (ForeignPtr addr (PlainPtr arr')) 0 (P.sizeofMutableByteArray arr)++-- | Deserialize a 'BloomFilter' from a @ByteString@ created with 'serialize'+-- or 'unsafeSerialize'. The key that was used to create the bloom filter is+-- not stored for security, and must be provided here. However if the key+-- provided does not match the key it was originally created with, a+-- 'BloomFilterException' will be thrown.+deserialize :: StableHashable a=> SipKey -> ByteString -> IO (BloomFilter a)+deserialize key (PS fp@(ForeignPtr _ arrWrapped) off len) = do+ log2l <- log2lFromArraySize len+ -- It would be possible to create an 'unsafeDeserialize' which could+ -- deserialize without this extra copy, where 'off' and 'len' are unused+ -- (i.e. we can use the MutableByteArray directly), however we still have+ -- the issue of finalizers; I think we would need to keep the ForeignPtr+ -- around and make sure to touch it. However we can still offer our own IO+ -- functions (e.g. an mmap routine) that does no extra copying.+ (arr, _) <- newBloomArr log2l++ -- Copy ByteString data to a fresh MutableByteArray:+ case arrWrapped of+ PlainPtr arrDirty -> P.copyMutableByteArray arr 0 (P.MutableByteArray arrDirty) off len+ MallocPtr arrDirty _ -> P.copyMutableByteArray arr 0 (P.MutableByteArray arrDirty) off len+ -- If we don't have access to the MutableByteArray we do a slow+ -- byte-at-a-time copy:+ _ -> withForeignPtr fp $ \ptr->+ forM_ (zip (take len [off..]) [0..]) $ \(ptrBytOff,targetBytIx)->+ peekElemOff ptr ptrBytOff >>= P.writeByteArray arr targetBytIx++ touchForeignPtr fp+ deserializeByteArray key arr+++-- | A low-level deserialization routine. This is very fast, and does no copying.+deserializeByteArray :: forall a. StableHashable a=> SipKey -> P.MutableByteArray RealWorld -> IO (BloomFilter a)+deserializeByteArray key arr = do+ let len = P.sizeofMutableByteArray arr+ log2lActual <- log2lFromArraySize len+ let metadataBytesIx = sIZEOF_INT `uncheckedShiftL` log2lActual+ assert (metadataBytesIx + sIZEOF_METADATA == len) $ return ()+ -- read bytes-at-a-time (endianness) and reconstruct metadata:+ byts <- forM (take sIZEOF_METADATA [metadataBytesIx..]) $ P.readByteArray arr+ let go [] = []+ go (b0:b1:b2:b3:b4:b5:b6:b7:bs) = unbytes64 [b0,b1,b2,b3,b4,b5,b6,b7] : go bs+ go _ = error "Bug: somehow sIZEOF_METADATA could not be chunked evenly into Word64s"+ case go byts of+ m@[version,tpHashBlParam,keyHash,tpHashKeyHash,wdSzBits,k64,log2l64,_pad] -> + assert (length m == mETADATA_WORDS) $ do+ let log2l = fromIntegral log2l64 + k = fromIntegral k64+ hash64Enough = isHash64Enough log2l k+ l_minus1 = (2^log2l)-1+ blDirty :: BloomFilter a+ blDirty = BloomFilter{..} -- defined here so we can use as proxy for param below.++ let check b = unless b . throwBloom++ check (version == sERIALIZATION_VERSION) $ + if version > sERIALIZATION_VERSION+ then "This bloomfilter was serialized with a new version of unagi-bloomfilter than the one in use."+ else "This bloomfilter was serialized with an older and incompatible version of unagi-bloomfilter than the one in use."+ -- This for now but we will offer forward compatibility, if possible, should serialization ever need to change.+ check (tpHashBlParam == tpHashOf blDirty)+ "This serialized bloom filter contained elements of a different type than you were expecting, or was created with an incompatible Hashable instance. See StableHashable."+ let keyHashExpected = hashSipKey key+ tpHashKeyHashExpected = tpHashOf keyHashExpected+ check (tpHashKeyHashExpected == tpHashKeyHash) + "Could not validate key. This serialized bloom filter was created with an incompatible Hashable instance. See StableHashable."+ check (keyHash == hashWord64 keyHashExpected)+ "The supplied key does not match the key that was used to create the serialized bloom filter."+ check (fromIntegral wdSzBits == wordSizeInBits) $ + "Serialized bloom filters are not currently cross-architecture compatible. Word size in bits when the filter was created was "++(show wdSzBits)++", but on the local machine is "++(show wordSizeInBits)+ check (fromIntegral k == k64 && fromIntegral log2l == log2l64) $+ "k or log2l could not fit in Int. This indicates corruption, or a bug: "++(show (k,k64,log2l,log2l64))+ checkParamInvariants k log2l++ return blDirty+ + _ -> error "Bug: somehow we returned the wrong number of metadata words"+ ++ +tpHashOf :: StableHashable a => proxy a -> Word64+tpHashOf = typeHashWord . typeHashOfProxy++bytes64 :: Word64 -> [Word8]+{-# INLINE bytes64 #-}+bytes64 wd = [ shifted 56, shifted 48, shifted 40, shifted 32+ , shifted 24, shifted 16, shifted 8, fromIntegral wd]+ where shifted = fromIntegral . uncheckedShiftR wd++unbytes64 :: [Word8] -> Word64+{-# INLINE unbytes64 #-}+unbytes64 [b0,b1,b2,b3,b4,b5,b6,b7] = + unshifted b0 56 .|. unshifted b1 48 .|. unshifted b2 40 .|. unshifted b3 32 .|.+ unshifted b4 24 .|. unshifted b5 16 .|. unshifted b6 8 .|. fromIntegral b7+ where unshifted = uncheckedShiftL . fromIntegral+unbytes64 _ = error "unbytes64"+ +++-- ------------------------------------------------------------------+-- Etc.+-- ------------------------------------------------------------------+++# ifdef EXPORT_INTERNALS+-- This could go anywhere, and lets us ensure that assertions are turned on+-- when running test suite.+assertionCanary :: IO Bool+assertionCanary = do+ assertionsWorking <- try $ assert False $ return ()+ return $+ case assertionsWorking of+ Left (AssertionFailed _) -> True+ _ -> False+# endif
+ tests/Main.hs view
@@ -0,0 +1,675 @@+{-# LANGUAGE CPP, BangPatterns, RecordWildCards, NamedFieldPuns #-}+module Main (main) where++import Control.Concurrent.BloomFilter.Internal+import qualified Control.Concurrent.BloomFilter as Bloom+import Data.Hashabler++import Test.QuickCheck hiding ((.&.))+import Data.Primitive.ByteArray+import Data.Primitive.MachDeps+import Data.Bits+import qualified Data.ByteString as B+import Control.Monad+import Control.Concurrent+import Data.Word+import Control.Exception+import Text.Printf+import Data.List+import System.Random+import Control.Applicative+import Prelude++main :: IO ()+main = do+# ifdef ASSERTIONS_ON+ checkAssertionsOn+# else+ putStrLn "!!! WARNING !!!: assertions not turned on in library code. configure with -finstrumented (first a `cabal clean` may be necessary) if you want to run tests with assertions enabled (it's good to test with both)"+# endif+ procs <- getNumCapabilities+ if procs < 2 + then putStrLn "!!! WARNING !!!: Some tests are only effective if more than 1 core is available"+ else return ()++ -- test helper sanity: --------+ unless ((fromBits64 $ replicate 64 '1') == (maxBound :: Word64) &&+ fromBits64 ((replicate 62 '0') ++ "11") == 3) $+ error "fromBits64 helper borked"+++ -- uncheckedSetBit: --------+ quickCheckErr 10000 $ \(Large i) ->+ all (\b-> ((i::Int) `setBit` b) == (i `uncheckedSetBit` b))+ [0.. wordSizeInBits-1]+++ -- log2w --------+ unless ((fromIntegral log2w :: Float)+ == logBase 2 (fromIntegral wordSizeInBits)+ && (2^log2w == wordSizeInBits)) $+ error "log2w /= logBase 2 wordSizeInBits"+++ -- maskLog2wRightmostBits --------+ let w = (2^^log2w) :: Float+ unless ((w-1) == fromIntegral maskLog2wRightmostBits) $+ error "maskLog2wRightmostBits is ill-defined"+ quickCheckErr 10000 $ \(Large i) ->+ fromIntegral (i .&. maskLog2wRightmostBits) < w+++ -- hash64Enough: --------+ let sz33MB = 22+ kThatJustFits = (64-sz33MB) `div` log2w+ do newOnlyNeeds64 <- Bloom.new (SipKey 1 1) kThatJustFits sz33MB+ unless (hash64Enough newOnlyNeeds64) $+ error "These parameters should have produced a bloom requiring only 64 hash bits"+ newNeeds128 <- Bloom.new (SipKey 1 1) (kThatJustFits+1) sz33MB+ unless (not $ hash64Enough newNeeds128) $+ error "These parameters should have produced a bloom requiring just a bit more than 64-bits!"++ -- for membershipWordAndBits128 and membershipWordAndBits64:+ membershipWordTests++ -- Creation/Insertion/FPR unit tests:+ createInsertFprTests+ smallBloomTest+ insertSaturateTest+ insertConcurrentTest+ highFprTest++ expectedExceptionsTest++ -- combining operations:+ unionSmokeTest+ unionTests+ intersectionTests+ + serializationTests++ putStrLn "TESTS PASSED"++-- Test exceptions that should only be possible to raise in untyped interface:+expectedExceptionsTest :: IO ()+expectedExceptionsTest = do+ let assertRaises io = catch (io >> error "Expected BloomFilterException to be raised.")+ (\e -> (e :: BloomFilterException) `seq` return ())+ nw :: Int -> Int -> IO (Bloom.BloomFilter Int)+ nw = Bloom.new (SipKey 1 1)+ -- `k` not > 0+ assertRaises $ nw 0 0+ -- `log2l` not >= 0+ assertRaises $ nw 1 (-1)+ -- `log2l` too damn big+ assertRaises $ nw 1 65+ -- requiring > 128 hash bits:+ assertRaises $ nw ((120 `div` log2w) + 1) 8+ assertRaises $ nw 3 ((128 - 3*log2w) + 1)++-- Try to get all bits of a small filter filled and force many configurations:+insertSaturateTest :: IO ()+insertSaturateTest = do+ randKey <- (,) <$> randomIO <*> randomIO+ bl <- Bloom.new (uncurry SipKey randKey) 2 2+ forM_ [(1::Int)..500] $ \el-> do+ void $ Bloom.insert bl el+ truePos <- Bloom.lookup bl el+ unless truePos $+ error $ "insertSaturateTest: Somehow got a false neg after insertion: "++(show (el, randKey))+ forM_ [0..3] $ \ix-> do+ wd <- readByteArray (arr bl) ix+ let fill = popCount (wd :: Word)+ when (fill < (wordSizeInBits - 10)) $+ error $ "Bloomfilter doesn't look like it was saturated like we expected "+ ++(show fill)++" "++(show randKey)+++insertConcurrentTest :: IO ()+insertConcurrentTest = do+ let k = 6+ forM_ [0..12] $ \log2l-> do+ let key = SipKey 23452345 (fromIntegral log2l)+ b <- Bloom.new key k log2l+ let szDataBytes = sIZEOF_INT * (floor ((2::Float)^log2l))+ let (payload0,payload1) = splitAt szDataBytes [1..(szDataBytes * 2)]+ done0 <- newEmptyMVar+ done1 <- newEmptyMVar+ void $ forkIO ((forM_ payload0 $ Bloom.insert b) >> putMVar done0 ())+ void $ forkIO ((forM_ payload1 $ Bloom.insert b) >> putMVar done1 ())+ takeMVar done0 >> takeMVar done1++ control <- Bloom.new key k log2l+ forM_ (payload0++payload1) $ Bloom.insert control++ equalBloom b control++++-- Smoke test for very small bloom filters:+smallBloomTest :: IO ()+smallBloomTest =+ forM_ [0..2] $ \ourLog2l-> do+ randKey <- (,) <$> randomIO <*> randomIO+ bl <- Bloom.new (uncurry SipKey randKey) 3 ourLog2l+ forM_ [1,2::Int] $ \el-> do+ likelyNotPresent <- Bloom.insert bl el+ truePos <- Bloom.lookup bl el+ unless truePos $+ error $ "smallBloomTest: Somehow got a false neg after insertion: "++(show (ourLog2l, el, randKey))+ unless likelyNotPresent $+ error $ "smallBloomTest: got unlikely failure, please report: "++(show (ourLog2l, el, randKey))+++membershipWordTests :: IO ()+membershipWordTests = do+ let sz33MB = 22+ -- membershipWordAndBits64 --------+ do let membershipWord = "1101001001001001001011"+ let h | wordSizeInBits == 64 = Hash64 $ fromBits64 $ membershipWord++" 001111 001110 001101 001100 001011 001010 001001"+ | otherwise = Hash64 $ fromBits64 $ "1111111"++membershipWord++" 01111 01110 01101 01100 01011 01010 01001"+ -- \ \ 7 membership bits (15..9) /+ -- \____ unused+ newOnlyNeeds64 <- Bloom.new (SipKey 1 1) 7 sz33MB+ assert (hash64Enough newOnlyNeeds64) $ return ()+ let (memberWordOut, wordToOr) =+ membershipWordAndBits64 h newOnlyNeeds64++ let memberWordExpected = fromIntegral $ fromBits64 (replicate (64-22) '0' ++ membershipWord)+ wordToOrExpected = fromIntegral $ fromBits64 $ -- casts to 32-bit Int on 32-bit arch:+ "000000000000000000000000000000000000000000000000 1111111 000000000"++ unless (memberWordOut == memberWordExpected) $+ error $ "membershipWordAndBits64 memberWord: expected "++(show memberWordExpected)++" but got "++(show memberWordOut)+ unless (wordToOr == wordToOrExpected) $+ error $ "membershipWordAndBits64 wordToOr: expected "++(show wordToOrExpected)++" but got "++(show wordToOr)++ do+ -- first test filling exactly 64-bits:+ let membershipWord = "1001" -- n.b. remaining bits divisible by log2w on both 32 and 64-bits+ let kFilling64 | wordSizeInBits == 64 = 10+ | otherwise = 12+ memberBitsToSet = take kFilling64 [3..]+ assert (maximum memberBitsToSet <= (wordSizeInBits-1)) $ return ()+ let kPayload = concatMap memberWordPaddedBinStr $ memberBitsToSet+ h = Hash64 $ fromBits64 $+ membershipWord++kPayload+ newNeedsExactly64 <- Bloom.new (SipKey 1 1) kFilling64 (length membershipWord)+ assert (hash64Enough newNeedsExactly64) $ return ()+ --+ -- shared with next test:+ let wordToOrExpected = foldl' setBit 0 memberBitsToSet+ do+ let memberWordExpected = 9+ let (memberWordOut, wordToOr) =+ membershipWordAndBits64 h newNeedsExactly64++ unless (memberWordOut == memberWordExpected) $+ error $ "membershipWordAndBits64-full memberWord: expected "++(show memberWordExpected)++" but got "++(show memberWordOut)+ unless (wordToOr == wordToOrExpected) $+ error $ "membershipWordAndBits64-full wordToOr: expected "++(show wordToOrExpected)++" but got "++(show wordToOr)+++ -- membershipWordAndBits128 --------++ -- repeat above, but with one bit more in `l` so we need a single bit from h_1 --------+ let membershipWord' = "10001" --17+ h' = let h_0 = fromBits64 $ take (64-length membershipWord') (cycle "10") ++ membershipWord'+ h_1 = fromBits64 $ take (64-length kPayload) (cycle "110") ++ kPayload+ in Hash128 h_0 h_1+ newJustNeeds128 <- Bloom.new (SipKey 1 1) kFilling64 (length membershipWord')+ assert (not $ hash64Enough newJustNeeds128) $ return ()+ do+ let (memberWordOut, wordToOr) =+ membershipWordAndBits128 h' newJustNeeds128+ let memberWordExpected = 17++ unless (memberWordOut == memberWordExpected) $+ error $ "membershipWordAndBitsJust128 memberWord: expected "++(show memberWordExpected)++" but got "++(show memberWordOut)+ unless (wordToOr == wordToOrExpected) $+ error $ "membershipWordAndBitsJust128 wordToOr: expected "++(show wordToOrExpected)++" but got "++(show wordToOr)+++ -- need all 128 bits --------+ do let kFillingAll128 | wordSizeInBits == 64 = 20+ | otherwise = 24+ memberWordExpected = 170+ membershipWord'' = printf "%08b" memberWordExpected+ memberWords = concatMap memberWordPaddedBinStr [1..kFillingAll128]+ h128 = Hash128 (fromBits64 $ ks_0++membershipWord'') (fromBits64 ks_1)+ where (ks_0, ks_1) = splitAt ((length memberWords) - 64) memberWords+ newNeedsAll128 <- Bloom.new (SipKey 1 1) kFillingAll128 (length membershipWord'')+ assert (not $ hash64Enough newNeedsAll128) $ return ()+ let wordToOrExpected' = foldl' setBit 0 [1..kFillingAll128]++ let (memberWordOut, wordToOr) =+ membershipWordAndBits128 h128 newNeedsAll128+ unless (memberWordOut == memberWordExpected) $+ error $ "membershipWordAndBits128-full memberWord: expected "++(show memberWordExpected)++" but got "++(show memberWordOut)+ unless (wordToOr == wordToOrExpected') $+ error $ "membershipWordAndBits128-full wordToOr: expected "++(show wordToOrExpected')++" but got "++(show wordToOr)++ -- need less than 128 bits, with 1s fill --------+ do let kJustOver = 13+ memberWordExpected = 170+ membershipWord'' = printf "%08b" memberWordExpected+ memberWords = concatMap memberWordPaddedBinStr [1..kJustOver]+ h128 = Hash128 (fromBits64 $ ks_0++pad_0++membershipWord'') (fromBits64 $ pad_1++ks_1)+ where (ks_0, ks_1) = splitAt ((length memberWords) - 64) memberWords+ pad_0 = replicate (64 - (length membershipWord'' + length ks_0)) '1'+ pad_1 = replicate (64 - (length ks_1)) '1'+ newJustOver <- Bloom.new (SipKey 1 1) kJustOver (length membershipWord'')+ assert (not $ hash64Enough newJustOver) $ return ()+ let wordToOrExpected' = foldl' setBit 0 [1..kJustOver]++ let (memberWordOut, wordToOr) =+ membershipWordAndBits128 h128 newJustOver+ unless (memberWordOut == memberWordExpected) $+ error $ "membershipWordAndBits128-fullx memberWord: expected "++(show memberWordExpected)++" but got "++(show memberWordOut)+ unless (wordToOr == wordToOrExpected') $+ error $ "membershipWordAndBits128-fullx wordToOr: expected "++(show wordToOrExpected')++" but got "++(show wordToOr)+++++-- set a unique bit in each source and target word, check exact expected individual bits+unionSmokeTest :: IO ()+unionSmokeTest = do+ b2 <- Bloom.new (SipKey 1 1) 3 1+ b8 <- Bloom.new (SipKey 1 1) 3 3+ let wds8 = zip [0..] $ map (2^) $ take 8 [(3::Int)..]+ let f (ix,v) (x1,x2) | even ix = (x1.|.v, x2)+ | otherwise = (x1, x2.|.v)+ let (expected_1,expected_2) = foldr f (2,4) wds8++ writeByteArray (arr b2) 0 (2::Word)+ writeByteArray (arr b2) 1 (4::Word)++ forM_ wds8 $ \(ix,v)->+ writeByteArray (arr b8) ix (v::Word)++ b8 `unionInto` b2+ actual_1 <- readByteArray (arr b2) 0+ actual_2 <- readByteArray (arr b2) 1+ unless (actual_1 == expected_1 && actual_2 == expected_2 && actual_1 > 0 && actual_2 > 0) $+ error $ "Union insane: "++(show [expected_1,actual_1, expected_2, actual_2])++ -- check identical size:+ b8' <- Bloom.new (SipKey 1 1) 3 3+ b8 `unionInto` b8'+ forM_ wds8 $ \(ix,v)-> do+ v' <- readByteArray (arr b8') ix+ unless (v == v') $+ error "Union smoke test on identical length filters failed."++unionTests :: IO ()+unionTests = do+ forM_ [19,20] $ \bigl-> forM_ [10..bigl] $ \littlel ->+ forM_ ([3,11,12,13]++ if log2w == 6 then [10] else []) $ \ourk -> do -- for 64 and 128+ b1 <- Bloom.new (SipKey 1 1) ourk bigl+ b2 <- Bloom.new (SipKey 1 1) ourk littlel+ let xs = [200..600] :: [Int]+ let ys = [400..800] :: [Int]+ let nots = [0..199]+ let xsys = [200..800]+ mapM_ (Bloom.insert b1) xs+ mapM_ (Bloom.insert b2) ys+ b1 `Bloom.unionInto` b2+ forM_ nots $ \v-> do+ exsts <- Bloom.lookup b2 v+ when exsts $ error $ (show (bigl,littlel,v,ourk))++": Found unexpected element"+ forM_ xsys $ \v-> do+ exsts <- Bloom.lookup b2 v+ unless exsts $ error $ (show (bigl,littlel,v,ourk))++": Could not find expected element."++ forM_ [0..10] $ \bigl-> forM_ [0..bigl] $ \littlel -> do+ forM_ [2,14] $ \ourk -> do+ b1 <- Bloom.new (SipKey 2 2) ourk bigl+ b2 <- Bloom.new (SipKey 2 2) ourk littlel+ void $ Bloom.insert b1 'a'+ void $ Bloom.insert b2 'b'+ b1 `Bloom.unionInto` b2+ forM_ "cdefghijkl" $ \v-> do+ exsts <- Bloom.lookup b2 v+ when exsts $ error $ (show (bigl,littlel,v))++": Found unexpected element"+ forM_ "ab" $ \v-> do+ exsts <- Bloom.lookup b2 v+ unless exsts $ error $ (show (bigl,littlel,v))++": Could not find expected element."++ -- another to excercise 128-bit a little more:+ forM_ [16,17] $ \bigl-> + forM_ [9..18] $ \ourk -> do+ let littlel = 16+ b1 <- Bloom.new (SipKey 2 2) ourk bigl+ b2 <- Bloom.new (SipKey 2 2) ourk littlel+ void $ Bloom.insert b1 'a'+ void $ Bloom.insert b2 'b'+ b1 `Bloom.unionInto` b2+ forM_ "cdefghijkl" $ \v-> do+ exsts <- Bloom.lookup b2 v+ when exsts $ error $ (show (bigl,littlel,v))++": Found unexpected element"+ forM_ "ab" $ \v-> do+ exsts <- Bloom.lookup b2 v+ unless exsts $ error $ (show (bigl,littlel,v))++": Could not find expected element."++ -- and using all 128 bits.+ let kFillingAll128 | wordSizeInBits == 64 = 20+ | otherwise = 24+ b1 <- Bloom.new (SipKey 2 2) kFillingAll128 8+ b2 <- Bloom.new (SipKey 2 2) kFillingAll128 7+ void $ Bloom.insert b1 'a'+ void $ Bloom.insert b2 'b'+ b1 `Bloom.unionInto` b2+ forM_ "cdefghijkl" $ \v-> do+ exsts <- Bloom.lookup b2 v+ when exsts $ error $ ": Found unexpected element"+ forM_ "ab" $ \v-> do+ exsts <- Bloom.lookup b2 v+ unless exsts $ error $ ": Could not find expected element."+++-- the union tests are sufficient to test 'combine'. Just do a sanity check here.+intersectionTests :: IO ()+intersectionTests =+ forM_ [18,19] $ \bigl-> forM_ [10..bigl] $ \littlel ->+ forM_ [5,14] $ \ourk -> do+ b1 <- Bloom.new (SipKey 3 1) ourk bigl+ b2 <- Bloom.new (SipKey 3 1) ourk littlel+ let xs = [200..600] :: [Int]+ let ys = [400..800] :: [Int]+ let nots = [199..399]++[601..801]+ let xsys = [400..600]+ mapM_ (Bloom.insert b1) xs+ mapM_ (Bloom.insert b2) ys+ b1 `Bloom.intersectionInto` b2+ forM_ nots $ \v-> do+ exsts <- Bloom.lookup b2 v+ when exsts $ error $ (show (bigl,littlel,v))++": Found unexpected element"+ forM_ xsys $ \v-> do+ exsts <- Bloom.lookup b2 v+ unless exsts $ error $ (show (bigl,littlel,v))++": Could not find expected element."++serializationTests :: IO ()+serializationTests = do+ quickCheckErr 1000 $ \(Large wd64)->+ wd64 == (unbytes64 . bytes64 $ wd64)+ equalBloomSane+ -- test log2lFromArraySize:+ forM_ [(1,0), (2,1), (3,2), (4,8), (5, 12)] $ \args-> do+ BloomFilter{..} <- uncurry (Bloom.new (SipKey 848 734783)) args+ log2lCalc <- log2lFromArraySize (sizeofMutableByteArray arr)+ unless (log2l == log2lCalc) $ + error $ "log2lFromArraySize mismatch: "++(show (args,log2l,log2lCalc))++ serializeRoundtripsTest+ serializeGoldenTests++-- For validating that we can serialize and deserialize across machines, and+-- try to handle forwards compatibility (later).+serializeGoldenTests :: IO ()+serializeGoldenTests = do+ if sIZEOF_INT == 8+ then + forM_ [(1,0), (2,1), (3,2), (3,7), (4, 10)] $ \(k, log2l)-> do+ let key = SipKey 983745 476835+ b <- Bloom.new key k log2l+ let szDataBytes = sIZEOF_INT * (floor ((2::Float)^log2l))+ payload <- forM [1..(szDataBytes * 2)] $ \x-> do+ void $ Bloom.insert b x+ return x++ let path = "tests/serialized/"++(show k)++"_"++(show log2l)++".64.bytestring"+ bSerNow <- unsafeSerialize b+ -- B.writeFile path bSerNow -- UNCOMMENT TO REGENERATE:+ bSerStored <- B.readFile path+ unless (bSerNow == bSerStored) $ + error $ "Deserialized stored bloom did not match: "++path++ b' <- Bloom.deserialize key bSerStored+ forM_ payload $ \x-> do+ present <- Bloom.lookup b' x+ unless present $ error $ "Did not find all expected elements in: "++path+ + else + -- TODO. Don't have a 32-bit machine to generate filters from.+ return ()++serializeRoundtripsTest :: IO ()+serializeRoundtripsTest = do+ let key = SipKey 87345 8723+ forM_ [(1,0), (2,1), (3,2), (3,7), (3, 14)] $ \(k, log2l)-> do+ b <- Bloom.new key k log2l+ let szDataBytes = sIZEOF_INT * (floor ((2::Float)^log2l))+ forM_ [1..(szDataBytes * 2)] $ \x-> do+ void $ Bloom.insert b x++ bSer <- Bloom.serialize b+ bUnsafeSer <- unsafeSerialize b+ unless (bSer == bUnsafeSer) $+ error $ "Unsafe and safe serialize produced different bytestrings with"++(show (k,log2l))+ b' <- Bloom.deserialize key bSer+ b'U <- Bloom.deserialize key bUnsafeSer+ equalBloom b b'+ equalBloom b b'U++ -- Now mangle and unmangle the bytestring to excercise offset/length, etc.+ -- in deserialization:+ let (!dc,!ba) = B.splitAt 5 $ B.reverse bUnsafeSer+ !bax = ba `B.snoc` 0xFF+ !xabcd = B.reverse bax `B.append` B.reverse dc+ let !bUnsafeSer' = B.drop 1 xabcd+ unless (bUnsafeSer == bUnsafeSer') $ error "Didn't mangle/unmangle properly"+ b'U' <- Bloom.deserialize key bUnsafeSer'+ equalBloom b b'U'+++equalBloomSane :: IO ()+equalBloomSane = do+ let key = SipKey 99 100+ forM_ [(1,0), (2,1), (3,2), (4,8), (5, 12)] $ \(k, log2l)-> do+ b0 <- Bloom.new key k log2l+ b1 <- Bloom.new key k log2l+ b2 <- Bloom.new key k log2l+ let szDataBytes = sIZEOF_INT * (floor ((2::Float)^log2l))+ forM_ [1..(szDataBytes * 2)] $ \x-> do+ void $ Bloom.insert b0 x+ void $ Bloom.insert b1 x+ void $ Bloom.insert b2 x+ equalBloom b0 b1+ -- modify in metadata region, and make sure equal:+ writeByteArray (arr b0) szDataBytes (0xFF::Word8)+ writeByteArray (arr b0) (sizeofMutableByteArray (arr b0) -1) (0xFF:: Word8)+ equalBloom b0 b1++ -- ensure we catch differences+ writeByteArray (arr b0) (szDataBytes-1) (0x02::Word8) -- last data byte+ throws1 <- try (equalBloom b0 b1)+ writeByteArray (arr b2) (szDataBytes-1) (0x02::Word8) -- last data byte+ equalBloom b0 b2+ writeByteArray (arr b2) 0 (0xFF::Word8) -- first data byte+ throws2 <- try (equalBloom b0 b2)+ case [throws1 :: Either SomeException (), throws2] of+ [Left _, Left _] -> return ()+ es -> error $ "equalBloom didn't detect differences: "++(show es)++ ++{-+ A NOTE ON TESTING FPR (from the paper)++"consideration when implementing Bloom-1 filters. To+ensure that the results obtained using Eq. (5) are accurate,+a Bloom-1 filter was implemented in Matlab using ideal+hash functions and simulated for the same parameters. In+each simulation, 10,000 Fast Bloom filters are generated+by inserting random elements until the specified load is+achieved. Then their false positive rate is evaluated doing+10^6 random queries of non member elements. The average+results were checked against those obtained with Eq. (5).+This was done for false positive rates larger than 10-6+. In all cases, differences were smaller than 0.5%."+-}++createInsertFprTests :: IO ()+createInsertFprTests =+ let bloomParams = [+ -- all params with low FPR:+ (2, 1, 2),+ (4, 1, 3),+ (500, 8, 3),+ (1000, 8, 10),+ (500, 8, 15),+ (500, 8, 20),+ (5000000, 22, 3)]+ in forM_ bloomParams $ \param@(payloadSz, ourLog2l, ourK)-> do+ let !loadedFpr = fpr payloadSz (2^ourLog2l) ourK wordSizeInBits+ payload = take payloadSz [2,4..] :: [Int]+ antiPayloadSz = 10000+ antiPayload = take antiPayloadSz [1,3..]+ randKey <- (,) <$> randomIO <*> randomIO+ bl <- Bloom.new (uncurry SipKey randKey) ourK ourLog2l++ allNeg <- mapM (Bloom.lookup bl) payload+ unless (all not allNeg) $+ error $ "Expected empty: "++(show param)++"\n"++(show randKey)++(show allNeg)++ falsesAndFPs <- mapM (Bloom.insert bl) payload+ -- This should on average be less than `loadedFpr` calculated on fully-loaded+ -- bloom filter:+ let insertionFprMeasured =+ (fromIntegral $ length $ filter not falsesAndFPs) / (fromIntegral payloadSz)+ allTruePositives <- mapM (Bloom.lookup bl) payload+ unless (and allTruePositives) $+ error $ "Expected all true positives"++(show param)++"\n"++(show randKey)++ falsePs <- mapM (Bloom.lookup bl) antiPayload+ let !loadedFprMeasured =+ (fromIntegral $ length $ filter id falsePs) / (fromIntegral antiPayloadSz)++ -- TODO proper statistical measure of accuracy of measured FPR+ unless (all (< 0.01) [insertionFprMeasured, loadedFprMeasured]) $+ error $ "Measured unexpectedly high FPR. Possible fluke; please retry tests: "+ ++(show param)++"\n"++(show randKey)+ unless ((abs $ loadedFprMeasured - loadedFpr) < 0.005) $+ error $ "Measured FPR deviated from calculated FPR more than we expected: "+ ++(show param)++"\n"++(show randKey)++ allTruePositivesIns <- mapM (Bloom.insert bl) payload+ unless (all not allTruePositivesIns) $+ error $ "Expected all true positives (i.e. insert failures): "+ ++(show param)++"\n"++(show randKey)+++-- spot check our `fpr` function at higher values:+highFprTest :: IO ()+highFprTest = do+ let bloomParams = [+ -- params with double-digit pct FPR+ (50000, 10, 3)+ , (65000, 10, 3) -- 84.8% calculated . I guess error only affects smaller filters significantly?+ , (5000, 8, 3)+ , (5000, 8, 10)+ , (500, 6, 1)+ , (1000, 5, 2)++ , (200, 5, 2) -- low single-digit FPR+ , (500, 6, 2)++-- TODO commented values below deviated slightly out of our allowed range after+-- changing to siphash64_1_3. Figure out and add back.++ -- for small sizes, high-ish loads+ -- , (625, 4, 2) -- 51% measured, 48% calculated+ , (625, 3, 2) -- 83% measured, 78% calculated+ , (700, 3, 2)+ -- , (750, 3, 2)+ , (750, 3, 3)+ -- 50% fp or lower:+ -- , (350, 3, 2)+ , (200, 3, 2)+ , (150, 3, 2)+ -- > 90% fpr+ , (2000, 4, 2)+ , (2000, 4, 3)++ , (2500, 5, 2)+ , (2450, 5, 2)+ , (2400, 5, 2)+ ]+ in forM_ bloomParams $ \param@(payloadSz, ourLog2l, ourK)-> do+ let !loadedFpr = fpr payloadSz (2^ourLog2l) ourK wordSizeInBits+ payload = take payloadSz [2,4..] :: [Int]+ antiPayloadSz = 200000+ antiPayload = take antiPayloadSz [1,3..]+ randKey <- (,) <$> randomIO <*> randomIO+ bl <- Bloom.new (uncurry SipKey randKey) ourK ourLog2l+ mapM_ (Bloom.insert bl) payload++ falsePs <- mapM (Bloom.lookup bl) antiPayload+ let !loadedFprMeasured =+ (fromIntegral $ length $ filter id falsePs) / (fromIntegral antiPayloadSz)++ unless ((abs $ loadedFprMeasured - loadedFpr) < 0.03) $+ error $ "Measured high FPR deviated from calculated FPR more than we expected: "+ ++(fmtPct loadedFprMeasured)++" "++(fmtPct loadedFpr)+ ++(show param)++"\n"++(show randKey)+++fmtPct :: Double -> String+fmtPct x = printf "%.2f%%" (x*100)+++# ifdef ASSERTIONS_ON+checkAssertionsOn :: IO ()+checkAssertionsOn = do+ -- Make sure testing environment is sane:+ assertionsWorking <- try $ assert False $ return ()+ assertionsWorkingInLib <- assertionCanary+ case assertionsWorking of+ Left (AssertionFailed _)+ | assertionsWorkingInLib -> putStrLn "Assertions: On"+ _ -> error "Assertions aren't working"+# endif+++-- Test helpers:+fromBits64 :: String -> Word64+fromBits64 bsDirty =+ let bs = zip [0..] $ reverse $ filter (\b-> b == '0' || b == '1') bsDirty+ in if length bs /= 64+ then error "Expecting 64-bits"+ else foldr (\(nth,c) wd-> if c == '1' then (wd `setBit` nth) else wd) 0x00 bs++memberWordPaddedBinStr :: Int -> String+memberWordPaddedBinStr n+ | n > wordSizeInBits = error "memberBitStr"+ | otherwise = printf ("%0"++(show log2w)++"b") n+++-- Utilites: ---------------------------------+quickCheckErr :: Testable prop => Int -> prop -> IO ()+quickCheckErr n p = + quickCheckWithResult stdArgs{ maxSuccess = n , chatty = False } p+ >>= maybeErr++ where maybeErr (Success _ _ _) = return ()+ maybeErr e = error $ show e++-- TODO eventually could replace this with an exported lib function (e.g. Eq on frozen BloomFilters)+-- easiest might just be unsafeSerialize + Eq for ByteString+equalBloom :: BloomFilter a -> BloomFilter a -> IO ()+equalBloom b0 b1 = do+ unless ((key b0, k b0, hash64Enough b0, l_minus1 b0, log2l b0) == (key b1, k b1, hash64Enough b1, l_minus1 b1, log2l b1)) $+ error "Can't compare arrays, since params aren't the same"+ let sz0 = sizeofMutableByteArray (arr b0)+ unless (sz0 == (sizeofMutableByteArray $ arr b1)) $+ error "Array sizes differ"++ let dataWords = floor ((2::Float)^(log2l b0))+ forM_ [0..(dataWords -1)] $ \wordIx -> do+ w0 <- readByteArray (arr b0) wordIx + w1 <- readByteArray (arr b1) wordIx + unless ((w0 :: Word) == w1) $+ error $ "Arrays differ at ix: "++(show wordIx)+ +
+ unagi-bloomfilter.cabal view
@@ -0,0 +1,144 @@+name: unagi-bloomfilter+version: 0.1.0.0+synopsis: A fast, cache-efficient, concurrent bloom filter+description:+ This library implements a fast concurrent bloom filter, based on bloom-1 from+ "Fast Bloom Filters and Their Generalization" by Y Qiao, et al. + .+ A bloom filter is a probabilistic, constant-space, set-like data structure+ supporting insertion and membership queries. This implementation is backed by+ SipHash so can safely consume untrusted inputs.+ .+ The implementation here compares favorably with traditional set+ implementations in a single-threaded context:+ .+ <<http://i.imgur.com/t3vroKE.png>>+ .+ Unfortunately writes in particular don't seem to scale currently; i.e.+ distributing writes across multiple threads may be /slower/ than in a+ single-threaded context, because of memory effects. We plan to export+ functionality that would support using the filter here in a concurrent+ context with better memory behavior (e.g. a server that shards to a+ thread-pool which handles only a portion of the bloom array).+ .+ <<http://i.imgur.com/RaUSmZB.png>>+ .++homepage: http://github.com/jberryman/unagi-bloomfilter+license: BSD3+license-file: LICENSE+author: Brandon Simmons+maintainer: brandon.m.simmons@gmail.com+-- copyright: +category: Concurrency+build-type: Simple+-- extra-source-files: +cabal-version: >=1.10++source-repository head+ type: git+ location: https://github.com/jberryman/unagi-bloomfilter.git++Flag dev+ Description: To build tests, executables and benchmarks do `configure -fdev --enable-tests` and run the built executables by hand (i.e. not with `cabal test` etc.; we put all our different executables in test-suite sections in order to hide their dependencies from hackage)+ Default: False+ -- TODO did this solve our issues with having executable sections and hackage deps?:+ Manual: True++Flag instrumented+ Description: Enables assertions in library code. When --enable-library-profiling and --enable-executable-profiling is turned on, you can get stacktraces as well+ Default: False+ Manual: True++library+ if flag(dev)+ CPP-Options: -DEXPORT_INTERNALS+ if flag(instrumented)+ ghc-options: -fno-ignore-asserts+ -- TODO stacktraces don't seem to show anything useful. Maybe because of INLINEs?:+ -- ghc-prof-options: "-with-rtsopts=-xc" -fprof-auto -fprof-auto-calls++ exposed-modules: Control.Concurrent.BloomFilter+ , Control.Concurrent.BloomFilter.Internal+ -- other-modules: + -- other-extensions: + build-depends: base >=4.7 && <5+ , atomic-primops >= 0.8+ , primitive+ , bytestring+ , hashabler >= 1.3.0+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall -fwarn-tabs -O2 -funbox-strict-fields++test-suite tests+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: tests+ main-is: Main.hs+ -- other-modules:++ ghc-options: -Wall -O2 -threaded -funbox-strict-fields -fno-ignore-asserts "-with-rtsopts=-N"+ if flag(instrumented)+ ghc-prof-options: "-with-rtsopts=-xc" -fprof-auto -fprof-auto-calls++ if flag(instrumented)+ CPP-Options: -DASSERTIONS_ON+ if flag(dev)+ buildable: True+ build-depends: base+ , QuickCheck+ , random+ , unagi-bloomfilter+ , primitive+ , bytestring+ , hashabler+ else + buildable: False+++benchmark bench+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ main-is: Main.hs+ ghc-options: -Wall -O2 -threaded -funbox-strict-fields+ ghc-options: "-with-rtsopts=-N -A50M -qa"+ hs-source-dirs: benchmarks+ if flag(instrumented)+ CPP-Options: -DASSERTIONS_ON+ if flag(dev)+ buildable: True+ build-depends: base+ , criterion+ , unagi-bloomfilter+ , unordered-containers+ , containers+ , text+ , deepseq+ , random+ , hashabler+ else + buildable: False+++executable dev-example+ if !flag(dev)+ buildable: False+ else+ build-depends: + base+ , unagi-bloomfilter++ -- ghc-options: -ddump-to-file -ddump-simpl -dsuppress-module-prefixes -dsuppress-uniques -ddump-core-stats -ddump-inlinings+ ghc-options: -O2 -rtsopts + -- for ghc bug(?) https://ghc.haskell.org/trac/ghc/ticket/11263+ ghc-options: -fsimpl-tick-factor=200+ + -- Either do threaded for eventlogging and simple timing...+ -- ghc-options: -threaded -eventlog+ -- and run e.g. with +RTS -N -l++ hs-source-dirs: core-example+ main-is: Main.hs+ default-language: Haskell2010+