Compare commits
3 commits
f2f18b5b0c
...
f23c222edc
| Author | SHA1 | Date | |
|---|---|---|---|
f23c222edc
|
|||
|
8986847679
|
|||
|
b4a2e5e984
|
9 changed files with 991 additions and 382 deletions
|
|
@ -870,9 +870,16 @@ scanZebra dbP zHost zPort b eChan znet = do
|
|||
BC.writeBChan eChan $
|
||||
TickMsg "Failed to update unconfirmed transactions"
|
||||
Right _ -> do
|
||||
logDebugN "Updated confirmations"
|
||||
logDebugN "Starting commitment tree update"
|
||||
_ <- updateCommitmentTrees pool zHost zPort (ZcashNetDB znet)
|
||||
logDebugN "Finished tree update"
|
||||
_ <- liftIO $ completeSync pool Successful
|
||||
liftIO $ BC.writeBChan eChan $ TickMsg "startSync"
|
||||
return ()
|
||||
else liftIO $ BC.writeBChan eChan $ TickVal 1.0
|
||||
else do
|
||||
liftIO $ BC.writeBChan eChan $ TickVal 1.0
|
||||
liftIO $ BC.writeBChan eChan $ TickMsg "startSync"
|
||||
where
|
||||
processBlock :: ConnectionPool -> Float -> Int -> IO ()
|
||||
processBlock pool step bl = do
|
||||
|
|
@ -920,28 +927,8 @@ appEvent (BT.AppEvent t) = do
|
|||
TickMsg m -> do
|
||||
case s ^. displayBox of
|
||||
AddrDisplay -> return ()
|
||||
MsgDisplay -> return ()
|
||||
PhraseDisplay -> return ()
|
||||
TxDisplay -> return ()
|
||||
TxIdDisplay -> return ()
|
||||
SyncDisplay -> return ()
|
||||
SendDisplay -> BT.modify $ set msg m
|
||||
AdrBookEntryDisplay -> return ()
|
||||
BlankDisplay -> return ()
|
||||
TickTx txid -> do
|
||||
BT.modify $ set sentTx (Just txid)
|
||||
BT.modify $ set displayBox TxIdDisplay
|
||||
TickVal v -> do
|
||||
case s ^. displayBox of
|
||||
AddrDisplay -> return ()
|
||||
MsgDisplay -> return ()
|
||||
PhraseDisplay -> return ()
|
||||
TxDisplay -> return ()
|
||||
TxIdDisplay -> return ()
|
||||
SendDisplay -> return ()
|
||||
AdrBookEntryDisplay -> return ()
|
||||
SyncDisplay -> do
|
||||
if s ^. barValue == 1.0
|
||||
MsgDisplay -> do
|
||||
if m == "startSync"
|
||||
then do
|
||||
selWallet <-
|
||||
do case L.listSelectedElement $ s ^. wallets of
|
||||
|
|
@ -968,8 +955,34 @@ appEvent (BT.AppEvent t) = do
|
|||
updatedState <- BT.get
|
||||
ns <- liftIO $ refreshWallet updatedState
|
||||
BT.put ns
|
||||
BT.modify $ set msg ""
|
||||
BT.modify $ set displayBox BlankDisplay
|
||||
else return ()
|
||||
PhraseDisplay -> return ()
|
||||
TxDisplay -> return ()
|
||||
TxIdDisplay -> return ()
|
||||
SyncDisplay -> return ()
|
||||
SendDisplay -> BT.modify $ set msg m
|
||||
AdrBookEntryDisplay -> return ()
|
||||
BlankDisplay -> return ()
|
||||
TickTx txid -> do
|
||||
BT.modify $ set sentTx (Just txid)
|
||||
BT.modify $ set displayBox TxIdDisplay
|
||||
TickVal v -> do
|
||||
case s ^. displayBox of
|
||||
AddrDisplay -> return ()
|
||||
MsgDisplay -> return ()
|
||||
PhraseDisplay -> return ()
|
||||
TxDisplay -> return ()
|
||||
TxIdDisplay -> return ()
|
||||
SendDisplay -> return ()
|
||||
AdrBookEntryDisplay -> return ()
|
||||
SyncDisplay -> do
|
||||
if s ^. barValue == 1.0
|
||||
then do
|
||||
BT.modify $ set msg "Decoding, please wait..."
|
||||
BT.modify $ set barValue 0.0
|
||||
BT.modify $ set displayBox MsgDisplay
|
||||
else BT.modify $ set barValue $ validBarValue (v + s ^. barValue)
|
||||
BlankDisplay -> do
|
||||
case s ^. dialogBox of
|
||||
|
|
@ -990,7 +1003,9 @@ appEvent (BT.AppEvent t) = do
|
|||
then do
|
||||
BT.modify $ set barValue 0.0
|
||||
BT.modify $ set displayBox SyncDisplay
|
||||
sBlock <- liftIO $ getMinBirthdayHeight pool
|
||||
sBlock <-
|
||||
liftIO $
|
||||
getMinBirthdayHeight pool (ZcashNetDB $ s ^. network)
|
||||
_ <-
|
||||
liftIO $
|
||||
forkIO $
|
||||
|
|
@ -1215,7 +1230,7 @@ appEvent (BT.VtyEvent e) = do
|
|||
(s ^. zebraPort)
|
||||
(s ^. network)
|
||||
(entityKey selAcc)
|
||||
(bl + 5)
|
||||
bl
|
||||
(fs1 ^. sendAmt)
|
||||
(fs1 ^. sendTo)
|
||||
(fs1 ^. sendMemo)
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ import Data.Binary.Get hiding (getBytes)
|
|||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Data.HexString (HexString, hexBytes, hexString, toBytes, toText)
|
||||
import Data.Int (Int64)
|
||||
import Data.Int (Int32, Int64)
|
||||
import Data.List
|
||||
import Data.Maybe (fromJust, fromMaybe)
|
||||
import Data.Scientific (Scientific, scientific, toBoundedInteger)
|
||||
|
|
@ -50,6 +50,7 @@ import ZcashHaskell.Orchard
|
|||
, genOrchardSpendingKey
|
||||
, getOrchardFrontier
|
||||
, getOrchardNotePosition
|
||||
, getOrchardTreeParts
|
||||
, getOrchardWitness
|
||||
, isValidUnifiedAddress
|
||||
, updateOrchardCommitmentTree
|
||||
|
|
@ -62,6 +63,7 @@ import ZcashHaskell.Sapling
|
|||
, genSaplingSpendingKey
|
||||
, getSaplingFrontier
|
||||
, getSaplingNotePosition
|
||||
, getSaplingTreeParts
|
||||
, getSaplingWitness
|
||||
, updateSaplingCommitmentTree
|
||||
, updateSaplingWitness
|
||||
|
|
@ -74,6 +76,7 @@ import ZcashHaskell.Transparent
|
|||
import ZcashHaskell.Types
|
||||
import ZcashHaskell.Utils
|
||||
import Zenith.DB
|
||||
import Zenith.Tree
|
||||
import Zenith.Types
|
||||
( Config(..)
|
||||
, HexStringDB(..)
|
||||
|
|
@ -303,66 +306,48 @@ findSaplingOutputs config b znet za = do
|
|||
let zn = getNet znet
|
||||
pool <- liftIO $ runNoLoggingT $ initPool dbPath
|
||||
tList <- liftIO $ getShieldedOutputs pool b znet
|
||||
trees <- liftIO $ getCommitmentTrees pool zebraHost zebraPort znet (b - 1)
|
||||
logDebugN "getting Sapling frontier"
|
||||
let sT = getSaplingFrontier $ SaplingCommitmentTree $ ztiSapling trees
|
||||
sT <- liftIO $ getSaplingTree pool
|
||||
case sT of
|
||||
Nothing ->
|
||||
liftIO $ throwIO $ userError "Failed to read Sapling commitment tree"
|
||||
Just sT' -> do
|
||||
logDebugN "Sapling frontier valid"
|
||||
decryptNotes sT' zn pool tList
|
||||
Just (sT', treeSync) -> do
|
||||
logDebugN "Sapling tree valid"
|
||||
mapM_ (decryptNotes sT' zn pool) tList
|
||||
sapNotes <- liftIO $ getWalletSapNotes pool (entityKey za)
|
||||
liftIO $ findSapSpends pool (entityKey za) sapNotes
|
||||
where
|
||||
sk :: SaplingSpendingKeyDB
|
||||
sk = zcashAccountSapSpendKey $ entityVal za
|
||||
decryptNotes ::
|
||||
SaplingFrontier
|
||||
Tree SaplingNode
|
||||
-> ZcashNet
|
||||
-> ConnectionPool
|
||||
-> [(Entity ZcashTransaction, Entity ShieldOutput)]
|
||||
-> (Entity ZcashTransaction, Entity ShieldOutput)
|
||||
-> NoLoggingT IO ()
|
||||
decryptNotes _ _ _ [] = return ()
|
||||
decryptNotes st n pool ((zt, o):txs) = do
|
||||
let updatedTree =
|
||||
updateSaplingCommitmentTree
|
||||
st
|
||||
(getHex $ shieldOutputCmu $ entityVal o)
|
||||
logDebugN "updated frontier"
|
||||
case updatedTree of
|
||||
Nothing ->
|
||||
liftIO $ throwIO $ userError "Failed to update commitment tree"
|
||||
Just uT -> do
|
||||
let noteWitness = getSaplingWitness uT
|
||||
logDebugN "got witness"
|
||||
let notePos = getSaplingNotePosition <$> noteWitness
|
||||
logDebugN "got position"
|
||||
case notePos of
|
||||
Nothing ->
|
||||
liftIO $ throwIO $ userError "Failed to obtain note position"
|
||||
decryptNotes st n pool (zt, o) = do
|
||||
case getNotePosition st $ fromSqlKey $ entityKey o of
|
||||
Nothing -> do
|
||||
logErrorN "Couldn't find sapling note in commitment tree"
|
||||
return ()
|
||||
Just nP -> do
|
||||
logDebugN "got position"
|
||||
case decodeShOut External n nP o of
|
||||
Nothing -> do
|
||||
logDebugN "couldn't decode external"
|
||||
case decodeShOut Internal n nP o of
|
||||
Nothing -> do
|
||||
logDebugN "couldn't decode internal"
|
||||
decryptNotes uT n pool txs
|
||||
Just dn1 -> do
|
||||
wId <-
|
||||
liftIO $ saveWalletTransaction pool (entityKey za) zt
|
||||
wId <- liftIO $ saveWalletTransaction pool (entityKey za) zt
|
||||
liftIO $
|
||||
saveWalletSapNote
|
||||
pool
|
||||
wId
|
||||
nP
|
||||
(fromJust noteWitness)
|
||||
True
|
||||
(entityKey za)
|
||||
(entityKey o)
|
||||
dn1
|
||||
decryptNotes uT n pool txs
|
||||
Just dn0 -> do
|
||||
wId <- liftIO $ saveWalletTransaction pool (entityKey za) zt
|
||||
liftIO $
|
||||
|
|
@ -370,18 +355,12 @@ findSaplingOutputs config b znet za = do
|
|||
pool
|
||||
wId
|
||||
nP
|
||||
(fromJust noteWitness)
|
||||
False
|
||||
(entityKey za)
|
||||
(entityKey o)
|
||||
dn0
|
||||
decryptNotes uT n pool txs
|
||||
decodeShOut ::
|
||||
Scope
|
||||
-> ZcashNet
|
||||
-> Integer
|
||||
-> Entity ShieldOutput
|
||||
-> Maybe DecodedNote
|
||||
Scope -> ZcashNet -> Int32 -> Entity ShieldOutput -> Maybe DecodedNote
|
||||
decodeShOut scope n pos s = do
|
||||
decodeSaplingOutputEsk
|
||||
(getSapSK sk)
|
||||
|
|
@ -394,7 +373,7 @@ findSaplingOutputs config b znet za = do
|
|||
(getHex $ shieldOutputProof $ entityVal s))
|
||||
n
|
||||
scope
|
||||
pos
|
||||
(fromIntegral pos)
|
||||
|
||||
-- | Get Orchard actions
|
||||
findOrchardActions ::
|
||||
|
|
@ -410,67 +389,52 @@ findOrchardActions config b znet za = do
|
|||
let zn = getNet znet
|
||||
pool <- runNoLoggingT $ initPool dbPath
|
||||
tList <- getOrchardActions pool b znet
|
||||
trees <- getCommitmentTrees pool zebraHost zebraPort znet (b - 1)
|
||||
let sT = getOrchardFrontier $ OrchardCommitmentTree $ ztiOrchard trees
|
||||
sT <- getOrchardTree pool
|
||||
case sT of
|
||||
Nothing -> throwIO $ userError "Failed to read Orchard commitment tree"
|
||||
Just sT' -> do
|
||||
decryptNotes sT' zn pool tList
|
||||
Just (sT', treeSync) -> do
|
||||
mapM_ (decryptNotes sT' zn pool) tList
|
||||
orchNotes <- getWalletOrchNotes pool (entityKey za)
|
||||
findOrchSpends pool (entityKey za) orchNotes
|
||||
where
|
||||
decryptNotes ::
|
||||
OrchardFrontier
|
||||
Tree OrchardNode
|
||||
-> ZcashNet
|
||||
-> ConnectionPool
|
||||
-> [(Entity ZcashTransaction, Entity OrchAction)]
|
||||
-> (Entity ZcashTransaction, Entity OrchAction)
|
||||
-> IO ()
|
||||
decryptNotes _ _ _ [] = return ()
|
||||
decryptNotes ot n pool ((zt, o):txs) = do
|
||||
let updatedTree =
|
||||
updateOrchardCommitmentTree
|
||||
ot
|
||||
(getHex $ orchActionCmx $ entityVal o)
|
||||
case updatedTree of
|
||||
Nothing -> throwIO $ userError "Failed to update commitment tree"
|
||||
Just uT -> do
|
||||
let noteWitness = getOrchardWitness uT
|
||||
let notePos = getOrchardNotePosition <$> noteWitness
|
||||
case notePos of
|
||||
Nothing -> throwIO $ userError "Failed to obtain note position"
|
||||
decryptNotes ot n pool (zt, o) = do
|
||||
case getNotePosition ot (fromSqlKey $ entityKey o) of
|
||||
Nothing -> do
|
||||
return ()
|
||||
Just nP ->
|
||||
case decodeOrchAction External nP o of
|
||||
Nothing ->
|
||||
case decodeOrchAction Internal nP o of
|
||||
Nothing -> decryptNotes uT n pool txs
|
||||
Nothing -> return ()
|
||||
Just dn1 -> do
|
||||
wId <- saveWalletTransaction pool (entityKey za) zt
|
||||
saveWalletOrchNote
|
||||
pool
|
||||
wId
|
||||
nP
|
||||
(fromJust noteWitness)
|
||||
True
|
||||
(entityKey za)
|
||||
(entityKey o)
|
||||
dn1
|
||||
decryptNotes uT n pool txs
|
||||
Just dn -> do
|
||||
wId <- saveWalletTransaction pool (entityKey za) zt
|
||||
saveWalletOrchNote
|
||||
pool
|
||||
wId
|
||||
nP
|
||||
(fromJust noteWitness)
|
||||
False
|
||||
(entityKey za)
|
||||
(entityKey o)
|
||||
dn
|
||||
decryptNotes uT n pool txs
|
||||
sk :: OrchardSpendingKeyDB
|
||||
sk = zcashAccountOrchSpendKey $ entityVal za
|
||||
decodeOrchAction ::
|
||||
Scope -> Integer -> Entity OrchAction -> Maybe DecodedNote
|
||||
decodeOrchAction :: Scope -> Int32 -> Entity OrchAction -> Maybe DecodedNote
|
||||
decodeOrchAction scope pos o =
|
||||
decryptOrchardActionSK (getOrchSK sk) scope $
|
||||
OrchardAction
|
||||
|
|
@ -814,11 +778,6 @@ shieldTransparentNotes ::
|
|||
shieldTransparentNotes pool zebraHost zebraPort znet za bh = do
|
||||
accRead <- liftIO $ getAccountById pool za
|
||||
logDebugN $ T.pack $ "Target block: " ++ show bh
|
||||
{-
|
||||
-trees <- liftIO $ getCommitmentTrees zebraHost zebraPort bh
|
||||
-let sT = SaplingCommitmentTree $ ztiSapling trees
|
||||
-let oT = OrchardCommitmentTree $ ztiOrchard trees
|
||||
-}
|
||||
case accRead of
|
||||
Nothing -> do
|
||||
logErrorN "Can't find Account"
|
||||
|
|
@ -831,6 +790,8 @@ shieldTransparentNotes pool zebraHost zebraPort znet za bh = do
|
|||
(\x ->
|
||||
filter (\y -> walletTrNoteAddress (entityVal y) == x) trNotes')
|
||||
dRecvs
|
||||
sTree <- liftIO $ getSaplingTree pool
|
||||
oTree <- liftIO $ getOrchardTree pool
|
||||
forM fNotes $ \trNotes -> do
|
||||
let noteTotal = getTotalAmount (trNotes, [], [])
|
||||
tSpends <-
|
||||
|
|
@ -864,8 +825,8 @@ shieldTransparentNotes pool zebraHost zebraPort znet za bh = do
|
|||
tx <-
|
||||
liftIO $
|
||||
createTransaction
|
||||
Nothing
|
||||
Nothing
|
||||
(maybe (hexString "00") (getHash . value . fst) sTree)
|
||||
(maybe (hexString "00") (getHash . value . fst) oTree)
|
||||
tSpends
|
||||
[]
|
||||
[]
|
||||
|
|
@ -931,10 +892,8 @@ prepareTxV2 pool zebraHost zebraPort zn za bh pnotes policy = do
|
|||
let recipients = map extractReceiver pnotes
|
||||
logDebugN $ T.pack $ show recipients
|
||||
logDebugN $ T.pack $ "Target block: " ++ show bh
|
||||
trees <-
|
||||
liftIO $ getCommitmentTrees pool zebraHost zebraPort (ZcashNetDB zn) bh
|
||||
let sT = SaplingCommitmentTree $ ztiSapling trees
|
||||
let oT = OrchardCommitmentTree $ ztiOrchard trees
|
||||
sTree <- liftIO $ getSaplingTree pool
|
||||
oTree <- liftIO $ getOrchardTree pool
|
||||
case accRead of
|
||||
Nothing -> do
|
||||
logErrorN "Can't find Account"
|
||||
|
|
@ -969,24 +928,6 @@ prepareTxV2 pool zebraHost zebraPort zn za bh pnotes policy = do
|
|||
logDebugN $ T.pack $ show oList
|
||||
let noteTotal = getTotalAmount (tList, sList, oList)
|
||||
logDebugN $ "noteTotal: " <> T.pack (show noteTotal)
|
||||
tSpends <-
|
||||
liftIO $
|
||||
prepTSpends
|
||||
(getTranSK $ zcashAccountTPrivateKey $ entityVal acc)
|
||||
tList
|
||||
--print tSpends
|
||||
sSpends <-
|
||||
liftIO $
|
||||
prepSSpends
|
||||
(getSapSK $ zcashAccountSapSpendKey $ entityVal acc)
|
||||
sList
|
||||
--print sSpends
|
||||
oSpends <-
|
||||
liftIO $
|
||||
prepOSpends
|
||||
(getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc)
|
||||
oList
|
||||
--print oSpends
|
||||
draft <-
|
||||
liftIO $
|
||||
makeOutgoing
|
||||
|
|
@ -1022,11 +963,13 @@ prepareTxV2 pool zebraHost zebraPort zn za bh pnotes policy = do
|
|||
liftIO $
|
||||
prepSSpends
|
||||
(getSapSK $ zcashAccountSapSpendKey $ entityVal acc)
|
||||
(maybe InvalidTree fst sTree)
|
||||
sList1
|
||||
oSpends1 <-
|
||||
liftIO $
|
||||
prepOSpends
|
||||
(getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc)
|
||||
(maybe InvalidTree fst oTree)
|
||||
oList1
|
||||
let noteTotal1 = getTotalAmount (tList1, sList1, oList1)
|
||||
outgoing' <-
|
||||
|
|
@ -1043,8 +986,14 @@ prepareTxV2 pool zebraHost zebraPort zn za bh pnotes policy = do
|
|||
tx <-
|
||||
liftIO $
|
||||
createTransaction
|
||||
(Just sT)
|
||||
(Just oT)
|
||||
(maybe
|
||||
(hexString "00")
|
||||
(getHash . value . fst)
|
||||
sTree)
|
||||
(maybe
|
||||
(hexString "00")
|
||||
(getHash . value . fst)
|
||||
oTree)
|
||||
tSpends1
|
||||
sSpends1
|
||||
oSpends1
|
||||
|
|
@ -1300,9 +1249,16 @@ prepareTxV2 pool zebraHost zebraPort zn za bh pnotes policy = do
|
|||
(fromIntegral $ walletTrNoteValue $ entityVal n)
|
||||
(walletTrNoteScript $ entityVal n))
|
||||
prepSSpends ::
|
||||
SaplingSpendingKey -> [Entity WalletSapNote] -> IO [SaplingTxSpend]
|
||||
prepSSpends sk notes = do
|
||||
SaplingSpendingKey
|
||||
-> Tree SaplingNode
|
||||
-> [Entity WalletSapNote]
|
||||
-> IO [SaplingTxSpend]
|
||||
prepSSpends sk tree notes = do
|
||||
forM notes $ \n -> do
|
||||
let notePath =
|
||||
Zenith.Tree.path
|
||||
(fromIntegral $ walletSapNotePosition $ entityVal n)
|
||||
tree
|
||||
return $
|
||||
SaplingTxSpend
|
||||
(getBytes sk)
|
||||
|
|
@ -1313,11 +1269,18 @@ prepareTxV2 pool zebraHost zebraPort zn za bh pnotes policy = do
|
|||
(getHex $ walletSapNoteNullifier $ entityVal n)
|
||||
""
|
||||
(getRseed $ walletSapNoteRseed $ entityVal n))
|
||||
(toBytes $ getHex $ walletSapNoteWitness $ entityVal n)
|
||||
(fromMaybe nullPath notePath)
|
||||
prepOSpends ::
|
||||
OrchardSpendingKey -> [Entity WalletOrchNote] -> IO [OrchardTxSpend]
|
||||
prepOSpends sk notes = do
|
||||
OrchardSpendingKey
|
||||
-> Tree OrchardNode
|
||||
-> [Entity WalletOrchNote]
|
||||
-> IO [OrchardTxSpend]
|
||||
prepOSpends sk tree notes = do
|
||||
forM notes $ \n -> do
|
||||
let notePath =
|
||||
Zenith.Tree.path
|
||||
(fromIntegral $ walletOrchNotePosition $ entityVal n)
|
||||
tree
|
||||
return $
|
||||
OrchardTxSpend
|
||||
(getBytes sk)
|
||||
|
|
@ -1328,21 +1291,7 @@ prepareTxV2 pool zebraHost zebraPort zn za bh pnotes policy = do
|
|||
(getHex $ walletOrchNoteNullifier $ entityVal n)
|
||||
(walletOrchNoteRho $ entityVal n)
|
||||
(getRseed $ walletOrchNoteRseed $ entityVal n))
|
||||
(toBytes $ getHex $ walletOrchNoteWitness $ entityVal n)
|
||||
sapAnchor :: [Entity WalletSapNote] -> Maybe SaplingWitness
|
||||
sapAnchor notes =
|
||||
if not (null notes)
|
||||
then Just $
|
||||
SaplingWitness $
|
||||
getHex $ walletSapNoteWitness $ entityVal $ head notes
|
||||
else Nothing
|
||||
orchAnchor :: [Entity WalletOrchNote] -> Maybe OrchardWitness
|
||||
orchAnchor notes =
|
||||
if not (null notes)
|
||||
then Just $
|
||||
OrchardWitness $
|
||||
getHex $ walletOrchNoteWitness $ entityVal $ head notes
|
||||
else Nothing
|
||||
(fromMaybe nullPath notePath)
|
||||
|
||||
-- | Sync the wallet with the data store
|
||||
syncWallet ::
|
||||
|
|
@ -1388,10 +1337,95 @@ syncWallet config w = do
|
|||
(findOrchardActions config startBlock (zcashWalletNetwork $ entityVal w))
|
||||
accs
|
||||
logDebugN "processed orchard actions"
|
||||
_ <- liftIO $ updateSaplingWitnesses pool
|
||||
logDebugN "updated sapling witnesses"
|
||||
_ <- liftIO $ updateOrchardWitnesses pool
|
||||
logDebugN "updated orchard witnesses"
|
||||
_ <- liftIO $ updateWalletSync pool chainTip (entityKey w)
|
||||
logDebugN "updated wallet lastSync"
|
||||
mapM_ (liftIO . runNoLoggingT . getWalletTransactions pool) addrs
|
||||
|
||||
-- | Update commitment trees
|
||||
updateCommitmentTrees ::
|
||||
ConnectionPool -> T.Text -> Int -> ZcashNetDB -> LoggingT IO ()
|
||||
updateCommitmentTrees pool zHost zPort zNet = do
|
||||
sTdb <- liftIO $ getSaplingTree pool
|
||||
oTdb <- liftIO $ getOrchardTree pool
|
||||
maxBlock <- liftIO $ getMaxBlock pool zNet
|
||||
newSapTree <-
|
||||
case sTdb of
|
||||
Nothing -> do
|
||||
logDebugN ">no Sapling tree in DB"
|
||||
bh <- liftIO $ getMinBirthdayHeight pool zNet
|
||||
logDebugN $ ">min birthday: " <> T.pack (show bh)
|
||||
saplingNotes <- liftIO $ getShieldedOutputs pool (bh + 1) zNet
|
||||
let saplingComm =
|
||||
map
|
||||
(\(_, y) ->
|
||||
( getHex $ shieldOutputCmu (entityVal y)
|
||||
, fromSqlKey (entityKey y)))
|
||||
saplingNotes
|
||||
logDebugN ">got shielded outputs"
|
||||
treeInfo <- liftIO $ getCommitmentTrees pool zHost zPort zNet bh
|
||||
case getSaplingTreeParts (SaplingCommitmentTree $ ztiSapling treeInfo) of
|
||||
Nothing -> do
|
||||
logDebugN ">failed to load tree from Zebra"
|
||||
return InvalidTree
|
||||
Just t1 -> do
|
||||
let newTree = mkSaplingTree t1
|
||||
return $ foldl' append newTree saplingComm
|
||||
Just (sTree, sSync) -> do
|
||||
logDebugN $ ">Sapling tree found, synced to " <> T.pack (show sSync)
|
||||
saplingNotes <- liftIO $ getShieldedOutputs pool (sSync + 1) zNet
|
||||
let saplingComm =
|
||||
map
|
||||
(\(_, y) ->
|
||||
( getHex $ shieldOutputCmu (entityVal y)
|
||||
, fromSqlKey (entityKey y)))
|
||||
saplingNotes
|
||||
logDebugN ">got shielded outputs"
|
||||
return $ foldl' append sTree saplingComm
|
||||
newOrchTree <-
|
||||
case oTdb of
|
||||
Nothing -> do
|
||||
logDebugN ">no Orchard tree in DB"
|
||||
bh <- liftIO $ getMinBirthdayHeight pool zNet
|
||||
logDebugN $ ">min birthday: " <> T.pack (show bh)
|
||||
orchardNotes <- liftIO $ getOrchardActions pool (bh + 1) zNet
|
||||
let orchardComm =
|
||||
map
|
||||
(\(_, y) ->
|
||||
( getHex $ orchActionCmx (entityVal y)
|
||||
, fromSqlKey (entityKey y)))
|
||||
orchardNotes
|
||||
logDebugN ">got orchard actions"
|
||||
treeInfo <- liftIO $ getCommitmentTrees pool zHost zPort zNet bh
|
||||
case getOrchardTreeParts (OrchardCommitmentTree $ ztiOrchard treeInfo) of
|
||||
Nothing -> do
|
||||
logDebugN ">failed to load tree from Zebra"
|
||||
return InvalidTree
|
||||
Just t1 -> do
|
||||
let newTree = mkOrchardTree t1
|
||||
return $ foldl' append newTree orchardComm
|
||||
Just (oTree, oSync) -> do
|
||||
logDebugN $ ">Orchard tree found, synced to " <> T.pack (show oSync)
|
||||
orchardNotes <- liftIO $ getOrchardActions pool (oSync + 1) zNet
|
||||
let orchardComm =
|
||||
map
|
||||
(\(_, y) ->
|
||||
( getHex $ orchActionCmx (entityVal y)
|
||||
, fromSqlKey (entityKey y)))
|
||||
orchardNotes
|
||||
logDebugN ">got orchard actions"
|
||||
return $ foldl' append oTree orchardComm
|
||||
case newSapTree of
|
||||
Branch {} -> do
|
||||
logInfoN ">Saving updated Sapling tree to db"
|
||||
_ <- liftIO $ upsertSaplingTree pool maxBlock newSapTree
|
||||
case newOrchTree of
|
||||
Branch {} -> do
|
||||
logInfoN ">Saving updated Orchard tree to db"
|
||||
_ <- liftIO $ upsertOrchardTree pool maxBlock newOrchTree
|
||||
return ()
|
||||
_anyOther -> do
|
||||
logErrorN ">Failed to update the Orchard tree"
|
||||
return ()
|
||||
_anyOther -> do
|
||||
logErrorN ">Failed to update the Sapling tree"
|
||||
return ()
|
||||
|
|
|
|||
206
src/Zenith/DB.hs
206
src/Zenith/DB.hs
|
|
@ -18,6 +18,7 @@
|
|||
|
||||
module Zenith.DB where
|
||||
|
||||
import Codec.Borsh
|
||||
import Control.Exception (SomeException(..), throw, throwIO, try)
|
||||
import Control.Monad (unless, when)
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
|
|
@ -25,6 +26,7 @@ import Control.Monad.Logger
|
|||
( LoggingT
|
||||
, NoLoggingT
|
||||
, logDebugN
|
||||
, logErrorN
|
||||
, runNoLoggingT
|
||||
, runStderrLoggingT
|
||||
)
|
||||
|
|
@ -80,6 +82,7 @@ import ZcashHaskell.Types
|
|||
, ValidAddress(..)
|
||||
, ZcashNet(..)
|
||||
)
|
||||
import Zenith.Tree (OrchardNode(..), SaplingNode(..), Tree(..), truncateTree)
|
||||
import Zenith.Types
|
||||
( AccountBalance(..)
|
||||
, HexStringDB(..)
|
||||
|
|
@ -304,6 +307,12 @@ share
|
|||
status ZenithStatus
|
||||
UniqueSync name
|
||||
deriving Show Eq
|
||||
TreeStore
|
||||
pool ZcashPool
|
||||
bytes BS.ByteString
|
||||
lastSync Int
|
||||
UniquePool pool
|
||||
deriving Show Eq
|
||||
|]
|
||||
|
||||
-- ** Type conversions
|
||||
|
|
@ -919,15 +928,17 @@ getMaxWalletBlock pool = do
|
|||
Nothing -> return $ -1
|
||||
Just x -> return $ walletTransactionBlock $ entityVal x
|
||||
|
||||
getMinBirthdayHeight :: ConnectionPool -> IO Int
|
||||
getMinBirthdayHeight pool = do
|
||||
getMinBirthdayHeight :: ConnectionPool -> ZcashNetDB -> IO Int
|
||||
getMinBirthdayHeight pool znet = do
|
||||
b <-
|
||||
runNoLoggingT $
|
||||
PS.retryOnBusy $
|
||||
flip PS.runSqlPool pool $ do
|
||||
selectOne $ do
|
||||
w <- from $ table @ZcashWallet
|
||||
where_ (w ^. ZcashWalletBirthdayHeight >. val 0)
|
||||
where_
|
||||
(w ^. ZcashWalletBirthdayHeight >. val 0 &&. w ^. ZcashWalletNetwork ==.
|
||||
val znet)
|
||||
orderBy [asc $ w ^. ZcashWalletBirthdayHeight]
|
||||
pure w
|
||||
case b of
|
||||
|
|
@ -983,14 +994,13 @@ saveWalletTransaction pool za zt = do
|
|||
saveWalletSapNote ::
|
||||
ConnectionPool -- ^ The database path
|
||||
-> WalletTransactionId -- ^ The index for the transaction that contains the note
|
||||
-> Integer -- ^ note position
|
||||
-> SaplingWitness -- ^ the Sapling incremental witness
|
||||
-> Int32 -- ^ note position
|
||||
-> Bool -- ^ change flag
|
||||
-> ZcashAccountId
|
||||
-> ShieldOutputId
|
||||
-> DecodedNote -- The decoded Sapling note
|
||||
-> IO ()
|
||||
saveWalletSapNote pool wId pos wit ch za zt dn = do
|
||||
saveWalletSapNote pool wId pos ch za zt dn = do
|
||||
runNoLoggingT $
|
||||
PS.retryOnBusy $
|
||||
flip PS.runSqlPool pool $ do
|
||||
|
|
@ -1005,7 +1015,7 @@ saveWalletSapNote pool wId pos wit ch za zt dn = do
|
|||
False
|
||||
(HexStringDB $ a_nullifier dn)
|
||||
(fromIntegral pos)
|
||||
(HexStringDB $ sapWit wit)
|
||||
(HexStringDB $ hexString "00")
|
||||
ch
|
||||
zt
|
||||
(RseedDB $ a_rseed dn))
|
||||
|
|
@ -1016,14 +1026,13 @@ saveWalletSapNote pool wId pos wit ch za zt dn = do
|
|||
saveWalletOrchNote ::
|
||||
ConnectionPool
|
||||
-> WalletTransactionId
|
||||
-> Integer
|
||||
-> OrchardWitness
|
||||
-> Int32
|
||||
-> Bool
|
||||
-> ZcashAccountId
|
||||
-> OrchActionId
|
||||
-> DecodedNote
|
||||
-> IO ()
|
||||
saveWalletOrchNote pool wId pos wit ch za zt dn = do
|
||||
saveWalletOrchNote pool wId pos ch za zt dn = do
|
||||
runNoLoggingT $
|
||||
PS.retryOnBusy $
|
||||
flip PS.runSqlPool pool $ do
|
||||
|
|
@ -1038,7 +1047,7 @@ saveWalletOrchNote pool wId pos wit ch za zt dn = do
|
|||
False
|
||||
(HexStringDB $ a_nullifier dn)
|
||||
(fromIntegral pos)
|
||||
(HexStringDB $ orchWit wit)
|
||||
(HexStringDB $ hexString "00")
|
||||
ch
|
||||
zt
|
||||
(a_rho dn)
|
||||
|
|
@ -2159,6 +2168,9 @@ clearWalletData pool = do
|
|||
runNoLoggingT $
|
||||
PS.retryOnBusy $
|
||||
flip PS.runSqlPool pool $ do
|
||||
delete $ do
|
||||
_ <- from $ table @TreeStore
|
||||
return ()
|
||||
delete $ do
|
||||
_ <- from $ table @TransparentNote
|
||||
return ()
|
||||
|
|
@ -2812,7 +2824,173 @@ rewindWalletData pool b net = do
|
|||
flip PS.runSqlPool pool $ do
|
||||
delete $ do
|
||||
blk <- from $ table @ZcashBlock
|
||||
where_
|
||||
(blk ^. ZcashBlockHeight >. val b &&. blk ^. ZcashBlockNetwork ==.
|
||||
val net)
|
||||
where_ $
|
||||
(blk ^. ZcashBlockHeight >. val b) &&.
|
||||
(blk ^. ZcashBlockNetwork ==. val net)
|
||||
logDebugN "Completed data store rewind"
|
||||
saplingOutputIx <- liftIO $ getSaplingOutputAtBlock pool net b
|
||||
orchardActionIx <- liftIO $ getOrchardActionAtBlock pool net b
|
||||
case saplingOutputIx of
|
||||
Nothing -> logErrorN "Couldn't get Sapling output index for tree rewind"
|
||||
Just soIx -> do
|
||||
saplingTree <- liftIO $ getSaplingTree pool
|
||||
let truncSapTree = truncateTree (maybe InvalidTree fst saplingTree) soIx
|
||||
_ <- liftIO $ upsertSaplingTree pool b truncSapTree
|
||||
logDebugN $ "Truncated Sapling tree at index " <> T.pack (show soIx)
|
||||
case orchardActionIx of
|
||||
Nothing -> logErrorN "Couldn't get Orchard action index for tree rewind"
|
||||
Just oaIx -> do
|
||||
orchardTree <- liftIO $ getOrchardTree pool
|
||||
let truncOrchTree =
|
||||
truncateTree (maybe InvalidTree fst orchardTree) oaIx
|
||||
_ <- liftIO $ upsertOrchardTree pool b truncOrchTree
|
||||
logDebugN $ "Truncated Orchard tree at index " <> T.pack (show oaIx)
|
||||
|
||||
getSaplingOutputAtBlock ::
|
||||
ConnectionPool -> ZcashNetDB -> Int -> IO (Maybe Int64)
|
||||
getSaplingOutputAtBlock pool znet b = do
|
||||
r <-
|
||||
runNoLoggingT $
|
||||
PS.retryOnBusy $
|
||||
flip PS.runSqlPool pool $ do
|
||||
selectOne $ do
|
||||
(blks :& txs :& sOutputs) <-
|
||||
from $ table @ZcashBlock `innerJoin` table @ZcashTransaction `on`
|
||||
(\(blks :& txs) ->
|
||||
blks ^. ZcashBlockId ==. txs ^. ZcashTransactionBlockId) `innerJoin`
|
||||
table @ShieldOutput `on`
|
||||
(\(_ :& txs :& sOutputs) ->
|
||||
txs ^. ZcashTransactionId ==. sOutputs ^. ShieldOutputTx)
|
||||
where_ (blks ^. ZcashBlockHeight <=. val b)
|
||||
where_ (blks ^. ZcashBlockNetwork ==. val znet)
|
||||
orderBy
|
||||
[ desc $ txs ^. ZcashTransactionId
|
||||
, desc $ sOutputs ^. ShieldOutputPosition
|
||||
]
|
||||
return sOutputs
|
||||
case r of
|
||||
Nothing -> return Nothing
|
||||
Just so -> return $ Just $ fromSqlKey $ entityKey so
|
||||
|
||||
getOrchardActionAtBlock ::
|
||||
ConnectionPool -> ZcashNetDB -> Int -> IO (Maybe Int64)
|
||||
getOrchardActionAtBlock pool znet b = do
|
||||
r <-
|
||||
runNoLoggingT $
|
||||
PS.retryOnBusy $
|
||||
flip PS.runSqlPool pool $ do
|
||||
selectOne $ do
|
||||
(blks :& txs :& oActions) <-
|
||||
from $ table @ZcashBlock `innerJoin` table @ZcashTransaction `on`
|
||||
(\(blks :& txs) ->
|
||||
blks ^. ZcashBlockId ==. txs ^. ZcashTransactionBlockId) `innerJoin`
|
||||
table @OrchAction `on`
|
||||
(\(_ :& txs :& oActions) ->
|
||||
txs ^. ZcashTransactionId ==. oActions ^. OrchActionTx)
|
||||
where_ (blks ^. ZcashBlockHeight <=. val b)
|
||||
where_ (blks ^. ZcashBlockNetwork ==. val znet)
|
||||
orderBy
|
||||
[ desc $ txs ^. ZcashTransactionId
|
||||
, desc $ oActions ^. OrchActionPosition
|
||||
]
|
||||
return oActions
|
||||
case r of
|
||||
Nothing -> return Nothing
|
||||
Just so -> return $ Just $ fromSqlKey $ entityKey so
|
||||
|
||||
-- * Tree storage
|
||||
-- | Read the Orchard commitment tree
|
||||
getOrchardTree :: ConnectionPool -> IO (Maybe (Tree OrchardNode, Int))
|
||||
getOrchardTree pool = do
|
||||
treeRecord <-
|
||||
runNoLoggingT $
|
||||
PS.retryOnBusy $
|
||||
flip PS.runSqlPool pool $ do
|
||||
selectOne $ do
|
||||
tr <- from $ table @TreeStore
|
||||
where_ (tr ^. TreeStorePool ==. val OrchardPool)
|
||||
pure tr
|
||||
case treeRecord of
|
||||
Nothing -> return Nothing
|
||||
Just tR ->
|
||||
case deserialiseBorsh $ BS.fromStrict $ treeStoreBytes $ entityVal tR of
|
||||
Left _ -> return Nothing
|
||||
Right t -> return $ Just (t, treeStoreLastSync $ entityVal tR)
|
||||
|
||||
-- | Save the Orchard commitment tree
|
||||
upsertOrchardTree :: ConnectionPool -> Int -> Tree OrchardNode -> IO ()
|
||||
upsertOrchardTree pool ls tree = do
|
||||
let treeBytes = BS.toStrict $ serialiseBorsh tree
|
||||
chk <-
|
||||
runNoLoggingT $
|
||||
PS.retryOnBusy $
|
||||
flip PS.runSqlPool pool $ do
|
||||
select $ do
|
||||
tr <- from $ table @TreeStore
|
||||
where_ (tr ^. TreeStorePool ==. val OrchardPool)
|
||||
pure tr
|
||||
if not (null chk)
|
||||
then do
|
||||
_ <-
|
||||
runNoLoggingT $
|
||||
PS.retryOnBusy $
|
||||
flip PS.runSqlPool pool $ do
|
||||
update $ \p -> do
|
||||
set p [TreeStoreBytes =. val treeBytes, TreeStoreLastSync =. val ls]
|
||||
where_ $ p ^. TreeStorePool ==. val OrchardPool
|
||||
return ()
|
||||
else do
|
||||
_ <-
|
||||
runNoLoggingT $
|
||||
PS.retryOnBusy $
|
||||
flip PS.runSqlPool pool $
|
||||
insertUnique_ $ TreeStore OrchardPool treeBytes ls
|
||||
return ()
|
||||
|
||||
-- | Read the Sapling commitment tree
|
||||
getSaplingTree :: ConnectionPool -> IO (Maybe (Tree SaplingNode, Int))
|
||||
getSaplingTree pool = do
|
||||
treeRecord <-
|
||||
runStderrLoggingT $
|
||||
PS.retryOnBusy $
|
||||
flip PS.runSqlPool pool $ do
|
||||
selectOne $ do
|
||||
tr <- from $ table @TreeStore
|
||||
where_ (tr ^. TreeStorePool ==. val SaplingPool)
|
||||
pure tr
|
||||
case treeRecord of
|
||||
Nothing -> return Nothing
|
||||
Just tR ->
|
||||
case deserialiseBorsh $ BS.fromStrict $ treeStoreBytes $ entityVal tR of
|
||||
Left _ -> return Nothing
|
||||
Right t -> return $ Just (t, treeStoreLastSync $ entityVal tR)
|
||||
|
||||
-- | Save the Sapling commitment tree
|
||||
upsertSaplingTree :: ConnectionPool -> Int -> Tree SaplingNode -> IO ()
|
||||
upsertSaplingTree pool ls tree = do
|
||||
let treeBytes = BS.toStrict $ serialiseBorsh tree
|
||||
chk <-
|
||||
runNoLoggingT $
|
||||
PS.retryOnBusy $
|
||||
flip PS.runSqlPool pool $ do
|
||||
select $ do
|
||||
tr <- from $ table @TreeStore
|
||||
where_ (tr ^. TreeStorePool ==. val SaplingPool)
|
||||
pure tr
|
||||
if not (null chk)
|
||||
then do
|
||||
_ <-
|
||||
runNoLoggingT $
|
||||
PS.retryOnBusy $
|
||||
flip PS.runSqlPool pool $ do
|
||||
update $ \p -> do
|
||||
set p [TreeStoreBytes =. val treeBytes, TreeStoreLastSync =. val ls]
|
||||
where_ $ p ^. TreeStorePool ==. val SaplingPool
|
||||
return ()
|
||||
else do
|
||||
_ <-
|
||||
runNoLoggingT $
|
||||
PS.retryOnBusy $
|
||||
flip PS.runSqlPool pool $
|
||||
insertUnique_ $ TreeStore SaplingPool treeBytes ls
|
||||
return ()
|
||||
|
|
|
|||
|
|
@ -1625,7 +1625,7 @@ scanZebra :: T.Text -> T.Text -> Int -> ZcashNet -> (AppEvent -> IO ()) -> IO ()
|
|||
scanZebra dbPath zHost zPort net sendMsg = do
|
||||
bStatus <- liftIO $ checkBlockChain zHost zPort
|
||||
pool <- runNoLoggingT $ initPool dbPath
|
||||
b <- liftIO $ getMinBirthdayHeight pool
|
||||
b <- liftIO $ getMinBirthdayHeight pool $ ZcashNetDB net
|
||||
dbBlock <- getMaxBlock pool $ ZcashNetDB net
|
||||
chkBlock <- checkIntegrity dbPath zHost zPort net dbBlock 1
|
||||
syncChk <- isSyncing pool
|
||||
|
|
|
|||
|
|
@ -887,7 +887,7 @@ scanZebra :: T.Text -> T.Text -> Int -> ZcashNet -> IO ()
|
|||
scanZebra dbPath zHost zPort net = do
|
||||
bStatus <- checkBlockChain zHost zPort
|
||||
pool <- runNoLoggingT $ initPool dbPath
|
||||
b <- getMinBirthdayHeight pool
|
||||
b <- getMinBirthdayHeight pool $ ZcashNetDB net
|
||||
dbBlock <- getMaxBlock pool $ ZcashNetDB net
|
||||
chkBlock <- checkIntegrity dbPath zHost zPort net dbBlock 1
|
||||
syncChk <- isSyncing pool
|
||||
|
|
|
|||
|
|
@ -31,7 +31,7 @@ import ZcashHaskell.Types
|
|||
, fromRawTBundle
|
||||
)
|
||||
import ZcashHaskell.Utils (getBlockTime, makeZebraCall, readZebraTransaction)
|
||||
import Zenith.Core (checkBlockChain, syncWallet)
|
||||
import Zenith.Core (checkBlockChain, syncWallet, updateCommitmentTrees)
|
||||
import Zenith.DB
|
||||
( ZcashBlock(..)
|
||||
, ZcashBlockId
|
||||
|
|
@ -83,7 +83,7 @@ rescanZebra host port dbFilePath = do
|
|||
clearWalletData pool1
|
||||
_ <- startSync pool1
|
||||
dbBlock <- getMaxBlock pool1 znet
|
||||
b <- liftIO $ getMinBirthdayHeight pool1
|
||||
b <- liftIO $ getMinBirthdayHeight pool1 znet
|
||||
let sb = max dbBlock b
|
||||
if sb > zgb_blocks bStatus || sb < 1
|
||||
then liftIO $ throwIO $ userError "Invalid starting block for scan"
|
||||
|
|
@ -108,6 +108,7 @@ rescanZebra host port dbFilePath = do
|
|||
{-mapM_ (processBlock host port pool3 pg3 znet) bl3-}
|
||||
print "Please wait..."
|
||||
_ <- completeSync pool1 Successful
|
||||
_ <- runStderrLoggingT $ updateCommitmentTrees pool1 host port znet
|
||||
print "Rescan complete"
|
||||
|
||||
-- | Function to process a raw block and extract the transaction information
|
||||
|
|
|
|||
|
|
@ -15,7 +15,13 @@ 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 (MerklePath(..), OrchardFrontier(..), OrchardTree(..))
|
||||
import ZcashHaskell.Sapling (combineSaplingNodes, getSaplingNodeValue)
|
||||
import ZcashHaskell.Types
|
||||
( MerklePath(..)
|
||||
, OrchardFrontier(..)
|
||||
, OrchardTree(..)
|
||||
, SaplingTree(..)
|
||||
)
|
||||
|
||||
type Level = Int8
|
||||
|
||||
|
|
@ -33,6 +39,7 @@ class Node v where
|
|||
getLevel :: v -> Level
|
||||
getHash :: v -> HexString
|
||||
getPosition :: v -> Position
|
||||
getIndex :: v -> Int64
|
||||
isFull :: v -> Bool
|
||||
isMarked :: v -> Bool
|
||||
mkNode :: Level -> Position -> HexString -> v
|
||||
|
|
@ -45,6 +52,14 @@ instance Measured OrchardCommitment OrchardNode where
|
|||
Nothing -> OrchardNode 0 (hexString "00") 0 True 0 False
|
||||
Just val -> OrchardNode p val 0 True i False
|
||||
|
||||
type SaplingCommitment = HexString
|
||||
|
||||
instance Measured SaplingCommitment SaplingNode where
|
||||
measure sc p i =
|
||||
case getSaplingNodeValue (hexBytes sc) of
|
||||
Nothing -> SaplingNode 0 (hexString "00") 0 True 0 False
|
||||
Just val -> SaplingNode p val 0 True i False
|
||||
|
||||
data Tree v
|
||||
= EmptyLeaf
|
||||
| Leaf !v
|
||||
|
|
@ -88,7 +103,7 @@ instance (Monoid v, Node v) => Semigroup (Tree v) where
|
|||
| 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 s = InvalidTree
|
||||
| isFull (value x) = branch x (y <> Leaf w)
|
||||
| otherwise = branch (x <> Leaf w) y
|
||||
(<>) (Branch s x y) (Branch s1 x1 y1)
|
||||
|
|
@ -151,6 +166,101 @@ path pos (Branch s x y) =
|
|||
| otherwise = []
|
||||
path _ _ = Nothing
|
||||
|
||||
nullPath :: MerklePath
|
||||
nullPath = MerklePath 0 []
|
||||
|
||||
getNotePosition :: Monoid v => Node v => Tree v -> Int64 -> Maybe Position
|
||||
getNotePosition (Leaf x) i
|
||||
| getIndex x == i = Just $ getPosition x
|
||||
| otherwise = Nothing
|
||||
getNotePosition (Branch _ x y) i
|
||||
| getIndex (value x) >= i = getNotePosition x i
|
||||
| getIndex (value y) >= i = getNotePosition y i
|
||||
| otherwise = Nothing
|
||||
getNotePosition _ _ = Nothing
|
||||
|
||||
truncateTree :: Monoid v => Node v => Tree v -> Int64 -> Tree v
|
||||
truncateTree (Branch s x y) i
|
||||
| getLevel s == 1 && getIndex (value x) == i = branch x EmptyLeaf
|
||||
| getLevel s == 1 && getIndex (value y) == i = branch x y
|
||||
| getIndex (value x) >= i =
|
||||
branch (truncateTree x i) (getEmptyRoot (getLevel s))
|
||||
| getIndex (value y) >= i = branch x (truncateTree y i)
|
||||
truncateTree x _ = x
|
||||
|
||||
data SaplingNode = SaplingNode
|
||||
{ sn_position :: !Position
|
||||
, sn_value :: !HexString
|
||||
, sn_level :: !Level
|
||||
, sn_full :: !Bool
|
||||
, sn_index :: !Int64
|
||||
, sn_mark :: !Bool
|
||||
} deriving stock (Eq, GHC.Generic)
|
||||
deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
|
||||
deriving (BorshSize, ToBorsh, FromBorsh) via AsStruct SaplingNode
|
||||
|
||||
instance Semigroup SaplingNode where
|
||||
(<>) x y =
|
||||
case combineSaplingNodes (sn_level x) (sn_value x) (sn_value y) of
|
||||
Nothing -> x
|
||||
Just newHash ->
|
||||
SaplingNode
|
||||
(max (sn_position x) (sn_position y))
|
||||
newHash
|
||||
(1 + sn_level x)
|
||||
(sn_full x && sn_full y)
|
||||
(max (sn_index x) (sn_index y))
|
||||
(sn_mark x || sn_mark y)
|
||||
|
||||
instance Monoid SaplingNode where
|
||||
mempty = SaplingNode 0 (hexString "00") 0 False 0 False
|
||||
mappend = (<>)
|
||||
|
||||
instance Node SaplingNode where
|
||||
getLevel = sn_level
|
||||
getHash = sn_value
|
||||
getPosition = sn_position
|
||||
getIndex = sn_index
|
||||
isFull = sn_full
|
||||
isMarked = sn_mark
|
||||
mkNode l p v = SaplingNode p v l True 0 False
|
||||
|
||||
instance Show SaplingNode where
|
||||
show = show . sn_value
|
||||
|
||||
saplingSize :: SaplingTree -> Int64
|
||||
saplingSize tree =
|
||||
(if isNothing (st_left tree)
|
||||
then 0
|
||||
else 1) +
|
||||
(if isNothing (st_right tree)
|
||||
then 0
|
||||
else 1) +
|
||||
foldl
|
||||
(\x (i, p) ->
|
||||
case p of
|
||||
Nothing -> x + 0
|
||||
Just _ -> x + 2 ^ i)
|
||||
0
|
||||
(zip [1 ..] $ st_parents tree)
|
||||
|
||||
mkSaplingTree :: SaplingTree -> Tree SaplingNode
|
||||
mkSaplingTree tree =
|
||||
foldl
|
||||
(\t (i, n) ->
|
||||
case n of
|
||||
Just n' -> prunedBranch i 0 n' <> t
|
||||
Nothing -> t <> getEmptyRoot i)
|
||||
leafRoot
|
||||
(zip [1 ..] $ st_parents tree)
|
||||
where
|
||||
leafRoot =
|
||||
case st_right tree of
|
||||
Just r' -> leaf (fromJust $ st_left tree) (pos - 1) 0 <> leaf r' pos 0
|
||||
Nothing -> leaf (fromJust $ st_left tree) pos 0 <> EmptyLeaf
|
||||
pos = fromIntegral $ saplingSize tree - 1
|
||||
|
||||
-- | Orchard
|
||||
data OrchardNode = OrchardNode
|
||||
{ on_position :: !Position
|
||||
, on_value :: !HexString
|
||||
|
|
@ -186,6 +296,7 @@ instance Node OrchardNode where
|
|||
getLevel = on_level
|
||||
getHash = on_value
|
||||
getPosition = on_position
|
||||
getIndex = on_index
|
||||
isFull = on_full
|
||||
isMarked = on_mark
|
||||
mkNode l p v = OrchardNode p v l True 0 False
|
||||
|
|
|
|||
308
test/Spec.hs
308
test/Spec.hs
|
|
@ -7,6 +7,7 @@ import Data.Aeson
|
|||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Data.HexString
|
||||
import Data.List (foldl')
|
||||
import Data.Maybe (fromJust)
|
||||
import qualified Data.Text.Encoding as E
|
||||
import Database.Persist
|
||||
|
|
@ -28,7 +29,12 @@ import ZcashHaskell.Orchard
|
|||
import ZcashHaskell.Sapling
|
||||
( decodeSaplingOutputEsk
|
||||
, encodeSaplingAddress
|
||||
, getSaplingFrontier
|
||||
, getSaplingNotePosition
|
||||
, getSaplingPathAnchor
|
||||
, getSaplingRootTest
|
||||
, getSaplingTreeAnchor
|
||||
, getSaplingTreeParts
|
||||
, getSaplingWitness
|
||||
, isValidShieldedAddress
|
||||
, updateSaplingCommitmentTree
|
||||
|
|
@ -46,8 +52,10 @@ import ZcashHaskell.Types
|
|||
, OrchardTree(..)
|
||||
, Phrase(..)
|
||||
, SaplingCommitmentTree(..)
|
||||
, SaplingFrontier(..)
|
||||
, SaplingReceiver(..)
|
||||
, SaplingSpendingKey(..)
|
||||
, SaplingTree(..)
|
||||
, Scope(..)
|
||||
, ShieldedOutput(..)
|
||||
, TxError(..)
|
||||
|
|
@ -203,26 +211,236 @@ main = do
|
|||
a `shouldBe`
|
||||
Just
|
||||
"ztestsapling1tgjr4zppwk4ne8xy6gdq4z2gwq7dmf5jq8z2ctpn8nlmtse0a74fa5z0m8z383gmpgqz6q6duu4"
|
||||
describe "Witnesses" $ do
|
||||
describe "Sapling" $ do
|
||||
it "max output id" $ do
|
||||
pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db"
|
||||
sId <- getMaxSaplingNote pool
|
||||
sId `shouldBe` toSqlKey 0
|
||||
describe "Notes" $ do
|
||||
xit "Check Orchard notes" $ do
|
||||
pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db"
|
||||
oNotes <- getWalletUnspentOrchNotes pool (toSqlKey 1)
|
||||
oNotes `shouldBe` []
|
||||
xit "Check Sapling notes" $ do
|
||||
pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db"
|
||||
oNotes <- getWalletUnspentSapNotes pool (toSqlKey 4)
|
||||
oNotes `shouldBe` []
|
||||
xit "Check transparent notes" $ do
|
||||
pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db"
|
||||
oNotes <- getWalletUnspentTrNotes pool (toSqlKey 1)
|
||||
oNotes `shouldBe` []
|
||||
describe "Tree loading" $ do
|
||||
it "Sapling tree" $ do
|
||||
let tree =
|
||||
SaplingCommitmentTree $
|
||||
hexString
|
||||
"01b4a6049100dd1aa53fd850c388e0ed3782b039448aa43de5fd41d9e2419b375b0114abe3b473ac2dcd9ec3c62ff5cffb683f2e584d70ce4c1c118d67a8c34f1d691f00000000014278a19b3777ee0ceb48c4d469ab0a95217de56f27a4eaf9f19a90244bcff05301692acd3dd617e7cb44a17026211a31899cf27ef5960d59b8323ba105c754965800016f641fd51f68efae0cb742182483d97054bca8fcfb8036b1c165acdb0b27fc1b0000015965da8d105e2d412c7e13f920e607461c8cbb67a38b3a667898d1eaa064ba5701be82b8379a88cce7629153e0b3d1bf826782d3e0c367d615d362b479ead41d6401e1dbd43a62ac601d82de803fc3b6485182854056c6577bae231882b19184b03e000000018f624406b4ebda9ee13c062063e16f65ab5d725b80645037be7760e4ca7887730000000000000000000000000000"
|
||||
case getSaplingTreeParts tree of
|
||||
Nothing -> assertFailure "Failed to get tree parts"
|
||||
Just t1 -> do
|
||||
pool <- runNoLoggingT $ initPool "test.db"
|
||||
let newTree = mkSaplingTree t1
|
||||
_ <- upsertSaplingTree pool 2000 newTree
|
||||
readTree <- getSaplingTree pool
|
||||
case readTree of
|
||||
Nothing -> assertFailure "Couldn't retrieve tree from db"
|
||||
Just (t1, x) -> t1 `shouldBe` newTree
|
||||
it "Sapling tree update" $ do
|
||||
let tree =
|
||||
SaplingCommitmentTree $
|
||||
hexString
|
||||
"01b4a6049100dd1aa53fd850c388e0ed3782b039448aa43de5fd41d9e2419b375b0114abe3b473ac2dcd9ec3c62ff5cffb683f2e584d70ce4c1c118d67a8c34f1d691f00000000014278a19b3777ee0ceb48c4d469ab0a95217de56f27a4eaf9f19a90244bcff05301692acd3dd617e7cb44a17026211a31899cf27ef5960d59b8323ba105c754965800016f641fd51f68efae0cb742182483d97054bca8fcfb8036b1c165acdb0b27fc1b0000015965da8d105e2d412c7e13f920e607461c8cbb67a38b3a667898d1eaa064ba5701be82b8379a88cce7629153e0b3d1bf826782d3e0c367d615d362b479ead41d6401e1dbd43a62ac601d82de803fc3b6485182854056c6577bae231882b19184b03e000000018f624406b4ebda9ee13c062063e16f65ab5d725b80645037be7760e4ca7887730000000000000000000000000000"
|
||||
let cmu1 =
|
||||
hexString
|
||||
"238a75ea513eb330cee527d3fa5000cd52620f116919a33afb9ac78ee1f91c17" :: SaplingCommitment
|
||||
case getSaplingTreeParts tree of
|
||||
Nothing -> assertFailure "Failed to get tree parts"
|
||||
Just t1 -> do
|
||||
pool <- runNoLoggingT $ initPool "test.db"
|
||||
let newTree = mkSaplingTree t1
|
||||
_ <- upsertSaplingTree pool 2000 newTree
|
||||
let updatedTree = append newTree (cmu1, 4)
|
||||
_ <- upsertSaplingTree pool 2001 updatedTree
|
||||
readTree <- getSaplingTree pool
|
||||
case readTree of
|
||||
Nothing -> assertFailure "Couldn't retrieve tree from db"
|
||||
Just (t1, x) -> t1 `shouldBe` updatedTree
|
||||
it "Orchard tree" $ do
|
||||
let tree =
|
||||
OrchardCommitmentTree $
|
||||
hexString
|
||||
"0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000"
|
||||
let cmx1 =
|
||||
hexString
|
||||
"1712ead46028d4349e234abf59e94e0640fe7a0829e2e2e17e1a931631810400" :: OrchardCommitment
|
||||
case getOrchardTreeParts tree of
|
||||
Nothing -> assertFailure "Failed to get tree parts"
|
||||
Just t1 -> do
|
||||
pool <- runNoLoggingT $ initPool "test.db"
|
||||
let newTree = mkOrchardTree t1
|
||||
_ <- upsertOrchardTree pool 2000 newTree
|
||||
readTree <- getOrchardTree pool
|
||||
case readTree of
|
||||
Nothing -> assertFailure "Couldn't retrieve tree from db"
|
||||
Just (t1, x) -> t1 `shouldBe` newTree
|
||||
it "Orchard tree update" $ do
|
||||
let tree =
|
||||
OrchardCommitmentTree $
|
||||
hexString
|
||||
"0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000"
|
||||
let cmx1 =
|
||||
hexString
|
||||
"1712ead46028d4349e234abf59e94e0640fe7a0829e2e2e17e1a931631810400" :: OrchardCommitment
|
||||
case getOrchardTreeParts tree of
|
||||
Nothing -> assertFailure "Failed to get tree parts"
|
||||
Just t1 -> do
|
||||
pool <- runNoLoggingT $ initPool "test.db"
|
||||
let newTree = mkOrchardTree t1
|
||||
_ <- upsertOrchardTree pool 2000 newTree
|
||||
let updatedTree = append newTree (cmx1, 4)
|
||||
_ <- upsertOrchardTree pool 2001 updatedTree
|
||||
readTree <- getOrchardTree pool
|
||||
case readTree of
|
||||
Nothing -> assertFailure "Couldn't retrieve tree from db"
|
||||
Just (t1, x) -> t1 `shouldBe` updatedTree
|
||||
describe "Tree tests" $ do
|
||||
describe "Sapling" $ do
|
||||
let cmx1 =
|
||||
hexString
|
||||
"238a75ea513eb330cee527d3fa5000cd52620f116919a33afb9ac78ee1f91c17"
|
||||
let t0 = EmptyLeaf <> EmptyLeaf :: Tree SaplingNode
|
||||
let t1 = t0 <> EmptyLeaf :: Tree SaplingNode
|
||||
let t1a = t0 <> t0
|
||||
it "Create leaf" $ do
|
||||
let n = leaf cmx1 0 0 :: Tree SaplingNode
|
||||
getLevel (value n) `shouldBe` 0
|
||||
it "Create minimal tree" $ do
|
||||
let t = leaf cmx1 0 0 <> EmptyLeaf :: Tree SaplingNode
|
||||
getLevel (value t) `shouldBe` 1
|
||||
it "Create minimal empty tree" $ do
|
||||
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
|
||||
getHash (value (getEmptyRoot 32 :: Tree SaplingNode)) `shouldBe`
|
||||
getSaplingRootTest 32
|
||||
it "Validate size of tree from Zebra" $ do
|
||||
let tree =
|
||||
SaplingCommitmentTree $
|
||||
hexString
|
||||
"01b4a6049100dd1aa53fd850c388e0ed3782b039448aa43de5fd41d9e2419b375b0114abe3b473ac2dcd9ec3c62ff5cffb683f2e584d70ce4c1c118d67a8c34f1d691f00000000014278a19b3777ee0ceb48c4d469ab0a95217de56f27a4eaf9f19a90244bcff05301692acd3dd617e7cb44a17026211a31899cf27ef5960d59b8323ba105c754965800016f641fd51f68efae0cb742182483d97054bca8fcfb8036b1c165acdb0b27fc1b0000015965da8d105e2d412c7e13f920e607461c8cbb67a38b3a667898d1eaa064ba5701be82b8379a88cce7629153e0b3d1bf826782d3e0c367d615d362b479ead41d6401e1dbd43a62ac601d82de803fc3b6485182854056c6577bae231882b19184b03e000000018f624406b4ebda9ee13c062063e16f65ab5d725b80645037be7760e4ca7887730000000000000000000000000000"
|
||||
case getSaplingTreeParts tree of
|
||||
Nothing -> assertFailure "Failed to get parts"
|
||||
Just t1 -> do
|
||||
case getSaplingFrontier tree of
|
||||
Nothing -> assertFailure "Failed to get frontier"
|
||||
Just f1 -> do
|
||||
saplingSize t1 `shouldBe` 1 + fromIntegral (sf_pos f1)
|
||||
it "Deserialize commitment tree from Zebra" $ do
|
||||
let tree =
|
||||
SaplingCommitmentTree $
|
||||
hexString
|
||||
"01b4a6049100dd1aa53fd850c388e0ed3782b039448aa43de5fd41d9e2419b375b0114abe3b473ac2dcd9ec3c62ff5cffb683f2e584d70ce4c1c118d67a8c34f1d691f00000000014278a19b3777ee0ceb48c4d469ab0a95217de56f27a4eaf9f19a90244bcff05301692acd3dd617e7cb44a17026211a31899cf27ef5960d59b8323ba105c754965800016f641fd51f68efae0cb742182483d97054bca8fcfb8036b1c165acdb0b27fc1b0000015965da8d105e2d412c7e13f920e607461c8cbb67a38b3a667898d1eaa064ba5701be82b8379a88cce7629153e0b3d1bf826782d3e0c367d615d362b479ead41d6401e1dbd43a62ac601d82de803fc3b6485182854056c6577bae231882b19184b03e000000018f624406b4ebda9ee13c062063e16f65ab5d725b80645037be7760e4ca7887730000000000000000000000000000"
|
||||
case getSaplingTreeParts tree of
|
||||
Nothing -> assertFailure "Failed to get frontier"
|
||||
Just t1 -> do
|
||||
length (st_parents t1) `shouldBe` 31
|
||||
it "Create commitment tree from Zebra" $ do
|
||||
let tree =
|
||||
SaplingCommitmentTree $
|
||||
hexString
|
||||
"01b4a6049100dd1aa53fd850c388e0ed3782b039448aa43de5fd41d9e2419b375b0114abe3b473ac2dcd9ec3c62ff5cffb683f2e584d70ce4c1c118d67a8c34f1d691f00000000014278a19b3777ee0ceb48c4d469ab0a95217de56f27a4eaf9f19a90244bcff05301692acd3dd617e7cb44a17026211a31899cf27ef5960d59b8323ba105c754965800016f641fd51f68efae0cb742182483d97054bca8fcfb8036b1c165acdb0b27fc1b0000015965da8d105e2d412c7e13f920e607461c8cbb67a38b3a667898d1eaa064ba5701be82b8379a88cce7629153e0b3d1bf826782d3e0c367d615d362b479ead41d6401e1dbd43a62ac601d82de803fc3b6485182854056c6577bae231882b19184b03e000000018f624406b4ebda9ee13c062063e16f65ab5d725b80645037be7760e4ca7887730000000000000000000000000000"
|
||||
case getSaplingTreeParts tree of
|
||||
Nothing -> assertFailure "Failed to get tree parts"
|
||||
Just t1 -> do
|
||||
let newTree = mkSaplingTree t1
|
||||
getLevel (value newTree) `shouldBe` 32
|
||||
it "Validate commitment tree from Zebra" $ do
|
||||
let tree =
|
||||
SaplingCommitmentTree $
|
||||
hexString
|
||||
"01b4a6049100dd1aa53fd850c388e0ed3782b039448aa43de5fd41d9e2419b375b0114abe3b473ac2dcd9ec3c62ff5cffb683f2e584d70ce4c1c118d67a8c34f1d691f00000000014278a19b3777ee0ceb48c4d469ab0a95217de56f27a4eaf9f19a90244bcff05301692acd3dd617e7cb44a17026211a31899cf27ef5960d59b8323ba105c754965800016f641fd51f68efae0cb742182483d97054bca8fcfb8036b1c165acdb0b27fc1b0000015965da8d105e2d412c7e13f920e607461c8cbb67a38b3a667898d1eaa064ba5701be82b8379a88cce7629153e0b3d1bf826782d3e0c367d615d362b479ead41d6401e1dbd43a62ac601d82de803fc3b6485182854056c6577bae231882b19184b03e000000018f624406b4ebda9ee13c062063e16f65ab5d725b80645037be7760e4ca7887730000000000000000000000000000"
|
||||
case getSaplingTreeParts tree of
|
||||
Nothing -> assertFailure "Failed to get tree parts"
|
||||
Just t1 -> do
|
||||
let newTree = mkSaplingTree t1
|
||||
let ctAnchor = getSaplingTreeAnchor tree
|
||||
{-
|
||||
-getHash (value newTree) `shouldBe` ctAnchor
|
||||
-isFull (value newTree) `shouldBe` False
|
||||
-}
|
||||
getPosition (value newTree) `shouldBe` 145761
|
||||
it "Validate appending nodes to tree" $ do
|
||||
let tree =
|
||||
SaplingCommitmentTree $
|
||||
hexString
|
||||
"01b4a6049100dd1aa53fd850c388e0ed3782b039448aa43de5fd41d9e2419b375b0114abe3b473ac2dcd9ec3c62ff5cffb683f2e584d70ce4c1c118d67a8c34f1d691f00000000014278a19b3777ee0ceb48c4d469ab0a95217de56f27a4eaf9f19a90244bcff05301692acd3dd617e7cb44a17026211a31899cf27ef5960d59b8323ba105c754965800016f641fd51f68efae0cb742182483d97054bca8fcfb8036b1c165acdb0b27fc1b0000015965da8d105e2d412c7e13f920e607461c8cbb67a38b3a667898d1eaa064ba5701be82b8379a88cce7629153e0b3d1bf826782d3e0c367d615d362b479ead41d6401e1dbd43a62ac601d82de803fc3b6485182854056c6577bae231882b19184b03e000000018f624406b4ebda9ee13c062063e16f65ab5d725b80645037be7760e4ca7887730000000000000000000000000000"
|
||||
let cmu1 =
|
||||
hexString
|
||||
"238a75ea513eb330cee527d3fa5000cd52620f116919a33afb9ac78ee1f91c17" :: SaplingCommitment
|
||||
let finalTree =
|
||||
SaplingCommitmentTree $
|
||||
hexString
|
||||
"01238a75ea513eb330cee527d3fa5000cd52620f116919a33afb9ac78ee1f91c17001f01fff1bcef0a4485a0beafb4813a3fd7fc7402c5efde08f56a8bb9ac99aa25ef4e000000014278a19b3777ee0ceb48c4d469ab0a95217de56f27a4eaf9f19a90244bcff05301692acd3dd617e7cb44a17026211a31899cf27ef5960d59b8323ba105c754965800016f641fd51f68efae0cb742182483d97054bca8fcfb8036b1c165acdb0b27fc1b0000015965da8d105e2d412c7e13f920e607461c8cbb67a38b3a667898d1eaa064ba5701be82b8379a88cce7629153e0b3d1bf826782d3e0c367d615d362b479ead41d6401e1dbd43a62ac601d82de803fc3b6485182854056c6577bae231882b19184b03e000000018f624406b4ebda9ee13c062063e16f65ab5d725b80645037be7760e4ca7887730000000000000000000000000000"
|
||||
case getSaplingTreeParts tree of
|
||||
Nothing -> assertFailure "Failed to get tree parts"
|
||||
Just t1 -> do
|
||||
let newTree = mkSaplingTree t1
|
||||
let updatedTree1 = append newTree (cmu1, 4)
|
||||
let finalAnchor = getSaplingTreeAnchor finalTree
|
||||
getHash (value updatedTree1) `shouldBe` finalAnchor
|
||||
it "Validate serializing tree to bytes" $ do
|
||||
let tree =
|
||||
SaplingCommitmentTree $
|
||||
hexString
|
||||
"01b4a6049100dd1aa53fd850c388e0ed3782b039448aa43de5fd41d9e2419b375b0114abe3b473ac2dcd9ec3c62ff5cffb683f2e584d70ce4c1c118d67a8c34f1d691f00000000014278a19b3777ee0ceb48c4d469ab0a95217de56f27a4eaf9f19a90244bcff05301692acd3dd617e7cb44a17026211a31899cf27ef5960d59b8323ba105c754965800016f641fd51f68efae0cb742182483d97054bca8fcfb8036b1c165acdb0b27fc1b0000015965da8d105e2d412c7e13f920e607461c8cbb67a38b3a667898d1eaa064ba5701be82b8379a88cce7629153e0b3d1bf826782d3e0c367d615d362b479ead41d6401e1dbd43a62ac601d82de803fc3b6485182854056c6577bae231882b19184b03e000000018f624406b4ebda9ee13c062063e16f65ab5d725b80645037be7760e4ca7887730000000000000000000000000000"
|
||||
case mkSaplingTree <$> getSaplingTreeParts 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 =
|
||||
SaplingCommitmentTree $
|
||||
hexString
|
||||
"01b4a6049100dd1aa53fd850c388e0ed3782b039448aa43de5fd41d9e2419b375b0114abe3b473ac2dcd9ec3c62ff5cffb683f2e584d70ce4c1c118d67a8c34f1d691f00000000014278a19b3777ee0ceb48c4d469ab0a95217de56f27a4eaf9f19a90244bcff05301692acd3dd617e7cb44a17026211a31899cf27ef5960d59b8323ba105c754965800016f641fd51f68efae0cb742182483d97054bca8fcfb8036b1c165acdb0b27fc1b0000015965da8d105e2d412c7e13f920e607461c8cbb67a38b3a667898d1eaa064ba5701be82b8379a88cce7629153e0b3d1bf826782d3e0c367d615d362b479ead41d6401e1dbd43a62ac601d82de803fc3b6485182854056c6577bae231882b19184b03e000000018f624406b4ebda9ee13c062063e16f65ab5d725b80645037be7760e4ca7887730000000000000000000000000000"
|
||||
case mkSaplingTree <$> getSaplingTreeParts tree of
|
||||
Nothing -> assertFailure "Failed to build tree"
|
||||
Just t1 -> do
|
||||
let treeBytes = serialiseBorsh t1
|
||||
let rebuiltTree = deserialiseBorsh treeBytes
|
||||
rebuiltTree `shouldBe` Right t1
|
||||
it "Create merkle path" $ do
|
||||
let tree =
|
||||
SaplingCommitmentTree $
|
||||
hexString
|
||||
"01b4a6049100dd1aa53fd850c388e0ed3782b039448aa43de5fd41d9e2419b375b0114abe3b473ac2dcd9ec3c62ff5cffb683f2e584d70ce4c1c118d67a8c34f1d691f00000000014278a19b3777ee0ceb48c4d469ab0a95217de56f27a4eaf9f19a90244bcff05301692acd3dd617e7cb44a17026211a31899cf27ef5960d59b8323ba105c754965800016f641fd51f68efae0cb742182483d97054bca8fcfb8036b1c165acdb0b27fc1b0000015965da8d105e2d412c7e13f920e607461c8cbb67a38b3a667898d1eaa064ba5701be82b8379a88cce7629153e0b3d1bf826782d3e0c367d615d362b479ead41d6401e1dbd43a62ac601d82de803fc3b6485182854056c6577bae231882b19184b03e000000018f624406b4ebda9ee13c062063e16f65ab5d725b80645037be7760e4ca7887730000000000000000000000000000"
|
||||
let cmu1 =
|
||||
hexString
|
||||
"238a75ea513eb330cee527d3fa5000cd52620f116919a33afb9ac78ee1f91c17" :: SaplingCommitment
|
||||
case getSaplingTreeParts tree of
|
||||
Nothing -> assertFailure "Failed to get tree parts"
|
||||
Just t1 -> do
|
||||
let newTree = mkSaplingTree t1
|
||||
let updatedTree = append newTree (cmu1, 4)
|
||||
case path 145762 updatedTree of
|
||||
Nothing -> assertFailure "Failed to get Merkle path"
|
||||
Just p1 -> p1 `shouldNotBe` MerklePath 0 []
|
||||
it "Validate merkle path" $ do
|
||||
let tree =
|
||||
SaplingCommitmentTree $
|
||||
hexString
|
||||
"01b4a6049100dd1aa53fd850c388e0ed3782b039448aa43de5fd41d9e2419b375b0114abe3b473ac2dcd9ec3c62ff5cffb683f2e584d70ce4c1c118d67a8c34f1d691f00000000014278a19b3777ee0ceb48c4d469ab0a95217de56f27a4eaf9f19a90244bcff05301692acd3dd617e7cb44a17026211a31899cf27ef5960d59b8323ba105c754965800016f641fd51f68efae0cb742182483d97054bca8fcfb8036b1c165acdb0b27fc1b0000015965da8d105e2d412c7e13f920e607461c8cbb67a38b3a667898d1eaa064ba5701be82b8379a88cce7629153e0b3d1bf826782d3e0c367d615d362b479ead41d6401e1dbd43a62ac601d82de803fc3b6485182854056c6577bae231882b19184b03e000000018f624406b4ebda9ee13c062063e16f65ab5d725b80645037be7760e4ca7887730000000000000000000000000000"
|
||||
let cmu1 =
|
||||
hexString
|
||||
"238a75ea513eb330cee527d3fa5000cd52620f116919a33afb9ac78ee1f91c17" :: SaplingCommitment
|
||||
case getSaplingTreeParts tree of
|
||||
Nothing -> assertFailure "Failed to get tree parts"
|
||||
Just t1 -> do
|
||||
let newTree = mkSaplingTree t1
|
||||
let updatedTree = append newTree (cmu1, 4)
|
||||
case path 145762 updatedTree of
|
||||
Nothing -> assertFailure "Failed to get Merkle path"
|
||||
Just p1 ->
|
||||
getSaplingPathAnchor cmu1 p1 `shouldBe`
|
||||
getHash (value updatedTree)
|
||||
it "Find position by index" $ do
|
||||
let tree =
|
||||
SaplingCommitmentTree $
|
||||
hexString
|
||||
"01b4a6049100dd1aa53fd850c388e0ed3782b039448aa43de5fd41d9e2419b375b0114abe3b473ac2dcd9ec3c62ff5cffb683f2e584d70ce4c1c118d67a8c34f1d691f00000000014278a19b3777ee0ceb48c4d469ab0a95217de56f27a4eaf9f19a90244bcff05301692acd3dd617e7cb44a17026211a31899cf27ef5960d59b8323ba105c754965800016f641fd51f68efae0cb742182483d97054bca8fcfb8036b1c165acdb0b27fc1b0000015965da8d105e2d412c7e13f920e607461c8cbb67a38b3a667898d1eaa064ba5701be82b8379a88cce7629153e0b3d1bf826782d3e0c367d615d362b479ead41d6401e1dbd43a62ac601d82de803fc3b6485182854056c6577bae231882b19184b03e000000018f624406b4ebda9ee13c062063e16f65ab5d725b80645037be7760e4ca7887730000000000000000000000000000"
|
||||
let cmu1 =
|
||||
hexString
|
||||
"238a75ea513eb330cee527d3fa5000cd52620f116919a33afb9ac78ee1f91c17" :: SaplingCommitment
|
||||
case getSaplingTreeParts tree of
|
||||
Nothing -> assertFailure "Failed to get tree parts"
|
||||
Just t1 -> do
|
||||
let newTree = mkSaplingTree t1
|
||||
let updatedTree = append newTree (cmu1, 4)
|
||||
getNotePosition updatedTree 4 `shouldBe` Just 145762
|
||||
describe "Orchard" $ do
|
||||
let cmx1 =
|
||||
hexString
|
||||
"1712ead46028d4349e234abf59e94e0640fe7a0829e2e2e17e1a931631810400"
|
||||
|
|
@ -387,6 +605,58 @@ main = do
|
|||
Just p1 -> do
|
||||
getOrchardPathAnchor cmx2 p1 `shouldBe`
|
||||
getHash (value updatedTree)
|
||||
it "Find position by index" $ 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)]
|
||||
getNotePosition updatedTree 4 `shouldBe` Just 39734
|
||||
it "Truncate tree" $ 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)]
|
||||
let truncTree = truncateTree updatedTree 4
|
||||
getIndex (value truncTree) `shouldBe` 4
|
||||
it "Validate tree from DB" $ do
|
||||
pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db"
|
||||
dbTree <- getOrchardTree pool
|
||||
case dbTree of
|
||||
Nothing -> assertFailure "failed to get tree from DB"
|
||||
Just (oTree, oSync) -> do
|
||||
zebraTrees <-
|
||||
getCommitmentTrees
|
||||
pool
|
||||
"localhost"
|
||||
18232
|
||||
(ZcashNetDB TestNet)
|
||||
oSync
|
||||
let finalAnchor =
|
||||
getOrchardTreeAnchor $
|
||||
OrchardCommitmentTree $ ztiOrchard zebraTrees
|
||||
getHash (value oTree) `shouldBe` finalAnchor
|
||||
describe "Creating Tx" $ do
|
||||
describe "Full" $ do
|
||||
it "To Orchard" $ do
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
Subproject commit 62cda9cc15621dead6fbfd7a4944840408d69da4
|
||||
Subproject commit dea960c2acf7479eeb42845c07b482449d538aae
|
||||
Loading…
Reference in a new issue