packages feed

bloomfilter-redis (empty) → 0.1.0.0

raw patch · 14 files changed

+728/−0 lines, 14 filesdep +QuickCheckdep +arithmoidep +basesetup-changed

Dependencies added: QuickCheck, arithmoi, base, binary, bloomfilter-redis, bytestring, criterion, hashable, hedis, random, tasty, tasty-hunit, tasty-quickcheck, tasty-rerun

Files

+ CHANGELOG.md view
@@ -0,0 +1,3 @@+0.1.0.0+------+Initial release
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright 2016 Tobias Markus <tobias AT miglix DOT eu>+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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bloomfilter-redis.cabal view
@@ -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 <https://hackage.haskell.org/package/bloomfilter>.+extra-source-files:  README.md CHANGELOG.md+license:             BSD3+license-file:        LICENSE+author:              Tobias Markus <tobias AT miglix DOT eu>+maintainer:          Tobias Markus <tobias AT miglix DOT eu>+copyright:           Copyright 2016 Tobias Markus <tobias AT miglix DOT eu>+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
+ src/Data/RedisBloom.hs view
@@ -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
+ src/Data/RedisBloom/Hash.hs view
@@ -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 <http://www.isthe.com/chongo/tech/comp/fnv/>+hashFamilyFNV1  = makeFromHashable fnv1+-- | A hash function family based on the Fowler–Noll–Vo hash function, Variant 1a.+-- See <http://www.isthe.com/chongo/tech/comp/fnv/>+hashFamilyFNV1a = makeFromHashable fnv1a
+ src/Data/RedisBloom/Hash/FNV.hs view
@@ -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 <http://www.isthe.com/chongo/tech/comp/fnv> 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.+--+-- <http://www.isthe.com/chongo/tech/comp/fnv/#FNV-param>+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').+--+-- <http://www.isthe.com/chongo/tech/comp/fnv/#FNV-0>+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').+--+-- <http://www.isthe.com/chongo/tech/comp/fnv/#FNV-param>+fnvOffsetBasis :: (FiniteBits a, Num a) => a+fnvOffsetBasis = fnv0 constant+    where+      constant = "chongo <Landon Curt Noll> /\\../\\" :: 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.+--+-- <http://www.isthe.com/chongo/tech/comp/fnv/#FNV-1>+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'.+--+-- <http://www.isthe.com/chongo/tech/comp/fnv/#FNV-1a>+fnv1a = B.foldr' (fnvFold True)  fnvOffsetBasis . BL.toStrict . encode
+ src/Data/RedisBloom/Hash/Families.hs view
@@ -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\",+-- <http://www.eecs.harvard.edu/~kirsch/pubs/bbbf/esa06.pdf> 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
+ src/Data/RedisBloom/Internal.hs view
@@ -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
+ src/Data/RedisBloom/Suggestions.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Safe #-}++-- | Suggestions based on <http://hur.st/bloomfilter>+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 <http://hur.st/bloomfilter>+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
+ test/Benchmark.hs view
@@ -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"]
+ test/Common.hs view
@@ -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
+ test/TestBloom.hs view
@@ -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+  ]