diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +0.1.0.0 +------ +Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright 2016 Tobias Markus +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. 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. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,39 @@ +Distributed bloom filters on Redis (using the Hedis client). + +The hash family algorithm is partly inspired by +[Brian O'Sullivan's bloomfilter package](https://hackage.haskell.org/package/bloomfilter). + +# Features + +* Implementation of the FNV-1/FNV-1a hash function is included +* Automatic derivation of a hash family from a single hash function + as described by Kirsch and Mitzenmacher +* The bloom filter is distributed without extra effort since + Redis does the heavy lifting +* Every `Hashable` type can be added to the bloom filter +* Every `Binary` type can be hashed + +# Benchmark and Testing suite + +A benchmark for the FNV hash function is included and can +be invoked using `cabal bench` or `stack bench`. +An HTML report is generated as `report.html`. + +A testing suite using `tasty` is included. + +# Further Information +## Todo + +* Separate the FNV hash function into a separate package +* The actual operations (`addBF`, `queryBF`, etc) should + ideally live in a `MonadReader (Bloom a)`, but this requires + some work on the Hedis side because of `RedisCtx` + +## Caveats + +* The only supported FNV hash sizes are 32 and 64 bits. + Support for larger widths is a matter of having a + data type with instances for `FiniteBits` and `Num`. +* The offset basis (`fnvOffsetBasis`) is not correctly + computed, although this has absolutely no effect on + the performance of the hash function in practice. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bloomfilter-redis.cabal b/bloomfilter-redis.cabal new file mode 100644 --- /dev/null +++ b/bloomfilter-redis.cabal @@ -0,0 +1,76 @@ +name: bloomfilter-redis +version: 0.1.0.0 +synopsis: Distributed bloom filters on Redis (using the Hedis client). +description: + Distributed bloom filters on Redis (using the Hedis client). + . + The hash family algorithm is partly inspired by + Brian O\'Sullivan\'s bloomfilter package at . +extra-source-files: README.md CHANGELOG.md +license: BSD3 +license-file: LICENSE +author: Tobias Markus +maintainer: Tobias Markus +copyright: Copyright 2016 Tobias Markus +category: Data +build-type: Simple +cabal-version: >=1.14 +stability: Experimental + +source-repository head + type: git + location: https://github.com/hesiod/bloomfilter-redis.git + +library + ghc-options: -Wall + exposed-modules: Data.RedisBloom + , Data.RedisBloom.Hash + , Data.RedisBloom.Suggestions + , Data.RedisBloom.Hash.FNV + , Data.RedisBloom.Hash.Families + other-modules: Data.RedisBloom.Internal + default-language: Haskell2010 + other-extensions: FlexibleContexts + , ScopedTypeVariables + , TemplateHaskell + , OverloadedStrings + , GeneralizedNewtypeDeriving + , DeriveGeneric + , BangPatterns + , Safe + , CPP + build-depends: base >= 4.7 && < 4.10 + , bytestring >= 0.9 && < 0.11 + , binary >= 0.7 && < 0.9 + , hashable >= 1.2 && < 1.3 + , hedis >= 0.5 && < 0.9 + , arithmoi >= 0.3 && < 0.5 + hs-source-dirs: src + +test-suite test-bloomfilter-redis + type: exitcode-stdio-1.0 + main-is: TestBloom.hs + other-modules: Common + default-language: Haskell2010 + hs-source-dirs: test + build-depends: base + , bloomfilter-redis + , bytestring >= 0.9 && < 0.11 + , hashable >= 1.2 && < 1.3 + , hedis >= 0.5 && < 0.9 + , tasty >= 0.8 && < 0.12 + , tasty-rerun >= 1.1 && < 1.2 + , tasty-quickcheck >= 0.8 && < 0.9 + , QuickCheck >= 2.8 && < 2.9 + , tasty-hunit >= 0.9 && < 0.10 + +benchmark bench-bloomfilter-redis + ghc-options: -O2 + type: exitcode-stdio-1.0 + main-is: Benchmark.hs + default-language: Haskell2010 + hs-source-dirs: test + build-depends: base + , bloomfilter-redis + , random >= 1.1 && < 1.2 + , criterion >= 1.1 && < 1.2 diff --git a/src/Data/RedisBloom.hs b/src/Data/RedisBloom.hs new file mode 100644 --- /dev/null +++ b/src/Data/RedisBloom.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE Trustworthy #-} + +-- | A bloom filter for the Redis in-memory store. +module Data.RedisBloom + ( + -- * Bloom filter configuration + -- ** Fundamental types + module Data.RedisBloom.Internal, + -- ** Static bloom filter configuration + Bloom(..), + -- * Bloom filter operations + createBF, createIfNewBF, addBF, queryBF + ) where + +#if !MIN_VERSION_base(4,8,0) +import Prelude hiding (mapM) +import Data.Traversable (Traversable(..)) +import Data.Foldable (foldMap) +#endif +import Data.Monoid (All(..)) +import Data.ByteString.Char8 (pack) +import Database.Redis + +import Data.RedisBloom.Hash +import Data.RedisBloom.Internal + +-- | Bloom filter static configuration. +-- To use suggested values based on the desired +-- false-positive rate and capacity, use 'Data.RedisBloom.Suggestions.suggestCreate'. +data Bloom a = Bloom { + -- | The key to store the bloom filter under. + key :: !Key, + -- | Bloom filter capacity, i.e. the number of bits used. + capacity :: !Capacity, + -- | The hash family associated with the bloom filter. + -- See 'Data.RedisBloom.Hash.hashFamilyFNV' and 'Data.RedisBloom.Hash.hashFamilySimple' + hf :: HashFamily a + } + +-- | Create a new bloom filter with the specified configuration. +createBF :: (RedisCtx m (Either Reply)) => Bloom a -> m (Either Reply Status) +createBF bf = set (key bf) empty + where + empty = pack "" +-- | Create a new bloom filter with the specified configuration if the specified key does not yet exist. +createIfNewBF :: (RedisCtx m (Either Reply)) => Bloom a -> m (Either Reply Bool) +createIfNewBF bf = setnx (key bf) empty + where + empty = pack "" + +-- | Add an element to an existing bloom filter. +addBF :: (RedisCtx m f) => Bloom a -> a -> m () +addBF bf = mapM_ (flip (setbit (key bf)) one) . fmap (toInteger . (`mod` cap) . fromIntegral) . hf bf + where + (Capacity cap) = capacity bf + one = pack "1" + +getBit :: (MonadRedis m, RedisCtx m (Either Reply)) => Bloom a -> Integer -> m Bool +getBit bf i = do + r <- getbit (key bf) i + let l = case r of + Left _ -> False + Right j -> j >= 1 + return l + +-- | Query whether an element exists in the bloom filter. +-- +-- Gracefully fails upon failure by returning 'False'. +queryBF :: (MonadRedis m, RedisCtx m (Either Reply)) => Bloom a -> a -> m Bool +queryBF bf = query (capacity bf) (getBit bf) (hf bf) + +query :: Monad m => Capacity -> (Integer -> m Bool) -> HashFamily a -> a -> m Bool +query (Capacity c) q hashf x = do + let hashes = fmap (toInteger . (`mod` c) . fromIntegral) . hashf $ x + lookupMany q hashes + +lookupMany :: (Traversable t, Monad m) => (a -> m Bool) -> t a -> m Bool +lookupMany lookupBit hashes = do + bools <- mapM lookupBit hashes + return . getAll . foldMap All $ bools diff --git a/src/Data/RedisBloom/Hash.hs b/src/Data/RedisBloom/Hash.hs new file mode 100644 --- /dev/null +++ b/src/Data/RedisBloom/Hash.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Safe #-} + +-- | Hash function families suitable for use in a bloom filter. +module Data.RedisBloom.Hash + ( + -- * Hash families + hashFamilySimple, hashFamilyFNV1, hashFamilyFNV1a, + module Data.RedisBloom.Hash.Families + ) +where + +import Data.Hashable + +import Data.RedisBloom.Hash.Families +import Data.RedisBloom.Hash.FNV +import Data.RedisBloom.Internal + +makeFromHashable :: Hashable a => RawHashFunction Int -> HashCount -> HashFamily a +makeFromHashable f = makeHashFamily $ f . hashWithSalt salt + where + salt = 5534023222112865484 + +hashFamilySimple, hashFamilyFNV1, hashFamilyFNV1a :: Hashable a => HashCount -> HashFamily a +-- | A simple hash function family. +hashFamilySimple = makeFromHashable fromIntegral +-- | A hash function family based on the Fowler–Noll–Vo hash function, Variant 1. +-- See +hashFamilyFNV1 = makeFromHashable fnv1 +-- | A hash function family based on the Fowler–Noll–Vo hash function, Variant 1a. +-- See +hashFamilyFNV1a = makeFromHashable fnv1a diff --git a/src/Data/RedisBloom/Hash/FNV.hs b/src/Data/RedisBloom/Hash/FNV.hs new file mode 100644 --- /dev/null +++ b/src/Data/RedisBloom/Hash/FNV.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE Trustworthy #-} + +-- | The Fowler–Noll–Vo or FNV hash function, +-- a simple and fast hash function suitable for use in a bloom filter. +-- +-- See for +-- further information. +module Data.RedisBloom.Hash.FNV + ( + -- * Hash functions + fnv1, fnv1a, + -- ** Historical + fnv0, + -- * Auxiliary constants + fnvPrime, fnvOffsetBasis + ) +where + +import Data.Binary (Binary, encode) +import Data.Word (Word8, Word32, Word64) +import Data.Bits (Bits(..), FiniteBits(..), shiftL, popCount) + +import Math.NumberTheory.Primes.Testing (isPrime) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL + +{-# INLINE twoPwr #-} +twoPwr :: (Num a, Bits a, Integral bits) => bits -> a +twoPwr x = 1 `shiftL` fromIntegral x + +ff :: forall a b. (Integral a, Bits a, Fractional b) => a -> b +ff 0 = 3 / 4 +ff 1 = ff (0 :: Int) - recip 8 +ff x = let op = if even x then (+) else (-) + x' = fromIntegral (twoPwr (x + 2) :: a) :: b + in ff (pred x) `op` recip x' + +fd :: forall a bits. (Bits a, Integral a, Integral bits) => bits -> a +fd x = twoPwr e + twoPwr (8::Int) + where + flx = fromIntegral x :: Double + x' = max 0 . pred . round $ sqrt flx / 4 :: a + e = round $ flx * ff x' :: a + +test :: (Bits a, Integral a) => a -> Bool +test x = x `mod` left > right + where + left = twoPwr (40 :: Int) - twoPwr (24 :: Int) - 1 + right = twoPwr (24 :: Int) + twoPwr (8 :: Int) + twoPwr (7 :: Int) + +findPrime :: Integral bits => bits -> Integer +findPrime s = if null primes then head candidates else head primes + where + bs = [ b | b <- [0..twoPwr (8 :: Int)], popCount b == 4 || popCount b == 5 ] + candidates = filter test . fmap (\x -> fd s + x) $ bs + primes = filter isPrime candidates + +fnvPrime32 :: Word32 +fnvPrime32 = $( [| fromInteger $ findPrime (32::Word32) |] ) +fnvPrime64 :: Word64 +fnvPrime64 = $( [| fromInteger $ findPrime (64::Word64) |] ) +{-# INLINE [1] fnvPrime #-} +{-# RULES + "prime/32" [2] fnvPrime = fnvPrime32; + "prime/64" [2] fnvPrime = fnvPrime64; + #-} +-- | The FNV prime. The prime is calculated +-- automatically based on the number of bits +-- in the resulting type. +-- However, primes for @2^n@ where @n@ is not +-- in the range @5..9@ are not (officialy) +-- supported. +-- +-- +fnvPrime :: forall a. (Num a, FiniteBits a) => a +fnvPrime = fromInteger . findPrime . finiteBitSize $ (undefined :: a) + +{-# INLINE fnvFold #-} +fnvFold :: (Num a, FiniteBits a) => Bool -> Word8 -> a -> a +fnvFold False !x !h = (fnvPrime * h) `xor` fromIntegral x +fnvFold True !x !h = fnvPrime * (h `xor` fromIntegral x) + +-- | Variant 0 is historical and should not be used directly. +-- Rather, it is used to calculate the offset basis ('fnvOffsetBasis') +-- of the algorithm ('fnv1' and 'fnv1a'). +-- +-- +fnv0 :: (Binary a, Num b, FiniteBits b) => a -> b +fnv0 = B.foldr' (fnvFold False) 0 . BL.toStrict . encode + +fnvOffsetBasis32 :: Word32 +fnvOffsetBasis32 = $( [| fnvOffsetBasis |] ) +fnvOffsetBasis64 :: Word64 +fnvOffsetBasis64 = $( [| fnvOffsetBasis |] ) +{-# INLINE [1] fnvOffsetBasis #-} +{-# RULES + "offset/32" [2] fnvOffsetBasis = fnvOffsetBasis32; + "offset/64" [2] fnvOffsetBasis = fnvOffsetBasis64; + #-} +-- | The offset basis for the FNV hash function ('fnv1' and 'fnv1a'). +-- +-- +fnvOffsetBasis :: (FiniteBits a, Num a) => a +fnvOffsetBasis = fnv0 constant + where + constant = "chongo /\\../\\" :: B.ByteString + +-- These lead to infinite loops (why?) +--{-# INLINABLE fnv1 #-} +--{-# INLINABLE fnv1a #-} +fnv1, fnv1a :: (Binary a, FiniteBits b, Num b) => a -> b +-- | Variant 1 of the FNV hash function. +-- The hash is first multiplied with the 'fnvPrime' and then 'xor'ed with the octet. +-- +-- +fnv1 = B.foldr' (fnvFold False) fnvOffsetBasis . BL.toStrict . encode +-- | Variant 1a of the FNV hash function. +-- The hash is first 'xor'ed with the octet and then multiplied with the 'fnvPrime'. +-- +-- +fnv1a = B.foldr' (fnvFold True) fnvOffsetBasis . BL.toStrict . encode diff --git a/src/Data/RedisBloom/Hash/Families.hs b/src/Data/RedisBloom/Hash/Families.hs new file mode 100644 --- /dev/null +++ b/src/Data/RedisBloom/Hash/Families.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} + +-- | Hash function family suitable for use in a bloom filter. +module Data.RedisBloom.Hash.Families + ( + -- * Types + Index, + -- ** Hash families + Hash, HashFamily, HashFunction, + -- ** Raw hash functions + RawHash, RawHashFunction, + -- * Creating hash families + makeIndexedHash, makeHashFamily + ) +where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +import Data.Bits (shiftR, finiteBitSize, (.&.)) +import Data.Word (Word32, Word64) +import Data.Hashable (Hashable) + +import Data.RedisBloom.Internal + +-- | A single hash. +type Hash = Word32 +-- | An index into the hash function family. +type Index = Int +-- | A family of hashes. +type HashFamily a = (a -> [Hash]) +-- | A single indexed hash function, part of a family. +type HashFunction a = (Index -> a -> Hash) + +-- | A raw hash. +type RawHash = Word64 +-- | A raw hash function. +type RawHashFunction a = (a -> RawHash) + +-- | Makes a indexed hash function out of a single 64-bit hash +-- function where 'i' is +-- an index in the range @0..30@ indicating +-- the member function to be computed. +-- +-- Just like the original bloom filter package, a variant of +-- Kirsch and Mitzenmacher's technique from \"Less +-- Hashing, Same Performance: Building a Better Bloom Filter\", +-- is used here. +-- +-- Quoting from the non-Redis bloomfilter package: +-- "Where Kirsch and Mitzenmacher multiply the second hash by a +-- coefficient, we shift right by the coefficient. This offers better +-- performance (as a shift is much cheaper than a multiply), and the +-- low order bits of the final hash stay well mixed." +makeIndexedHash :: Hashable a => RawHashFunction a -> HashFunction a +makeIndexedHash hh i x = h1 + (h2 `shiftR` i) + where + bs = finiteBitSize (undefined :: Word32) + h = hh x :: Word64 + mb = fromIntegral (maxBound :: Word32) - 1 :: Word64 + h1 = fromIntegral $ h .&. mb :: Word32 + h2 = fromIntegral $ (h `shiftR` bs) .&. mb :: Word32 + +-- | Makes a hash function family from a raw hash function. +makeHashFamily :: Hashable a => RawHashFunction a -> HashCount -> HashFamily a +makeHashFamily raw (HashCount n) x = uncurry ih <$> zip [1..n] xs + where + ih = makeIndexedHash raw + xs = replicate (fromIntegral n) x diff --git a/src/Data/RedisBloom/Internal.hs b/src/Data/RedisBloom/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/RedisBloom/Internal.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE Trustworthy #-} + +-- | Internals +module Data.RedisBloom.Internal where + +import GHC.Generics (Generic) +import Data.Typeable (Typeable) + +import qualified Data.ByteString.Char8 as BS + +-- | Number of hashes to use in a bloom filter. +newtype HashCount = HashCount Int deriving (Generic, Typeable, Show, Eq, Ord, Enum, Num, Real, Integral, Bounded) +-- | Capacity of a bloom filter. +newtype Capacity = Capacity Int deriving (Generic, Typeable, Show, Eq, Ord, Enum, Num, Real, Integral) + +-- | Redis Key +type Key = BS.ByteString diff --git a/src/Data/RedisBloom/Suggestions.hs b/src/Data/RedisBloom/Suggestions.hs new file mode 100644 --- /dev/null +++ b/src/Data/RedisBloom/Suggestions.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Safe #-} + +-- | Suggestions based on +module Data.RedisBloom.Suggestions + ( + -- * Suggestions + suggestCapacity, suggestHashCount, + -- * Bloom filter creation + suggestCreate + ) +where + +import Data.Hashable (Hashable) + +import Data.RedisBloom +import Data.RedisBloom.Hash + +-- | Suggests an appropriate capacity for a given number of elements. +-- +-- This uses the algorithm described at +suggestCapacity :: forall a b. (Integral a, RealFrac b, Floating b) + => a -- ^ expected maximum capacity + -> b -- ^ desired false positive rate where 0 < /e/ < 1 + -> Capacity +suggestCapacity n p = ceiling g + where + n' = fromIntegral n + x = n' * log p + tw = 2 :: b + y = recip $ tw ** log tw + g = x / log y :: b + +-- | Suggets an appropriate number of hash functions for a given capacity and false positive pro +suggestHashCount :: forall a. (Integral a) + => a -- ^ expected maximum capacity + -> Capacity + -> HashCount +suggestHashCount n m = HashCount . round $ log tw * (fromIntegral m / fromIntegral n) + where + tw = 2 :: Double + +-- | Creates a bloom filter configuration with the specified values. +suggestCreate :: (Integral a, RealFrac b, Floating b, Hashable d) + => a -- ^ expected maximum capacity + -> b -- ^ desired false positive rate where 0 < /e/ < 1 + -> Key -- ^ Redis key for the bloom filter + -> Bloom d +suggestCreate n p k = Bloom k ca haff + where + ca = suggestCapacity n p + hc = suggestHashCount n ca + haff = hashFamilyFNV1a hc diff --git a/test/Benchmark.hs b/test/Benchmark.hs new file mode 100644 --- /dev/null +++ b/test/Benchmark.hs @@ -0,0 +1,31 @@ +import Criterion +import Criterion.Main +import Criterion.Types +import System.Random + +import Data.RedisBloom +import Data.RedisBloom.Hash + +setup :: a -> IO (a, Int, [Int], [Int]) +setup z = do + gen <- getStdGen + let rr = randoms gen + few = take 64 rr + many = take 4096 . drop 64 $ rr + one = head rr + return $ z `seq` (z, one, few, many) + +config :: Config +config = defaultConfig { reportFile = Just "report.html" } + +esetup :: (HashCount -> Int -> [Hash]) -> String -> Benchmark +esetup f name = env (setup . f . HashCount $ 16) $ \ ~(g, x, few, many) -> bgroup name [ + bench "single" $ nf g x, + bench "multiple-64" $ nf (fmap g) few, + bench "multiple-4096" $ nf (fmap g) many + ] + +main :: IO () +main = defaultMainWith config [ + esetup hashFamilyFNV1 "FNV-1", + esetup hashFamilyFNV1a "FNV-1a"] diff --git a/test/Common.hs b/test/Common.hs new file mode 100644 --- /dev/null +++ b/test/Common.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Trustworthy #-} + +module Common where + +#if !MIN_VERSION_base(4,8,0) +import Prelude hiding (mapM, mapM_) +import Data.Traversable (Traversable(..)) +#endif +import Data.Hashable +import Database.Redis +import qualified Data.ByteString.Char8 as BS + +import Data.RedisBloom +import Data.RedisBloom.Hash + +test_key :: Key +test_key = BS.pack "tk" + +test_bf :: Bloom Int +test_bf = Bloom test_key sz hb + where + hc = HashCount 16 + hb = hashFamilyFNV1a hc :: HashFamily Int + kb = (*8192) + sz = Capacity $ kb 32 + +createAddQuery :: Hashable a => Bloom a -> a -> Redis Bool +createAddQuery b x = createBF b >> addBF b x >> queryBF b x +createAddL :: (Hashable a, Traversable t) => Bloom a -> t a -> Redis () +createAddL b l = createBF b >> mapM_ (addBF b) l +queryL :: (Hashable a, Traversable t) => Bloom a -> t a -> Redis (t Bool) +queryL b = mapM (queryBF b) +createAddQueryL :: (Hashable a, Traversable t) => Bloom a -> t a -> Redis (t Bool) +createAddQueryL b l = createAddL b l >> queryL b l diff --git a/test/TestBloom.hs b/test/TestBloom.hs new file mode 100644 --- /dev/null +++ b/test/TestBloom.hs @@ -0,0 +1,129 @@ +import Test.Tasty +import Test.Tasty.Runners +import Test.Tasty.Ingredients.Rerun +import Test.Tasty.QuickCheck as QC +import Test.Tasty.HUnit as HU hiding (assert) +import Test.QuickCheck.Monadic + +import Data.List (nub) +import Data.Monoid (All(..)) +import Data.Word (Word32, Word64) +import Database.Redis + +import Data.RedisBloom +import Data.RedisBloom.Hash.FNV +import Data.RedisBloom.Suggestions + +import Common + +main :: IO () +main = defaultMainWithIngredients [ rerunningTests [ consoleTestReporter ] ] tests + +exec :: Redis a -> IO a +exec x = do + conn <- connect defaultConnectInfo + runRedis conn x + +encode :: Num a => Bool -> a +encode False = 0 +encode True = 1 + +valBound :: Int +valBound = 2 ^ (12 :: Int) + +capacityBounds :: Gen Int +capacityBounds = choose (1, 2 ^ (16 :: Int)) + +elementGen :: Gen Int +elementGen = choose (negate valBound, valBound :: Int) + +elementGenL :: Gen [Int] +elementGenL = listOf1 elementGen + +elementGenLNubbed :: Monad m => PropertyM m [Int] +elementGenLNubbed = fmap nub . pick $ elementGenL + +epsilonBounds :: Gen Double +epsilonBounds = choose (1e-6, 0.5 :: Double) + +bfg :: Monad m => PropertyM m (Bloom Int, Double) +bfg = do + cap <- pick capacityBounds + epsilon <- pick epsilonBounds + return (suggestCreate cap epsilon test_key, epsilon) + +limit :: RealFrac a => Int -> a -> a +limit n = let k = 10 ^ n in (/k) . fromIntegral . round . (*k) + +collectLabeled :: Monad m => String -> Double -> PropertyM m () +collectLabeled name x = monitor . label $ name ++ show (limit 1 x) + +tests, treeFNV, treeFixed, treeVar, treeConsistency, treeEpsilonVar, treeEpsilon :: TestTree +tests = testGroup "Tests" [treeFNV, treeConsistency, treeEpsilon] +treeFNV = testGroup "Fowler-Noll-Vo hash function" [ testGroup "FNV primes" [ + testCase "32 bits" $ + 16777619 @=? (fnvPrime :: Word32), + testCase "64 bits" $ + 1099511628211 @=? (fnvPrime :: Word64) + ]] +treeConsistency = testGroup "consistency" [treeFixed, treeVar] +treeEpsilon = testGroup "false positive rate" [treeEpsilonVar] +treeFixed = testGroup "fixed configuration" + [ QC.testProperty "single element" $ + monadicIO $ do + x <- pick elementGen + b <- run . exec $ createAddQuery test_bf x + assert b, + QC.testProperty "multiple elements" $ + monadicIO $ do + lx <- elementGenLNubbed + b <- run . exec $ fmap (getAll . foldMap All) (createAddQueryL test_bf lx) + assert b + ] +treeVar = testGroup "variable configuration" + [ QC.testProperty "single element" $ + monadicIO $ do + (blt, _) <- bfg + x <- pick elementGen + b <- run . exec $ createAddQuery blt x + assert b, + QC.testProperty "multiple elements" $ + monadicIO $ do + (blt, _) <- bfg + len <- pick . choose $ (2^2, 2^8) + lx <- pick $ vectorOf (min (fromIntegral $ capacity blt) len) elementGen + let lx' = nub lx + b <- run . exec $ fmap (getAll . foldMap All) (createAddQueryL blt lx') + assert b + ] +treeEpsilonVar = testGroup "variable configuration" + [ QC.testProperty "multiple elements" $ + monadicIO $ do + (blt, epsilon) <- bfg + let (Capacity c) = capacity blt + c' = fromIntegral c :: Double + len <- pick . choose $ (4, min (2^8) c) + notlen <- pick . choose $ (4, 2 * len) + let vec = vectorOf len elementGen + check l = not . flip elem l + vecn l = vectorOf notlen . flip suchThat (check l) $ elementGen + lx <- pick vec + let lx' = nub lx + lxnot <- pick $ vecn lx' + let lxnot' = nub lxnot + run . exec . createAddL blt $ lx' + falsePositives <- run . exec . queryL blt $ lxnot' + let notlen' = fromIntegral . length $ lxnot' + fp = sum . fmap encode $ falsePositives + ratio = fp / notlen' + cl = c' / fromIntegral len + monitor . counterexample $ "Length: " ++ show len + monitor . counterexample $ "Capacity: " ++ show c + monitor . counterexample $ "Capacity / Length: " ++ show cl + monitor . counterexample $ "False Positives: " ++ show fp + monitor . counterexample $ "Actual False-Positive Ratio (α): " ++ show ratio + monitor . counterexample $ "Expected False-Positive Ratio (ɛ): " ++ show epsilon + collectLabeled "α = " ratio + collectLabeled "α ∕ ɛ = " $ ratio / epsilon + assert $ ratio <= epsilon + ]