diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2017 Adjoint Inc. + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,89 @@ +

+ +

+ +merkle-tree +=========== + +This library implements a merkle-tree data structure, for representing a list of +hashed data as a binary tree of pairs of hashes converging to a single hash, the +`merkle root`. `SHA3_256` is used as the hashing algorithm. + +# Description + +A Merkle tree is a tamper-resistant data structure that allows a large amount of +data to be compressed into a single hash and can be queried for the presence +of specific elements in the data with a proof constructed in logarithmic space. + +## Construction + +A Merkle tree is a binary tree of hashes, in which all the leaf nodes are the +individual data elements in the block. To construct a merkle tree, the initial +data elements are first hashed using the merkle tree hash function to generate +the leaf nodes of the tree. The resulting hashed data are subsequently hashed +together in pairs to create the parent nodes of the leaf nodes. This process +continues until it results in a single hash known as the merkle root. + +```haskell +-- | Constructs a Merkle Tree from a list of ByteStrings +mkMerkleTree :: [ByteString] -> MerkleTree ByteString + +-- | Generates the hash of a piece of data existing as a leaf node in the Tree +mkLeafRootHash :: ByteString -> MerkleRoot ByteString +``` + +## Merkle Inclusion Proof + +Perhaps the most important reason to use a merkle tree to represent the block +data is the ability to construct a merkle proof (`O(n)`) that verifies +the inclusion of a transaction *t* in a specific block *b* (`O(log(n))`). + +Merkle proofs are an important part in creating decentralized block chain +networks as nodes or client programs (aka "light-weight nodes") that do not +store blocks in memory or on disk regularly need to *verify* that a +transaction has been included on the chain or not. This can be accomplished +by the lightweight node supplying the transaction hash and a block index, +querying a full node for a merkle inclusion proof of the transaction's inclusion +in the block with the index supplied. If the full node finds the transaction in +that block and responds with the inclusion proof and the block's merkle root. +With this information, it takes `O(log(n))` for the lightweight node to validate +the inclusion proof. + +```haskell +-- | Constructs a Merkle Inclusion Proof +merkleProof + :: MerkleTree a -- ^ Tree to which data may belong + -> MerkleRoot a -- ^ Leaf root hash, data to query inclusion of + -> MerkleProof a -- ^ A list of hashes to verify data inclusion + +-- | Validates a Merkle Inclusion Proof +validateMerkleProof + :: MerkleProof a -- ^ Inclusion proof constructed by the prover + -> MerkleRoot a -- ^ Root of the merkle tree from which the proof was constructed + -> MerkleRoot a -- ^ Leaf root hash for which the proof was constructed + -> Bool -- ^ Leaf root inclusion +``` + +# Example + +```haskell +import Crypto.Hash.MerkleTree + +example :: Bool +example = + -- Does the proof prove that `mleaf` exists in `mtree`? + validateMerkleProof proof (mtRoot mtree) mleaf + where + -- Build a merkle tree from a list of data + mtree = mkMerkleTree ["tx1", "tx2", "tx3"] + -- Construct merkle proof that a leaf exists in `merkleTree` + mleaf = mkLeafRootHash "tx2" + proof = merkleProof mtree mleaf +``` + +License +------- + +Copyright 2017 Adjoint Inc + +Released under Apache 2.0. diff --git a/merkle-tree.cabal b/merkle-tree.cabal new file mode 100644 --- /dev/null +++ b/merkle-tree.cabal @@ -0,0 +1,62 @@ +-- This file has been generated from package.yaml by hpack version 0.19.3. +-- +-- see: https://github.com/sol/hpack + +name: merkle-tree +version: 0.1.0 +synopsis: An implementation of a Merkle Tree and merkle tree proofs +homepage: https://github.com/adjoint-io/merkle-tree#readme +bug-reports: https://github.com/adjoint-io/merkle-tree/issues +license: Apache +license-file: LICENSE +maintainer: Adjoint Inc. (info@adjoint.io) +category: Development +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/adjoint-io/merkle-tree + +library + hs-source-dirs: + src + default-extensions: OverloadedStrings NoImplicitPrelude FlexibleInstances + ghc-options: -fwarn-tabs -fwarn-incomplete-patterns -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-redundant-constraints -fwarn-implicit-prelude -fwarn-overflowed-literals -fwarn-orphans -fwarn-identities -fwarn-dodgy-exports -fwarn-dodgy-imports -fwarn-duplicate-exports -fwarn-overlapping-patterns -fwarn-missing-fields -fwarn-missing-methods -fwarn-missing-signatures -fwarn-noncanonical-monad-instances -fwarn-unused-pattern-binds -fwarn-unused-type-patterns -fwarn-unrecognised-pragmas -fwarn-wrong-do-bind -fwarn-hi-shadowing -fno-warn-name-shadowing -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-unused-do-bind + exposed-modules: + Crypto.Hash.MerkleTree + other-modules: + Paths_merkle_tree + build-depends: + base >=4.7 && <5 + , bytestring + , cereal + , cryptonite >=0.21 + , memory + , protolude >=0.2 + , random + default-language: Haskell2010 + +test-suite merkle-test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + test + build-depends: + QuickCheck + , base >=4.7 && <5 + , bytestring + , cereal + , cryptonite >=0.21 + , memory + , merkle-tree + , protolude >=0.2 + , random + , tasty + , tasty-quickcheck + other-modules: + Paths_merkle_tree + default-language: Haskell2010 diff --git a/src/Crypto/Hash/MerkleTree.hs b/src/Crypto/Hash/MerkleTree.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Hash/MerkleTree.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE StrictData #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Crypto.Hash.MerkleTree ( + MerkleTree(..), + MerkleRoot(..), + MerkleNode(..), + + -- ** Constructors + mkMerkleTree, + mkRootHash, + mkLeafRootHash, + emptyHash, + + -- ** Merkle Proof + MerkleProof(..), + merkleProof, + validateMerkleProof, + + -- ** Size + mtRoot, + mtSize, + mtHash, + mtHeight, + + -- ** Testing + testMerkleProofN, +) where + +import Protolude hiding (hash) + +import Crypto.Hash (Digest, SHA3_256(..), hash) + +import qualified Data.List as List +import qualified Data.Serialize as S +import qualified Data.ByteArray as B +import qualified Data.ByteArray.Encoding as B +import qualified Data.ByteString as BS + +import System.Random (randomRIO) + +------------------------------------------------------------------------------- +-- Types +------------------------------------------------------------------------------- + +-- | A merkle tree root. +newtype MerkleRoot a = MerkleRoot + { getMerkleRoot :: ByteString + } deriving (Show, Eq, Ord, Generic, S.Serialize) + +instance B.ByteArrayAccess (MerkleRoot a) where + length (MerkleRoot bs) = B.length bs + withByteArray (MerkleRoot bs) f = B.withByteArray bs f + +-- | A merkle tree. +data MerkleTree a + = MerkleEmpty + | MerkleTree Word32 (MerkleNode a) + deriving (Show, Eq, Generic, S.Serialize) + +data MerkleNode a + = MerkleBranch { + mRoot :: MerkleRoot a + , mLeft :: MerkleNode a + , mRight :: MerkleNode a + } + | MerkleLeaf { + mRoot :: MerkleRoot a + , mVal :: a + } + deriving (Eq, Show, Generic, S.Serialize) + +instance Foldable MerkleTree where + foldMap _ MerkleEmpty = mempty + foldMap f (MerkleTree _ n) = foldMap f n + + null MerkleEmpty = True + null _ = False + + length MerkleEmpty = 0 + length (MerkleTree s _) = fromIntegral s + +instance Foldable MerkleNode where + foldMap f x = case x of + MerkleLeaf{mVal} -> f mVal + MerkleBranch{mLeft, mRight} -> + foldMap f mLeft `mappend` foldMap f mRight + +-- | Returns root of merkle tree. +mtRoot :: MerkleTree a -> MerkleRoot a +mtRoot MerkleEmpty = emptyHash +mtRoot (MerkleTree _ x) = mRoot x + +-- | Returns root of merkle tree root hashed. +mtHash :: MerkleTree a -> ByteString +mtHash MerkleEmpty = merkleHash "" +mtHash (MerkleTree _ x) = B.convert (mRoot x) + +mtSize :: MerkleTree a -> Word32 +mtSize MerkleEmpty = 0 +mtSize (MerkleTree s _) = s + +emptyHash :: MerkleRoot a +emptyHash = MerkleRoot (merkleHash mempty) + +-- | Merkle tree height +mtHeight :: Int -> Int +mtHeight ntx + | ntx < 2 = 0 + | even ntx = 1 + mtHeight (ntx `div` 2) + | otherwise = mtHeight $ ntx + 1 + +-- | Merkle tree width +mtWidth + :: Int -- ^ Number of transactions (leaf nodes). + -> Int -- ^ Height at which we want to compute the width. + -> Int -- ^ Width of the merkle tree. +mtWidth ntx h = (ntx + (1 `shiftL` h) - 1) `shiftR` h + +-- | Return the largest power of two such that it's smaller than n. +powerOfTwo :: (Bits a, Num a) => a -> a +powerOfTwo n + | n .&. (n - 1) == 0 = n `shiftR` 1 + | otherwise = go n + where + go w = if w .&. (w - 1) == 0 then w else go (w .&. (w - 1)) + +------------------------------------------------------------------------------- +-- Constructors +------------------------------------------------------------------------------- + +mkLeaf :: ByteString -> MerkleNode ByteString +mkLeaf a = + MerkleLeaf + { mVal = a + , mRoot = mkLeafRootHash a + } + +mkLeafRootHash :: B.ByteArrayAccess a => a -> MerkleRoot a +mkLeafRootHash a = MerkleRoot $ merkleHash (BS.singleton 0 <> B.convert a) + +mkBranch :: MerkleNode a -> MerkleNode a -> MerkleNode a +mkBranch a b = + MerkleBranch + { mLeft = a + , mRight = b + , mRoot = mkRootHash (mRoot a) (mRoot b) + } + +mkRootHash :: MerkleRoot a -> MerkleRoot a -> MerkleRoot a +mkRootHash (MerkleRoot l) (MerkleRoot r) = MerkleRoot $ merkleHash $ mconcat + [ BS.singleton 1, B.convert l, B.convert r ] + +-- | Smart constructor for 'MerkleTree'. +mkMerkleTree :: [ByteString] -> MerkleTree ByteString +mkMerkleTree [] = MerkleEmpty +mkMerkleTree ls = MerkleTree (fromIntegral lsLen) (go lsLen ls) + where + lsLen = length ls + go _ [x] = mkLeaf x + go len xs = mkBranch (go i l) (go (len - i) r) + where + i = powerOfTwo len + (l, r) = splitAt i xs + +------------------------------------------------------------------------------- +-- Merkle Proofs +------------------------------------------------------------------------------- + +newtype MerkleProof a = MerkleProof { getMerkleProof :: [ProofElem a] } + deriving (Show, Eq, Ord, Generic, S.Serialize) + +data ProofElem a = ProofElem + { nodeRoot :: MerkleRoot a + , siblingRoot :: MerkleRoot a + , nodeSide :: Side + } deriving (Show, Eq, Ord, Generic, S.Serialize) + +data Side = L | R + deriving (Show, Eq, Ord, Generic, S.Serialize) + +-- | Construct a merkle tree proof of inclusion +-- Walks the entire tree recursively, building a list of "proof elements" +-- that are comprised of the current node's root and it's sibling's root, +-- and whether it is the left or right sibling (this is necessary to determine +-- the order in which to hash each proof element root and it's sibling root). +-- The list is ordered such that the for each element, the next element in +-- the list is the proof element corresponding to the node's parent node. +merkleProof :: forall a. MerkleTree a -> MerkleRoot a -> MerkleProof a +merkleProof MerkleEmpty _ = MerkleProof [] +merkleProof (MerkleTree _ rootNode) leafRoot = MerkleProof $ constructPath [] rootNode + where + constructPath :: [ProofElem a] -> MerkleNode a -> [ProofElem a] + constructPath pElems (MerkleLeaf leafRoot' _) + | leafRoot == leafRoot' = pElems + | otherwise = [] + constructPath pElems (MerkleBranch bRoot ln rn) = lPath ++ rPath + where + lProofElem = ProofElem (mRoot ln) (mRoot rn) L + rProofElem = ProofElem (mRoot rn) (mRoot ln) R + + lPath = constructPath (lProofElem:pElems) ln + rPath = constructPath (rProofElem:pElems) rn + +-- | Validate a merkle tree proof of inclusion +validateMerkleProof :: forall a. MerkleProof a -> MerkleRoot a -> MerkleRoot a -> Bool +validateMerkleProof (MerkleProof proofElems) treeRoot leafRoot = + validate proofElems leafRoot + where + validate :: [ProofElem a] -> MerkleRoot a -> Bool + validate [] proofRoot = proofRoot == treeRoot + validate (pElem:pElems) proofRoot + | proofRoot /= nodeRoot pElem = False + | otherwise = validate pElems $ hashProofElem pElem + + hashProofElem :: ProofElem a -> MerkleRoot a + hashProofElem (ProofElem pRoot sibRoot side) = + case side of + L -> mkRootHash pRoot sibRoot + R -> mkRootHash sibRoot pRoot + +------------------------------------------------------------------------------- +-- Hashing +------------------------------------------------------------------------------- + +-- | Compute SHA-256 hash of a bytestring. +-- Maximum input size is (2^{64}-1)/8 bytes. +-- +-- > Output size : 256 +-- > Internal state size : 1600 +-- > Block size : 1088 +-- > Length size : n/a +-- > Word size : 64 +-- > Rounds : 24 +sha256 :: ByteString -> ByteString +sha256 x = B.convertToBase B.Base16 (hash x :: Digest SHA3_256) + +-- | Hash function to use for merkle tree +merkleHash :: ByteString -> ByteString +merkleHash = sha256 + +------------------------------------------------------------------------------- +-- Testing +------------------------------------------------------------------------------- + +-- | Constructs a merkle tree and random leaf root to test inclusion of +testMerkleProofN :: Int -> IO Bool +testMerkleProofN n + | n < 2 = panic "Cannot construct a merkle tree with < 2 nodes" + | otherwise = do + randN <- randomRIO (1,n) :: IO Int + let mtree = mkMerkleTree $ map show [1..n] + randLeaf = mkLeafRootHash $ show randN + proof = merkleProof mtree randLeaf + return $ validateMerkleProof proof (mtRoot mtree) randLeaf diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,26 @@ +module Main where + +import Protolude + +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.QuickCheck.Monadic + +import qualified Data.ByteString as BS + +import Crypto.Hash.MerkleTree + +newtype MerkleTest = MerkleTest Int + deriving (Show) + +instance Arbitrary MerkleTest where + arbitrary = MerkleTest <$> choose (100,10000) + +main :: IO () +main = defaultMain merkleTests + +merkleTests :: TestTree +merkleTests = testGroup "Merkle Tree & Proof tests" + [ testProperty "Random Tree/Proof construction and validation:" $ \(MerkleTest n) -> + monadicIO $ assert =<< liftIO (testMerkleProofN n) + ]