merkle-log (empty) → 0.1.0.0
raw patch · 8 files changed
+1684/−0 lines, 8 filesdep +QuickCheckdep +basedep +bytestringsetup-changed
Dependencies added: QuickCheck, base, bytestring, cereal, criterion, cryptonite, deepseq, exceptions, hash-tree, memory, merkle-log, merkle-tree, mwc-random, random, random-bytestring, text
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- README.md +88/−0
- Setup.hs +2/−0
- bench/Main.hs +339/−0
- merkle-log.cabal +87/−0
- src/Data/MerkleLog.hs +791/−0
- test/Main.hs +342/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for merkle-log++## 0.1.0.0 -- 2019-05-28++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, Kadena LLC++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 Lars Kuhtz 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.
+ README.md view
@@ -0,0 +1,88 @@+# Haskell Implementation of Merkle Tree Logs++This packages implements Merkle Tree Logs similar to those described in RFC 6962+in Haskell.++Merkle Logs are a append-only data structure. The tree layout in this+implementation of Merkle trees is based on the description of Merkle trees in+RFC 6962. With this tree layout extending a Merkle tree requires chaining a+logarithmic number of nodes at the end of the tree. Unlike RFC 6962 the Merkle+trees in this module support the creation of unbalanced MerkleTrees by nesting+sub-trees as leafs of Merkle trees. Also, unlike RFC 6962 this module generates+fully self-contained inclusion proofs that don't rely on the client being aware+of the balancing of the Merkle Tree that was used to generate the proof.++## Format++The implementation stores Merkle trees in a packed format in memory. This allows+for efficient construction, serialization, and querying. Trees are opaque+objects that are allocated and deallocated as well as serialized and+deserialized as a whole, which matches many use cases. Also, trees can be+nested, by building larger Merkle trees that have smaller trees as inputs to+their leafs.++The overhead per indexed item is 64 bytes when 256 bit hashes are used. Thus,+about 16,000 items can be index in 1MB of memory.++We plan to make the trees extensible and support loading and storing trees in+chunks that represent immutable full subtrees. Please file an issue on GitHub if+you need this feature.++## Proofs++Proofs are self contained and don't rely on a particular implementation of+Merkle tree. In particular, proofs don't depend on how the tree is balanced.++A proof contains the proof subject (the input for which inclusion is proven) as+a plain `ByteString`. The result of validating a proof is a Merkle tree root+that must match the root of the Merkle tree that includes the subject. A proof+doesn't include the root hash of the Merkle tree, because the root must be+obtained from a trusted / authenticated source. Including it in the proof would+thus be redundant and may even be misleading.++At the moment only inclusion / audit proofs are supported. We plan to also+implement consistency proofs. Please file an issue on GitHub if you need+consistency proofs.++## Build and Installation++The package can be build with cabal via++```sh+cabal new-update+cabal new-build merkle-log+```++The test suite can be run with++```sh+cabal new-test merkle-log+```++Benchmarks are available via+++```sh+cabal new-bench merkle-log+```++## Benchmarks++The following benchmark results compare the performance of this package with+the Merkle tree implementations in the packages+[merkle-tree](http://hackage.haskell.org/package/merkle-tree) and+[hash-tree](http://hackage.haskell.org/package/hash-tree) for different hash+functions on a 64bit Intel CPU.++Create tree:++++Create inclusion proof:++++Verify inclusion proof:+++
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Main.hs view
@@ -0,0 +1,339 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++-- |+-- Module: Main+-- Copyright: Copyright © 2019 Kadena LLC.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@kadena.io>+-- Stability: experimental+--+-- TODO+--+module Main+( main+) where++import Control.DeepSeq++import Criterion+import Criterion.Main++import Crypto.Hash+import qualified Crypto.Hash.MerkleTree as MT++import qualified Data.ByteArray as BA+import qualified Data.ByteString as B+import Data.ByteString.Random.MWC+import qualified Data.HashTree as HT+import Data.Maybe+import Data.Serialize (encode)++import GHC.Generics++import Numeric.Natural++import System.Random+import qualified System.Random.MWC as MWC++-- internal modules++import qualified Data.MerkleLog as ML++-- -------------------------------------------------------------------------- --+-- Main++main :: IO ()+main = defaultMain+ [ env globalEnv $ \ ~e -> bgroup "main"+ [ bgroup "create tree"+ [ bgroup "SHA512t_256"+ [ createBench @(ML SHA512t_256) e+ , createBench @(HT SHA512t_256) e+ ]+ , bgroup "SHA256"+ [ createBench @(ML SHA256) e+ , createBench @(HT SHA256) e+ ]+ , bgroup "SHA3_256"+ [ createBench @(ML SHA3_256) e+ , createBench @(HT SHA3_256) e+ , createBench @MT e+ ]+ , bgroup "BLAKE2b_256"+ [ createBench @(ML Blake2b_256) e+ ]+ ]+ , bgroup "create inclusion proof"+ [ bgroup "SHA512t_256"+ [ proofBench @(ML SHA512t_256) e+ , proofBench @(HT SHA512t_256) e+ ]+ , bgroup "SHA256"+ [ proofBench @(ML SHA256) e+ , proofBench @(HT SHA256) e+ ]+ , bgroup "SHA3_256"+ [ proofBench @(ML SHA3_256) e+ , proofBench @(HT SHA3_256) e+ , proofBench @MT e+ ]+ , bgroup "BLAKE2b_256"+ [ proofBench @(ML Blake2b_256) e+ ]+ ]+ , bgroup "verify inclusion proof"+ [ bgroup "SHA512t_256"+ [ verifyBench @(ML SHA512t_256) e+ , verifyBench @(HT SHA512t_256) e+ ]+ , bgroup "SHA256"+ [ verifyBench @(ML SHA256) e+ , verifyBench @(HT SHA256) e+ ]+ , bgroup "SHA3_256"+ [ verifyBench @(ML SHA3_256) e+ , verifyBench @(HT SHA3_256) e+ , verifyBench @MT e+ ]+ , bgroup "BLAKE2b_256"+ [ verifyBench @(ML Blake2b_256) e+ ]+ ]+ ]+ ]++-- -------------------------------------------------------------------------- --+-- Merkle Tree Implementations+-- -------------------------------------------------------------------------- --++-- -------------------------------------------------------------------------- --+-- Global Environment++leafCount :: Int+leafCount = 10000++leafMaxSize :: Int+leafMaxSize = 1000++type GlobalEnv = [B.ByteString]++globalEnv :: IO GlobalEnv+globalEnv = do+ gen <- MWC.create+ traverse (randomGen gen) (randomNats leafCount)+ where++randomNats :: Int -> [Natural]+randomNats i = fmap fromIntegral $ take i $ randomRs @Int (0,leafMaxSize) $ mkStdGen 1++-- -------------------------------------------------------------------------- --+-- Create Benchmark++createBench :: forall a . Impl a => GlobalEnv -> Benchmark+createBench = bench (label @a) . nf (tree @a)++-- -------------------------------------------------------------------------- --+-- Proof Benchmark++type ProofEnv a = (Tree a, B.ByteString, Int)++proofEnv :: forall a . Impl a => GlobalEnv -> IO (ProofEnv a)+proofEnv e = return (tree @a e, e !! 277, 277)++-- | Note that this also includes verification of the proof, because that's the+-- only way we can ensure that the resulting proofs are in normal form.+--+proofBench+ :: forall a+ . Impl a+ => GlobalEnv+ -> Benchmark+proofBench e = env (proofEnv @a e)+ $ bench (label @a) . nf (\(t, ix, i) -> proof @a t ix i)++-- -------------------------------------------------------------------------- --+-- Verify Benchmark++type VerifyEnv a = Proof a++verifyEnv :: forall a . Impl a => GlobalEnv -> IO (VerifyEnv a)+verifyEnv e = return $ proof @a (tree @a e) (e !! 277) 277++verifyBench+ :: forall a+ . Impl a+ => GlobalEnv+ -> Benchmark+verifyBench e = env (verifyEnv @a e) $ bench (label @a) . nf verifyThrow+ where+ verifyThrow p+ | verify @a p = ()+ | otherwise = error "benchmark failure"++-- -------------------------------------------------------------------------- --+-- Merkle Tree Implementations+-- -------------------------------------------------------------------------- --++-- -------------------------------------------------------------------------- --+-- Merkle Tree Implementation Class++class (NFData (Tree a), NFData (Root a), NFData (Proof a)) => Impl a where+ type Tree a+ type Proof a+ type Root a++ label :: String+ tree :: [B.ByteString] -> Tree a+ root :: Tree a -> Root a+ proof :: Tree a -> B.ByteString -> Int -> Proof a+ verify :: Proof a -> Bool++-- -------------------------------------------------------------------------- --+-- merkle-log++data MLProof a = MLProof+ {-# UNPACK #-} !(ML.MerkleProof a)+ {-# UNPACK #-} !(ML.MerkleRoot a)+ -- ^ Root of the Tree+ deriving (Generic)++instance NFData (MLProof a)++data ML a++instance HashAlgorithm a => Impl (ML a) where+ type Tree (ML a) = ML.MerkleTree a+ type Proof (ML a) = MLProof a+ type Root (ML a) = ML.MerkleRoot a++ label = "merkle-log"+ tree = ML.merkleTree @a . fmap ML.InputNode+ root = ML.merkleRoot+ proof t ix i =+ let Right p = ML.merkleProof (ML.InputNode ix) i t+ in MLProof p (ML.merkleRoot t)+ verify (MLProof p r) = ML.runMerkleProof p == r++ {-# INLINE label #-}+ {-# INLINE tree #-}+ {-# INLINE root #-}+ {-# INLINE proof #-}+ {-# INLINE verify #-}++-- -------------------------------------------------------------------------- --+-- merkle-tree package++data MTProof = MTProof+ !(MT.MerkleProof B.ByteString)+ {-# UNPACK #-} !B.ByteString+ -- ^ Proof subject (leaf)+ {-# UNPACK #-} !(MT.MerkleRoot B.ByteString)+ -- ^ Root of the Tree++-- | The merkle-tree package doesn't export the 'ProofElem'. Without that the+-- 'Generic' instance for 'MT.MerkleProof' become almost useless. In particular+-- we can't define an 'NFData' instance.+--+-- This instance is a workaround that probably leads to worse benchmark results.+--+instance NFData MTProof where+ -- rnf (MTProof p subj r) = rnf+ -- $ MT.validateMerkleProof p r $ MT.mkLeafRootHash subj+ rnf (MTProof p _ _) = rnf $ encode p+ {-# INLINE rnf #-}++instance NFData (MT.MerkleRoot B.ByteString) where+ rnf r = rnf (MT.getMerkleRoot r)+ {-# INLINE rnf #-}++instance NFData (MT.MerkleTree B.ByteString) where+ rnf t = rnf $ MT.mtRoot t+ {-# INLINE rnf #-}++data MT++instance Impl MT where+ type Tree MT = MT.MerkleTree B.ByteString+ type Proof MT = MTProof+ type Root MT = MT.MerkleRoot B.ByteString++ label = "merkle-tree"+ tree = MT.mkMerkleTree+ root = MT.mtRoot+ proof t subj _ = MTProof+ (MT.merkleProof t (MT.mkLeafRootHash subj))+ subj+ (MT.mtRoot t)+ verify (MTProof p subj r)+ = MT.validateMerkleProof p r (MT.mkLeafRootHash subj)++ {-# INLINE label #-}+ {-# INLINE tree #-}+ {-# INLINE root #-}+ {-# INLINE proof #-}+ {-# INLINE verify #-}++-- -------------------------------------------------------------------------- --+-- hash-tree package++data HTProof a = HTProof+ {-# UNPACK #-} !(HT.InclusionProof a)+ {-# UNPACK #-} !B.ByteString+ -- ^ Proof subject (leaf)+ {-# UNPACK #-} !(Digest a)+ -- ^ Root of the Tree+ deriving (Generic)++instance NFData (HTProof a)++instance NFData (HT.MerkleHashTrees B.ByteString a) where+ rnf t = rnf $ HT.digest (HT.size t) t+ {-# INLINE rnf #-}++instance NFData (HT.InclusionProof a) where+ rnf p = rnf (HT.leafIndex p)+ `seq` rnf (HT.treeSize p)+ `seq` rnf (HT.inclusion p)+ {-# INLINE rnf #-}++data HT a++htSettings :: forall a . HashAlgorithm a => HT.Settings B.ByteString a+htSettings = HT.defaultSettings+ { HT.hash0 = hash @B.ByteString @a mempty+ , HT.hash1 = \x -> hash @_ @a (B.singleton 0x00 `B.append` x)+ , HT.hash2 = \x y -> hash @_ @a $ B.concat [B.singleton 0x01, BA.convert x, BA.convert y]+ }++instance HashAlgorithm a => Impl (HT a) where+ type Tree (HT a) = HT.MerkleHashTrees B.ByteString a+ type Proof (HT a) = HTProof a+ type Root (HT a) = Digest a++ label = "hash-tree"+ tree = HT.fromList htSettings+ root t = fromJust $ HT.digest (HT.size t) t+ proof t ix _ = HTProof+ (fromJust $ HT.generateInclusionProof (HT.hash1 (htSettings @a) ix) (HT.size t) t)+ ix+ (root @(HT a) t)+ verify (HTProof p subj r) = HT.verifyInclusionProof+ (htSettings @a) (HT.hash1 (htSettings @a) subj) r p++ {-# INLINE label #-}+ {-# INLINE tree #-}+ {-# INLINE root #-}+ {-# INLINE proof #-}+ {-# INLINE verify #-}+
+ merkle-log.cabal view
@@ -0,0 +1,87 @@+cabal-version: 2.2+name: merkle-log+version: 0.1.0.0+synopsis: Merkle Tree Logs+description: Binary Merkle Trees+homepage: https://github.com/kadena-io/merkle-log+bug-reports: https://github.com/kadena-io/merkle-log/issues+license: BSD-3-Clause+license-file: LICENSE+author: Lars Kuhtz+maintainer: Lars Kuhtz <lars@kadena.io>+copyright: Copyright (c) 2019, Kadena LLC+category: Data+extra-source-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/kadena-io/merkle-log.git++library+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options:+ -Wall+ exposed-modules:+ Data.MerkleLog+ build-depends:+ base >=4.11 && <4.14+ , bytestring >=0.10+ , cryptonite >=0.25+ , deepseq >=1.4+ , exceptions >=0.10+ , memory >=0.14+ , text >=1.2++test-suite test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ ghc-options:+ -Wall+ -threaded+ -with-rtsopts=-N+ default-language: Haskell2010+ main-is: Main.hs+ build-depends:+ -- internal+ merkle-log++ -- external+ , QuickCheck >=2.11+ , base >=4.11 && <4.14+ , bytestring >=0.10+ , cryptonite >=0.25+ , deepseq >=1.4+ , exceptions >=0.10+ , memory >=0.14++benchmark benchmarks+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ ghc-options:+ -Wall+ -threaded+ -with-rtsopts=-N+ default-language: Haskell2010+ main-is: Main.hs+ build-depends:+ -- internal+ merkle-log++ -- external+ , QuickCheck >=2.11+ , base >=4.11 && <4.14+ , bytestring >=0.10+ , cereal >=0.5+ , criterion >=1.5+ , cryptonite >=0.25+ , deepseq >=1.4+ , hash-tree >=0.0+ , memory >=0.14+ , merkle-tree >=0.1+ , mwc-random >=0.14+ , random >=1.1+ , random-bytestring >=0.1+
+ src/Data/MerkleLog.hs view
@@ -0,0 +1,791 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module: Data.MerkleLog+-- Copyright: Copyright © 2019 Kadena LLC.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@kadena.io>+-- Stability: experimental+--+-- Merkle Logs are a append-only data structure. The tree layout in this+-- implementation of Merkle trees is based on the description of Merkle trees in+-- RFC 6962. With this tree layout extending a Merkle tree requires chaining a+-- logarithmic number of nodes at the end of the tree. Unlike RFC 6962 the+-- Merkle trees in this module support the creation of unbalanced MerkleTrees by+-- nesting sub-trees as leafs of Merkle trees. Also, unlike RFC 6962 this module+-- generates fully self-contained inclusion proofs that don't rely on the client+-- being aware of the balancing of the Merkle Tree that was used to generate the+-- proof.+--+-- The API requires the usage of type applications which can be enabled with the+-- following pragma.+--+-- @+-- {-\# LANGUAGE TypeApplications #-}+-- @+--+-- = Example+--+-- @+-- {-\# LANGUAGE TypeApplications #-}+-- {-\# LANGUAGE OverloadedStrings #-}+--+-- import qualified Data.ByteString as B+-- import Crypto.Hash.Algorithms (SHA512t_256)+--+-- inputs = ["a", "b", "c"] :: [B.ByteString]+--+-- -- create tree+-- t = merkleTree @SHA512t_256 inputs+--+-- -- create inclusion proof+-- p = either (error . show) id $ merkleProof 1 (inputs !! 1) t+--+-- -- verify proof+-- runMerkleProof p == merkleRoot t+-- @+--+-- = TODO+--+-- * implement extension of trees (possibly by linking memory chunks of maximal full trees)+-- (how important is this?)+-- * implement consistency proofs+-- * document encodings and hash format+-- * describe tree layout+--+module Data.MerkleLog+(+-- * Merkle Tree+ MerkleTree+, merkleTree+, encodeMerkleTree+, decodeMerkleTree++-- * Merkle Root+, MerkleRoot+, merkleRoot+, encodeMerkleRoot+, decodeMerkleRoot++-- * Merkle Proofs+, MerkleNodeType(..)+, MerkleProof(..)+, MerkleProofSubject(..)+, MerkleProofObject+, encodeMerkleProofObject+, decodeMerkleProofObject+, merkleProof+, merkleProof_+, runMerkleProof++-- * Exceptions+, Expected(..)+, Actual(..)+, MerkleTreeException(..)+, textMessage++-- * Internal++, isEmpty+, emptyMerkleTree+, size+, leafCount+, MerkleHash+, getHash+, merkleLeaf+, merkleNode++) where++import Control.DeepSeq+import Control.Monad+import Control.Monad.Catch++import Crypto.Hash (hash)+import Crypto.Hash.Algorithms (HashAlgorithm)+import Crypto.Hash.IO++import qualified Data.ByteArray as BA+import Data.ByteArray.Encoding+import qualified Data.ByteString as B+import qualified Data.List.NonEmpty as NE+import qualified Data.Memory.Endian as BA+import Data.String+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Word++import Foreign.Ptr+import Foreign.Storable++import GHC.Generics+import GHC.Stack++import System.IO.Unsafe++-- -------------------------------------------------------------------------- --+-- Exceptions++-- | An expected value.+--+newtype Expected a = Expected a+ deriving (Show, Eq, Ord, Generic)+ deriving anyclass (NFData)++-- | An actual value.+--+newtype Actual a = Actual a+ deriving (Show, Eq, Ord, Generic)+ deriving anyclass (NFData)++-- | Format a text messages that compares an 'Expected' with an 'Actual' value.+--+expectedMessage :: Show a => Expected a -> Actual a -> T.Text+expectedMessage (Expected e) (Actual a)+ = "Expected: " <> sshow e <> ", Actual: " <> sshow a++-- | Exceptions that are thrown by functions in "Data.MerkleLog". All functions+-- that throw exceptions can be called as pure functions in `Either+-- SomeException`.+--+data MerkleTreeException+ = EncodingSizeException T.Text (Expected Int) (Actual Int)+ | EncodingSizeConstraintException T.Text (Expected T.Text) (Actual Int)+ | IndexOutOfBoundsException T.Text (Expected (Int, Int)) (Actual Int)+ | InputNotInTreeException T.Text Int B.ByteString+ | MerkleRootNotInTreeException T.Text Int B.ByteString+ | InvalidProofObjectException T.Text+ deriving (Eq, Generic)+ deriving anyclass (NFData)++instance Exception MerkleTreeException where+ displayException = T.unpack . textMessage++instance Show MerkleTreeException where+ show = T.unpack . textMessage++-- | Display 'MerkleTreeException' values as text messages.+--+textMessage :: MerkleTreeException -> T.Text+textMessage (EncodingSizeException ty e a)+ = "Failed to decode " <> ty <> " because the input is of wrong size"+ <> ". " <> expectedMessage e a+textMessage (EncodingSizeConstraintException ty (Expected e) (Actual a))+ = "Failed to decode " <> ty <> " because the input is of wrong size"+ <> ". " <> "Expected: " <> e+ <> ", " <> "Actual: " <> sshow a+textMessage (IndexOutOfBoundsException ty (Expected e) (Actual a))+ = "Index out of bounds"+ <> ". " <> ty+ <> ". " <> "Expected: " <> sshow e+ <> ", " <> "Actual: " <> sshow a+textMessage (InputNotInTreeException t i b)+ = "Item not in tree"+ <> ". " <> t+ <> ". Position: " <> sshow i+ <> ". Input (b64): " <> T.take 1024 (b64 b)+textMessage (MerkleRootNotInTreeException t i b)+ = "Item not in tree"+ <> ". " <> t+ <> ". Position: " <> sshow i+ <> ". Input (b64): " <> b64 b+textMessage (InvalidProofObjectException t)+ = "Invalid ProofObject: " <> t++inputNotInTreeException+ :: T.Text+ -> Int+ -> MerkleNodeType a B.ByteString+ -> MerkleTreeException+inputNotInTreeException t pos (TreeNode r)+ = MerkleRootNotInTreeException t pos $ encodeMerkleRoot r+inputNotInTreeException t pos (InputNode b)+ = InputNotInTreeException t pos b++-- -------------------------------------------------------------------------- --+-- Hashes++-- | Internal type to represent hash values.+--+newtype MerkleHash a = MerkleHash BA.Bytes+ deriving (Eq, Ord, Generic)+ deriving newtype (NFData, BA.ByteArrayAccess)++instance Show (MerkleHash a) where+ show = fmap (toEnum . fromEnum)+ . BA.unpack @BA.Bytes+ . convertToBase Base64URLUnpadded+ {-# INLINEABLE show #-}++-- | The size of 'MerkleHash' values in bytes.+--+hashSize :: forall a c . HashAlgorithm a => Num c => c+hashSize = fromIntegral $ hashDigestSize @a undefined+ -- the 'undefined' argument is a type proxy that isn't evaluated+{-# INLINE hashSize #-}++-- | Decode a 'MerkleHash' from bytes.+--+decodeMerkleHash+ :: forall a b m+ . MonadThrow m+ => HashAlgorithm a+ => BA.ByteArrayAccess b+ => b+ -> m (MerkleHash a)+decodeMerkleHash b+ | BA.length b /= hashSize @a = throwM e+ | otherwise = return $ MerkleHash $ BA.convert b+ where+ e = EncodingSizeException "MerkleHash"+ (Expected (hashSize @a @Int))+ (Actual (BA.length b))+{-# INLINE decodeMerkleHash #-}++-- -------------------------------------------------------------------------- --+-- Merkle Tree Nodes++leafTag :: BA.ByteArray a => a+leafTag = BA.singleton 0+{-# INLINE leafTag #-}++nodeTag :: BA.ByteArray a => a+nodeTag = BA.singleton 1+{-# INLINE nodeTag #-}++-- | Compute hash for a leaf node in a Merkle tree.+--+merkleLeaf+ :: forall a b+ . HashAlgorithm a+ => BA.ByteArrayAccess b+ => b+ -> MerkleHash a+merkleLeaf !bytes = MerkleHash $ BA.allocAndFreeze (hashSize @a) $ \ptr -> do+ !ctx <- hashMutableInit @a+ merkleLeafPtr ctx bytes ptr++-- | Compute hash for an inner node of a Merkle tree.+--+merkleNode+ :: forall a+ . HashAlgorithm a+ => MerkleHash a+ -> MerkleHash a+ -> MerkleRoot a+merkleNode !a !b = MerkleRoot $ MerkleHash $ BA.allocAndFreeze (hashSize @a) $ \ptr -> do+ !ctx <- hashMutableInit @a+ BA.withByteArray a $ \aptr ->+ BA.withByteArray b $ \bptr ->+ merkleNodePtr ctx aptr bptr ptr++-- | Compute hash for inner node of a Merkle tree.+--+merkleNodePtr+ :: forall a+ . HashAlgorithm a+ => MutableContext a+ -> Ptr (MerkleHash a)+ -> Ptr (MerkleHash a)+ -> Ptr (MerkleHash a)+ -> IO ()+merkleNodePtr !ctx !a !b !r = do+ hashMutableReset ctx+ hashMutableUpdate ctx (nodeTag @BA.Bytes)+ BA.withByteArray ctx $ \ctxPtr -> do+ hashInternalUpdate @a ctxPtr (castPtr a) (hashSize @a)+ hashInternalUpdate ctxPtr (castPtr b) (hashSize @a)+ hashInternalFinalize ctxPtr (castPtr r)++-- | Compute hash for a leaf node in a Merkle tree.+--+merkleLeafPtr+ :: forall a b+ . HashAlgorithm a+ => BA.ByteArrayAccess b+ => MutableContext a+ -> b+ -> Ptr (MerkleHash a)+ -> IO ()+merkleLeafPtr !ctx !b !r = do+ hashMutableReset ctx+ hashMutableUpdate ctx (leafTag @BA.Bytes)+ hashMutableUpdate ctx b+ BA.withByteArray ctx $ \ctxPtr ->+ hashInternalFinalize @a ctxPtr (castPtr r)++-- -------------------------------------------------------------------------- --+-- Merkle Tree+--+-- Using unsafe operations in the implementation is fine, since proof testing of+-- Merkle proof validation provides robust assurance that the data in the+-- underlying memory is correct to the bit level, i.e. it's very unlikely that a+-- bug would slip through the unit tests.+--++-- | The Type of leafs nodes in a Merkle tree. A node is either an input value+-- or a root of another nested Merkle tree.+--+data MerkleNodeType a b+ = TreeNode (MerkleRoot a)+ | InputNode b+ deriving (Show, Eq, Ord, Generic, Functor)+ deriving anyclass (NFData)++-- | Binary Merkle Tree.+--+-- A Merkle Tree is only an index. It doesn't store any data but only hashes of+-- the data that is referenced in the tree.+--+newtype MerkleTree a = MerkleTree BA.Bytes+ deriving (Eq, Generic)+ deriving newtype (NFData, BA.ByteArrayAccess)++instance Show (MerkleTree a) where+ show = fmap (toEnum . fromEnum)+ . BA.unpack @BA.Bytes+ . convertToBase Base64URLUnpadded+ {-# INLINEABLE show #-}++-- | Merkle Tree as described in RFC 6962, but with a configurable hash function+-- and support for nested Merkle trees.+--+-- The Merkle tree for the empty input log is the hash of the empty string.+--+-- TODO: The length of the list is forced before the algorithm starts processing+-- the items. Either demand a strict structure (e.g. vector or array) or+-- allocate tree memory dynamically while traversing the log structure.+--+merkleTree+ :: forall a b+ . HasCallStack+ => HashAlgorithm a+ => BA.ByteArrayAccess b+ => [MerkleNodeType a b]+ -> MerkleTree a+merkleTree [] = MerkleTree $ BA.convert $ hash @_ @a (mempty @B.ByteString)+merkleTree !items = MerkleTree $ BA.allocAndFreeze (tsize * hashSize @a) $ \ptr -> do++ !ctx <- hashMutableInit @a++ -- TODO compare performance with explicit construction+ let+ -- | This uses logarithmic stack space+ --+ go+ :: Ptr (MerkleHash a)+ -- ^ ptr into output tree+ -> [MerkleNodeType a b]+ -- ^ input log+ -> [(Int, Ptr (MerkleHash a))]+ -- stack of tree hight and ptr into tree+ -> IO ()++ -- Create new inner node from stack tree positions on stack+ --+ go !i t ((!a, !ia) : (!b, !ib) : s) | a == b = do+ merkleNodePtr ctx ib ia i+ go (i `plusPtr` hs) t ((succ a, i) : s)++ -- Create new leaf node on the stack+ --+ go !i (InputNode h : t) !s = do+ merkleLeafPtr ctx h i+ go (i `plusPtr` hs) t ((0, i) : s)++ go !i (TreeNode h : t) !s = do+ BA.copyByteArrayToPtr h i+ go (i `plusPtr` hs) t ((0, i) : s)++ -- When all inputs are consumed, include remaining nodes on the+ -- stack as unbalanced subtree+ --+ go !i [] ((!a, !ia) : (!_, !ib) : s) = do+ merkleNodePtr ctx ib ia i+ go (i `plusPtr` hs) [] ((succ a, i) : s)++ go _ [] [_] = return ()++ go _ [] [] = error "code invariant violation"++ go ptr items []++ where+ !isize = length items+ !tsize = isize + (isize - 1)+ !hs = hashSize @a++-- | Test a Merkle tree is the tree of the empty log.+--+isEmpty :: forall a . HashAlgorithm a => MerkleTree a -> Bool+isEmpty = BA.constEq (emptyMerkleTree @a)+{-# INLINE isEmpty #-}++-- | The Merkle tree of the empty log. RFC 6962 specifies that this is the hash+-- of the empty string.+--+emptyMerkleTree :: forall a . HashAlgorithm a => MerkleTree a+emptyMerkleTree = merkleTree @a ([] @(MerkleNodeType a B.ByteString))+{-# INLINEABLE emptyMerkleTree #-}++-- | Binary encoding of a Merkle tree.+--+encodeMerkleTree :: BA.ByteArray b => MerkleTree a -> b+encodeMerkleTree = BA.convert+{-# INLINE encodeMerkleTree #-}++-- | The number of nodes (including leafs) in a Merkle tree.+--+size :: forall a . HashAlgorithm a => MerkleTree a -> Int+size t = BA.length t `div` hashSize @a+{-# INLINE size #-}++-- | Decode are Merkle tree from a binary representation.+--+decodeMerkleTree+ :: forall a b m+ . MonadThrow m+ => HashAlgorithm a+ => BA.ByteArrayAccess b+ => b+ -> m (MerkleTree a)+decodeMerkleTree b+ | BA.length b `mod` hashSize @a == 0 = return $ MerkleTree $ BA.convert b+ | otherwise = throwM $ EncodingSizeConstraintException+ "MerkleTree"+ (Expected $ "multiple of " <> sshow (hashSize @a @Int))+ (Actual $ BA.length b)+{-# INLINE decodeMerkleTree #-}++-- -------------------------------------------------------------------------- --+-- Merkle Root++-- | The root of a Merkle tree.+--+newtype MerkleRoot a = MerkleRoot (MerkleHash a)+ deriving (Eq, Ord, Generic)+ deriving newtype (Show, NFData, BA.ByteArrayAccess)++-- | Get the root of Merkle tree.+--+merkleRoot :: forall a . HashAlgorithm a => MerkleTree a -> MerkleRoot a+merkleRoot t = MerkleRoot $ getHash t (size t - 1)+{-# INLINE merkleRoot #-}++-- | Encode a Merkle tree root into binary format.+--+encodeMerkleRoot :: BA.ByteArray b => MerkleRoot a -> b+encodeMerkleRoot = BA.convert+{-# INLINE encodeMerkleRoot #-}++-- | Decode a Merkle tree root from a binary representation.+--+decodeMerkleRoot+ :: MonadThrow m+ => HashAlgorithm a+ => BA.ByteArrayAccess b+ => b+ -> m (MerkleRoot a)+decodeMerkleRoot = fmap MerkleRoot . decodeMerkleHash+{-# INLINE decodeMerkleRoot #-}++-- -------------------------------------------------------------------------- --+-- Proof Object++-- | Opaque proof object.+--+newtype MerkleProofObject a = MerkleProofObject BA.Bytes+ deriving (Eq, Generic)+ deriving anyclass (NFData)+ deriving newtype (BA.ByteArrayAccess)++instance Show (MerkleProofObject a) where+ show = fmap (toEnum . fromEnum)+ . BA.unpack @BA.Bytes+ . convertToBase @_ @BA.Bytes Base64URLUnpadded+ {-# INLINEABLE show #-}++-- | Encode a Merkle proof object into binary format.+--+-- This copies the bytes of the underlying byte array. The encoded object+-- doesn't reference the 'MerkleProofObject'+--+encodeMerkleProofObject :: BA.ByteArray b => MerkleProofObject a -> b+encodeMerkleProofObject = BA.convert+{-# INLINE encodeMerkleProofObject #-}++-- | Encode a Merkle proof object from a binary representation.+--+-- This copies the original bytes and doesn't keep a reference to the input+-- bytes.+--+decodeMerkleProofObject+ :: forall a b m+ . MonadThrow m+ => HashAlgorithm a+ => BA.ByteArrayAccess b+ => b+ -> m (MerkleProofObject a)+decodeMerkleProofObject bytes+ | BA.length bytes < 12 = throwM+ $ EncodingSizeConstraintException+ "MerkleProofObject"+ (Expected "larger than 12")+ (Actual $ BA.length bytes)+ | BA.length bytes /= proofObjectSizeInBytes @a stepCount = throwM+ $ EncodingSizeException+ "MerkleProofObject"+ (Expected $ proofObjectSizeInBytes @a stepCount)+ (Actual $ BA.length bytes)+ | otherwise = return $ MerkleProofObject $ BA.convert bytes+ where+ stepCount = fromIntegral $ BA.fromBE $ peekBA @(BA.BE Word32) bytes++stepSize :: forall a . HashAlgorithm a => Int+stepSize = hashSize @a + 1+{-# INLINE stepSize #-}++proofObjectSizeInBytes :: forall a . HashAlgorithm a => Int -> Int+proofObjectSizeInBytes stepCount = stepSize @a * stepCount + 12+{-# INLINE proofObjectSizeInBytes #-}++-- -------------------------------------------------------------------------- --+-- Proof Subject++-- | The subject for which inclusion is proven.+--+newtype MerkleProofSubject a = MerkleProofSubject+ { _getMerkleProofSubject :: (MerkleNodeType a B.ByteString) }+ deriving (Show, Eq, Ord, Generic)+ deriving anyclass (NFData)++-- -------------------------------------------------------------------------- --+-- Merkle Proof++-- | Merkle Inclusion Proof. In RFC 6962 this is called an audit proof. The+-- proof in this module are not compatible with RFC 6962. They support proving+-- inclusion of subtrees and proof for unbalanced trees of unknown size.+--+-- The proof is self-contained. It is independent of the concrete implementation+-- of the Merkle tree. This type works with any binary Merkle tree type and+-- doesn't make any assumptions about the balancing of the tree.+--+-- The proof includes the subject of the proof (for which inclusion is proven)+-- as a plaintext bytestring. The proof does not include the root hash of the+-- Merkle tree, because the proof is only meaningful if the root is available+-- from a trusted source. Including it into the proof would thus be redundant or+-- even misleading.+--+-- A more compact encoding would use the first bit of each hash to encode the+-- side, but that would require to alter the hash computation. We also could+-- pack the sides into a bit array. However, the total number of bytes for the+-- sides will be most likely less than two hashes, so the overhead is small and+-- doesn't justify more clever encodings.+--+data MerkleProof a = MerkleProof+ { _merkleProofSubject :: !(MerkleProofSubject a)+ , _merkleProofObject :: !(MerkleProofObject a)+ }+ deriving (Show, Eq, Generic)+ deriving anyclass (NFData)++-- | Construct a self-contained Merkle inclusion proof.+--+merkleProof+ :: forall a m+ . MonadThrow m+ => HashAlgorithm a+ => MerkleNodeType a B.ByteString+ -> Int+ -> MerkleTree a+ -> m (MerkleProof a)+merkleProof a pos t+ | pos < 0 || pos >= leafCount t = throwM $ IndexOutOfBoundsException+ "merkleProof"+ (Expected (0,leafCount t - 1))+ (Actual pos)+ | not (BA.constEq (view t tpos) (inputHash a)) = throwM+ $ inputNotInTreeException "merkleProof" pos a+ | otherwise = return $ MerkleProof+ { _merkleProofSubject = MerkleProofSubject a+ , _merkleProofObject = MerkleProofObject go+ }+ where+ inputHash (InputNode bytes) = merkleLeaf @a bytes+ inputHash (TreeNode (MerkleRoot bytes)) = bytes++ (tpos, path) = proofPath pos (leafCount t)+ go = BA.allocAndFreeze (proofObjectSizeInBytes @a (length path)) $ \ptr -> do+ -- encode number of proof stepts in 4 bytes+ pokeBE @Word32 ptr $ fromIntegral $ length path++ -- encode index of subject in input order in 8 bytes+ pokeBE @Word64 (ptr `plusPtr` 4) (fromIntegral pos)++ -- encode path+ let pathPtr = ptr `plusPtr` 12+ forM_ (path `zip` [0, fromIntegral (stepSize @a) ..]) $ \((s, i), x) -> do+ poke (pathPtr `plusPtr` x) (sideWord8 s)+ BA.copyByteArrayToPtr (view t i) (pathPtr `plusPtr` succ x)++-- | Construct a Merkle proof for a proof subject in a nested sub-tree.+--+-- FIXME: make this function more efficient by implementing it more directly.+--+merkleProof_+ :: forall a m+ . MonadThrow m+ => HashAlgorithm a+ => MerkleNodeType a B.ByteString+ -- ^ The proof subject+ -> NE.NonEmpty (Int, MerkleTree a)+ -- ^ The proof components+ -> m (MerkleProof a)+merkleProof_ a l+ = MerkleProof (MerkleProofSubject a) . MerkleProofObject . assemble <$> go a (NE.toList l)+ where+ go _ [] = return []+ go sub ((pos, tree) : t) = do+ -- create sub-proof+ MerkleProof (MerkleProofSubject _) (MerkleProofObject o) <- merkleProof sub pos tree+ -- collect step counts and stripped proof objects+ (:) (strip o) <$> go (TreeNode $ merkleRoot tree) t++ -- strip path length and subject position from proof object+ strip o = (peekBeBA o :: Word32, BA.drop 12 o)+ assemble ps =+ let (s, os) = unzip ps+ in BA.concat+ -- inject length of overall path+ $ BA.allocAndFreeze 4 (flip pokeBE $ sum s)+ -- inject position of proof subject+ : BA.allocAndFreeze 8 (flip (pokeBE @Word64) $ fromIntegral $ fst $ NE.head l)+ : os++proofPath+ :: Int+ -- ^ Position in log+ -> Int+ -- ^ Size of log+ -> (Int, [(Side, Int)])+ -- ^ The tree position of the target node and tree positions and+ -- directions of the audit proof.+proofPath b c = go 0 0 b c []+ where+ go _ !treeOff _ 1 !acc = (treeOff, acc)+ go !logOff !treeOff !m !n !acc+ | m < k = go logOff treeOff m k $ (R, treeOff + 2 * n - 3) : acc+ | otherwise = go (logOff + k) (treeOff + 2 * k - 1) (m - k) (n - k)+ $ (L, treeOff + 2 * k - 2) : acc+ where+ k = k2 n++-- | Execute an inclusion proof. The result of the execution is a Merkle root+-- that must be compared to the trusted root of the Merkle tree.+--+runMerkleProof :: forall a . HashAlgorithm a => MerkleProof a -> MerkleRoot a+runMerkleProof p = MerkleRoot $ MerkleHash $ runMerkleProofInternal @a subj obj+ where+ MerkleProofSubject subj = _merkleProofSubject p+ MerkleProofObject obj = _merkleProofObject p++runMerkleProofInternal+ :: forall a b c d+ . HashAlgorithm a+ => BA.ByteArrayAccess b+ => BA.ByteArrayAccess c+ => BA.ByteArray d+ => MerkleNodeType a b+ -- ^ proof subject+ -> c+ -- ^ proof object+ -> d+runMerkleProofInternal subj obj = BA.allocAndFreeze (hashSize @a) $ \ptr -> do+ ctx <- hashMutableInit @a+ case subj of+ InputNode x -> merkleLeafPtr ctx x ptr+ TreeNode x -> BA.copyByteArrayToPtr x ptr+ BA.withByteArray obj $ \objPtr -> do+ stepCount <- fromIntegral <$> peekBE @Word32 objPtr+ forM_ [0 .. stepCount - 1] $ \(i :: Int) -> do+ let off = 12 + i * stepSize @a+ peekByteOff @Word8 objPtr off >>= \case+ 0x00 -> merkleNodePtr ctx (objPtr `plusPtr` succ off) ptr ptr+ 0x01 -> merkleNodePtr ctx ptr (objPtr `plusPtr` succ off) ptr+ _ -> throwM $ InvalidProofObjectException "runMerkleProofInternal"++-- -------------------------------------------------------------------------- --+-- Utils++k2 :: Int -> Int+k2 i = 2 ^ floor @Double @Int (logBase 2 $ fromIntegral i - 1)+{-# INLINE k2 #-}++data Side = L | R+ deriving (Show, Eq)++sideWord8 :: Side -> Word8+sideWord8 L = 0x00+sideWord8 R = 0x01+{-# INLINE sideWord8 #-}++view :: forall a . HashAlgorithm a => MerkleTree a -> Int -> BA.View BA.Bytes+view (MerkleTree v) i = BA.view v (i * hashSize @a) (hashSize @a)+{-# INLINE view #-}++-- | Get the hash of a node in the Merkle tree.+--+getHash :: HashAlgorithm a => MerkleTree a -> Int -> MerkleHash a+getHash t = MerkleHash . BA.convert . view t+{-# INLINE getHash #-}++-- | Get the number of leafs in a Merkle tree.+--+leafCount :: HashAlgorithm a => MerkleTree a -> Int+leafCount t+ | isEmpty t = 0+ | otherwise = 1 + size t `div` 2+{-# INLINE leafCount #-}++peekBE :: forall a . BA.ByteSwap a => Storable a => Ptr (BA.BE a) -> IO a+peekBE ptr = BA.fromBE <$> peek @(BA.BE a) ptr+{-# INLINE peekBE #-}++pokeBE :: forall a . BA.ByteSwap a => Storable a => Ptr (BA.BE a) -> a -> IO ()+pokeBE ptr = poke ptr . BA.toBE @a+{-# INLINE pokeBE #-}++peekBA :: forall a b . Storable a => BA.ByteArrayAccess b => b -> a+peekBA bytes = unsafePerformIO $ BA.withByteArray bytes (peek @a)+{-# INLINE peekBA #-}++peekBeBA :: forall a b . BA.ByteSwap a => Storable a => BA.ByteArrayAccess b => b -> a+peekBeBA = BA.fromBE . peekBA @(BA.BE a)+{-# INLINE peekBeBA #-}++{- Useful for debugging+hex :: BA.ByteArrayAccess a => a -> String+hex = fmap (toEnum . fromEnum)+ . BA.unpack @BA.Bytes+ . convertToBase Base16+-}++b64 :: BA.ByteArrayAccess a => a -> T.Text+b64 = T.decodeUtf8 . convertToBase Base64URLUnpadded+{-# INLINE b64 #-}++sshow :: Show a => IsString b => a -> b+sshow = fromString . show+{-# INLINE sshow #-}
+ test/Main.hs view
@@ -0,0 +1,342 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++-- |+-- Module: Main+-- Copyright: Copyright © 2019 Kadena LLC.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@kadena.io>+-- Stability: experimental+--+-- TODO+--+module Main+( main++-- * Properties+, properties+, prop_proof+, prop_proofExhaustive+, prop_proofSize+, prop_encodeProofObject+, prop_encodeMerkleRoot+, prop_encodeMerkleTree+) where++import Control.DeepSeq+import Control.Monad.Catch++import Crypto.Hash.Algorithms (SHA512t_256, HashAlgorithm)++import Data.Bitraversable+import qualified Data.ByteArray as BA+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.List.NonEmpty as NE++import System.Exit++import Test.QuickCheck++-- internal modules++import Data.MerkleLog++-- -------------------------------------------------------------------------- --+-- Support for QuickCheck < 2.12++#if ! MIN_VERSION_QuickCheck(2,12,0)+infix 4 =/=+(=/=) :: (Eq a, Show a) => a -> a -> Property+x =/= y = counterexample (show x ++ interpret res ++ show y) res+ where+ res = x /= y+ interpret True = " /= "+ interpret False = " == "++isSuccess :: Result -> Bool+isSuccess Success{} = True+isSuccess _ = False+#endif++-- -------------------------------------------------------------------------- --+-- Main++main :: IO ()+main = do+ results <- traverse (bitraverse print quickCheckResult) properties+ if and $ isSuccess . snd <$> results+ then exitSuccess+ else exitFailure++-- | Properties+--+properties :: [(String, Property)]+properties =+ [ ("create merkle tree and confirm the size", property prop_tree)+ , ("create and verify merkle proof", property prop_proof)+ , ("create and verify merkle proof for all tree items for tree of size 30", prop_proofExhaustive 30)+ , ("create and verify merkle proof for tree of size 1000 with items of sizes up to 1000 bytes", prop_proofSize 1000 1000)+ , ("creating proof for invalid input fails", property prop_proofInvalidInput)+ , ("running proof with invalid subject fails", property prop_proofInvalidSubject)+ , ("running proof with invalid object path fails", property prop_proofInvalidObjectPath)+ , ("running proof with invalid object hash fails", property prop_proofInvalidObjectHash)+ , ("running proof with invalid object step count fails", property prop_proofInvalidStepCount)+ , ("create and verify merkle proof for nested trees", property prop_chainProof)+ , ("encoding roundtrip for merkle proof object", property prop_encodeProofObject)+ , ("encoding roundtrip for merkle proof chain object", property prop_encodeProofChainObject)+ , ("encoding roundtrip for merkle root", property prop_encodeMerkleRoot)+ , ("encoding roundtrip for merkle tree", property prop_encodeMerkleTree)+ ]++-- -------------------------------------------------------------------------- --+-- Utils++nodeCount :: Int -> Int+nodeCount i = max 1 (2 * i - 1)+{-# INLINE nodeCount #-}++-- | Change diretion of first proof step. Throws error is the proof+-- is empty (singleton tree).+--+changeProofPath :: HashAlgorithm a => MerkleProof a -> MerkleProof a+changeProofPath p = p { _merkleProofObject = o }+ where+ Right o = decodeMerkleProofObject . BA.pack @BA.Bytes+ $ case splitAt 12 (BA.unpack (_merkleProofObject p)) of+ (h, 0x00 : t) -> h <> (0x01 : t)+ (h, 0x01 : t) -> h <> (0x00 : t)+ (_, _ : _) -> error "invalid proof object"+ (_, []) -> error "unexpected empty proof object"+++-- | Change hash of first proof step. Throws error is the proof+-- is empty (singleton tree).+--+changeProofHash :: HashAlgorithm a => MerkleProof a -> MerkleProof a+changeProofHash p = p { _merkleProofObject = o }+ where+ Right o = decodeMerkleProofObject . BA.pack @BA.Bytes+ $ case splitAt 12 (BA.unpack (_merkleProofObject p)) of+ (h, h1 : h2 : t) -> h <> (h1 : 1 + h2 : t)+ (_, []) -> error "unexpected empty proof object"+ _ -> error "invalid proof object"++-- | Changes the proof step count and verifies that decoding of the modified proof object fails.+-- Throws error is the proof is empty (singleton tree).+--+changeProofStepCount :: forall a . HashAlgorithm a => MerkleProof a -> Bool+changeProofStepCount p = case r of+ Left _ -> True+ Right _ -> False+ where+ r = decodeMerkleProofObject @a . BA.pack @BA.Bytes+ $ case splitAt 3 (BA.unpack (_merkleProofObject p)) of+ (h, c : t) -> h <> (c + 1 : t)+ (_, []) -> error "unexpected empty proof object"++-- -------------------------------------------------------------------------- --+-- Generators++newtype UniqueInputs a = UniqueInputs [MerkleNodeType a B.ByteString]+ deriving Show++instance HashAlgorithm a => Arbitrary (UniqueInputs a) where+ arbitrary = UniqueInputs+ . zipWith (\a () -> InputNode $ B8.pack (show a)) [0 :: Int .. ]+ <$> arbitrary++instance HashAlgorithm a => Arbitrary (MerkleNodeType a B.ByteString) where+ arbitrary = oneof+ [ InputNode . B.pack <$> arbitrary+ , TreeNode <$> arbitrary+ ]++instance HashAlgorithm a => Arbitrary (MerkleRoot a) where+ arbitrary = merkleNode <$> arbitrary <*> arbitrary++instance HashAlgorithm a => Arbitrary (MerkleHash a) where+ arbitrary = merkleLeaf @a . B.pack <$> arbitrary++instance HashAlgorithm a => Arbitrary (MerkleTree a) where+ arbitrary = merkleTree <$> arbitrary @[MerkleNodeType a B.ByteString]++instance HashAlgorithm a => Arbitrary (MerkleProof a) where+ arbitrary = go `suchThatMap` either (const Nothing) Just+ where+ go = do+ NonEmpty l <- arbitrary @(NonEmptyList (MerkleNodeType a B.ByteString))+ i <- choose (0, length l - 1)+ return (merkleProof (l !! i) i (merkleTree l))++-- | A chain of nested Merkle trees.+--+newtype MerkleTreeChain a = MerkleTreeChain+ { _getMerkleTreeChain :: NE.NonEmpty (Int, MerkleTree a)+ -- ^ a list of of merkle trees along with the position of the previous+ -- tree in the chain+ }+ deriving Show++genTrees+ :: forall a+ . HashAlgorithm a+ => Gen (MerkleTreeChain a)+genTrees = do+ a <- genTree (InputNode "a")+ i <- choose @Int (0, 10)+ MerkleTreeChain . (NE.:|) a <$> go i (merkleRoot $ snd a)+ where+ genTree x = do+ il <- arbitrary @[MerkleNodeType a B.ByteString]+ ir <- arbitrary+ return (length il , merkleTree (concat [il, pure x, ir]))++ go 0 _ = return []+ go i r = do+ a <- genTree (TreeNode r)+ (:) a <$> go (pred i) (merkleRoot $ snd a)++instance HashAlgorithm a => Arbitrary (MerkleTreeChain a) where+ arbitrary = genTrees++-- -------------------------------------------------------------------------- --+-- Properties++prop_tree :: [MerkleNodeType SHA512t_256 B.ByteString] -> Property+prop_tree l = size t === nodeCount (length l) .&. leafCount t === length l+ where+ t = force $ merkleTree @SHA512t_256 l++prop_proof :: [MerkleNodeType SHA512t_256 B.ByteString] -> NonNegative Int -> Property+prop_proof l (NonNegative i) = i < length l ==> runMerkleProof p === merkleRoot t+ where+ t = merkleTree @SHA512t_256 l+ p = case merkleProof (l !! i) i t of+ Left e -> error (displayException e)+ Right x -> x++-- | Runtime is quadradic in the input parameter. 50 ~ 1sec, 100 ~ 5sec.+--+prop_proofExhaustive :: Int -> Property+prop_proofExhaustive n = once $ conjoin+ [ prop_proof ((InputNode . B.singleton . fromIntegral) <$> [0 .. i]) (NonNegative j)+ | i <- [0..n]+ , j <- [0..i]+ ]++-- | Runtime of @testSize n m@ can be expected to be bounded by @Ω(n * m)@.+-- @testSize 1000 1000@ ~ 1sec.+--+prop_proofSize :: Int -> Int -> Property+prop_proofSize n m = once $ do+ l <- vectorOf n (resize m arbitrary)+ i <- choose (0, n - 1)+ return $ prop_proof l (NonNegative i)++prop_proofInvalidInput+ :: [MerkleNodeType SHA512t_256 B.ByteString]+ -> NonNegative Int+ -> Property+prop_proofInvalidInput a (NonNegative i) = i < length a+ ==> case merkleProof (InputNode "a") i (merkleTree @SHA512t_256 a) of+ Left _ -> True+ Right _ -> False++prop_proofInvalidSubject+ :: [MerkleNodeType SHA512t_256 B.ByteString]+ -> NonNegative Int+ -> Property+prop_proofInvalidSubject l (NonNegative i) = i < length l+ ==> runMerkleProof p' =/= merkleRoot t+ where+ t = merkleTree @SHA512t_256 l+ p = case merkleProof (l !! i) i t of+ Left e -> error (displayException e)+ Right x -> x+ p' = p { _merkleProofSubject = MerkleProofSubject (InputNode "a") }++prop_proofInvalidObjectPath+ :: UniqueInputs SHA512t_256+ -> NonNegative Int+ -> Property+prop_proofInvalidObjectPath (UniqueInputs l) (NonNegative i)+ = length l > 1 && i < length l+ ==> runMerkleProof (changeProofPath p) =/= merkleRoot t+ where+ t = merkleTree @SHA512t_256 l+ p = case merkleProof (l !! i) i t of+ Left e -> error (displayException e)+ Right x -> x++prop_proofInvalidStepCount+ :: NonEmptyList (MerkleNodeType SHA512t_256 B.ByteString)+ -> NonNegative Int+ -> Property+prop_proofInvalidStepCount (NonEmpty l) (NonNegative i)+ = i < length l ==> changeProofStepCount p+ where+ t = merkleTree @SHA512t_256 l+ p = case merkleProof (l !! i) i t of+ Left e -> error (displayException e)+ Right x -> x++prop_proofInvalidObjectHash+ :: NonEmptyList (MerkleNodeType SHA512t_256 B.ByteString)+ -> NonNegative Int+ -> Property+prop_proofInvalidObjectHash (NonEmpty l) (NonNegative i)+ = 1 < length l && i < length l+ ==> runMerkleProof (changeProofHash p) =/= merkleRoot t+ where+ t = merkleTree @SHA512t_256 l+ p = case merkleProof (l !! i) i t of+ Left e -> error (displayException e)+ Right x -> x++prop_chainProof :: MerkleTreeChain SHA512t_256 -> Property+prop_chainProof (MerkleTreeChain l)+ = runMerkleProof @SHA512t_256 p === merkleRoot (snd $ NE.last l)+ where+ Right p = merkleProof_ (InputNode "a") l++prop_encodeProofObject :: MerkleProof SHA512t_256 -> Property+prop_encodeProofObject p+ = case decodeMerkleProofObject (encodeMerkleProofObject @BA.Bytes po) of+ Left e -> error (displayException e)+ Right x -> po === x+ where+ po = _merkleProofObject p++prop_encodeProofChainObject :: MerkleTreeChain SHA512t_256 -> Property+prop_encodeProofChainObject (MerkleTreeChain l)+ = case decodeMerkleProofObject (encodeMerkleProofObject @BA.Bytes po) of+ Left e -> error (displayException e)+ Right x -> po === x+ where+ p = case merkleProof_ (InputNode "a") l of+ Left e -> error (displayException e)+ Right x -> x+ po = _merkleProofObject p++prop_encodeMerkleRoot :: MerkleTree SHA512t_256 -> Property+prop_encodeMerkleRoot t+ = case decodeMerkleRoot (encodeMerkleRoot @BA.Bytes r) of+ Left e -> error (displayException e)+ Right x -> r === x+ where+ r = merkleRoot t++prop_encodeMerkleTree :: MerkleTree SHA512t_256 -> Property+prop_encodeMerkleTree t+ = case decodeMerkleTree (encodeMerkleTree @BA.Bytes t) of+ Left e -> error (displayException e)+ Right x -> t === x+