From d445ba33243c3ca5a2a672ac6337122391fcd494 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Wed, 23 Oct 2024 15:49:24 -0500 Subject: [PATCH 1/7] feat: draft commitment tree tracker --- src/Zenith/Tree.hs | 44 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 44 insertions(+) create mode 100644 src/Zenith/Tree.hs diff --git a/src/Zenith/Tree.hs b/src/Zenith/Tree.hs new file mode 100644 index 0000000..a2e1ec9 --- /dev/null +++ b/src/Zenith/Tree.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Zenith.Tree where + +import Data.HexString + +class Monoid v => + Measured a v + where + measure :: a -> v + +data Tree v a + = Leaf !v !a + | Branch !v !(Tree v a) !(Tree v a) + +value :: Tree v a -> v +value (Leaf v _) = v +value (Branch v _ _) = v + +branch :: Monoid v => Tree v a -> Tree v a -> Tree v a +branch x y = Branch (value x <> value y) x y + +leaf :: Measured a v => a -> Tree v a +leaf a = Leaf (measure a) a + +data OrchardNode = OrchardNode + { on_position :: !Integer + , on_value :: !String + , on_level :: !Int + } deriving (Show, Eq) + +instance Semigroup OrchardNode where + (<>) x y = + if on_level x == on_level y + then OrchardNode + (max (on_position x) (on_position y)) + (on_value x <> on_value y) + (on_level x) + else x + +instance Monoid OrchardNode where + mempty = OrchardNode 0 "" (-1) + mappend = (<>) From 70ef4d85f42c518cbbae2735c452fd6d13f878f8 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Wed, 23 Oct 2024 15:51:30 -0500 Subject: [PATCH 2/7] feat: update cabal --- zenith.cabal | 2 ++ 1 file changed, 2 insertions(+) diff --git a/zenith.cabal b/zenith.cabal index c6de5c3..12118bc 100644 --- a/zenith.cabal +++ b/zenith.cabal @@ -36,6 +36,7 @@ library Zenith.Zcashd Zenith.Scanner Zenith.RPC + Zenith.Tree hs-source-dirs: src build-depends: @@ -143,6 +144,7 @@ test-suite zenith-tests , bytestring , configurator , monad-logger + , aeson , data-default , sort , text From b0ca5b7d4b88f63071d026fd4c38a491c606e7eb Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Fri, 25 Oct 2024 09:09:21 -0500 Subject: [PATCH 3/7] feat: structure for a balanced monoidal tree --- src/Zenith/Tree.hs | 92 +++++++++++++++++++++++++++++++++++++--------- test/Spec.hs | 27 ++++++++++++++ 2 files changed, 101 insertions(+), 18 deletions(-) diff --git a/src/Zenith/Tree.hs b/src/Zenith/Tree.hs index a2e1ec9..09dd323 100644 --- a/src/Zenith/Tree.hs +++ b/src/Zenith/Tree.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} module Zenith.Tree where @@ -8,37 +9,92 @@ import Data.HexString class Monoid v => Measured a v where - measure :: a -> v + measure :: a -> Integer -> v -data Tree v a - = Leaf !v !a - | Branch !v !(Tree v a) !(Tree v a) +class Node v where + getLevel :: v -> Level + getTag :: v -> String + getPosition :: v -> Integer + isFull :: v -> Bool -value :: Tree v a -> v -value (Leaf v _) = v +type Level = Int + +type OrchardCommitment = String + +instance Measured [Char] OrchardNode where + measure oc p = OrchardNode p oc 0 True + +data Tree v + = Leaf !v + | Branch !v !(Tree v) !(Tree v) + | EmptyLeaf + deriving (Eq) + +instance (Node v, Show v) => Show (Tree v) where + show EmptyLeaf = "()" + show (Leaf v) = "(" ++ show v ++ ")" + show (Branch s x y) = "<" ++ getTag s ++ ">\n" ++ show x ++ "\n" ++ show y + +instance (Monoid v, Node v) => Semigroup (Tree v) where + (<>) EmptyLeaf x = x + (<>) (Leaf x) EmptyLeaf = branch (Leaf x) EmptyLeaf + (<>) (Leaf x) (Leaf y) = branch (Leaf x) (Leaf y) + (<>) (Leaf x) Branch {} = Leaf x + (<>) (Branch s x y) EmptyLeaf = branch (Branch s x y) EmptyLeaf + (<>) (Branch s x y) (Leaf w) + | isFull s = Branch s x y <> mkSubTree (getLevel s) (Leaf w) + | isFull (value x) = branch x (y <> Leaf w) + | otherwise = branch (x <> Leaf w) y + (<>) (Branch s x y) (Branch s1 x1 y1) + | getLevel s == getLevel s1 = branch (Branch s x y) (Branch s1 x1 y1) + | otherwise = Branch s x y + +value :: Monoid v => Tree v -> v +value EmptyLeaf = mempty +value (Leaf v) = v value (Branch v _ _) = v -branch :: Monoid v => Tree v a -> Tree v a -> Tree v a +branch :: Monoid v => Tree v -> Tree v -> Tree v branch x y = Branch (value x <> value y) x y -leaf :: Measured a v => a -> Tree v a -leaf a = Leaf (measure a) a +leaf :: Measured a v => a -> Integer -> Tree v +leaf a p = Leaf (measure a p) data OrchardNode = OrchardNode { on_position :: !Integer , on_value :: !String - , on_level :: !Int - } deriving (Show, Eq) + , on_level :: !Level + , on_full :: !Bool + } deriving (Eq) instance Semigroup OrchardNode where (<>) x y = - if on_level x == on_level y - then OrchardNode - (max (on_position x) (on_position y)) - (on_value x <> on_value y) - (on_level x) - else x + OrchardNode + (max (on_position x) (on_position y)) + (on_value x <> on_value y) + (1 + on_level x) + (on_full x && on_full y) instance Monoid OrchardNode where - mempty = OrchardNode 0 "" (-1) + mempty = OrchardNode 0 "" 0 False mappend = (<>) + +instance Node OrchardNode where + getLevel = on_level + getTag = on_value + getPosition = on_position + isFull = on_full + +instance Show OrchardNode where + show = on_value + +instance Measured OrchardNode OrchardNode where + measure o p = OrchardNode p (on_value o) (on_level o) (on_full o) + +mkSubTree :: Node v => Monoid v => Level -> Tree v -> Tree v +mkSubTree level t = + if getLevel (value subtree) == level + then subtree + else mkSubTree level subtree + where + subtree = t <> EmptyLeaf diff --git a/test/Spec.hs b/test/Spec.hs index 5d548b4..e5f0351 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -39,6 +39,7 @@ import ZcashHaskell.Types import ZcashHaskell.Utils (readZebraTransaction) import Zenith.Core import Zenith.DB +import Zenith.Tree import Zenith.Types main :: IO () @@ -581,3 +582,29 @@ main = do case tx of Left e -> assertFailure $ show e Right h -> h `shouldNotBe` (hexString "deadbeef") + describe "Tree tests" $ do + it "Create leaf" $ do + let a = "a" :: OrchardCommitment + let n = append EmptyLeaf a :: Tree OrchardNode + getLevel (value n) `shouldBe` 0 + it "Create minimal tree" $ do + let a = "a" :: OrchardCommitment + let b = "b" :: OrchardCommitment + let n = append EmptyLeaf a :: Tree OrchardNode + let t = append n b :: Tree OrchardNode + getLevel (value t) `shouldBe` 1 + it "Create bigger tree" $ do + let a = "a" :: OrchardCommitment + let b = "b" :: OrchardCommitment + let c = "c" :: OrchardCommitment + let d = "d" :: OrchardCommitment + let n = append EmptyLeaf a :: Tree OrchardNode + let t1 = append n b :: Tree OrchardNode + let t2 = append t1 c :: Tree OrchardNode + {- + -let t3 = append t2 d :: Tree OrchardNode + -} + {- + -getLevel (value t2) `shouldBe` 2 + -} + t2 `shouldBe` EmptyLeaf From 13b55ad266532f2e08cdac2348ef6a3c76e52121 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Tue, 29 Oct 2024 07:01:13 -0500 Subject: [PATCH 4/7] feat: add function to fill tree to depth --- src/Zenith/Tree.hs | 105 +++++++++++++++++++++++++++++++++++---------- test/Spec.hs | 72 +++++++++++++++++++++---------- zcash-haskell | 2 +- 3 files changed, 134 insertions(+), 45 deletions(-) diff --git a/src/Zenith/Tree.hs b/src/Zenith/Tree.hs index 09dd323..7258c79 100644 --- a/src/Zenith/Tree.hs +++ b/src/Zenith/Tree.hs @@ -5,42 +5,68 @@ module Zenith.Tree where import Data.HexString +import Data.Int (Int64) +import ZcashHaskell.Orchard (combineOrchardNodes, getOrchardNodeValue) +import ZcashHaskell.Types (OrchardFrontier(..)) + +type Level = Integer + +maxLevel :: Level +maxLevel = 32 + +type Position = Int64 class Monoid v => Measured a v where - measure :: a -> Integer -> v + measure :: a -> Position -> v class Node v where getLevel :: v -> Level - getTag :: v -> String - getPosition :: v -> Integer + getTag :: v -> HexString + getPosition :: v -> Position isFull :: v -> Bool + mkNode :: Level -> Position -> HexString -> v -type Level = Int +type OrchardCommitment = HexString -type OrchardCommitment = String - -instance Measured [Char] OrchardNode where - measure oc p = OrchardNode p oc 0 True +instance Measured OrchardCommitment OrchardNode where + measure oc p = + case getOrchardNodeValue (hexBytes oc) of + Nothing -> OrchardNode 0 (hexString "00") 0 True + Just val -> OrchardNode p val 0 True data Tree v - = Leaf !v + = EmptyLeaf + | Leaf !v + | PrunedBranch !v | Branch !v !(Tree v) !(Tree v) - | EmptyLeaf deriving (Eq) instance (Node v, Show v) => Show (Tree v) where show EmptyLeaf = "()" show (Leaf v) = "(" ++ show v ++ ")" - show (Branch s x y) = "<" ++ getTag s ++ ">\n" ++ show x ++ "\n" ++ show y + show (PrunedBranch v) = "{" ++ show v ++ "}" + show (Branch s x y) = + "<" ++ show (getTag s) ++ ">\n" ++ show x ++ "\n" ++ show y instance (Monoid v, Node v) => Semigroup (Tree v) where + (<>) EmptyLeaf EmptyLeaf = PrunedBranch $ value $ branch EmptyLeaf EmptyLeaf (<>) EmptyLeaf x = x (<>) (Leaf x) EmptyLeaf = branch (Leaf x) EmptyLeaf (<>) (Leaf x) (Leaf y) = branch (Leaf x) (Leaf y) (<>) (Leaf x) Branch {} = Leaf x - (<>) (Branch s x y) EmptyLeaf = branch (Branch s x y) EmptyLeaf + (<>) (Leaf x) (PrunedBranch _) = Leaf x + (<>) (PrunedBranch x) EmptyLeaf = PrunedBranch $ x <> x + (<>) (PrunedBranch x) (Leaf _) = PrunedBranch x + (<>) (PrunedBranch x) (Branch s t u) = + if getLevel x == getLevel s + then branch (PrunedBranch x) (Branch s t u) + else EmptyLeaf + (<>) (PrunedBranch x) (PrunedBranch y) = PrunedBranch $ x <> y + (<>) (Branch s x y) EmptyLeaf = + branch (Branch s x y) $ getEmptyRoot (getLevel s) + (<>) (Branch s x y) (PrunedBranch _) = Branch s x y (<>) (Branch s x y) (Leaf w) | isFull s = Branch s x y <> mkSubTree (getLevel s) (Leaf w) | isFull (value x) = branch x (y <> Leaf w) @@ -52,31 +78,47 @@ instance (Monoid v, Node v) => Semigroup (Tree v) where value :: Monoid v => Tree v -> v value EmptyLeaf = mempty value (Leaf v) = v +value (PrunedBranch v) = v value (Branch v _ _) = v branch :: Monoid v => Tree v -> Tree v -> Tree v branch x y = Branch (value x <> value y) x y -leaf :: Measured a v => a -> Integer -> Tree v +leaf :: Measured a v => a -> Int64 -> Tree v leaf a p = Leaf (measure a p) +prunedBranch :: Monoid v => Node v => Level -> Position -> HexString -> Tree v +prunedBranch level pos val = PrunedBranch $ mkNode level pos val + +root :: Monoid v => Node v => Tree v -> Tree v +root tree = + if getLevel (value tree) == maxLevel - 1 + then tree + else mkSubTree (maxLevel - 1) tree + +getEmptyRoot :: Monoid v => Node v => Level -> Tree v +getEmptyRoot level = iterate (\x -> x <> x) EmptyLeaf !! fromIntegral level + data OrchardNode = OrchardNode - { on_position :: !Integer - , on_value :: !String + { on_position :: !Position + , on_value :: !HexString , on_level :: !Level , on_full :: !Bool } deriving (Eq) instance Semigroup OrchardNode where (<>) x y = - OrchardNode - (max (on_position x) (on_position y)) - (on_value x <> on_value y) - (1 + on_level x) - (on_full x && on_full y) + case combineOrchardNodes (on_level x) (on_value x) (on_value y) of + Nothing -> x + Just newHash -> + OrchardNode + (max (on_position x) (on_position y)) + newHash + (1 + on_level x) + (on_full x && on_full y) instance Monoid OrchardNode where - mempty = OrchardNode 0 "" 0 False + mempty = OrchardNode 0 (hexString "00") 0 False mappend = (<>) instance Node OrchardNode where @@ -84,9 +126,10 @@ instance Node OrchardNode where getTag = on_value getPosition = on_position isFull = on_full + mkNode l p v = OrchardNode p v l True instance Show OrchardNode where - show = on_value + show = show . on_value instance Measured OrchardNode OrchardNode where measure o p = OrchardNode p (on_value o) (on_level o) (on_full o) @@ -98,3 +141,21 @@ mkSubTree level t = else mkSubTree level subtree where subtree = t <> EmptyLeaf + +mkOrchardTree :: OrchardFrontier -> Tree OrchardNode +mkOrchardTree (OrchardFrontier p l o) = + if odd p + then addOrchardOmmers (tail o) $ + Leaf (OrchardNode (p - 1) (head o) 0 True) <> + Leaf (OrchardNode p l 0 True) + else addOrchardOmmers o $ Leaf (OrchardNode p l 0 True) <> EmptyLeaf + +addOrchardOmmers :: [HexString] -> Tree OrchardNode -> Tree OrchardNode +addOrchardOmmers xs t = + foldl + (\s x -> PrunedBranch (mkNode (getLevel $ value s) (p (value s)) x) <> s) + t + xs + where + p :: OrchardNode -> Position + p (OrchardNode pos _ l _) = pos - (2 ^ l) diff --git a/test/Spec.hs b/test/Spec.hs index e5f0351..3a955f6 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -10,7 +10,12 @@ import Database.Persist.Sqlite import System.Directory import Test.HUnit import Test.Hspec -import ZcashHaskell.Orchard (isValidUnifiedAddress, parseAddress) +import ZcashHaskell.Orchard + ( getOrchardFrontier + , getOrchardTreeAnchor + , isValidUnifiedAddress + , parseAddress + ) import ZcashHaskell.Sapling ( decodeSaplingOutputEsk , encodeSaplingAddress @@ -25,6 +30,8 @@ import ZcashHaskell.Transparent ) import ZcashHaskell.Types ( DecodedNote(..) + , OrchardCommitmentTree(..) + , OrchardFrontier(..) , OrchardSpendingKey(..) , Phrase(..) , SaplingCommitmentTree(..) @@ -583,28 +590,49 @@ main = do Left e -> assertFailure $ show e Right h -> h `shouldNotBe` (hexString "deadbeef") describe "Tree tests" $ do + let cmx1 = + hexString + "1712ead46028d4349e234abf59e94e0640fe7a0829e2e2e17e1a931631810400" + let t0 = EmptyLeaf <> EmptyLeaf :: Tree OrchardNode + let t1 = t0 <> EmptyLeaf :: Tree OrchardNode + let t1a = t0 <> t0 it "Create leaf" $ do - let a = "a" :: OrchardCommitment - let n = append EmptyLeaf a :: Tree OrchardNode + let n = leaf cmx1 1 :: Tree OrchardNode getLevel (value n) `shouldBe` 0 it "Create minimal tree" $ do - let a = "a" :: OrchardCommitment - let b = "b" :: OrchardCommitment - let n = append EmptyLeaf a :: Tree OrchardNode - let t = append n b :: Tree OrchardNode + let t = (leaf cmx1 1) <> EmptyLeaf :: Tree OrchardNode getLevel (value t) `shouldBe` 1 - it "Create bigger tree" $ do - let a = "a" :: OrchardCommitment - let b = "b" :: OrchardCommitment - let c = "c" :: OrchardCommitment - let d = "d" :: OrchardCommitment - let n = append EmptyLeaf a :: Tree OrchardNode - let t1 = append n b :: Tree OrchardNode - let t2 = append t1 c :: Tree OrchardNode - {- - -let t3 = append t2 d :: Tree OrchardNode - -} - {- - -getLevel (value t2) `shouldBe` 2 - -} - t2 `shouldBe` EmptyLeaf + it "Create minimal empty tree" $ do + getTag (value t0) `shouldNotBe` hexString "00" + it "Expand empty tree" $ do t1 `shouldBe` t1a + it "Create empty tree" $ mkSubTree 2 EmptyLeaf `shouldBe` t1 + it "Create empty tree non-rec" $ getEmptyRoot 2 `shouldBe` t1 + it "Create a tree from Frontier" $ do + let tree = + OrchardCommitmentTree $ + hexString + "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" + case getOrchardFrontier tree of + Nothing -> assertFailure "Failed to get frontier" + Just t1 -> do + of_ommers t1 `shouldBe` [] + it "Validate a tree's depth from Frontier" $ do + let tree = + OrchardCommitmentTree $ + hexString + "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" + case getOrchardFrontier tree of + Nothing -> assertFailure "Failed to get frontier" + Just t1 -> do + let t = root $ mkOrchardTree t1 + getLevel (value t) `shouldBe` 31 + it "Validate a tree from Frontier" $ do + let tree = + OrchardCommitmentTree $ + hexString + "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" + case getOrchardFrontier tree of + Nothing -> assertFailure "Failed to get frontier" + Just t1 -> do + let t = root $ mkOrchardTree t1 + getTag (value t) `shouldBe` getOrchardTreeAnchor t1 diff --git a/zcash-haskell b/zcash-haskell index 662a0d1..b6d490d 160000 --- a/zcash-haskell +++ b/zcash-haskell @@ -1 +1 @@ -Subproject commit 662a0d1148d3f52e2683157a4c9280bb8e81b0cb +Subproject commit b6d490d05300a9db9cdf9929baa9b984bee9f3f6 From 1898770bf566191c5a894419683f87f4d40faa35 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Mon, 4 Nov 2024 10:17:54 -0600 Subject: [PATCH 5/7] feat: implement Borsh serialization --- src/Zenith/Tree.hs | 192 +++++++++++++++++++++++++++++---------------- test/Spec.hs | 120 ++++++++++++++++++++++++---- zcash-haskell | 2 +- zenith.cabal | 3 + 4 files changed, 231 insertions(+), 86 deletions(-) diff --git a/src/Zenith/Tree.hs b/src/Zenith/Tree.hs index 7258c79..cc8fe7b 100644 --- a/src/Zenith/Tree.hs +++ b/src/Zenith/Tree.hs @@ -1,15 +1,23 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE UndecidableInstances #-} module Zenith.Tree where +import Codec.Borsh import Data.HexString -import Data.Int (Int64) +import Data.Int (Int64, Int8) +import Data.Maybe (fromJust, isNothing) +import qualified GHC.Generics as GHC +import qualified Generics.SOP as SOP import ZcashHaskell.Orchard (combineOrchardNodes, getOrchardNodeValue) -import ZcashHaskell.Types (OrchardFrontier(..)) +import ZcashHaskell.Types (MerklePath(..), OrchardFrontier(..), OrchardTree(..)) -type Level = Integer +type Level = Int8 maxLevel :: Level maxLevel = 32 @@ -19,29 +27,33 @@ type Position = Int64 class Monoid v => Measured a v where - measure :: a -> Position -> v + measure :: a -> Position -> Int64 -> v class Node v where getLevel :: v -> Level getTag :: v -> HexString getPosition :: v -> Position isFull :: v -> Bool + isMarked :: v -> Bool mkNode :: Level -> Position -> HexString -> v type OrchardCommitment = HexString instance Measured OrchardCommitment OrchardNode where - measure oc p = + measure oc p i = case getOrchardNodeValue (hexBytes oc) of - Nothing -> OrchardNode 0 (hexString "00") 0 True - Just val -> OrchardNode p val 0 True + Nothing -> OrchardNode 0 (hexString "00") 0 True 0 False + Just val -> OrchardNode p val 0 True i False data Tree v = EmptyLeaf | Leaf !v | PrunedBranch !v | Branch !v !(Tree v) !(Tree v) - deriving (Eq) + | InvalidTree + deriving stock (Eq, GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + deriving (BorshSize, ToBorsh, FromBorsh) via AsEnum (Tree v) instance (Node v, Show v) => Show (Tree v) where show EmptyLeaf = "()" @@ -49,90 +61,69 @@ instance (Node v, Show v) => Show (Tree v) where show (PrunedBranch v) = "{" ++ show v ++ "}" show (Branch s x y) = "<" ++ show (getTag s) ++ ">\n" ++ show x ++ "\n" ++ show y + show InvalidTree = "InvalidTree" instance (Monoid v, Node v) => Semigroup (Tree v) where + (<>) InvalidTree _ = InvalidTree + (<>) _ InvalidTree = InvalidTree (<>) EmptyLeaf EmptyLeaf = PrunedBranch $ value $ branch EmptyLeaf EmptyLeaf (<>) EmptyLeaf x = x (<>) (Leaf x) EmptyLeaf = branch (Leaf x) EmptyLeaf (<>) (Leaf x) (Leaf y) = branch (Leaf x) (Leaf y) - (<>) (Leaf x) Branch {} = Leaf x - (<>) (Leaf x) (PrunedBranch _) = Leaf x + (<>) (Leaf _) Branch {} = InvalidTree + (<>) (Leaf _) (PrunedBranch _) = InvalidTree (<>) (PrunedBranch x) EmptyLeaf = PrunedBranch $ x <> x - (<>) (PrunedBranch x) (Leaf _) = PrunedBranch x + (<>) (PrunedBranch x) (Leaf y) = + if isFull x + then InvalidTree + else mkSubTree (getLevel x) (Leaf y) (<>) (PrunedBranch x) (Branch s t u) = if getLevel x == getLevel s then branch (PrunedBranch x) (Branch s t u) - else EmptyLeaf + else InvalidTree (<>) (PrunedBranch x) (PrunedBranch y) = PrunedBranch $ x <> y (<>) (Branch s x y) EmptyLeaf = branch (Branch s x y) $ getEmptyRoot (getLevel s) - (<>) (Branch s x y) (PrunedBranch _) = Branch s x y + (<>) (Branch s x y) (PrunedBranch w) + | getLevel s == getLevel w = branch (Branch s x y) (PrunedBranch w) + | otherwise = InvalidTree (<>) (Branch s x y) (Leaf w) | isFull s = Branch s x y <> mkSubTree (getLevel s) (Leaf w) | isFull (value x) = branch x (y <> Leaf w) | otherwise = branch (x <> Leaf w) y (<>) (Branch s x y) (Branch s1 x1 y1) | getLevel s == getLevel s1 = branch (Branch s x y) (Branch s1 x1 y1) - | otherwise = Branch s x y + | otherwise = InvalidTree value :: Monoid v => Tree v -> v value EmptyLeaf = mempty value (Leaf v) = v value (PrunedBranch v) = v value (Branch v _ _) = v +value InvalidTree = mempty branch :: Monoid v => Tree v -> Tree v -> Tree v branch x y = Branch (value x <> value y) x y -leaf :: Measured a v => a -> Int64 -> Tree v -leaf a p = Leaf (measure a p) +leaf :: Measured a v => a -> Int64 -> Int64 -> Tree v +leaf a p i = Leaf (measure a p i) prunedBranch :: Monoid v => Node v => Level -> Position -> HexString -> Tree v prunedBranch level pos val = PrunedBranch $ mkNode level pos val root :: Monoid v => Node v => Tree v -> Tree v root tree = - if getLevel (value tree) == maxLevel - 1 + if getLevel (value tree) == maxLevel then tree - else mkSubTree (maxLevel - 1) tree + else mkSubTree maxLevel tree getEmptyRoot :: Monoid v => Node v => Level -> Tree v getEmptyRoot level = iterate (\x -> x <> x) EmptyLeaf !! fromIntegral level -data OrchardNode = OrchardNode - { on_position :: !Position - , on_value :: !HexString - , on_level :: !Level - , on_full :: !Bool - } deriving (Eq) - -instance Semigroup OrchardNode where - (<>) x y = - case combineOrchardNodes (on_level x) (on_value x) (on_value y) of - Nothing -> x - Just newHash -> - OrchardNode - (max (on_position x) (on_position y)) - newHash - (1 + on_level x) - (on_full x && on_full y) - -instance Monoid OrchardNode where - mempty = OrchardNode 0 (hexString "00") 0 False - mappend = (<>) - -instance Node OrchardNode where - getLevel = on_level - getTag = on_value - getPosition = on_position - isFull = on_full - mkNode l p v = OrchardNode p v l True - -instance Show OrchardNode where - show = show . on_value - -instance Measured OrchardNode OrchardNode where - measure o p = OrchardNode p (on_value o) (on_level o) (on_full o) +append :: Monoid v => Measured a v => Node v => Tree v -> a -> Int64 -> Tree v +append tree n i = tree <> leaf n p i + where + p = 1 + getPosition (value tree) mkSubTree :: Node v => Monoid v => Level -> Tree v -> Tree v mkSubTree level t = @@ -142,20 +133,85 @@ mkSubTree level t = where subtree = t <> EmptyLeaf -mkOrchardTree :: OrchardFrontier -> Tree OrchardNode -mkOrchardTree (OrchardFrontier p l o) = - if odd p - then addOrchardOmmers (tail o) $ - Leaf (OrchardNode (p - 1) (head o) 0 True) <> - Leaf (OrchardNode p l 0 True) - else addOrchardOmmers o $ Leaf (OrchardNode p l 0 True) <> EmptyLeaf - -addOrchardOmmers :: [HexString] -> Tree OrchardNode -> Tree OrchardNode -addOrchardOmmers xs t = - foldl - (\s x -> PrunedBranch (mkNode (getLevel $ value s) (p (value s)) x) <> s) - t - xs +path :: Position -> Tree v -> Maybe MerklePath +path pos (Branch s x y) = undefined where - p :: OrchardNode -> Position - p (OrchardNode pos _ l _) = pos - (2 ^ l) + collectPath t = undefined + +data OrchardNode = OrchardNode + { on_position :: !Position + , on_value :: !HexString + , on_level :: !Level + , on_full :: !Bool + , on_index :: !Int64 + , on_mark :: !Bool + } deriving stock (Eq, GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + deriving (BorshSize, ToBorsh, FromBorsh) via AsStruct OrchardNode + +instance Semigroup OrchardNode where + (<>) x y = + case combineOrchardNodes + (fromIntegral $ on_level x) + (on_value x) + (on_value y) of + Nothing -> x + Just newHash -> + OrchardNode + (max (on_position x) (on_position y)) + newHash + (1 + on_level x) + (on_full x && on_full y) + (max (on_index x) (on_index y)) + (on_mark x || on_mark y) + +instance Monoid OrchardNode where + mempty = OrchardNode 0 (hexString "00") 0 False 0 False + mappend = (<>) + +instance Node OrchardNode where + getLevel = on_level + getTag = on_value + getPosition = on_position + isFull = on_full + isMarked = on_mark + mkNode l p v = OrchardNode p v l True 0 False + +instance Show OrchardNode where + show = show . on_value + +instance Measured OrchardNode OrchardNode where + measure o p i = + OrchardNode p (on_value o) (on_level o) (on_full o) i (on_mark o) + +orchardSize :: OrchardTree -> Int64 +orchardSize tree = + (if isNothing (ot_left tree) + then 0 + else 1) + + (if isNothing (ot_right tree) + then 0 + else 1) + + foldl + (\x (i, p) -> + case p of + Nothing -> x + 0 + Just _ -> x + 2 ^ i) + 0 + (zip [1 ..] $ ot_parents tree) + +mkOrchardTree :: OrchardTree -> Tree OrchardNode +mkOrchardTree tree = + foldl + (\t (i, n) -> + case n of + Just n' -> prunedBranch i 0 n' <> t + Nothing -> t <> getEmptyRoot i) + leafRoot + (zip [1 ..] $ ot_parents tree) + where + leafRoot = + case ot_right tree of + Just r' -> leaf (fromJust $ ot_left tree) (pos - 1) 0 <> leaf r' pos 0 + Nothing -> leaf (fromJust $ ot_left tree) pos 0 <> EmptyLeaf + pos = orchardSize tree - 1 diff --git a/test/Spec.hs b/test/Spec.hs index 794e983..d063add 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,8 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} +import Codec.Borsh import Control.Monad (when) import Control.Monad.Logger (runFileLoggingT, runNoLoggingT) import Data.Aeson +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS import Data.HexString import Data.Maybe (fromJust) import qualified Data.Text.Encoding as E @@ -12,8 +15,12 @@ import System.Directory import Test.HUnit import Test.Hspec import ZcashHaskell.Orchard - ( getOrchardFrontier + ( addOrchardNodeGetRoot + , getOrchardFrontier + , getOrchardNodeValue + , getOrchardRootTest , getOrchardTreeAnchor + , getOrchardTreeParts , isValidUnifiedAddress , parseAddress ) @@ -34,6 +41,7 @@ import ZcashHaskell.Types , OrchardCommitmentTree(..) , OrchardFrontier(..) , OrchardSpendingKey(..) + , OrchardTree(..) , Phrase(..) , SaplingCommitmentTree(..) , SaplingReceiver(..) @@ -216,49 +224,127 @@ main = do let cmx1 = hexString "1712ead46028d4349e234abf59e94e0640fe7a0829e2e2e17e1a931631810400" + let cmx2 = + hexString + "39f5ad39817fb432fa07c5feb3a957189fbe7662a4b5555ca95093b6d853cf07" let t0 = EmptyLeaf <> EmptyLeaf :: Tree OrchardNode let t1 = t0 <> EmptyLeaf :: Tree OrchardNode let t1a = t0 <> t0 it "Create leaf" $ do - let n = leaf cmx1 1 :: Tree OrchardNode + let n = leaf cmx1 0 0 :: Tree OrchardNode getLevel (value n) `shouldBe` 0 it "Create minimal tree" $ do - let t = (leaf cmx1 1) <> EmptyLeaf :: Tree OrchardNode + let t = leaf cmx1 0 0 <> EmptyLeaf :: Tree OrchardNode getLevel (value t) `shouldBe` 1 it "Create minimal empty tree" $ do getTag (value t0) `shouldNotBe` hexString "00" it "Expand empty tree" $ do t1 `shouldBe` t1a - it "Create empty tree" $ mkSubTree 2 EmptyLeaf `shouldBe` t1 it "Create empty tree non-rec" $ getEmptyRoot 2 `shouldBe` t1 - it "Create a tree from Frontier" $ do + it "Validate empty tree" $ do + getTag (value (getEmptyRoot 32 :: Tree OrchardNode)) `shouldBe` + getOrchardRootTest 32 + it "Validate tree with one leaf" $ do + let n = leaf cmx1 0 1 :: Tree OrchardNode + let n1 = root n + getTag (value n1) `shouldBe` addOrchardNodeGetRoot 32 (hexBytes cmx1) + it "Validate size of tree from Zebra" $ do let tree = OrchardCommitmentTree $ hexString "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" - case getOrchardFrontier tree of - Nothing -> assertFailure "Failed to get frontier" + case getOrchardTreeParts tree of + Nothing -> assertFailure "Failed to get parts" Just t1 -> do - of_ommers t1 `shouldBe` [] - it "Validate a tree's depth from Frontier" $ do + case getOrchardFrontier tree of + Nothing -> assertFailure "Failed to get frontier" + Just f1 -> do + orchardSize t1 `shouldBe` 1 + fromIntegral (of_pos f1) + it "Deserialize commitment tree from Zebra" $ do let tree = OrchardCommitmentTree $ hexString "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" - case getOrchardFrontier tree of + case getOrchardTreeParts tree of Nothing -> assertFailure "Failed to get frontier" Just t1 -> do - let t = root $ mkOrchardTree t1 - getLevel (value t) `shouldBe` 31 - it "Validate a tree from Frontier" $ do + length (ot_parents t1) `shouldBe` 31 + it "Create commitment tree from Zebra" $ do let tree = OrchardCommitmentTree $ hexString "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" - case getOrchardFrontier tree of - Nothing -> assertFailure "Failed to get frontier" + case getOrchardTreeParts tree of + Nothing -> assertFailure "Failed to get tree parts" Just t1 -> do - let t = root $ mkOrchardTree t1 - getTag (value t) `shouldBe` getOrchardTreeAnchor t1 + let newTree = mkOrchardTree t1 + getLevel (value newTree) `shouldBe` 32 + it "Validate commitment tree from Zebra" $ do + let tree = + OrchardCommitmentTree $ + hexString + "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" + case getOrchardTreeParts tree of + Nothing -> assertFailure "Failed to get tree parts" + Just t1 -> do + let newTree = mkOrchardTree t1 + let ctAnchor = getOrchardTreeAnchor tree + {- + -getTag (value newTree) `shouldBe` ctAnchor + -isFull (value newTree) `shouldBe` False + -} + getPosition (value newTree) `shouldBe` 39733 + it "Validate appending nodes to tree" $ do + let tree = + OrchardCommitmentTree $ + hexString + "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" + let cmx1 = + hexString + "1712ead46028d4349e234abf59e94e0640fe7a0829e2e2e17e1a931631810400" :: OrchardCommitment + let cmx2 = + hexString + "39f5ad39817fb432fa07c5feb3a957189fbe7662a4b5555ca95093b6d853cf07" :: OrchardCommitment + let cmx3 = + hexString + "84f7fbc4b9f87215c653078d7fdd90756c3ba370c745065167da9eb73a65a83f" :: OrchardCommitment + let cmx4 = + hexString + "e55ad64e1ea2b261893fdea6ad0509b66e5f62d3142f351298c7135c4498d429" :: OrchardCommitment + let finalTree = + OrchardCommitmentTree $ + hexString + "0184f7fbc4b9f87215c653078d7fdd90756c3ba370c745065167da9eb73a65a83f01e55ad64e1ea2b261893fdea6ad0509b66e5f62d3142f351298c7135c4498d4291f0000014b1a76d3820087b26cd087ca84e17f3067a25ebed82ad23a93fa485affb5530b01ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" + case getOrchardTreeParts tree of + Nothing -> assertFailure "Failed to get tree parts" + Just t1 -> do + let newTree = mkOrchardTree t1 + let updatedTree1 = append newTree cmx1 4 + let updatedTree2 = append updatedTree1 cmx2 5 + let updatedTree3 = append updatedTree2 cmx3 6 + let updatedTree4 = append updatedTree3 cmx4 7 + let finalAnchor = getOrchardTreeAnchor finalTree + getTag (value updatedTree4) `shouldBe` finalAnchor + it "Validate serializing tree to bytes" $ do + let tree = + OrchardCommitmentTree $ + hexString + "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" + case mkOrchardTree <$> getOrchardTreeParts tree of + Nothing -> assertFailure "Failed to build tree" + Just t1 -> do + let treeBytes = serialiseBorsh t1 + LBS.length treeBytes `shouldNotBe` 0 + it "Validate deserializing tree from bytes" $ do + let tree = + OrchardCommitmentTree $ + hexString + "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" + case mkOrchardTree <$> getOrchardTreeParts tree of + Nothing -> assertFailure "Failed to build tree" + Just t1 -> do + let treeBytes = serialiseBorsh t1 + let rebuiltTree = deserialiseBorsh treeBytes + rebuiltTree `shouldBe` Right t1 describe "Creating Tx" $ do describe "Full" $ do it "To Orchard" $ do diff --git a/zcash-haskell b/zcash-haskell index f6b8a77..7092764 160000 --- a/zcash-haskell +++ b/zcash-haskell @@ -1 +1 @@ -Subproject commit f6b8a772770f492221dc99281016d7090f981e63 +Subproject commit 70927645e774d53dd04650d68d996670033a8ef1 diff --git a/zenith.cabal b/zenith.cabal index 2f32e51..c97e222 100644 --- a/zenith.cabal +++ b/zenith.cabal @@ -50,6 +50,7 @@ library , base >=4.12 && <5 , base64-bytestring , binary + , borsh , brick , bytestring , configurator @@ -59,6 +60,7 @@ library , exceptions , filepath , ghc + , generics-sop , haskoin-core , hexstring , http-client @@ -145,6 +147,7 @@ test-suite zenith-tests , aeson , configurator , monad-logger + , borsh , aeson , data-default , sort From a7cf3a75c66b9f14562c65be939daa0c3f4b7a48 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Mon, 4 Nov 2024 18:56:16 -0600 Subject: [PATCH 6/7] feat: implement merkle path calculator --- src/Zenith/Tree.hs | 37 ++++++++++++++++++--------- test/Spec.hs | 62 ++++++++++++++++++++++++++++++++++++++-------- 2 files changed, 77 insertions(+), 22 deletions(-) diff --git a/src/Zenith/Tree.hs b/src/Zenith/Tree.hs index cc8fe7b..e4b5802 100644 --- a/src/Zenith/Tree.hs +++ b/src/Zenith/Tree.hs @@ -10,7 +10,7 @@ module Zenith.Tree where import Codec.Borsh import Data.HexString -import Data.Int (Int64, Int8) +import Data.Int (Int32, Int64, Int8) import Data.Maybe (fromJust, isNothing) import qualified GHC.Generics as GHC import qualified Generics.SOP as SOP @@ -22,7 +22,7 @@ type Level = Int8 maxLevel :: Level maxLevel = 32 -type Position = Int64 +type Position = Int32 class Monoid v => Measured a v @@ -31,7 +31,7 @@ class Monoid v => class Node v where getLevel :: v -> Level - getTag :: v -> HexString + getHash :: v -> HexString getPosition :: v -> Position isFull :: v -> Bool isMarked :: v -> Bool @@ -60,7 +60,7 @@ instance (Node v, Show v) => Show (Tree v) where show (Leaf v) = "(" ++ show v ++ ")" show (PrunedBranch v) = "{" ++ show v ++ "}" show (Branch s x y) = - "<" ++ show (getTag s) ++ ">\n" ++ show x ++ "\n" ++ show y + "<" ++ show (getHash s) ++ ">\n" ++ show x ++ "\n" ++ show y show InvalidTree = "InvalidTree" instance (Monoid v, Node v) => Semigroup (Tree v) where @@ -105,7 +105,7 @@ value InvalidTree = mempty branch :: Monoid v => Tree v -> Tree v -> Tree v branch x y = Branch (value x <> value y) x y -leaf :: Measured a v => a -> Int64 -> Int64 -> Tree v +leaf :: Measured a v => a -> Int32 -> Int64 -> Tree v leaf a p i = Leaf (measure a p i) prunedBranch :: Monoid v => Node v => Level -> Position -> HexString -> Tree v @@ -120,8 +120,8 @@ root tree = getEmptyRoot :: Monoid v => Node v => Level -> Tree v getEmptyRoot level = iterate (\x -> x <> x) EmptyLeaf !! fromIntegral level -append :: Monoid v => Measured a v => Node v => Tree v -> a -> Int64 -> Tree v -append tree n i = tree <> leaf n p i +append :: Monoid v => Measured a v => Node v => Tree v -> (a, Int64) -> Tree v +append tree (n, i) = tree <> leaf n p i where p = 1 + getPosition (value tree) @@ -133,10 +133,23 @@ mkSubTree level t = where subtree = t <> EmptyLeaf -path :: Position -> Tree v -> Maybe MerklePath -path pos (Branch s x y) = undefined +path :: Monoid v => Node v => Position -> Tree v -> Maybe MerklePath +path pos (Branch s x y) = + if length (collectPath (Branch s x y)) /= 32 + then Nothing + else Just $ MerklePath pos $ collectPath (Branch s x y) where - collectPath t = undefined + collectPath :: Monoid v => Node v => Tree v -> [HexString] + collectPath EmptyLeaf = [] + collectPath Leaf {} = [] + collectPath PrunedBranch {} = [] + collectPath InvalidTree = [] + collectPath (Branch _ j k) + | getPosition (value k) /= 0 && getPosition (value k) < pos = [] + | getPosition (value j) < pos = collectPath k <> [getHash (value j)] + | getPosition (value j) >= pos = collectPath j <> [getHash (value k)] + | otherwise = [] +path _ _ = Nothing data OrchardNode = OrchardNode { on_position :: !Position @@ -171,7 +184,7 @@ instance Monoid OrchardNode where instance Node OrchardNode where getLevel = on_level - getTag = on_value + getHash = on_value getPosition = on_position isFull = on_full isMarked = on_mark @@ -214,4 +227,4 @@ mkOrchardTree tree = case ot_right tree of Just r' -> leaf (fromJust $ ot_left tree) (pos - 1) 0 <> leaf r' pos 0 Nothing -> leaf (fromJust $ ot_left tree) pos 0 <> EmptyLeaf - pos = orchardSize tree - 1 + pos = fromIntegral $ orchardSize tree - 1 diff --git a/test/Spec.hs b/test/Spec.hs index d063add..c615c1d 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -12,12 +12,13 @@ import qualified Data.Text.Encoding as E import Database.Persist import Database.Persist.Sqlite import System.Directory -import Test.HUnit +import Test.HUnit hiding (State(..)) import Test.Hspec import ZcashHaskell.Orchard ( addOrchardNodeGetRoot , getOrchardFrontier , getOrchardNodeValue + , getOrchardPathAnchor , getOrchardRootTest , getOrchardTreeAnchor , getOrchardTreeParts @@ -38,6 +39,7 @@ import ZcashHaskell.Transparent ) import ZcashHaskell.Types ( DecodedNote(..) + , MerklePath(..) , OrchardCommitmentTree(..) , OrchardFrontier(..) , OrchardSpendingKey(..) @@ -237,16 +239,16 @@ main = do let t = leaf cmx1 0 0 <> EmptyLeaf :: Tree OrchardNode getLevel (value t) `shouldBe` 1 it "Create minimal empty tree" $ do - getTag (value t0) `shouldNotBe` hexString "00" + getHash (value t0) `shouldNotBe` hexString "00" it "Expand empty tree" $ do t1 `shouldBe` t1a it "Create empty tree non-rec" $ getEmptyRoot 2 `shouldBe` t1 it "Validate empty tree" $ do - getTag (value (getEmptyRoot 32 :: Tree OrchardNode)) `shouldBe` + getHash (value (getEmptyRoot 32 :: Tree OrchardNode)) `shouldBe` getOrchardRootTest 32 it "Validate tree with one leaf" $ do let n = leaf cmx1 0 1 :: Tree OrchardNode let n1 = root n - getTag (value n1) `shouldBe` addOrchardNodeGetRoot 32 (hexBytes cmx1) + getHash (value n1) `shouldBe` addOrchardNodeGetRoot 32 (hexBytes cmx1) it "Validate size of tree from Zebra" $ do let tree = OrchardCommitmentTree $ @@ -289,7 +291,7 @@ main = do let newTree = mkOrchardTree t1 let ctAnchor = getOrchardTreeAnchor tree {- - -getTag (value newTree) `shouldBe` ctAnchor + -getHash (value newTree) `shouldBe` ctAnchor -isFull (value newTree) `shouldBe` False -} getPosition (value newTree) `shouldBe` 39733 @@ -318,12 +320,12 @@ main = do Nothing -> assertFailure "Failed to get tree parts" Just t1 -> do let newTree = mkOrchardTree t1 - let updatedTree1 = append newTree cmx1 4 - let updatedTree2 = append updatedTree1 cmx2 5 - let updatedTree3 = append updatedTree2 cmx3 6 - let updatedTree4 = append updatedTree3 cmx4 7 + let updatedTree1 = append newTree (cmx1, 4) + let updatedTree2 = append updatedTree1 (cmx2, 5) + let updatedTree3 = append updatedTree2 (cmx3, 6) + let updatedTree4 = append updatedTree3 (cmx4, 7) let finalAnchor = getOrchardTreeAnchor finalTree - getTag (value updatedTree4) `shouldBe` finalAnchor + getHash (value updatedTree4) `shouldBe` finalAnchor it "Validate serializing tree to bytes" $ do let tree = OrchardCommitmentTree $ @@ -345,6 +347,46 @@ main = do let treeBytes = serialiseBorsh t1 let rebuiltTree = deserialiseBorsh treeBytes rebuiltTree `shouldBe` Right t1 + it "Create merkle path" $ do + let tree = + OrchardCommitmentTree $ + hexString + "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" + let cmx1 = + hexString + "1712ead46028d4349e234abf59e94e0640fe7a0829e2e2e17e1a931631810400" :: OrchardCommitment + let cmx2 = + hexString + "39f5ad39817fb432fa07c5feb3a957189fbe7662a4b5555ca95093b6d853cf07" :: OrchardCommitment + case getOrchardTreeParts tree of + Nothing -> assertFailure "Failed to get tree parts" + Just t1 -> do + let newTree = mkOrchardTree t1 + let updatedTree = foldl append newTree [(cmx1, 4), (cmx2, 5)] + case path 39735 updatedTree of + Nothing -> assertFailure "Failed to get Merkle path" + Just p1 -> p1 `shouldNotBe` MerklePath 0 [] + it "Validate merkle path" $ do + let tree = + OrchardCommitmentTree $ + hexString + "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" + let cmx1 = + hexString + "1712ead46028d4349e234abf59e94e0640fe7a0829e2e2e17e1a931631810400" :: OrchardCommitment + let cmx2 = + hexString + "39f5ad39817fb432fa07c5feb3a957189fbe7662a4b5555ca95093b6d853cf07" :: OrchardCommitment + case getOrchardTreeParts tree of + Nothing -> assertFailure "Failed to get tree parts" + Just t1 -> do + let newTree = mkOrchardTree t1 + let updatedTree = foldl append newTree [(cmx1, 4), (cmx2, 5)] + case path 39735 updatedTree of + Nothing -> assertFailure "Failed to get Merkle path" + Just p1 -> do + getOrchardPathAnchor cmx2 p1 `shouldBe` + getHash (value updatedTree) describe "Creating Tx" $ do describe "Full" $ do it "To Orchard" $ do From 5979d922868bf3f8425fa0f0dd586fee3e35f429 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Tue, 5 Nov 2024 12:55:51 -0600 Subject: [PATCH 7/7] Update to zcash-haskell 0.7.4.0 --- zcash-haskell | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/zcash-haskell b/zcash-haskell index 7092764..62cda9c 160000 --- a/zcash-haskell +++ b/zcash-haskell @@ -1 +1 @@ -Subproject commit 70927645e774d53dd04650d68d996670033a8ef1 +Subproject commit 62cda9cc15621dead6fbfd7a4944840408d69da4