module Network.Haskoin.Node.Bloom
( BloomFlags(..)
, BloomFilter(..)
, FilterLoad(..)
, FilterAdd(..)
, bloomCreate
, bloomInsert
, bloomContains
, isBloomValid
, isBloomEmpty
, isBloomFull
) where
import Control.Monad (replicateM, forM_)
import Control.DeepSeq (NFData, rnf)
import Data.Word
import Data.Bits
import Data.Hash.Murmur (murmur3)
import Data.Binary (Binary, get, put)
import Data.Binary.Get
( getWord8
, getWord32le
, getByteString
)
import Data.Binary.Put
( putWord8
, putWord32le
, putByteString
)
import qualified Data.Foldable as F
import qualified Data.Sequence as S
import qualified Data.ByteString as BS
import Network.Haskoin.Node.Types
maxBloomSize :: Int
maxBloomSize = 36000
maxHashFuncs :: Word32
maxHashFuncs = 50
ln2Squared :: Double
ln2Squared = 0.4804530139182014246671025263266649717305529515945455
ln2 :: Double
ln2 = 0.6931471805599453094172321214581765680755001343602552
bitMask :: [Word8]
bitMask = [0x01, 0x02, 0x04, 0x08, 0x10, 0x20, 0x40, 0x80]
data BloomFlags
= BloomUpdateNone
| BloomUpdateAll
| BloomUpdateP2PubKeyOnly
deriving (Eq, Show, Read)
instance NFData BloomFlags where rnf x = seq x ()
instance Binary BloomFlags where
get = go =<< getWord8
where
go 0 = return BloomUpdateNone
go 1 = return BloomUpdateAll
go 2 = return BloomUpdateP2PubKeyOnly
go _ = fail "BloomFlags get: Invalid bloom flag"
put f = putWord8 $ case f of
BloomUpdateNone -> 0
BloomUpdateAll -> 1
BloomUpdateP2PubKeyOnly -> 2
data BloomFilter = BloomFilter
{ bloomData :: !(S.Seq Word8)
, bloomHashFuncs :: !Word32
, bloomTweak :: !Word32
, bloomFlags :: !BloomFlags
}
deriving (Eq, Show, Read)
instance NFData BloomFilter where
rnf (BloomFilter d h t g) =
rnf d `seq` rnf h `seq` rnf t `seq` rnf g
instance Binary BloomFilter where
get = BloomFilter <$> (S.fromList <$> (readDat =<< get))
<*> getWord32le <*> getWord32le
<*> get
where
readDat (VarInt len) = replicateM (fromIntegral len) getWord8
put (BloomFilter dat hashFuncs tweak flags) = do
put $ VarInt $ fromIntegral $ S.length dat
forM_ (F.toList dat) putWord8
putWord32le hashFuncs
putWord32le tweak
put flags
newtype FilterLoad = FilterLoad { filterLoadBloomFilter :: BloomFilter }
deriving (Eq, Show, Read)
instance NFData FilterLoad where
rnf (FilterLoad f) = rnf f
instance Binary FilterLoad where
get = FilterLoad <$> get
put (FilterLoad f) = put f
newtype FilterAdd = FilterAdd { getFilterData :: BS.ByteString }
deriving (Eq, Show, Read)
instance NFData FilterAdd where
rnf (FilterAdd f) = rnf f
instance Binary FilterAdd where
get = do
(VarInt len) <- get
dat <- getByteString $ fromIntegral len
return $ FilterAdd dat
put (FilterAdd bs) = do
put $ VarInt $ fromIntegral $ BS.length bs
putByteString bs
bloomCreate :: Int
-> Double
-> Word32
-> BloomFlags
-> BloomFilter
bloomCreate numElem fpRate =
BloomFilter (S.replicate bloomSize 0) numHashF
where
bloomSize = truncate $ (min a b) / 8
a = 1 / ln2Squared * (fromIntegral numElem) * log fpRate
b = fromIntegral $ maxBloomSize * 8
numHashF = truncate $ min c (fromIntegral maxHashFuncs)
c = (fromIntegral bloomSize) * 8 / (fromIntegral numElem) * ln2
bloomHash :: BloomFilter -> Word32 -> BS.ByteString -> Word32
bloomHash bfilter hashNum bs =
murmur3 seed bs `mod` (fromIntegral (S.length (bloomData bfilter)) * 8)
where
seed = hashNum * 0xfba4c795 + (bloomTweak bfilter)
bloomInsert :: BloomFilter
-> BS.ByteString
-> BloomFilter
bloomInsert bfilter bs
| isBloomFull bfilter = bfilter
| otherwise = bfilter { bloomData = newData }
where
idxs = map (\i -> bloomHash bfilter i bs) [0..bloomHashFuncs bfilter 1]
upd s i = S.adjust (.|. bitMask !! fromIntegral (7 .&. i))
(fromIntegral $ i `shiftR` 3) s
newData = foldl upd (bloomData bfilter) idxs
bloomContains :: BloomFilter
-> BS.ByteString
-> Bool
bloomContains bfilter bs
| isBloomFull bfilter = True
| isBloomEmpty bfilter = False
| otherwise = all isSet idxs
where
s = bloomData bfilter
idxs = map (\i -> bloomHash bfilter i bs) [0..bloomHashFuncs bfilter 1]
isSet i = (S.index s (fromIntegral $ i `shiftR` 3))
.&. (bitMask !! fromIntegral (7 .&. i)) /= 0
isBloomEmpty :: BloomFilter -> Bool
isBloomEmpty bfilter = all (== 0x00) $ F.toList $ bloomData bfilter
isBloomFull :: BloomFilter -> Bool
isBloomFull bfilter = all (== 0xff) $ F.toList $ bloomData bfilter
isBloomValid :: BloomFilter
-> Bool
isBloomValid bfilter =
(S.length $ bloomData bfilter) <= maxBloomSize &&
(bloomHashFuncs bfilter) <= maxHashFuncs