diff --git a/bitcoin-compact-filters.cabal b/bitcoin-compact-filters.cabal --- a/bitcoin-compact-filters.cabal +++ b/bitcoin-compact-filters.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: bitcoin-compact-filters -version: 0.1.0.1 +version: 0.1.0.2 synopsis: BIP 158 compact block filters copyright: 2020 Bitnomial, Inc. @@ -14,15 +14,20 @@ data-files: examples/*.json +tested-with: + GHC == 8.10.4 + , GHC == 8.10.5 + , GHC == 9.0.1 + common core default-language: Haskell2010 ghc-options: -Wall build-depends: - base >=4.12 && <4.15 - , bytestring >=0.10 && <0.12 - , cereal ^>=0.5 - , haskoin-core >=0.13 && <0.19 - , text ^>=1.2 + base >=4.12 && <4.16 + , bytestring >=0.10 && <0.12 + , cereal ^>=0.5 + , haskoin-core >=0.17.1 && <0.21 + , text ^>=1.2 library @@ -33,10 +38,9 @@ Bitcoin.CompactFilter build-depends: - bitstream ^>=0.3.0.1 - , base16-bytestring <1.0 - , transformers ^>=0.5 - , memory ^>=0.15 + bitstream ^>=0.3.0.1 + , transformers ^>=0.5 + , memory >=0.15 && <0.17 test-suite bitcoin-cf-tests @@ -57,8 +61,8 @@ Paths_bitcoin_compact_filters build-depends: - aeson >=1.0 && <1.6 + aeson >=1.0 && <1.6 , bitcoin-compact-filters - , tasty >=1.0 && <1.5 - , tasty-hunit >=0.9 && <0.11 - , tasty-quickcheck >=0.8.1 && <0.11 + , tasty >=1.0 && <1.5 + , tasty-hunit >=0.9 && <0.11 + , tasty-quickcheck >=0.8.1 && <0.11 diff --git a/src/Bitcoin/CompactFilter.hs b/src/Bitcoin/CompactFilter.hs --- a/src/Bitcoin/CompactFilter.hs +++ b/src/Bitcoin/CompactFilter.hs @@ -1,159 +1,178 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-type-defaults #-} -module Bitcoin.CompactFilter - ( BlockFilter - , blockFilter - , BlockFilterHeader - , blockFilterHeader - , filterHeaderToHex - , filterHeaderFromHex - , genesisHeader - , filterContents - , encodeFilter - , isMember - ) where +module Bitcoin.CompactFilter ( + BlockFilter, + blockFilter, + BlockFilterHeader, + blockFilterHeader, + filterHeaderToHex, + filterHeaderFromHex, + genesisHeader, + filterContents, + encodeFilter, + isMember, +) where -import Control.Monad (replicateM, (>=>)) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State.Strict (StateT, evalStateT) +import Control.Monad (replicateM, (>=>)) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.State.Strict (StateT, evalStateT) import qualified Control.Monad.Trans.State.Strict as St -import Data.Bits (shiftL, shiftR, testBit) -import Data.Bitstream (Bitstream, Right) -import qualified Data.Bitstream as BiS -import Data.Bool (bool) -import Data.ByteArray.Hash (SipHash (..), SipKey (..), - sipHash) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.Foldable (foldl') -import Data.List (sort) -import Data.Serialize (Get, Serialize (..), decode, - encode, getWord16le, - getWord32le, getWord64le, - getWord8, putByteString, - putWord16le, putWord32le, - putWord64le, putWord8, - runGet) -import Data.Text (Text) -import Data.Word (Word64, Word8) -import Haskoin.Block (Block, BlockHash, - blockHeader, blockTxns, - headerHash) -import Haskoin.Crypto (Hash256, doubleSHA256) -import Haskoin.Script (Script (..), ScriptOp (..)) -import Haskoin.Transaction (scriptOutput, txOut) -import Haskoin.Util (decodeHex, encodeHex) - +import Data.Bits (shiftL, shiftR, testBit) +import Data.Bitstream (Bitstream, Right) +import qualified Data.Bitstream as BiS +import Data.Bool (bool) +import Data.ByteArray.Hash ( + SipHash (..), + SipKey (..), + sipHash, + ) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Foldable (foldl') +import Data.List (sort) +import Data.Serialize ( + Get, + Serialize (..), + decode, + encode, + getWord16le, + getWord32le, + getWord64le, + getWord8, + putByteString, + putWord16le, + putWord32le, + putWord64le, + putWord8, + runGet, + ) +import Data.Text (Text) +import Data.Word (Word64, Word8) +import Haskoin.Block ( + Block, + BlockHash, + blockHeader, + blockTxns, + headerHash, + ) +import Haskoin.Crypto (Hash256, doubleSHA256) +import Haskoin.Script (Script (..), ScriptOp (..)) +import Haskoin.Transaction (scriptOutput, txOut) +import Haskoin.Util (decodeHex, encodeHex) +-- | SIP hash parameter paramP :: Int paramP = 19 - +-- | SIP hash parameter paramM :: Word64 paramM = 784931 - -- | Hashes of scripts in the block -newtype BlockFilter = BlockFilter { blockFilter :: [Word64] } deriving (Eq, Show) - +newtype BlockFilter = BlockFilter + { -- | Get the list of hashes in increasing order + blockFilter :: [Word64] + } + deriving (Eq, Show) +-- | Number of elements in the filter blockFilterSize :: BlockFilter -> CompactSize blockFilterSize = CompactSize . length . blockFilter - -newtype BlockFilterHeader = BlockFilterHeader { getBFHeader :: Hash256 } +newtype BlockFilterHeader = BlockFilterHeader {getBFHeader :: Hash256} deriving (Eq, Show, Ord, Serialize) - filterHeaderToHex :: BlockFilterHeader -> Text filterHeaderToHex = encodeHex . BS.reverse . encode . getBFHeader - filterHeaderFromHex :: Text -> Either String BlockFilterHeader filterHeaderFromHex = maybe (Left "Invalid hex") Right . decodeHex >=> decode . BS.reverse - genesisHeader :: BlockFilterHeader Right genesisHeader = BlockFilterHeader <$> decode (BS.replicate 32 0x0) - -blockFilterHeader :: BlockFilterHeader -> BlockFilter -> BlockFilterHeader -blockFilterHeader prev bf - = BlockFilterHeader . doubleSHA256 - $ (encode . doubleSHA256) (encode bf) <> encode (getBFHeader prev) - +-- | Calculate the header for the block filter +blockFilterHeader :: + -- | previous header + BlockFilterHeader -> + -- | current filter + BlockFilter -> + BlockFilterHeader +blockFilterHeader prev bf = + BlockFilterHeader . doubleSHA256 $ + (encode . doubleSHA256) (encode bf) <> encode (getBFHeader prev) instance Serialize BlockFilter where put bf = put (blockFilterSize bf) >> putByteString (constructGCS paramP $ blockFilter bf) get = get >>= fmap BlockFilter . getGolombRiceSet paramP . unCompactSize - --- | Scripts in the block which belong in the BIP158 block filter -filterContents - :: [ByteString] - -- ^ previous output scripts spent in this block - -> Block - -> [ByteString] +-- | Calculate the list of scripts which belong in the BIP158 block filter +filterContents :: + -- | previous output scripts spent in this block + [ByteString] -> + Block -> + [ByteString] filterContents prev b = filter scriptFilter prev <> these - where - these = filter scriptFilter . fmap scriptOutput $ blockTxns b >>= txOut + where + these = filter scriptFilter . fmap scriptOutput $ blockTxns b >>= txOut scriptFilter scr = not (BS.null scr) && contentFilter scr contentFilter bs = case decode bs of Right (Script (OP_RETURN : _)) -> False - _ -> True - + _ -> True -- | Construct a BIP158 filter from a block -encodeFilter :: [ByteString] -> Block -> BlockFilter +encodeFilter :: + -- | output scripts spent in this block + [ByteString] -> + Block -> + BlockFilter encodeFilter os b = BlockFilter s - where - h = headerHash $ blockHeader b + where + h = headerHash $ blockHeader b bs = toSet $ filterContents os b - s = hashedSetConstruct (sipKey h) paramM (length bs) bs - + s = hashedSetConstruct (sipKey h) paramM (length bs) bs --- | Test membership -isMember :: BlockHash -> [ByteString] -> BlockFilter -> Bool +-- | Test membership. The test succeeds if /any/ of the scripts matches the block filter. +isMember :: + BlockHash -> + -- | Scripts we want to match against the filter + [ByteString] -> + BlockFilter -> + Bool isMember h bs (BlockFilter bf) = orderedScan hs bf - where - k = sipKey h + where + k = sipKey h hs = hashedSetConstruct k paramM (length bf) bs - orderedScan :: [Word64] -> [Word64] -> Bool orderedScan xs@(x : xs') hs@(h : hs') - | x > h = orderedScan xs hs' - | x < h = orderedScan xs' hs + | x > h = orderedScan xs hs' + | x < h = orderedScan xs' hs | otherwise = True orderedScan _ _ = False - type GetBits = StateT [Bool] Get - getGolombRiceSet :: Int -> Int -> Get [Word64] getGolombRiceSet p n = fmap unDiffs . evalBitstream $ replicateM n getEncoded - where + where getEncoded = do q <- unaryPart r <- fromBits <$> getBits p - return $ q * 2^p + r - + return $ q * 2 ^ p + r unaryPart :: GetBits Word64 unaryPart = go 0 - where - go q = getBit >>= bool (return q) (go $ q + 1) + where + go q = getBit >>= bool (return q) (go $ q + 1) getBit = head <$> getBits 1 - evalBitstream :: GetBits a -> Get a evalBitstream = (`evalStateT` mempty) - getBits :: Int -> GetBits [Bool] getBits n = do bs <- St.get @@ -163,107 +182,95 @@ combine m t = bs <> mconcat m <> t lastByte - | r > 0 = getBs >>= takeSome r + | r > 0 = getBs >>= takeSome r | otherwise = mempty <$ St.put mempty - getBs = byteBits <$> lift getWord8 + getBs = byteBits <$> lift getWord8 takeSome m xs = take m xs <$ St.put (drop m xs) if n < l then takeSome n bs else combine <$> replicateM q getBs <*> lastByte - sipKey :: BlockHash -> SipKey sipKey h = SipKey k1 k2 - where + where Right (k1, k2) = runGet word64Pair $ encode h - word64Pair = (,) <$> getWord64le <*> getWord64le - + word64Pair = (,) <$> getWord64le <*> getWord64le hashToRange :: Word64 -> SipKey -> ByteString -> Word64 hashToRange f k bs = v - where + where SipHash h = sipHash k bs - v = remap (fromIntegral f) (fromIntegral h) + v = remap (fromIntegral f) (fromIntegral h) remap :: Integer -> Integer -> Word64 remap x y = fromIntegral $ (x * y) `shiftR` 64 - hashedSetConstruct :: SipKey -> Word64 -> Int -> [ByteString] -> [Word64] hashedSetConstruct k m n bs = toSet $ hashToRange f k <$> bs - where + where f = fromIntegral n * m - toSet :: Ord a => [a] -> [a] toSet = dedup . sort - where + where dedup = \case (x0 : xs@(x1 : _)) - | x0 == x1 -> dedup xs + | x0 == x1 -> dedup xs | otherwise -> x0 : dedup xs xs -> xs - -constructGCS - :: Int - -- ^ modulus - -> [Word64] - -- ^ sorted list of input values - -> ByteString -constructGCS p - = BiS.toByteString - . foldMap (golombRiceEncode p) - . diffs - +constructGCS :: + -- | modulus + Int -> + -- | sorted list of input values + [Word64] -> + ByteString +constructGCS p = + BiS.toByteString + . foldMap (golombRiceEncode p) + . diffs diffs :: Num a => [a] -> [a] diffs xs = zipWith (-) xs (0 : xs) - unDiffs :: Num a => [a] -> [a] unDiffs (x : xs) = scanl (+) x xs -unDiffs [] = [] - +unDiffs [] = [] golombRiceEncode :: Int -> Word64 -> Bitstream Right golombRiceEncode p v = x <> BiS.singleton False <> y - where + where q = fromIntegral $ v `shiftR` p x = BiS.replicate q True y = BiS.fromNBits p v - fromBits :: Num a => [Bool] -> a fromBits = foldl' onBit 0 - where + where onBit n b = 2 * n + bool 0 1 b - byteBits :: Word8 -> [Bool] byteBits b = testBit b <$> reverse [0 .. 7] - -newtype CompactSize = CompactSize { unCompactSize :: Int } deriving (Eq, Ord, Enum, Num, Real, Integral) - +newtype CompactSize = CompactSize {unCompactSize :: Int} deriving (Eq, Ord, Enum, Num, Real, Integral) instance Serialize CompactSize where get = CompactSize <$> (getWord8 >>= getCS) - where + where getCS s - | s < 253 = return $ fromIntegral s - | s == 253 = fromIntegral <$> getWord16le - | s == 254 = fromIntegral <$> getWord32le + | s < 253 = return $ fromIntegral s + | s == 253 = fromIntegral <$> getWord16le + | s == 254 = fromIntegral <$> getWord32le | otherwise = fromIntegral <$> getWord64le put (CompactSize n) - | n < 0 = error $ "Invalid CompactSize: " <> show n - | n < 253 = putWord8 (fromIntegral n) + | n < 0 = error $ "Invalid CompactSize: " <> show n + | n < 253 = putWord8 (fromIntegral n) | n < bound16 = putWord8 253 >> putWord16le (fromIntegral n) | n < bound32 = putWord8 254 >> putWord32le (fromIntegral n) - | otherwise = putWord8 255 >> putWord64le (fromIntegral n) - where + | otherwise = putWord8 255 >> putWord64le (fromIntegral n) + where bound16 = 1 `shiftL` 16 bound32 = 1 `shiftL` 32 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,56 +1,56 @@ module Main where -import Data.Serialize (decode, encode) -import Haskoin.Block (blockHeader, headerHash) -import Test.Tasty (TestTree, defaultMain, testGroup) -import Test.Tasty.HUnit (testCase, (@?=)) -import Test.Tasty.QuickCheck (elements, forAll, testProperty, (===)) +import Data.Serialize (decode, encode) +import Haskoin.Block (blockHeader, headerHash) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.QuickCheck (elements, forAll, testProperty, (===)) -import Bitcoin.CompactFilter (blockFilterHeader, encodeFilter, - filterContents, isMember) -import Test.CompactFilter (genBlockFilter) -import qualified Test.Examples.Bip as BIP +import Bitcoin.CompactFilter ( + blockFilterHeader, + encodeFilter, + filterContents, + isMember, + ) +import Test.CompactFilter (genBlockFilter) +import qualified Test.Examples.Bip as BIP import qualified Test.Examples.Mainnet as Mainnet -import Test.Util (Example (..)) - +import Test.Util (Example (..)) main :: IO () main = do - bipExamples <- BIP.examples + bipExamples <- BIP.examples mainnetExamples <- Mainnet.examples defaultMain . testGroup "bip158 unit tests" $ [ testGroup "Serialization" [testRoundtrip] - , testGroup "Filter" + , testGroup + "Filter" [ testGroup "BIP 158" $ testFilter <$> bipExamples , testGroup "Mainnet" $ testFilter <$> mainnetExamples ] ] - testRoundtrip :: TestTree testRoundtrip = testProperty "serialization round trip" . forAll genBlockFilter $ \bf -> decode (encode bf) === Right bf - testFilter :: Example -> TestTree -testFilter v = testGroup (testLabel v) $ [ construction ] <> [ membership | not (null ss) ] - - where - +testFilter v = testGroup (testLabel v) $ [construction] <> [membership | not (null ss)] + where construction = testCase "Construction" $ do ourFilter @?= exampleFilter v ourHeader @?= exampleHeader v - membership = testProperty "Filter membership" $ forAll (elements ss) $ \s -> - isMember bh [s] ourFilter + membership = testProperty "Filter membership" $ + forAll (elements ss) $ \s -> + isMember bh [s] ourFilter ourFilter = encodeFilter (examplePrevOuts v) block ourHeader = blockFilterHeader (examplePrevHeader v) ourFilter - bh = headerHash $ blockHeader block - ss = filterContents (examplePrevOuts v) block + bh = headerHash $ blockHeader block + ss = filterContents (examplePrevOuts v) block block = exampleBlock v - testLabel :: Example -> String testLabel e = "Block " <> show (exampleHeight e) diff --git a/test/Test/CompactFilter.hs b/test/Test/CompactFilter.hs --- a/test/Test/CompactFilter.hs +++ b/test/Test/CompactFilter.hs @@ -1,19 +1,18 @@ -module Test.CompactFilter - ( genBlockFilter - ) where - -import Control.Monad (replicateM) -import Haskoin.Constants (btc) -import Haskoin.Util.Arbitrary.Block (arbitraryBlock) -import Haskoin.Util.Arbitrary.Util (arbitraryBS1) -import Test.Tasty.QuickCheck (Gen, choose) +module Test.CompactFilter ( + genBlockFilter, +) where -import Bitcoin.CompactFilter (BlockFilter, encodeFilter) +import Control.Monad (replicateM) +import Haskoin.Constants (btc) +import Haskoin.Util.Arbitrary.Block (arbitraryBlock) +import Haskoin.Util.Arbitrary.Util (arbitraryBS1) +import Test.Tasty.QuickCheck (Gen, choose) +import Bitcoin.CompactFilter (BlockFilter, encodeFilter) genBlockFilter :: Gen BlockFilter genBlockFilter = encodeFilter <$> scripts <*> arbitraryBlock btc - where + where scripts = do n <- choose (1, 100) replicateM n arbitraryBS1 diff --git a/test/Test/Examples/Bip.hs b/test/Test/Examples/Bip.hs --- a/test/Test/Examples/Bip.hs +++ b/test/Test/Examples/Bip.hs @@ -1,33 +1,34 @@ {-# OPTIONS_GHC -Wno-type-defaults #-} -module Test.Examples.Bip - ( examples - ) where - -import Data.Aeson (eitherDecodeFileStrict) -import Data.Text (Text) -import Haskoin.Block (BlockHeight) +module Test.Examples.Bip ( + examples, +) where -import Bitcoin.CompactFilter (filterHeaderFromHex) -import Paths_bitcoin_compact_filters (getDataFileName) -import Test.Util (Example (..), decodeFromHex, - parseHex) +import Data.Aeson (eitherDecodeFileStrict) +import Data.Text (Text) +import Haskoin.Block (BlockHeight) +import Bitcoin.CompactFilter (filterHeaderFromHex) +import Paths_bitcoin_compact_filters (getDataFileName) +import Test.Util ( + Example (..), + decodeFromHex, + parseHex, + ) examples :: IO [Example] -examples - = getDataFileName "examples/testnet-19.json" - >>= eitherDecodeFileStrict - >>= either error return . (>>= traverse interpretRawVector) - +examples = + getDataFileName "examples/testnet-19.json" + >>= eitherDecodeFileStrict + >>= either error return . (>>= traverse interpretRawVector) -interpretRawVector - :: (BlockHeight, Text, Text, [Text], Text, Text, Text, Text) - -> Either String Example -interpretRawVector (n, h, b, ss, ph, f, fh, _) - = Example n <$> decodeFromHex h - <*> decodeFromHex b - <*> traverse parseHex ss - <*> decodeFromHex f - <*> filterHeaderFromHex ph - <*> filterHeaderFromHex fh +interpretRawVector :: + (BlockHeight, Text, Text, [Text], Text, Text, Text, Text) -> + Either String Example +interpretRawVector (n, h, b, ss, ph, f, fh, _) = + Example n <$> decodeFromHex h + <*> decodeFromHex b + <*> traverse parseHex ss + <*> decodeFromHex f + <*> filterHeaderFromHex ph + <*> filterHeaderFromHex fh diff --git a/test/Test/Examples/Mainnet.hs b/test/Test/Examples/Mainnet.hs --- a/test/Test/Examples/Mainnet.hs +++ b/test/Test/Examples/Mainnet.hs @@ -1,12 +1,11 @@ -module Test.Examples.Mainnet - ( examples - ) where - -import Data.Aeson (eitherDecodeFileStrict) +module Test.Examples.Mainnet ( + examples, +) where -import Paths_bitcoin_compact_filters (getDataFileName) -import Test.Util (Example) +import Data.Aeson (eitherDecodeFileStrict) +import Paths_bitcoin_compact_filters (getDataFileName) +import Test.Util (Example) examples :: IO [Example] examples = getDataFileName "examples/examples.json" >>= eitherDecodeFileStrict >>= either error return diff --git a/test/Test/Util.hs b/test/Test/Util.hs --- a/test/Test/Util.hs +++ b/test/Test/Util.hs @@ -1,42 +1,42 @@ {-# LANGUAGE OverloadedStrings #-} -module Test.Util - ( Example (..) - , decodeFromHex - , parseHex - ) where - -import Control.Monad ((>=>)) -import Data.Aeson (FromJSON (..), withObject, (.:)) -import Data.Aeson.Types (Parser) -import Data.ByteString (ByteString) -import Data.Serialize (Serialize, decode) -import Data.Text (Text) -import Haskoin.Block (Block, BlockHash, BlockHeight) -import qualified Haskoin.Util as U +module Test.Util ( + Example (..), + decodeFromHex, + parseHex, +) where -import Bitcoin.CompactFilter (BlockFilter, BlockFilterHeader, - filterHeaderFromHex) +import Control.Monad ((>=>)) +import Data.Aeson (FromJSON (..), withObject, (.:)) +import Data.Aeson.Types (Parser) +import Data.ByteString (ByteString) +import Data.Serialize (Serialize, decode) +import Data.Text (Text) +import Haskoin.Block (Block, BlockHash, BlockHeight) +import qualified Haskoin.Util as U +import Bitcoin.CompactFilter ( + BlockFilter, + BlockFilterHeader, + filterHeaderFromHex, + ) decodeFromHex :: Serialize a => Text -> Either String a decodeFromHex = parseHex >=> decode - parseHex :: Text -> Either String ByteString parseHex = maybe (Left "Bad hex") Right . U.decodeHex - data Example = Example - { exampleHeight :: BlockHeight - , exampleBlockHash :: BlockHash - , exampleBlock :: Block - , examplePrevOuts :: [ByteString] - , exampleFilter :: BlockFilter + { exampleHeight :: BlockHeight + , exampleBlockHash :: BlockHash + , exampleBlock :: Block + , examplePrevOuts :: [ByteString] + , exampleFilter :: BlockFilter , examplePrevHeader :: BlockFilterHeader - , exampleHeader :: BlockFilterHeader - } deriving (Eq, Show) - + , exampleHeader :: BlockFilterHeader + } + deriving (Eq, Show) instance FromJSON Example where parseJSON = withObject "Example" $ \obj -> @@ -48,7 +48,6 @@ <*> (fromHex =<< obj .: "filter") <*> (either fail return . filterHeaderFromHex =<< obj .: "prev_filter_header") <*> (either fail return . filterHeaderFromHex =<< obj .: "filter_header") - fromHex :: Serialize a => Text -> Parser a fromHex = either fail return . decodeFromHex