diff --git a/.gitignore b/.gitignore index 00967d7..938bae6 100644 --- a/.gitignore +++ b/.gitignore @@ -5,3 +5,7 @@ zenith.db zenith.log zenith.db-shm zenith.db-wal +test.db +test.db-shm +test.db-wal + diff --git a/.gitmodules b/.gitmodules index 8a74eac..601b93a 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,4 +1,4 @@ [submodule "zcash-haskell"] path = zcash-haskell url = https://git.vergara.tech/Vergara_Tech/zcash-haskell.git - branch = milestone2 + branch = master diff --git a/CHANGELOG.md b/CHANGELOG.md index a58632b..3f041b4 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,7 +5,7 @@ All notable changes to this project will be documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). -## [Unreleased] +## [0.7.0.0-beta] ### Added @@ -20,13 +20,20 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - `getnewaccount` RPC method - `getnewaddress` RPC method - `getoperationstatus` RPC method + - `sendmany` RPC method - Function `prepareTxV2` implementing `PrivacyPolicy` +- Support for TEX addresses +- Functionality to shield transparent balance +- Functionality to de-shield shielded notes +- Native commitment trees + - Batch append to trees in O(log n) ### Changed - Detection of changes in database schema for automatic re-scan - Block tracking for chain re-org detection - Refactored `ZcashPool` +- Preventing write operations to occur during wallet sync ## [0.6.0.0-beta] diff --git a/app/Main.hs b/app/Main.hs index f3d4b4c..acad309 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -210,9 +210,18 @@ main = do zebraPort <- require config "zebraPort" zebraHost <- require config "zebraHost" nodePort <- require config "nodePort" + currencyCode <- require config "currencyCode" dbFP <- getZenithPath let dbFilePath = T.pack $ dbFP ++ dbFileName - let myConfig = Config dbFilePath zebraHost zebraPort nodeUser nodePwd nodePort + let myConfig = + Config + dbFilePath + zebraHost + zebraPort + nodeUser + nodePwd + nodePort + currencyCode if not (null args) then do case head args diff --git a/app/Server.hs b/app/Server.hs index ea64684..827419d 100644 --- a/app/Server.hs +++ b/app/Server.hs @@ -2,28 +2,51 @@ module Server where -import Control.Exception (throwIO, try) -import Control.Monad (when) +import Control.Concurrent (forkIO, threadDelay) +import Control.Exception (throwIO, throwTo, try) +import Control.Monad (forever, when) +import Control.Monad.Logger (runNoLoggingT) import Data.Configurator +import qualified Data.Text as T import Network.Wai.Handler.Warp (run) import Servant +import System.Exit +import System.Posix.Signals import ZcashHaskell.Types (ZebraGetBlockChainInfo(..), ZebraGetInfo(..)) import Zenith.Core (checkBlockChain, checkZebra) -import Zenith.DB (initDb) -import Zenith.RPC (State(..), ZenithRPC(..), authenticate, zenithServer) +import Zenith.DB (getWallets, initDb, initPool) +import Zenith.RPC + ( State(..) + , ZenithRPC(..) + , authenticate + , scanZebra + , zenithServer + ) import Zenith.Scanner (rescanZebra) import Zenith.Types (Config(..)) +import Zenith.Utils (getZenithPath) main :: IO () main = do config <- load ["$(HOME)/Zenith/zenith.cfg"] - dbFilePath <- require config "dbFilePath" + dbFileName <- require config "dbFileName" nodeUser <- require config "nodeUser" nodePwd <- require config "nodePwd" zebraPort <- require config "zebraPort" zebraHost <- require config "zebraHost" nodePort <- require config "nodePort" - let myConfig = Config dbFilePath zebraHost zebraPort nodeUser nodePwd nodePort + currencyCode <- require config "currencyCode" + dbFP <- getZenithPath + let dbFilePath = T.pack $ dbFP ++ dbFileName + let myConfig = + Config + dbFilePath + zebraHost + zebraPort + nodeUser + nodePwd + nodePort + currencyCode let ctx = authenticate myConfig :. EmptyContext w <- try $ checkZebra zebraHost zebraPort :: IO (Either IOError ZebraGetInfo) case w of @@ -39,16 +62,39 @@ main = do Left e2 -> throwIO $ userError e2 Right x' -> do when x' $ rescanZebra zebraHost zebraPort dbFilePath - let myState = - State - (zgb_net chainInfo) - zebraHost - zebraPort - dbFilePath - (zgi_build zebra) - (zgb_blocks chainInfo) - run nodePort $ - serveWithContext - (Proxy :: Proxy ZenithRPC) - ctx - (zenithServer myState) + pool <- runNoLoggingT $ initPool dbFilePath + walList <- getWallets pool $ zgb_net chainInfo + if not (null walList) + then do + scanThread <- + forkIO $ + forever $ do + _ <- + scanZebra + dbFilePath + zebraHost + zebraPort + (zgb_net chainInfo) + threadDelay 90000000 + putStrLn "Zenith RPC Server 0.7.0.0-beta" + putStrLn "------------------------------" + putStrLn $ + "Connected to " ++ + show (zgb_net chainInfo) ++ + " Zebra " ++ + T.unpack (zgi_build zebra) ++ " on port " ++ show zebraPort + let myState = + State + (zgb_net chainInfo) + zebraHost + zebraPort + dbFilePath + (zgi_build zebra) + (zgb_blocks chainInfo) + run nodePort $ + serveWithContext + (Proxy :: Proxy ZenithRPC) + ctx + (zenithServer myState) + else putStrLn + "No wallets available. Please start Zenith interactively to create a wallet" diff --git a/sapling-output.params b/sapling-output.params deleted file mode 100644 index 01760fa..0000000 Binary files a/sapling-output.params and /dev/null differ diff --git a/sapling-spend.params b/sapling-spend.params deleted file mode 100644 index b91cd77..0000000 Binary files a/sapling-spend.params and /dev/null differ diff --git a/src/Zenith/CLI.hs b/src/Zenith/CLI.hs index baa61f4..c48de3c 100644 --- a/src/Zenith/CLI.hs +++ b/src/Zenith/CLI.hs @@ -2,6 +2,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} module Zenith.CLI where @@ -62,17 +63,19 @@ import qualified Brick.Widgets.List as L import qualified Brick.Widgets.ProgressBar as P import Control.Concurrent (forkIO, threadDelay) import Control.Exception (throw, throwIO, try) -import Control.Monad (forever, unless, void, when) +import Control.Monad (forM_, forever, unless, void, when) import Control.Monad.IO.Class (liftIO) import Control.Monad.Logger ( LoggingT + , NoLoggingT , logDebugN - , runFileLoggingT , runNoLoggingT + , runStderrLoggingT ) import Data.Aeson import Data.HexString (HexString(..), toText) import Data.Maybe +import Data.Scientific (Scientific, scientific) import qualified Data.Text as T import qualified Data.Text.Encoding as E import Data.Time.Clock.POSIX (posixSecondsToUTCTime) @@ -86,10 +89,23 @@ import Lens.Micro.Mtl import Lens.Micro.TH import System.Hclip import Text.Printf -import Text.Wrap (FillScope(..), FillStrategy(..), WrapSettings(..)) +import Text.Wrap + ( FillScope(..) + , FillStrategy(..) + , WrapSettings(..) + , defaultWrapSettings + , wrapTextToLines + ) import ZcashHaskell.Keys (generateWalletSeedPhrase) -import ZcashHaskell.Orchard (getSaplingFromUA, isValidUnifiedAddress) -import ZcashHaskell.Transparent (encodeTransparentReceiver) +import ZcashHaskell.Orchard + ( getSaplingFromUA + , isValidUnifiedAddress + , parseAddress + ) +import ZcashHaskell.Transparent + ( decodeTransparentAddress + , encodeTransparentReceiver + ) import ZcashHaskell.Types import ZcashHaskell.Utils (getBlockTime, makeZebraCall) import Zenith.Core @@ -100,17 +116,21 @@ import Zenith.Types , HexStringDB(..) , PhraseDB(..) , PrivacyPolicy(..) - , UnifiedAddressDB(..) - , ZcashNetDB(..) + , ProposedNote(..) , ShieldDeshieldOp(..) + , UnifiedAddressDB(..) + , ValidAddressAPI(..) + , ZcashNetDB(..) + , ZenithStatus(..) ) import Zenith.Utils ( displayTaz , displayZec + , getChainTip + , getZcashPrice , isRecipientValid , isRecipientValidGUI , jsonNumber - , parseAddressUA , showAddress , validBarValue ) @@ -133,10 +153,11 @@ data Name | PrivacyLowField | PrivacyMediumField | PrivacyFullField - | ShieldField + | ShieldField | DeshieldField | TotalTranspField | TotalShieldedField + | SFBViewPort deriving (Eq, Show, Ord) data DialogInput = DialogInput @@ -147,7 +168,7 @@ makeLenses ''DialogInput data SendInput = SendInput { _sendTo :: !T.Text - , _sendAmt :: !Float + , _sendAmt :: !Scientific , _sendMemo :: !T.Text , _policyField :: !PrivacyPolicy } deriving (Show) @@ -161,14 +182,19 @@ data AdrBookEntry = AdrBookEntry makeLenses ''AdrBookEntry -data ShDshEntry = ShDshEntry - { _totalTransparent :: !Float - , _totalShielded :: !Float - , _shAmt :: !Float - } deriving (Show) +newtype ShDshEntry = ShDshEntry + { _shAmt :: Scientific + } deriving (Show) makeLenses ''ShDshEntry +data PaymentInput = PaymentInput + { _pmtAmt :: !Scientific + , _pmtMemo :: !T.Text + } deriving (Show) + +makeLenses ''PaymentInput + data DialogType = WName | AName @@ -181,8 +207,12 @@ data DialogType | AdrBookForm | AdrBookUpdForm | AdrBookDelForm - | DeshieldForm + | DeshieldForm | ShieldForm + | ShowFIATBalance + | ViewingKeyMenu + | ViewingKeyShow + | PaymentURIShow data DisplayType = AddrDisplay @@ -200,7 +230,7 @@ data Tick | TickMsg !String | TickTx !HexString -data DropDownItem = +newtype DropDownItem = DropdownItem String data State = State @@ -232,11 +262,35 @@ data State = State , _sentTx :: !(Maybe HexString) , _unconfBalance :: !Integer , _deshieldForm :: !(Form ShDshEntry () Name) - , _shieldForm :: !(Form ShDshEntry () Name) + , _tBalance :: !Integer + , _sBalance :: !Integer + , _currencyCode :: !T.Text + , _zprice :: !Double + , _vkName :: !T.Text + , _vkData :: !T.Text + , _pmtURIForm :: !(Form PaymentInput () Name) } makeLenses ''State +zBalance :: State -> Double +zBalance st = (fromIntegral (st ^. balance)) / 100000000 + +-- Function to split text into fixed-size chunks +splitText :: Int -> T.Text -> [T.Text] +splitText chunkSize text = + let strippedText = T.filter (/= '\n') text -- Remove newlines + in if T.null strippedText + then [] + else T.take chunkSize strippedText : + splitText chunkSize (T.drop chunkSize strippedText) + +-- Create a widget to display the long text +renderLongText :: Int -> T.Text -> Widget Name +renderLongText lineLength longText = + let linesOfText = splitText lineLength longText + in vBox $ map txt linesOfText + drawUI :: State -> [Widget Name] drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] where @@ -249,11 +303,11 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] (" Zenith - " <> show (st ^. network) <> " - " <> - (T.unpack - (maybe - "(None)" - (\(_, w) -> zcashWalletName $ entityVal w) - (L.listSelectedElement (st ^. wallets)))) ++ + T.unpack + (maybe + "(None)" + (\(_, w) -> zcashWalletName $ entityVal w) + (L.listSelectedElement (st ^. wallets))) ++ " ")) (C.hCenter (str @@ -280,25 +334,30 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] (C.hCenter (str ("Last block seen: " ++ show (st ^. syncBlock) ++ "\n")) <=> listTxBox " Transactions " (st ^. network) (st ^. transactions))) <=> - (vBox - [C.hCenter - (hBox - [ capCommand "W" "allets" - , capCommand "A" "ccounts" - , capCommand "V" "iew address" - , capCommand3 "" "S" "end Tx" - ]) - ,C.hCenter - (hBox - [ capCommand2 "Address " "B" "ook" - , capCommand2 "s" "H" "ield" - , capCommand "D" "e-shield" - , capCommand "Q" "uit" - , capCommand "?" " Help" - , str $ show (st ^. timer) - ]) - ] - ) + (vBox + [ C.hCenter + (hBox + [ capCommand "W" "allets" + , capCommand "A" "ccounts" + , capCommand "V" "iew address" + , capCommand "S" "end Tx" + , capCommand2 "Gen " "U" "RI" + , capCommand3 + "ba" + "L" + ("ance (" ++ (T.unpack (st ^. currencyCode)) ++ ")") + ]) + , C.hCenter + (hBox + [ capCommand2 "Address " "B" "ook" + , capCommand2 "s" "H" "ield" + , capCommand "D" "e-shield" + , capCommand2 "Viewing " "K" "eys" + , capCommand "Q" "uit" + , capCommand "?" " Help" + , str $ show (st ^. timer) + ]) + ]) listBox :: Show e => String -> L.List Name e -> Widget Name listBox titleLabel l = C.vCenter $ @@ -364,7 +423,9 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] else emptyWidget where keyList = - map (C.hCenter . str) ["?", "Esc", "w", "a", "v", "s", "b", "d", "q"] + map + (C.hCenter . str) + ["?", "Esc", "w", "a", "v", "s", "u", "b", "d", "k", "l", "q"] actionList = map (hLimit 40 . str) @@ -374,8 +435,11 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] , "Switch accounts" , "View address" , "Send Tx" + , "Gen URI" , "Address Book" , "Shield/De-Shield" + , "Viewing Keys" + , "Balance in Fiat" , "Quit" ] inputDialog :: State -> Widget Name @@ -422,18 +486,63 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] (renderForm (st ^. txForm) <=> C.hCenter (hBox [capCommand "↲ " "Send", capCommand " " "Cancel"])) + PaymentURIShow -> + D.renderDialog + (D.dialog (Just (str " Create Payment URI ")) Nothing 50) + (renderForm (st ^. pmtURIForm) <=> + C.hCenter + (hBox + [capCommand "P" "rocess", capCommand3 " " " " "Cancel"])) DeshieldForm -> D.renderDialog - (D.dialog (Just (str " De-Shield Zec ")) Nothing 50) - (renderForm (st ^. deshieldForm) <=> + (D.dialog (Just (str " De-Shield ZEC ")) Nothing 50) + (C.hCenter + (padAll 1 $ + vBox + [ str $ + "Transparent Bal.: " ++ + if st ^. network == MainNet + then displayZec (st ^. tBalance) + else displayTaz (st ^. tBalance) + , str $ + "Shielded Bal.: " ++ + if st ^. network == MainNet + then displayZec (st ^. sBalance) + else displayTaz (st ^. sBalance) + ]) <=> + renderForm (st ^. deshieldForm) <=> C.hCenter (hBox [capCommand "P" "roceed", capCommand " " "Cancel"])) ShieldForm -> D.renderDialog - (D.dialog (Just (str " Shield Zec ")) Nothing 50) - (renderForm (st ^. shieldForm) <=> + (D.dialog (Just (str " Shield ZEC ")) Nothing 50) + (C.hCenter + (str $ + "Shield " ++ + if st ^. network == MainNet + then displayZec (st ^. tBalance) + else displayTaz (st ^. tBalance) ++ "?") <=> C.hCenter (hBox [capCommand "P" "roceed", capCommand " " "Cancel"])) + ViewingKeyShow -> + D.renderDialog + (D.dialog + (Just (str (" " ++ (T.unpack (st ^. vkName)) ++ " Viewing Key "))) + Nothing + 50) + (padAll 1 (C.hCenter (renderLongText 45 (st ^. vkData))) <=> + C.hCenter + (hBox + [capCommand "C" "opy to Clipoard", capCommand3 "" "E" "xit"])) + ViewingKeyMenu -> + D.renderDialog + (D.dialog (Just (str " Viewing Keys ")) Nothing 50) + (C.hCenter + (hBox + [ capCommand "F" "ull" + , capCommand "I" "ncoming" + , capCommand3 "" "E" "xit" + ])) Blank -> emptyWidget -- Address Book List AdrBook -> @@ -486,7 +595,51 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] [ capCommand "C" "onfirm delete" , capCommand3 "" "" " Cancel" ])) - -- + -- Show Balance in FIAT form + ShowFIATBalance -> + D.renderDialog + (D.dialog + (Just $ + str + (" Account Balance (" ++ + (T.unpack (st ^. currencyCode)) ++ ") ")) + Nothing + 60) + (withAttr abDefAttr $ + setAvailableSize (50, 8) $ + viewport SFBViewPort BT.Vertical $ + vLimit 8 $ + hLimit 50 $ + vBox $ + [ vLimit 4 $ + hLimit 50 $ + vBox $ + [ C.hCenter (str $ " ") + , C.hCenter + (str $ + "1 ZEC = " ++ + (printf "%.2f" (s ^. zprice)) ++ + " " ++ (T.unpack (s ^. currencyCode))) + , C.hCenter (str $ " ") + , C.hCenter + (str $ + " Balance: " ++ + (printf "%.8f" $ zBalance s) ++ + " ZEC ==> " ++ + (printf "%.2f" ((s ^. zprice) * (zBalance s)) ++ + " " ++ (T.unpack (s ^. currencyCode)))) + ] + , padTop Max $ + vLimit 4 $ + hLimit 50 $ + withAttr abMBarAttr $ + vBox $ + [ C.hCenter (str " ") + , C.hCenter $ + (capCommand "R" "efresh" <+> capCommand3 "E" "x" "it") + ] + ]) + -- splashDialog :: State -> Widget Name splashDialog st = if st ^. splashBox @@ -498,7 +651,7 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] (str " _____ _ _ _ \n|__ /___ _ __ (_) |_| |__\n / // _ \\ '_ \\| | __| '_ \\\n / /| __/ | | | | |_| | | |\n/____\\___|_| |_|_|\\__|_| |_|") <=> C.hCenter - (withAttr titleAttr (str "Zcash Wallet v0.6.0.0-beta")) <=> + (withAttr titleAttr (str "Zcash Wallet v0.7.0.0-beta")) <=> C.hCenter (withAttr blinkAttr $ str "Press any key...")) else emptyWidget capCommand3 :: String -> String -> String -> Widget Name @@ -672,18 +825,49 @@ mkSendForm bal = , label "Memo: " @@= editTextField sendMemo MemoField (Just 1) ] where - isAmountValid :: Integer -> Float -> Bool - isAmountValid b i = (fromIntegral b / 100000000.0) >= i + isAmountValid :: Integer -> Scientific -> Bool + isAmountValid b i = fromIntegral b >= (i * scientific 1 8) + label s w = + padBottom (Pad 1) $ vLimit 1 (hLimit 15 $ str s <+> fill ' ') <+> w + +mkPaymentURIForm :: Integer -> PaymentInput -> Form PaymentInput e Name +mkPaymentURIForm bal = + newForm + [ label "Amount: " @@= + editShowableFieldWithValidate pmtAmt AmtField (isAmountValid bal) + , label "Memo: " @@= editTextField pmtMemo MemoField (Just 1) + ] + where + isAmountValid :: Integer -> Scientific -> Bool + isAmountValid b i = fromIntegral b >= (i * scientific 1 8) + label s w = + padBottom (Pad 1) $ vLimit 1 (hLimit 15 $ str s <+> fill ' ') <+> w + +mkDeshieldForm :: Integer -> ShDshEntry -> Form ShDshEntry e Name +mkDeshieldForm tbal = + newForm + [ label "Amount: " @@= + editShowableFieldWithValidate shAmt AmtField (isAmountValid tbal) + ] + where + isAmountValid :: Integer -> Scientific -> Bool + isAmountValid b i = fromIntegral b >= (i * scientific 1 8) label s w = padBottom (Pad 1) $ vLimit 1 (hLimit 15 $ str s <+> fill ' ') <+> w mkDeshieldForm :: Integer -> ShDshEntry -> Form ShDshEntry e Name mkDeshieldForm bal = newForm - [ label "Total Transp. : " @@= - editShowableFieldWithValidate totalTransparent TotalTranspField (isAmountValid bal) - , label "Total Shielded : " @@= - editShowableFieldWithValidate totalShielded TotalShieldedField (isAmountValid bal) + [ label "Total Transp. : " @@= + editShowableFieldWithValidate + totalTransparent + TotalTranspField + (isAmountValid bal) + , label "Total Shielded : " @@= + editShowableFieldWithValidate + totalShielded + TotalShieldedField + (isAmountValid bal) , label "Amount: " @@= editShowableFieldWithValidate shAmt AmtField (isAmountValid bal) ] @@ -813,40 +997,58 @@ scanZebra :: -> Int -> BC.BChan Tick -> ZcashNet - -> LoggingT IO () + -> NoLoggingT IO () scanZebra dbP zHost zPort b eChan znet = do bStatus <- liftIO $ checkBlockChain zHost zPort pool <- liftIO $ runNoLoggingT $ initPool dbP dbBlock <- liftIO $ getMaxBlock pool $ ZcashNetDB znet - chkBlock <- liftIO $ checkIntegrity dbP zHost zPort dbBlock 1 - logDebugN $ - "dbBlock: " <> - T.pack (show dbBlock) <> " chkBlock: " <> T.pack (show chkBlock) - when (chkBlock /= dbBlock) $ liftIO $ rewindWalletData pool chkBlock - let sb = - if chkBlock == dbBlock - then max dbBlock b - else max chkBlock b - if sb > zgb_blocks bStatus || sb < 1 - then do - liftIO $ BC.writeBChan eChan $ TickMsg "Invalid starting block for scan" + chkBlock <- liftIO $ checkIntegrity dbP zHost zPort znet dbBlock 1 + syncChk <- liftIO $ isSyncing pool + if syncChk + then liftIO $ BC.writeBChan eChan $ TickMsg "Sync alread in progress" else do - let bList = [(sb + 1) .. (zgb_blocks bStatus)] - if not (null bList) + logDebugN $ + "dbBlock: " <> + T.pack (show dbBlock) <> " chkBlock: " <> T.pack (show chkBlock) + let sb = + if chkBlock == dbBlock + then max dbBlock b + else max chkBlock b + when (chkBlock /= dbBlock && chkBlock /= 1) $ + rewindWalletData pool sb $ ZcashNetDB znet + if sb > zgb_blocks bStatus || sb < 1 then do - let step = - (1.0 :: Float) / fromIntegral (zgb_blocks bStatus - (sb + 1)) - mapM_ (liftIO . processBlock pool step) bList - else liftIO $ BC.writeBChan eChan $ TickVal 1.0 - confUp <- - liftIO $ try $ updateConfs zHost zPort pool :: LoggingT - IO - (Either IOError ()) - case confUp of - Left _e0 -> - liftIO $ - BC.writeBChan eChan $ TickMsg "Failed to update unconfirmed transactions" - Right _ -> return () + liftIO $ + BC.writeBChan eChan $ TickMsg "Invalid starting block for scan" + else do + let bList = [(sb + 1) .. (zgb_blocks bStatus)] + if not (null bList) + then do + let step = + (1.0 :: Float) / + fromIntegral (zgb_blocks bStatus - (sb + 1)) + _ <- liftIO $ startSync pool + mapM_ (liftIO . processBlock pool step) bList + confUp <- + liftIO $ try $ updateConfs zHost zPort pool :: NoLoggingT + IO + (Either IOError ()) + case confUp of + Left _e0 -> do + _ <- liftIO $ completeSync pool Failed + liftIO $ + 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 do + liftIO $ BC.writeBChan eChan $ TickMsg "startSync" where processBlock :: ConnectionPool -> Float -> Int -> IO () processBlock pool step bl = do @@ -858,7 +1060,9 @@ scanZebra dbP zHost zPort b eChan znet = do "getblock" [Data.Aeson.String $ T.pack $ show bl, jsonNumber 1] case r of - Left e1 -> liftIO $ BC.writeBChan eChan $ TickMsg e1 + Left e1 -> do + _ <- liftIO $ completeSync pool Failed + liftIO $ BC.writeBChan eChan $ TickMsg e1 Right blk -> do r2 <- liftIO $ @@ -868,7 +1072,9 @@ scanZebra dbP zHost zPort b eChan znet = do "getblock" [Data.Aeson.String $ T.pack $ show bl, jsonNumber 0] case r2 of - Left e2 -> liftIO $ BC.writeBChan eChan $ TickMsg e2 + Left e2 -> do + _ <- liftIO $ completeSync pool Failed + liftIO $ BC.writeBChan eChan $ TickMsg e2 Right hb -> do let blockTime = getBlockTime hb bi <- @@ -890,7 +1096,36 @@ appEvent (BT.AppEvent t) = do TickMsg m -> do case s ^. displayBox of AddrDisplay -> return () - MsgDisplay -> return () + MsgDisplay -> do + when (m == "startSync") $ do + selWallet <- + do case L.listSelectedElement $ s ^. wallets of + Nothing -> do + let fWall = + L.listSelectedElement $ + L.listMoveToBeginning $ s ^. wallets + case fWall of + Nothing -> throw $ userError "Failed to select wallet" + Just (_j, w1) -> return w1 + Just (_k, w) -> return w + _ <- + liftIO $ + runNoLoggingT $ + syncWallet + (Config + (s ^. dbPath) + (s ^. zebraHost) + (s ^. zebraPort) + "user" + "pwd" + 8080 + (s ^. currencyCode)) + selWallet + updatedState <- BT.get + ns <- liftIO $ refreshWallet updatedState + BT.put ns + BT.modify $ set msg "" + BT.modify $ set displayBox BlankDisplay PhraseDisplay -> return () TxDisplay -> return () TxIdDisplay -> return () @@ -913,33 +1148,9 @@ appEvent (BT.AppEvent t) = do SyncDisplay -> do if s ^. barValue == 1.0 then do - selWallet <- - do case L.listSelectedElement $ s ^. wallets of - Nothing -> do - let fWall = - L.listSelectedElement $ - L.listMoveToBeginning $ s ^. wallets - case fWall of - Nothing -> throw $ userError "Failed to select wallet" - Just (_j, w1) -> return w1 - Just (_k, w) -> return w - _ <- - liftIO $ - runFileLoggingT "zenith.log" $ - syncWallet - (Config - (s ^. dbPath) - (s ^. zebraHost) - (s ^. zebraPort) - "user" - "pwd" - 8080) - selWallet - BT.modify $ set displayBox BlankDisplay + BT.modify $ set msg "Decoding, please wait..." BT.modify $ set barValue 0.0 - updatedState <- BT.get - ns <- liftIO $ refreshWallet updatedState - BT.put ns + BT.modify $ set displayBox MsgDisplay else BT.modify $ set barValue $ validBarValue (v + s ^. barValue) BlankDisplay -> do case s ^. dialogBox of @@ -955,16 +1166,22 @@ appEvent (BT.AppEvent t) = do AdrBookDelForm -> return () DeshieldForm -> return () ShieldForm -> return () + ViewingKeyShow -> return () + ViewingKeyMenu -> return () + ShowFIATBalance -> return () + PaymentURIShow -> return () Blank -> do if s ^. timer == 90 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 $ - runFileLoggingT "zenith.log" $ + runNoLoggingT $ scanZebra (s ^. dbPath) (s ^. zebraHost) @@ -1173,7 +1390,8 @@ appEvent (BT.VtyEvent e) = do Just (_k, w) -> return w fs1 <- BT.zoom txForm $ BT.gets formState bl <- - liftIO $ getLastSyncBlock pool $ entityKey selWal + liftIO $ + getChainTip (s ^. zebraHost) (s ^. zebraPort) _ <- liftIO $ forkIO $ @@ -1188,6 +1406,7 @@ appEvent (BT.VtyEvent e) = do (fs1 ^. sendAmt) (fs1 ^. sendTo) (fs1 ^. sendMemo) + (fs1 ^. policyField) BT.modify $ set msg "Preparing transaction..." BT.modify $ set displayBox SendDisplay BT.modify $ set dialogBox Blank @@ -1201,16 +1420,103 @@ appEvent (BT.VtyEvent e) = do fs <- BT.gets formState BT.modify $ setFieldValid - (isRecipientValidGUI (fs ^. policyField) (fs ^. sendTo)) + (isRecipientValidGUI + (fs ^. policyField) + (fs ^. sendTo)) RecField - DeshieldForm -> do - case e of - V.EvKey V.KEsc [] -> BT.modify $ set dialogBox Blank - ev -> - BT.zoom deshieldForm $ do - handleFormEvent (BT.VtyEvent ev) --- fs <- BT.gets formState --- ev -> BT.zoom deshieldForm $ L.handleListEvent ev + DeshieldForm -> do + case e of + V.EvKey V.KEsc [] -> BT.modify $ set dialogBox Blank + V.EvKey (V.KChar 'p') [] -> do + if allFieldsValid (s ^. deshieldForm) + then do + pool <- + liftIO $ runNoLoggingT $ initPool $ s ^. dbPath + selWal <- + do case L.listSelectedElement $ s ^. wallets of + Nothing -> do + let fWall = + L.listSelectedElement $ + L.listMoveToBeginning $ s ^. wallets + case fWall of + Nothing -> + throw $ + userError "Failed to select wallet" + Just (_j, w1) -> return w1 + Just (_k, w) -> return w + selAcc <- + do case L.listSelectedElement $ s ^. accounts of + Nothing -> do + let fAcc = + L.listSelectedElement $ + L.listMoveToBeginning $ + s ^. accounts + case fAcc of + Nothing -> + throw $ + userError "Failed to select wallet" + Just (_j, w1) -> return w1 + Just (_k, w) -> return w + selAddr <- + do case L.listSelectedElement $ s ^. addresses of + Nothing -> do + let fAddr = + L.listSelectedElement $ + L.listMoveToBeginning $ + s ^. addresses + case fAddr of + Nothing -> + throw $ + userError "Failed to select address" + Just (_j, w1) -> return w1 + Just (_k, w) -> return w + fs1 <- BT.zoom deshieldForm $ BT.gets formState + let tAddrMaybe = + Transparent <$> + ((decodeTransparentAddress . + E.encodeUtf8 . + encodeTransparentReceiver (s ^. network)) =<< + (t_rec =<< + (isValidUnifiedAddress . + E.encodeUtf8 . + getUA . walletAddressUAddress) + (entityVal selAddr))) + bl <- + liftIO $ + getChainTip (s ^. zebraHost) (s ^. zebraPort) + case tAddrMaybe of + Nothing -> do + BT.modify $ + set + msg + "Failed to obtain transparent address" + BT.modify $ set displayBox MsgDisplay + BT.modify $ set dialogBox Blank + Just tAddr -> do + _ <- + liftIO $ + forkIO $ + deshieldTransaction + pool + (s ^. eventDispatch) + (s ^. zebraHost) + (s ^. zebraPort) + (s ^. network) + (entityKey selAcc) + bl + (ProposedNote + (ValidAddressAPI tAddr) + (fs1 ^. shAmt) + Nothing) + BT.modify $ set displayBox SendDisplay + BT.modify $ set dialogBox Blank + else do + BT.modify $ set msg "Invalid inputs" + BT.modify $ set displayBox MsgDisplay + BT.modify $ set dialogBox Blank + ev -> + BT.zoom deshieldForm $ do + handleFormEvent (BT.VtyEvent ev) AdrBook -> do case e of V.EvKey (V.KChar 'x') [] -> @@ -1228,7 +1534,7 @@ appEvent (BT.VtyEvent e) = do "Address copied to Clipboard from >>\n" ++ T.unpack (addressBookAbdescrip (entityVal a)) BT.modify $ set displayBox MsgDisplay - _ -> do + _any -> do BT.modify $ set msg "Error while copying the address!!" BT.modify $ set displayBox MsgDisplay @@ -1394,7 +1700,118 @@ appEvent (BT.VtyEvent e) = do BT.put s' BT.modify $ set dialogBox AdrBook ev -> BT.modify $ set dialogBox AdrBookDelForm + ShieldForm -> do + case e of + V.EvKey V.KEsc [] -> BT.modify $ set dialogBox Blank + V.EvKey (V.KChar 'p') [] -> do + pool <- liftIO $ runNoLoggingT $ initPool $ s ^. dbPath + selWal <- + do case L.listSelectedElement $ s ^. wallets of + Nothing -> do + let fWall = + L.listSelectedElement $ + L.listMoveToBeginning $ s ^. wallets + case fWall of + Nothing -> + throw $ + userError "Failed to select wallet" + Just (_j, w1) -> return w1 + Just (_k, w) -> return w + selAcc <- + do case L.listSelectedElement $ s ^. accounts of + Nothing -> do + let fAcc = + L.listSelectedElement $ + L.listMoveToBeginning $ s ^. accounts + case fAcc of + Nothing -> + throw $ + userError "Failed to select account" + Just (_j, w1) -> return w1 + Just (_k, w) -> return w + bl <- liftIO $ getLastSyncBlock pool $ entityKey selWal + _ <- + liftIO $ + forkIO $ + shieldTransaction + pool + (s ^. eventDispatch) + (s ^. zebraHost) + (s ^. zebraPort) + (s ^. network) + (entityKey selAcc) + bl + BT.modify $ set msg "Preparing transaction..." + BT.modify $ set displayBox SendDisplay + BT.modify $ set dialogBox Blank + ev -> + BT.zoom deshieldForm $ do + handleFormEvent (BT.VtyEvent ev) + -- Process ShowFIATBalance events + ShowFIATBalance -> do + case e of + V.EvKey (V.KChar 'x') [] -> + BT.modify $ set dialogBox Blank + V.EvKey (V.KChar 'r') [] -> do + BT.modify $ set dialogBox Blank + zpr <- liftIO $ getZcashPrice $ s ^. currencyCode + case zpr of + Just p -> do + BT.modify $ set zprice p + BT.modify $ set dialogBox ShowFIATBalance + Nothing -> do + BT.modify $ + set msg ("CoinGecko is not responding!!!") + BT.modify $ set displayBox MsgDisplay + -- Process any other event + ev -> BT.zoom abAddresses $ L.handleListEvent ev + -- + -- Viewing Key Display Support + -- + ViewingKeyShow -> do + case e of + V.EvKey (V.KChar 'c') [] -> do + liftIO $ setClipboard $ T.unpack $ s ^. vkData + BT.modify $ + set msg $ + (T.unpack (s ^. vkName)) ++ + " viewing key copied to Clipboard!!" + BT.modify $ set displayBox MsgDisplay + V.EvKey (V.KChar 'e') [] -> do + BT.modify $ set vkName "" + BT.modify $ set vkData "" + BT.modify $ set dialogBox ViewingKeyMenu + ev -> return () + -- + ViewingKeyMenu -> do + case e of + V.EvKey (V.KChar 'f') [] -> do + BT.modify $ set vkName "Full" + BT.modify $ + set + vkData + "VKFull->ztestsapling1tgjr4zppwk4ne8xy6gdq4z2gwq7dmf5jq8z2ctpn8nlmtse0a74fa5z0m8z383gmpgqz6q6duu4" + BT.modify $ set dialogBox ViewingKeyShow + V.EvKey (V.KChar 'i') [] -> do + BT.modify $ set vkName "Incomming" + BT.modify $ + set + vkData + "VKIncoming->ztestsapling1tgjr4zppwk4ne8xy6gdq4z2gwq7dmf5jq8z2ctpn8nlmtse0a74fa5z0m8z383gmpgqz6q6duu4" + BT.modify $ set dialogBox ViewingKeyShow + V.EvKey (V.KChar 'e') [] -> + BT.modify $ set dialogBox Blank + ev -> return () + -- + -- Payment URI Form Events + -- + PaymentURIShow -> do + case e of + V.EvKey V.KEsc [] -> BT.modify $ set dialogBox Blank + ev -> return () + -- -- Process any other event + -- Blank -> do case e of V.EvKey (V.KChar '\t') [] -> focusRing %= F.focusNext @@ -1418,12 +1835,87 @@ appEvent (BT.VtyEvent e) = do set txForm $ mkSendForm (s ^. balance) (SendInput "" 0.0 "" Full) BT.modify $ set dialogBox SendTx + V.EvKey (V.KChar 'u') [] -> do + BT.modify $ + set pmtURIForm $ + mkPaymentURIForm (s ^. balance) (PaymentInput 0.0 "") + BT.modify $ set dialogBox PaymentURIShow V.EvKey (V.KChar 'b') [] -> BT.modify $ set dialogBox AdrBook - V.EvKey (V.KChar 'd') [] -> + V.EvKey (V.KChar 'l') [] -> do + if s ^. network == MainNet + then do + zpr <- liftIO $ getZcashPrice $ s ^. currencyCode + case zpr of + Just p -> do + BT.modify $ set zprice p + BT.modify $ set dialogBox ShowFIATBalance + Nothing -> do + BT.modify $ + set + msg + ("Currency not supported (" ++ + T.unpack (s ^. currencyCode) ++ ")!!!") + BT.modify $ set displayBox MsgDisplay + else do + BT.modify $ + set + msg + "Balance conversion not available for TestNet" + BT.modify $ set displayBox MsgDisplay + V.EvKey (V.KChar 'd') [] -> do + pool <- liftIO $ runNoLoggingT $ initPool $ s ^. dbPath + selAcc <- + do case L.listSelectedElement $ s ^. accounts of + Nothing -> do + let fAcc = + L.listSelectedElement $ + L.listMoveToBeginning $ s ^. accounts + case fAcc of + Nothing -> + throw $ + userError "Failed to select account" + Just (_j, w1) -> return w1 + Just (_k, w) -> return w + tBal <- + liftIO $ + getTransparentBalance pool $ entityKey selAcc + sBal <- + liftIO $ getShieldedBalance pool $ entityKey selAcc + BT.modify $ set tBalance tBal + BT.modify $ set sBalance sBal + BT.modify $ + set deshieldForm $ + mkDeshieldForm sBal (ShDshEntry 0.0) BT.modify $ set dialogBox DeshieldForm - V.EvKey (V.KChar 'h') [] -> - BT.modify $ set dialogBox ShieldForm + V.EvKey (V.KChar 'h') [] -> do + pool <- liftIO $ runNoLoggingT $ initPool $ s ^. dbPath + selAcc <- + do case L.listSelectedElement $ s ^. accounts of + Nothing -> do + let fAcc = + L.listSelectedElement $ + L.listMoveToBeginning $ s ^. accounts + case fAcc of + Nothing -> + throw $ + userError "Failed to select account" + Just (_j, w1) -> return w1 + Just (_k, w) -> return w + tBal <- + liftIO $ + getTransparentBalance pool $ entityKey selAcc + BT.modify $ set tBalance tBal + if tBal > 20000 + then BT.modify $ set dialogBox ShieldForm + else do + BT.modify $ + set + msg + "Not enough transparent funds in this account" + BT.modify $ set displayBox MsgDisplay + V.EvKey (V.KChar 'k') [] -> do + BT.modify $ set dialogBox ViewingKeyMenu ev -> case r of Just AList -> @@ -1438,6 +1930,8 @@ appEvent (BT.VtyEvent e) = do printMsg s = BT.modify $ updateMsg s updateMsg :: String -> State -> State updateMsg = set msg +-- fs <- BT.gets formState +-- ev -> BT.zoom shdshForm $ L.handleListEvent ev appEvent _ = return () theMap :: A.AttrMap @@ -1476,6 +1970,7 @@ runZenithTUI config = do let host = c_zebraHost config let port = c_zebraPort config let dbFilePath = c_dbPath config + let currencyCode = c_currencyCode config pool <- runNoLoggingT $ initPool dbFilePath w <- try $ checkZebra host port :: IO (Either IOError ZebraGetInfo) case w of @@ -1520,6 +2015,14 @@ runZenithTUI config = do if not (null accList) then getUnconfirmedBalance pool $ entityKey $ head accList else return 0 + tBal <- + if not (null accList) + then getTransparentBalance pool $ entityKey $ head accList + else return 0 + sBal <- + if not (null accList) + then getShieldedBalance pool $ entityKey $ head accList + else return 0 eventChan <- BC.newBChan 10 _ <- forkIO $ @@ -1533,7 +2036,7 @@ runZenithTUI config = do State (zgb_net chainInfo) (L.list WList (Vec.fromList walList) 1) - (L.list AcList (Vec.fromList accList) 0) + (L.list AcList (Vec.fromList accList) 1) (L.list AList (Vec.fromList addrList) 1) (L.list TList (Vec.fromList txList) 1) ("Start up Ok! Connected to Zebra " ++ @@ -1562,8 +2065,14 @@ runZenithTUI config = do "" Nothing uBal - (mkDeshieldForm 0 (ShDshEntry 0 0 0.0 )) - (mkShieldForm 0 (ShDshEntry 0 0 0.0 )) + (mkDeshieldForm 0 (ShDshEntry 0.0)) + tBal + sBal + currencyCode + 0 + "" + "" + (mkPaymentURIForm 0 $ PaymentInput 0.0 "") Left _e -> do print $ "No Zebra node available on port " <> @@ -1583,7 +2092,7 @@ refreshWallet s = do Just (j, w1) -> return (j, w1) Just (k, w) -> return (k, w) aL <- runNoLoggingT $ getAccounts pool $ entityKey selWallet - let bl = zcashWalletLastSync $ entityVal selWallet + let bl = zcashWalletLastSync $ entityVal $ walList !! ix addrL <- if not (null aL) then runNoLoggingT $ getAddresses pool $ entityKey $ head aL @@ -1774,22 +2283,37 @@ sendTransaction :: -> ZcashNet -> ZcashAccountId -> Int - -> Float + -> Scientific -> T.Text -> T.Text + -> PrivacyPolicy -> IO () -sendTransaction pool chan zHost zPort znet accId bl amt ua memo = do +sendTransaction pool chan zHost zPort znet accId bl amt ua memo policy = do BC.writeBChan chan $ TickMsg "Preparing transaction..." - case parseAddressUA ua znet of + case parseAddress (E.encodeUtf8 ua) of Nothing -> BC.writeBChan chan $ TickMsg "Incorrect address" Just outUA -> do res <- - runFileLoggingT "zenith.log" $ - prepareTx pool zHost zPort znet accId bl amt outUA memo - BC.writeBChan chan $ TickMsg "Transaction ready, sending to Zebra..." + runNoLoggingT $ + prepareTxV2 + pool + zHost + zPort + znet + accId + bl + [ ProposedNote + (ValidAddressAPI outUA) + amt + (if memo == "" + then Nothing + else Just memo) + ] + policy case res of Left e -> BC.writeBChan chan $ TickMsg $ show e Right rawTx -> do + BC.writeBChan chan $ TickMsg "Transaction ready, sending to Zebra..." resp <- makeZebraCall zHost @@ -1799,3 +2323,56 @@ sendTransaction pool chan zHost zPort znet accId bl amt ua memo = do case resp of Left e1 -> BC.writeBChan chan $ TickMsg $ "Zebra error: " ++ show e1 Right txId -> BC.writeBChan chan $ TickTx txId + +shieldTransaction :: + ConnectionPool + -> BC.BChan Tick + -> T.Text + -> Int + -> ZcashNet + -> ZcashAccountId + -> Int + -> IO () +shieldTransaction pool chan zHost zPort znet accId bl = do + BC.writeBChan chan $ TickMsg "Preparing shielding transaction..." + res <- runNoLoggingT $ shieldTransparentNotes pool zHost zPort znet accId bl + forM_ res $ \case + Left e -> BC.writeBChan chan $ TickMsg $ show e + Right rawTx -> do + BC.writeBChan chan $ TickMsg "Transaction ready, sending to Zebra..." + resp <- + makeZebraCall + zHost + zPort + "sendrawtransaction" + [Data.Aeson.String $ toText rawTx] + case resp of + Left e1 -> BC.writeBChan chan $ TickMsg $ "Zebra error: " ++ show e1 + Right txId -> BC.writeBChan chan $ TickTx txId + +deshieldTransaction :: + ConnectionPool + -> BC.BChan Tick + -> T.Text + -> Int + -> ZcashNet + -> ZcashAccountId + -> Int + -> ProposedNote + -> IO () +deshieldTransaction pool chan zHost zPort znet accId bl pnote = do + BC.writeBChan chan $ TickMsg "Deshielding funds..." + res <- runNoLoggingT $ deshieldNotes pool zHost zPort znet accId bl pnote + case res of + Left e -> BC.writeBChan chan $ TickMsg $ show e + Right rawTx -> do + BC.writeBChan chan $ TickMsg "Transaction ready, sending to Zebra..." + resp <- + makeZebraCall + zHost + zPort + "sendrawtransaction" + [Data.Aeson.String $ toText rawTx] + case resp of + Left e1 -> BC.writeBChan chan $ TickMsg $ "Zebra error: " ++ show e1 + Right txId -> BC.writeBChan chan $ TickTx txId diff --git a/src/Zenith/Core.hs b/src/Zenith/Core.hs index 80bc5f7..835a00d 100644 --- a/src/Zenith/Core.hs +++ b/src/Zenith/Core.hs @@ -8,36 +8,28 @@ import Control.Monad (forM, unless, when) import Control.Monad.IO.Class (liftIO) import Control.Monad.Logger ( LoggingT - , MonadLoggerIO , NoLoggingT , logDebugN , logErrorN , logInfoN - , logWarnN - , runFileLoggingT , runNoLoggingT - , runStdoutLoggingT ) import Crypto.Secp256k1 (SecKey(..)) import Data.Aeson -import Data.Binary.Get hiding (getBytes) import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import Data.Digest.Pure.MD5 -import Data.HexString (HexString, hexString, toBytes, toText) +import Data.HexString (HexString, hexBytes, hexString, toBytes, toText) +import Data.Int (Int32, Int64) import Data.List -import Data.Maybe (fromJust) -import Data.Pool (Pool) +import Data.Maybe (fromJust, fromMaybe) +import Data.Scientific (Scientific, scientific, toBoundedInteger) import qualified Data.Text as T import qualified Data.Text.Encoding as E import Data.Time import qualified Database.Esqueleto.Experimental as ESQ import Database.Persist import Database.Persist.Sqlite -import GHC.Float.RealFracMethods (floorFloatInteger) import Haskoin.Crypto.Keys (XPrvKey(..)) import Lens.Micro ((&), (.~), (^.), set) -import Network.HTTP.Client import ZcashHaskell.Keys import ZcashHaskell.Orchard ( decryptOrchardActionSK @@ -46,6 +38,7 @@ import ZcashHaskell.Orchard , genOrchardSpendingKey , getOrchardFrontier , getOrchardNotePosition + , getOrchardTreeParts , getOrchardWitness , isValidUnifiedAddress , updateOrchardCommitmentTree @@ -56,7 +49,9 @@ import ZcashHaskell.Sapling , genSaplingInternalAddress , genSaplingPaymentAddress , genSaplingSpendingKey + , getSaplingFrontier , getSaplingNotePosition + , getSaplingTreeParts , getSaplingWitness , updateSaplingCommitmentTree , updateSaplingWitness @@ -69,17 +64,20 @@ import ZcashHaskell.Transparent import ZcashHaskell.Types import ZcashHaskell.Utils import Zenith.DB +import Zenith.Tree import Zenith.Types ( Config(..) , HexStringDB(..) , OrchardSpendingKeyDB(..) , PhraseDB(..) , PrivacyPolicy(..) + , ProposedNote(..) , RseedDB(..) , SaplingSpendingKeyDB(..) , ScopeDB(..) , TransparentSpendingKeyDB(..) , UnifiedAddressDB(..) + , ValidAddressAPI(..) , ZcashNetDB(..) , ZebraTreeInfo(..) ) @@ -109,20 +107,35 @@ checkBlockChain nodeHost nodePort = do -- | Get commitment trees from Zebra getCommitmentTrees :: - T.Text -- ^ Host where `zebrad` is avaiable + ConnectionPool + -> T.Text -- ^ Host where `zebrad` is avaiable -> Int -- ^ Port where `zebrad` is available + -> ZcashNetDB -> Int -- ^ Block height -> IO ZebraTreeInfo -getCommitmentTrees nodeHost nodePort block = do - r <- - makeZebraCall - nodeHost - nodePort - "z_gettreestate" - [Data.Aeson.String $ T.pack $ show block] - case r of - Left e -> throwIO $ userError e - Right zti -> return zti +getCommitmentTrees pool nodeHost nodePort znet block = do + bh' <- getBlockHash pool block znet + case bh' of + Nothing -> do + r <- + makeZebraCall + nodeHost + nodePort + "z_gettreestate" + [Data.Aeson.String $ T.pack $ show block] + case r of + Left e -> throwIO $ userError e + Right zti -> return zti + Just bh -> do + r <- + makeZebraCall + nodeHost + nodePort + "z_gettreestate" + [Data.Aeson.String $ toText bh] + case r of + Left e -> throwIO $ userError e + Right zti -> return zti -- * Spending Keys -- | Create an Orchard Spending Key for the given wallet and account index @@ -273,77 +286,69 @@ findSaplingOutputs :: -> Int -- ^ the starting block -> ZcashNetDB -- ^ The network -> Entity ZcashAccount -- ^ The account to use - -> IO () + -> NoLoggingT IO () findSaplingOutputs config b znet za = do let dbPath = c_dbPath config let zebraHost = c_zebraHost config let zebraPort = c_zebraPort config let zn = getNet znet - pool <- runNoLoggingT $ initPool dbPath - tList <- getShieldedOutputs pool b znet - trees <- getCommitmentTrees zebraHost zebraPort (b - 1) - let sT = SaplingCommitmentTree $ ztiSapling trees - decryptNotes sT zn pool tList - sapNotes <- getWalletSapNotes pool (entityKey za) - findSapSpends pool (entityKey za) sapNotes + pool <- liftIO $ runNoLoggingT $ initPool dbPath + tList <- liftIO $ getShieldedOutputs pool b znet + sT <- liftIO $ getSaplingTree pool + case sT of + Nothing -> + liftIO $ throwIO $ userError "Failed to read Sapling commitment tree" + 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 :: - SaplingCommitmentTree + Tree SaplingNode -> ZcashNet -> ConnectionPool - -> [(Entity ZcashTransaction, Entity ShieldOutput)] - -> IO () - decryptNotes _ _ _ [] = return () - decryptNotes st n pool ((zt, o):txs) = do - let updatedTree = - updateSaplingCommitmentTree - st - (getHex $ shieldOutputCmu $ entityVal o) - case updatedTree of - Nothing -> throwIO $ userError "Failed to update commitment tree" - Just uT -> do - let noteWitness = getSaplingWitness uT - let notePos = getSaplingNotePosition <$> noteWitness - case notePos of - Nothing -> throwIO $ userError "Failed to obtain note position" - Just nP -> do - case decodeShOut External n nP o of + -> (Entity ZcashTransaction, Entity ShieldOutput) + -> NoLoggingT IO () + 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 - case decodeShOut Internal n nP o of - Nothing -> do - decryptNotes uT n pool txs - Just dn1 -> do - wId <- saveWalletTransaction pool (entityKey za) zt - saveWalletSapNote - pool - wId - nP - (fromJust noteWitness) - True - (entityKey za) - (entityKey o) - dn1 - decryptNotes uT n pool txs - Just dn0 -> do - wId <- saveWalletTransaction pool (entityKey za) zt - saveWalletSapNote - pool - wId - nP - (fromJust noteWitness) - False - (entityKey za) - (entityKey o) - dn0 - decryptNotes uT n pool txs + logDebugN "couldn't decode internal" + Just dn1 -> do + wId <- liftIO $ saveWalletTransaction pool (entityKey za) zt + liftIO $ + saveWalletSapNote + pool + wId + nP + True + (entityKey za) + (entityKey o) + dn1 + Just dn0 -> do + wId <- liftIO $ saveWalletTransaction pool (entityKey za) zt + liftIO $ + saveWalletSapNote + pool + wId + nP + False + (entityKey za) + (entityKey o) + dn0 decodeShOut :: - Scope - -> ZcashNet - -> Integer - -> Entity ShieldOutput - -> Maybe DecodedNote + Scope -> ZcashNet -> Int32 -> Entity ShieldOutput -> Maybe DecodedNote decodeShOut scope n pos s = do decodeSaplingOutputEsk (getSapSK sk) @@ -356,7 +361,7 @@ findSaplingOutputs config b znet za = do (getHex $ shieldOutputProof $ entityVal s)) n scope - pos + (fromIntegral pos) -- | Get Orchard actions findOrchardActions :: @@ -372,67 +377,52 @@ findOrchardActions config b znet za = do let zn = getNet znet pool <- runNoLoggingT $ initPool dbPath tList <- getOrchardActions pool b znet - trees <- getCommitmentTrees zebraHost zebraPort (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" - Just nP -> - case decodeOrchAction External nP o of - Nothing -> - case decodeOrchAction Internal nP o of - Nothing -> decryptNotes uT n pool txs - 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 + 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 -> return () + Just dn1 -> do wId <- saveWalletTransaction pool (entityKey za) zt saveWalletOrchNote pool wId nP - (fromJust noteWitness) - False + True (entityKey za) (entityKey o) - dn - decryptNotes uT n pool txs + dn1 + Just dn -> do + wId <- saveWalletTransaction pool (entityKey za) zt + saveWalletOrchNote + pool + wId + nP + False + (entityKey za) + (entityKey o) + dn 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 @@ -455,7 +445,7 @@ updateSaplingWitnesses pool = do updateOneNote maxId n = do let noteSync = walletSapNoteWitPos $ entityVal n when (noteSync < maxId) $ do - cmus <- liftIO $ getSaplingCmus pool $ walletSapNoteWitPos $ entityVal n + cmus <- liftIO $ getSaplingCmus pool noteSync maxId let cmuList = map (\(ESQ.Value x) -> getHex x) cmus let newWitness = updateSaplingWitness @@ -473,7 +463,7 @@ updateOrchardWitnesses pool = do updateOneNote maxId n = do let noteSync = walletOrchNoteWitPos $ entityVal n when (noteSync < maxId) $ do - cmxs <- liftIO $ getOrchardCmxs pool noteSync + cmxs <- liftIO $ getOrchardCmxs pool noteSync maxId let cmxList = map (\(ESQ.Value x) -> getHex x) cmxs let newWitness = updateOrchardWitness @@ -484,160 +474,357 @@ updateOrchardWitnesses pool = do -- | Calculate fee per ZIP-317 calculateTxFee :: ([Entity WalletTrNote], [Entity WalletSapNote], [Entity WalletOrchNote]) - -> Int - -> Integer -calculateTxFee (t, s, o) i = - fromIntegral - (5000 * (max (length t) tout + max (length s) sout + length o + oout)) + -> [OutgoingNote] + -> Int64 +calculateTxFee (t, s, o) nout = + fromIntegral $ 5000 * (tcount + saction + oaction) where tout = - if i == 1 || i == 2 - then 1 - else 0 - sout = - if i == 3 - then 1 - else 0 - oout = - if i == 4 - then 1 - else 0 + length $ + filter + (\(OutgoingNote x _ _ _ _ _) -> x == 1 || x == 2 || x == 5 || x == 6) + nout + sout = length $ filter (\(OutgoingNote x _ _ _ _ _) -> x == 3) nout + oout = length $ filter (\(OutgoingNote x _ _ _ _ _) -> x == 4) nout + tcount = max (length t) tout + scount = max (length s) sout + ocount = max (length o) oout + saction = + if scount == 1 + then 2 + else scount + oaction = + if ocount == 1 + then 2 + else ocount -- | Prepare a transaction for sending -prepareTx :: +{- + -prepareTx :: + - ConnectionPool + - -> T.Text + - -> Int + - -> ZcashNet + - -> ZcashAccountId + - -> Int + - -> Scientific + - -> UnifiedAddress + - -> T.Text + - -> LoggingT IO (Either TxError HexString) + -prepareTx pool zebraHost zebraPort zn za bh amt ua memo = do + - accRead <- liftIO $ getAccountById pool za + - let recipient = + - case o_rec ua of + - Nothing -> + - case s_rec ua of + - Nothing -> + - case t_rec ua of + - Nothing -> (0, "") + - Just r3 -> + - case tr_type r3 of + - P2PKH -> (1, toBytes $ tr_bytes r3) + - P2SH -> (2, toBytes $ tr_bytes r3) + - Just r2 -> (3, getBytes r2) + - Just r1 -> (4, getBytes r1) + - logDebugN $ T.pack $ show recipient + - 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 + - case accRead of + - Nothing -> do + - logErrorN "Can't find Account" + - return $ Left ZHError + - Just acc -> do + - logDebugN $ T.pack $ show acc + - let zats' = toBoundedInteger $ amt * scientific 1 8 + - case zats' of + - Nothing -> return $ Left ZHError + - Just zats -> do + - logDebugN $ T.pack $ show (zats :: Int64) + - {-firstPass <- liftIO $ selectUnspentNotes pool za zats-} + - --let fee = calculateTxFee firstPass $ fst recipient + - --logDebugN $ T.pack $ "calculated fee " ++ show fee + - (tList, sList, oList) <- + - liftIO $ selectUnspentNotes pool za (fromIntegral $ zats + 5000) + - logDebugN "selected notes" + - logDebugN $ T.pack $ show tList + - logDebugN $ T.pack $ show sList + - logDebugN $ T.pack $ show oList + - let noteTotal = getTotalAmount (tList, sList, oList) + - 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 + - dummy <- + - liftIO $ + - makeOutgoing + - acc + - recipient + - zats + - (fromInteger noteTotal - 5000 - zats) + - logDebugN "Calculating fee" + - let feeResponse = + - createTransaction + - (Just sT) + - (Just oT) + - tSpends + - sSpends + - oSpends + - dummy + - zn + - bh + - False + - case feeResponse of + - Left e1 -> return $ Left Fee + - Right fee -> do + - let feeAmt = + - fromIntegral + - (runGet getInt64le $ LBS.fromStrict $ toBytes fee) + - (tList1, sList1, oList1) <- + - liftIO $ selectUnspentNotes pool za (fromIntegral zats + feeAmt) + - logDebugN $ T.pack $ "selected notes with fee" ++ show feeAmt + - logDebugN $ T.pack $ show tList + - logDebugN $ T.pack $ show sList + - logDebugN $ T.pack $ show oList + - outgoing <- + - liftIO $ + - makeOutgoing + - acc + - recipient + - zats + - (fromInteger noteTotal - fromInteger feeAmt - zats) + - logDebugN $ T.pack $ show outgoing + - let tx = + - createTransaction + - (Just sT) + - (Just oT) + - tSpends + - sSpends + - oSpends + - outgoing + - zn + - bh + - True + - logDebugN $ T.pack $ show tx + - return tx + - where + - makeOutgoing :: + - Entity ZcashAccount + - -> (Int, BS.ByteString) + - -> Int64 + - -> Int64 + - -> IO [OutgoingNote] + - makeOutgoing acc (k, recvr) zats chg = do + - chgAddr <- runNoLoggingT $ getInternalAddresses pool $ entityKey acc + - let internalUA = getUA $ walletAddressUAddress $ entityVal $ head chgAddr + - let chgRcvr = + - fromJust $ o_rec =<< isValidUnifiedAddress (E.encodeUtf8 internalUA) + - return + - [ OutgoingNote + - 4 + - (getBytes $ getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc) + - (getBytes chgRcvr) + - (fromIntegral chg) + - "" + - True + - , OutgoingNote + - (fromIntegral k) + - (case k of + - 4 -> + - getBytes $ getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc + - 3 -> + - getBytes $ getSapSK $ zcashAccountSapSpendKey $ entityVal acc + - _ -> "") + - recvr + - (fromIntegral zats) + - (E.encodeUtf8 memo) + - False + - ] + - getTotalAmount :: + - ( [Entity WalletTrNote] + - , [Entity WalletSapNote] + - , [Entity WalletOrchNote]) + - -> Integer + - getTotalAmount (t, s, o) = + - sum (map (fromIntegral . walletTrNoteValue . entityVal) t) + + - sum (map (fromIntegral . walletSapNoteValue . entityVal) s) + + - sum (map (fromIntegral . walletOrchNoteValue . entityVal) o) + - prepTSpends :: + - TransparentSpendingKey + - -> [Entity WalletTrNote] + - -> IO [TransparentTxSpend] + - prepTSpends sk notes = do + - forM notes $ \n -> do + - tAddRead <- getAddressById pool $ walletTrNoteAddress $ entityVal n + - case tAddRead of + - Nothing -> throwIO $ userError "Couldn't read t-address" + - Just tAdd -> do + - (XPrvKey _ _ _ _ (SecKey xp_key)) <- + - genTransparentSecretKey + - (walletAddressIndex $ entityVal tAdd) + - (getScope $ walletAddressScope $ entityVal tAdd) + - sk + - mReverseTxId <- getWalletTxId pool $ walletTrNoteTx $ entityVal n + - case mReverseTxId of + - Nothing -> throwIO $ userError "failed to get tx ID" + - Just (ESQ.Value reverseTxId) -> do + - let flipTxId = BS.reverse $ toBytes $ getHex reverseTxId + - return $ + - TransparentTxSpend + - xp_key + - (RawOutPoint + - flipTxId + - (fromIntegral $ walletTrNotePosition $ entityVal n)) + - (RawTxOut + - (fromIntegral $ walletTrNoteValue $ entityVal n) + - (walletTrNoteScript $ entityVal n)) + - prepSSpends :: + - SaplingSpendingKey -> [Entity WalletSapNote] -> IO [SaplingTxSpend] + - prepSSpends sk notes = do + - forM notes $ \n -> do + - return $ + - SaplingTxSpend + - (getBytes sk) + - (DecodedNote + - (fromIntegral $ walletSapNoteValue $ entityVal n) + - (walletSapNoteRecipient $ entityVal n) + - (E.encodeUtf8 $ walletSapNoteMemo $ entityVal n) + - (getHex $ walletSapNoteNullifier $ entityVal n) + - "" + - (getRseed $ walletSapNoteRseed $ entityVal n)) + - (toBytes $ getHex $ walletSapNoteWitness $ entityVal n) + - prepOSpends :: + - OrchardSpendingKey -> [Entity WalletOrchNote] -> IO [OrchardTxSpend] + - prepOSpends sk notes = do + - forM notes $ \n -> do + - return $ + - OrchardTxSpend + - (getBytes sk) + - (DecodedNote + - (fromIntegral $ walletOrchNoteValue $ entityVal n) + - (walletOrchNoteRecipient $ entityVal n) + - (E.encodeUtf8 $ walletOrchNoteMemo $ entityVal n) + - (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 + -} +deshieldNotes :: ConnectionPool -> T.Text -> Int -> ZcashNet -> ZcashAccountId -> Int - -> Float - -> UnifiedAddress + -> ProposedNote + -> NoLoggingT IO (Either TxError HexString) +deshieldNotes pool zebraHost zebraPort znet za bh pnote = do + bal <- liftIO $ getShieldedBalance pool za + let zats = pn_amt pnote * scientific 1 8 + if fromInteger bal > (scientific 2 4 + zats) + then prepareTxV2 pool zebraHost zebraPort znet za bh [pnote] Low + else return $ Left InsufficientFunds + +shieldTransparentNotes :: + ConnectionPool -> T.Text - -> LoggingT IO (Either TxError HexString) -prepareTx pool zebraHost zebraPort zn za bh amt ua memo = do + -> Int + -> ZcashNet + -> ZcashAccountId + -> Int + -> NoLoggingT IO [Either TxError HexString] +shieldTransparentNotes pool zebraHost zebraPort znet za bh = do accRead <- liftIO $ getAccountById pool za - let recipient = - case o_rec ua of - Nothing -> - case s_rec ua of - Nothing -> - case t_rec ua of - Nothing -> (0, "") - Just r3 -> - case tr_type r3 of - P2PKH -> (1, toBytes $ tr_bytes r3) - P2SH -> (2, toBytes $ tr_bytes r3) - Just r2 -> (3, getBytes r2) - Just r1 -> (4, getBytes r1) - logDebugN $ T.pack $ show recipient 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" - return $ Left ZHError + return [Left ZHError] Just acc -> do - logDebugN $ T.pack $ show acc - let zats = fromIntegral $ floorFloatInteger $ amt * (10 ^ 8) - logDebugN $ T.pack $ show zats - {-firstPass <- liftIO $ selectUnspentNotes pool za zats-} - --let fee = calculateTxFee firstPass $ fst recipient - --logDebugN $ T.pack $ "calculated fee " ++ show fee - (tList, sList, oList) <- liftIO $ selectUnspentNotes pool za (zats + 5000) - logDebugN "selected notes" - logDebugN $ T.pack $ show tList - logDebugN $ T.pack $ show sList - logDebugN $ T.pack $ show oList - let noteTotal = getTotalAmount (tList, sList, oList) - 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 - dummy <- - liftIO $ makeOutgoing acc recipient zats (noteTotal - 5000 - zats) - logDebugN "Calculating fee" - let feeResponse = - createTransaction - (Just sT) - (Just oT) - tSpends - sSpends - oSpends - dummy - zn - (bh + 3) - False - case feeResponse of - Left e1 -> return $ Left Fee - Right fee -> do - let feeAmt = - fromIntegral (runGet getInt64le $ LBS.fromStrict $ toBytes fee) - (tList1, sList1, oList1) <- - liftIO $ selectUnspentNotes pool za (zats + feeAmt) - logDebugN $ T.pack $ "selected notes with fee" ++ show feeAmt - logDebugN $ T.pack $ show tList - logDebugN $ T.pack $ show sList - logDebugN $ T.pack $ show oList - outgoing <- - liftIO $ makeOutgoing acc recipient zats (noteTotal - feeAmt - zats) - logDebugN $ T.pack $ show outgoing - let tx = - createTransaction - (Just sT) - (Just oT) - tSpends - sSpends - oSpends - outgoing - zn - (bh + 3) - True - logDebugN $ T.pack $ show tx - return tx - where - makeOutgoing :: - Entity ZcashAccount - -> (Int, BS.ByteString) - -> Integer - -> Integer - -> IO [OutgoingNote] - makeOutgoing acc (k, recvr) zats chg = do - chgAddr <- runNoLoggingT $ getInternalAddresses pool $ entityKey acc - let internalUA = getUA $ walletAddressUAddress $ entityVal $ head chgAddr - let chgRcvr = - fromJust $ o_rec =<< isValidUnifiedAddress (E.encodeUtf8 internalUA) - return - [ OutgoingNote - 4 - (getBytes $ getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc) - (getBytes chgRcvr) - (fromIntegral chg) - "" + trNotes' <- liftIO $ getWalletUnspentTrNotes pool za + dRecvs <- liftIO $ getReceivers pool trNotes' + let fNotes = + map + (\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 <- + liftIO $ + prepTSpends + (getTranSK $ zcashAccountTPrivateKey $ entityVal acc) + trNotes + chgAddr <- getInternalAddresses pool $ entityKey acc + let internalUA = + getUA $ walletAddressUAddress $ entityVal $ head chgAddr + let oRcvr = + fromJust $ + o_rec =<< isValidUnifiedAddress (E.encodeUtf8 internalUA) + let dummy = + OutgoingNote + 4 + (getBytes $ getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc) + (getBytes oRcvr) + (fromIntegral $ noteTotal - 500) + "" + True + let feeAmt = calculateTxFee (trNotes, [], []) [dummy] + let snote = + OutgoingNote + 4 + (getBytes $ getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc) + (getBytes oRcvr) + (fromIntegral $ noteTotal - fromIntegral feeAmt) + "" + True + tx <- + liftIO $ + createTransaction + (maybe (hexString "00") (getHash . value . fst) sTree) + (maybe (hexString "00") (getHash . value . fst) oTree) + tSpends + [] + [] + [snote] + znet + (bh + 3) True - , OutgoingNote - (fromIntegral k) - (case k of - 4 -> - getBytes $ getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc - 3 -> - getBytes $ getSapSK $ zcashAccountSapSpendKey $ entityVal acc - _ -> "") - recvr - (fromIntegral zats) - (E.encodeUtf8 memo) - False - ] + logDebugN $ T.pack $ show tx + return tx + where getTotalAmount :: ( [Entity WalletTrNote] , [Entity WalletSapNote] @@ -676,50 +863,6 @@ prepareTx pool zebraHost zebraPort zn za bh amt ua memo = do (RawTxOut (fromIntegral $ walletTrNoteValue $ entityVal n) (walletTrNoteScript $ entityVal n)) - prepSSpends :: - SaplingSpendingKey -> [Entity WalletSapNote] -> IO [SaplingTxSpend] - prepSSpends sk notes = do - forM notes $ \n -> do - return $ - SaplingTxSpend - (getBytes sk) - (DecodedNote - (fromIntegral $ walletSapNoteValue $ entityVal n) - (walletSapNoteRecipient $ entityVal n) - (E.encodeUtf8 $ walletSapNoteMemo $ entityVal n) - (getHex $ walletSapNoteNullifier $ entityVal n) - "" - (getRseed $ walletSapNoteRseed $ entityVal n)) - (toBytes $ getHex $ walletSapNoteWitness $ entityVal n) - prepOSpends :: - OrchardSpendingKey -> [Entity WalletOrchNote] -> IO [OrchardTxSpend] - prepOSpends sk notes = do - forM notes $ \n -> do - return $ - OrchardTxSpend - (getBytes sk) - (DecodedNote - (fromIntegral $ walletOrchNoteValue $ entityVal n) - (walletOrchNoteRecipient $ entityVal n) - (E.encodeUtf8 $ walletOrchNoteMemo $ entityVal n) - (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 -- | Prepare a transaction for sending prepareTxV2 :: @@ -729,117 +872,73 @@ prepareTxV2 :: -> ZcashNet -> ZcashAccountId -> Int - -> Float - -> ValidAddress - -> T.Text + -> [ProposedNote] -> PrivacyPolicy - -> LoggingT IO (Either TxError HexString) -prepareTxV2 pool zebraHost zebraPort zn za bh amt va memo policy = do + -> NoLoggingT IO (Either TxError HexString) +prepareTxV2 pool zebraHost zebraPort zn za bh pnotes policy = do accRead <- liftIO $ getAccountById pool za - let recipient = - case va of - Unified ua -> - case o_rec ua of - Nothing -> - case s_rec ua of - Nothing -> - case t_rec ua of - Nothing -> (0, "") - Just r3 -> - case tr_type r3 of - P2PKH -> (1, toBytes $ tr_bytes r3) - P2SH -> (2, toBytes $ tr_bytes r3) - Just r2 -> (3, getBytes r2) - Just r1 -> (4, getBytes r1) - Sapling sa -> (3, getBytes $ sa_receiver sa) - Transparent ta -> - case tr_type (ta_receiver ta) of - P2PKH -> (1, toBytes $ tr_bytes (ta_receiver ta)) - P2SH -> (2, toBytes $ tr_bytes (ta_receiver ta)) - Exchange ea -> - case tr_type (ex_address ea) of - P2PKH -> (1, toBytes $ tr_bytes (ex_address ea)) - P2SH -> (2, toBytes $ tr_bytes (ex_address ea)) - logDebugN $ T.pack $ show recipient + let recipients = map extractReceiver pnotes + logDebugN $ T.pack $ show recipients logDebugN $ T.pack $ "Target block: " ++ show bh - trees <- liftIO $ getCommitmentTrees zebraHost zebraPort 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" return $ Left ZHError Just acc -> do logDebugN $ T.pack $ show acc - let zats = fromIntegral $ floorFloatInteger $ amt * (10 ^ 8) - logDebugN $ T.pack $ show zats - {-firstPass <- liftIO $ selectUnspentNotes pool za zats-} - --let fee = calculateTxFee firstPass $ fst recipient - --logDebugN $ T.pack $ "calculated fee " ++ show fee - notePlan <- - liftIO $ - selectUnspentNotesV2 pool za (zats + 10000) (fst recipient) policy - case notePlan of - Right (tList, sList, oList) -> do - logDebugN "selected notes" - logDebugN $ T.pack $ show tList - logDebugN $ T.pack $ show sList - logDebugN $ T.pack $ show oList - let noteTotal = getTotalAmount (tList, sList, oList) - tSpends <- + let amt = foldl' (\x y -> x + pn_amt y) 0 pnotes + let zats' = toBoundedInteger $ amt * scientific 1 8 + case zats' of + Nothing -> do + logErrorN "Failed to parse amount into zats" + return $ Left ZHError + Just zats -> do + logDebugN $ "amt: " <> T.pack (show amt) + logDebugN $ "zats: " <> T.pack (show zats) + {-firstPass <- liftIO $ selectUnspentNotes pool za zats-} + --let fee = calculateTxFee firstPass $ fst recipient + --logDebugN $ T.pack $ "calculated fee " ++ show fee + notePlan <- 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 - dummy' <- - liftIO $ - makeOutgoing acc recipient zats (noteTotal - 5000 - zats) policy - case dummy' of - Left e -> return $ Left e - Right dummy -> do - logDebugN "Calculating fee" - let feeResponse = - createTransaction - (Just sT) - (Just oT) - tSpends - sSpends - oSpends - dummy - zn - (bh + 3) - False - case feeResponse of - Left e1 -> return $ Left Fee - Right fee -> do - let feeAmt = - fromIntegral - (runGet getInt64le $ LBS.fromStrict $ toBytes fee) + selectUnspentNotesV2 + pool + za + (zats + 20000) + (map (\(x, _, _, _) -> x) recipients) + policy + case notePlan of + Right (tList, sList, oList) -> do + logDebugN "selected notes" + logDebugN $ T.pack $ show tList + logDebugN $ T.pack $ show sList + logDebugN $ T.pack $ show oList + let noteTotal = getTotalAmount (tList, sList, oList) + logDebugN $ "noteTotal: " <> T.pack (show noteTotal) + draft <- + liftIO $ + makeOutgoing + acc + recipients + (noteTotal - 5000 - fromIntegral zats) + policy + case draft of + Left e -> return $ Left e + Right draftOut -> do + let fee = calculateTxFee (tList, sList, oList) draftOut + logDebugN $ T.pack $ "calculated fee " ++ show fee finalNotePlan <- liftIO $ selectUnspentNotesV2 pool za - (zats + feeAmt) - (fst recipient) + (zats + fee) + (map (\(x, _, _, _) -> x) recipients) policy case finalNotePlan of Right (tList1, sList1, oList1) -> do - logDebugN $ - T.pack $ "selected notes with fee" ++ show feeAmt + logDebugN $ T.pack $ "selected notes with fee" ++ show fee logDebugN $ T.pack $ show tList1 logDebugN $ T.pack $ show sList1 logDebugN $ T.pack $ show oList1 @@ -852,67 +951,203 @@ prepareTxV2 pool zebraHost zebraPort zn za bh amt va memo 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' <- liftIO $ makeOutgoing acc - recipient - zats - (noteTotal1 - feeAmt - zats) + recipients + (noteTotal1 - fee - fromIntegral zats) policy logDebugN $ T.pack $ show outgoing' case outgoing' of Left e -> return $ Left e Right outgoing -> do - let tx = - createTransaction - (Just sT) - (Just oT) - tSpends1 - sSpends1 - oSpends1 - outgoing - zn - (bh + 3) - True + tx <- + liftIO $ + createTransaction + (maybe + (hexString "00") + (getHash . value . fst) + sTree) + (maybe + (hexString "00") + (getHash . value . fst) + oTree) + tSpends1 + sSpends1 + oSpends1 + outgoing + zn + bh + True logDebugN $ T.pack $ show tx return tx Left e -> return $ Left e - Left e -> do - logErrorN $ T.pack $ show e - return $ Left e + Left e -> do + logErrorN $ T.pack $ show e + return $ Left e where + extractReceiver :: ProposedNote -> (Int, BS.ByteString, Int64, T.Text) + extractReceiver (ProposedNote (ValidAddressAPI va) amt m) = + let zats' = toBoundedInteger $ amt * scientific 1 8 + in case zats' of + Nothing -> (0, "", 0, "") + Just zats -> + case va of + Unified ua -> + case o_rec ua of + Nothing -> + case s_rec ua of + Nothing -> + case t_rec ua of + Nothing -> (0, "", 0, "") + Just r3 -> + case tr_type r3 of + P2PKH -> + ( 1 + , toBytes $ tr_bytes r3 + , zats + , fromMaybe "" m) + P2SH -> + ( 2 + , toBytes $ tr_bytes r3 + , zats + , fromMaybe "" m) + Just r2 -> (3, getBytes r2, zats, fromMaybe "" m) + Just r1 -> (4, getBytes r1, zats, fromMaybe "" m) + Sapling sa -> + (3, getBytes $ sa_receiver sa, zats, fromMaybe "" m) + Transparent ta -> + case tr_type (ta_receiver ta) of + P2PKH -> + ( 1 + , toBytes $ tr_bytes (ta_receiver ta) + , zats + , fromMaybe "" m) + P2SH -> + ( 2 + , toBytes $ tr_bytes (ta_receiver ta) + , zats + , fromMaybe "" m) + Exchange ea -> + case tr_type (ex_address ea) of + P2PKH -> + ( 5 + , toBytes $ tr_bytes (ex_address ea) + , zats + , fromMaybe "" m) + P2SH -> + ( 6 + , toBytes $ tr_bytes (ex_address ea) + , zats + , fromMaybe "" m) + prepareOutgoingNote :: + ZcashAccount -> (Int, BS.ByteString, Int64, T.Text) -> OutgoingNote + prepareOutgoingNote zac (k, r, a, m) = + OutgoingNote + (if k == 5 + then 1 + else if k == 6 + then 2 + else fromIntegral k) + (case k of + 4 -> getBytes $ getOrchSK $ zcashAccountOrchSpendKey zac + 3 -> getBytes $ getSapSK $ zcashAccountSapSpendKey zac + _anyOther -> BS.empty) + r + (fromIntegral a) + (E.encodeUtf8 m) + False makeOutgoing :: Entity ZcashAccount - -> (Int, BS.ByteString) - -> Integer - -> Integer + -> [(Int, BS.ByteString, Int64, T.Text)] + -> Int64 -> PrivacyPolicy -> IO (Either TxError [OutgoingNote]) - makeOutgoing acc (k, recvr) zats chg policy = do + makeOutgoing acc recvs chg pol = do + let k = map (\(x, _, _, _) -> x) recvs + let j = map (\(_, _, x, _) -> x) recvs chgAddr <- runNoLoggingT $ getInternalAddresses pool $ entityKey acc let internalUA = getUA $ walletAddressUAddress $ entityVal $ head chgAddr - case k of - 4 -> - case policy of - None -> - return $ - Left $ - PrivacyPolicyError "Receiver not compatible with privacy policy" - _anyOther -> do + case pol of + Full -> + if elem 1 k || elem 2 k || elem 5 k || elem 6 k + then return $ + Left $ + PrivacyPolicyError + "Receiver not compatible with privacy policy" + else if elem 3 k && elem 4 k + then return $ + Left $ + PrivacyPolicyError + "Multiple shielded pools not allowed for Full privacy" + else if 3 `elem` k + then do + let chgRcvr = + fromJust $ + s_rec =<< + isValidUnifiedAddress + (E.encodeUtf8 internalUA) + let cnote = + OutgoingNote + 3 + (getBytes $ + getSapSK $ + zcashAccountSapSpendKey $ entityVal acc) + (getBytes chgRcvr) + (fromIntegral chg) + "" + True + let onotes = + map + (prepareOutgoingNote (entityVal acc)) + recvs + return $ Right $ cnote : onotes + else if 4 `elem` k + then do + let chgRcvr = + fromJust $ + o_rec =<< + isValidUnifiedAddress + (E.encodeUtf8 internalUA) + let cnote = + OutgoingNote + 4 + (getBytes $ + getOrchSK $ + zcashAccountOrchSpendKey $ + entityVal acc) + (getBytes chgRcvr) + (fromIntegral chg) + "" + True + let onotes = + map + (prepareOutgoingNote (entityVal acc)) + recvs + return $ Right $ cnote : onotes + else return $ Left ZHError + Medium -> + if elem 1 k || elem 2 k || elem 5 k || elem 6 k + then return $ + Left $ + PrivacyPolicyError + "Receiver not compatible with privacy policy" + else do let chgRcvr = fromJust $ o_rec =<< isValidUnifiedAddress (E.encodeUtf8 internalUA) - return $ - Right - [ OutgoingNote + let cnote = + OutgoingNote 4 (getBytes $ getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc) @@ -920,51 +1155,20 @@ prepareTxV2 pool zebraHost zebraPort zn za bh amt va memo policy = do (fromIntegral chg) "" True - , OutgoingNote - 4 - (getBytes $ - getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc) - recvr - (fromIntegral zats) - (E.encodeUtf8 memo) - False - ] - 3 -> - case policy of - None -> - return $ - Left $ - PrivacyPolicyError "Receiver not compatible with privacy policy" - Full -> do - let chgRcvr = - fromJust $ - s_rec =<< isValidUnifiedAddress (E.encodeUtf8 internalUA) - return $ - Right - [ OutgoingNote - 3 - (getBytes $ - getSapSK $ zcashAccountSapSpendKey $ entityVal acc) - (getBytes chgRcvr) - (fromIntegral chg) - "" - True - , OutgoingNote - 3 - (getBytes $ - getSapSK $ zcashAccountSapSpendKey $ entityVal acc) - recvr - (fromIntegral zats) - (E.encodeUtf8 memo) - False - ] - _anyOther -> do + let onotes = map (prepareOutgoingNote (entityVal acc)) recvs + return $ Right $ cnote : onotes + Low -> + if elem 5 k || elem 6 k + then return $ + Left $ + PrivacyPolicyError + "Receiver not compatible with privacy policy" + else do let chgRcvr = fromJust $ o_rec =<< isValidUnifiedAddress (E.encodeUtf8 internalUA) - return $ - Right - [ OutgoingNote + let cnote = + OutgoingNote 4 (getBytes $ getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc) @@ -972,63 +1176,33 @@ prepareTxV2 pool zebraHost zebraPort zn za bh amt va memo policy = do (fromIntegral chg) "" True - , OutgoingNote - 3 - (getBytes $ - getSapSK $ zcashAccountSapSpendKey $ entityVal acc) - recvr - (fromIntegral zats) - (E.encodeUtf8 memo) - False - ] - 2 -> - if policy <= Low - then do + let onotes = map (prepareOutgoingNote (entityVal acc)) recvs + return $ Right $ cnote : onotes + None -> + if elem 3 k || elem 4 k + then return $ + Left $ + PrivacyPolicyError + "Receiver not compatible with privacy policy" + else do let chgRcvr = fromJust $ t_rec =<< isValidUnifiedAddress (E.encodeUtf8 internalUA) - return $ - Right - [ OutgoingNote + let cnote = + OutgoingNote 1 BS.empty (toBytes $ tr_bytes chgRcvr) (fromIntegral chg) "" True - , OutgoingNote 2 BS.empty recvr (fromIntegral zats) "" False - ] - else return $ - Left $ - PrivacyPolicyError - "Receiver not compatible with privacy policy" - 1 -> - if policy <= Low - then do - let chgRcvr = - fromJust $ - t_rec =<< isValidUnifiedAddress (E.encodeUtf8 internalUA) - return $ - Right - [ OutgoingNote - 1 - BS.empty - (toBytes $ tr_bytes chgRcvr) - (fromIntegral chg) - "" - True - , OutgoingNote 1 BS.empty recvr (fromIntegral zats) "" False - ] - else return $ - Left $ - PrivacyPolicyError - "Receiver not compatible with privacy policy" - _anyOther -> return $ Left ZHError + let onotes = map (prepareOutgoingNote (entityVal acc)) recvs + return $ Right $ cnote : onotes getTotalAmount :: ( [Entity WalletTrNote] , [Entity WalletSapNote] , [Entity WalletOrchNote]) - -> Integer + -> Int64 getTotalAmount (t, s, o) = sum (map (fromIntegral . walletTrNoteValue . entityVal) t) + sum (map (fromIntegral . walletSapNoteValue . entityVal) s) + @@ -1063,9 +1237,16 @@ prepareTxV2 pool zebraHost zebraPort zn za bh amt va memo 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) @@ -1076,11 +1257,18 @@ prepareTxV2 pool zebraHost zebraPort zn za bh amt va memo 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) @@ -1091,34 +1279,20 @@ prepareTxV2 pool zebraHost zebraPort zn za bh amt va memo 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 :: Config -- ^ configuration parameters -> Entity ZcashWallet - -> LoggingT IO () + -> NoLoggingT IO () syncWallet config w = do startTime <- liftIO getCurrentTime + logDebugN $ T.pack $ show startTime let walletDb = c_dbPath config let znet = zcashWalletNetwork $ entityVal w pool <- liftIO $ runNoLoggingT $ initPool walletDb accs <- liftIO $ runNoLoggingT $ getAccounts pool $ entityKey w - logDebugN $ "Accounts: " <> T.pack (show accs) addrs <- concat <$> mapM (liftIO . runNoLoggingT . getAddresses pool . entityKey) accs @@ -1128,27 +1302,126 @@ syncWallet config w = do mapM (liftIO . runNoLoggingT . getInternalAddresses pool . entityKey) accs chainTip <- liftIO $ getMaxBlock pool znet logDebugN $ "chain tip: " <> T.pack (show chainTip) - let lastBlock = zcashWalletLastSync $ entityVal w + lastBlock <- liftIO $ getLastSyncBlock pool $ entityKey w logDebugN $ "last block: " <> T.pack (show lastBlock) let startBlock = if lastBlock > 0 then lastBlock - else zcashWalletBirthdayHeight $ entityVal w + else 1 + zcashWalletBirthdayHeight (entityVal w) logDebugN $ "start block: " <> T.pack (show startBlock) mapM_ (liftIO . findTransparentNotes pool startBlock znet) addrs mapM_ (liftIO . findTransparentNotes pool startBlock znet) intAddrs + logDebugN "processed transparent notes" mapM_ (liftIO . findTransparentSpends pool . entityKey) accs - sapNotes <- - liftIO $ - mapM + logDebugN "processed transparent spends" + liftIO $ + runNoLoggingT $ + mapM_ (findSaplingOutputs config startBlock (zcashWalletNetwork $ entityVal w)) accs - orchNotes <- - liftIO $ - mapM + logDebugN "processed sapling outputs" + liftIO $ + mapM_ (findOrchardActions config startBlock (zcashWalletNetwork $ entityVal w)) accs - _ <- liftIO $ updateSaplingWitnesses pool - _ <- liftIO $ updateOrchardWitnesses pool + logDebugN "processed orchard actions" _ <- 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 -> NoLoggingT 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 + let zippedSapComms = + zip [(getPosition (value newTree) + 1) ..] saplingComm + return $ batchAppend newTree zippedSapComms + 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" + let zippedSapComms = + zip [(getPosition (value sTree) + 1) ..] saplingComm + return $ batchAppend sTree zippedSapComms + 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 + let zippedOrchComms = + zip [(getPosition (value newTree) + 1) ..] orchardComm + return $ batchAppend newTree zippedOrchComms + 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" + let zippedOrchComms = + zip [(getPosition (value oTree) + 1) ..] orchardComm + return $ batchAppend oTree zippedOrchComms + 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 () diff --git a/src/Zenith/DB.hs b/src/Zenith/DB.hs index 3f50113..dfbedf9 100644 --- a/src/Zenith/DB.hs +++ b/src/Zenith/DB.hs @@ -18,10 +18,18 @@ 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) -import Control.Monad.Logger (NoLoggingT, runNoLoggingT) +import Control.Monad.Logger + ( LoggingT + , NoLoggingT + , logDebugN + , logErrorN + , runNoLoggingT + , runStderrLoggingT + ) import qualified Data.ByteString as BS import Data.HexString import Data.Int @@ -74,6 +82,7 @@ import ZcashHaskell.Types , ValidAddress(..) , ZcashNet(..) ) +import Zenith.Tree (OrchardNode(..), SaplingNode(..), Tree(..), truncateTree) import Zenith.Types ( AccountBalance(..) , HexStringDB(..) @@ -150,7 +159,7 @@ share script BS.ByteString change Bool position Int - UniqueTNote tx script + UniqueTNote tx accId script deriving Show Eq WalletTrSpend tx WalletTransactionId OnDeleteCascade OnUpdateCascade @@ -291,6 +300,19 @@ share result T.Text Maybe UniqueOp uuid deriving Show Eq + ChainSync + name T.Text + start UTCTime + end UTCTime Maybe + status ZenithStatus + UniqueSync name + deriving Show Eq + TreeStore + pool ZcashPool + bytes BS.ByteString + lastSync Int + UniquePool pool + deriving Show Eq |] -- ** Type conversions @@ -685,22 +707,42 @@ saveAddress pool w = runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ insertUniqueEntity w +-- * Block -- | Save a block to the database saveBlock :: ConnectionPool -> ZcashBlock -> IO (Key ZcashBlock) saveBlock pool b = runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do insert b -- | Read a block by height -getBlock :: ConnectionPool -> Int -> IO (Maybe (Entity ZcashBlock)) -getBlock pool b = +getBlock :: + ConnectionPool -> Int -> ZcashNetDB -> IO (Maybe (Entity ZcashBlock)) +getBlock pool b znet = runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do selectOne $ do bl <- from $ table @ZcashBlock - where_ $ bl ^. ZcashBlockHeight ==. val b + where_ $ + bl ^. ZcashBlockHeight ==. val b &&. bl ^. ZcashBlockNetwork ==. + val znet pure bl +getBlockHash :: ConnectionPool -> Int -> ZcashNetDB -> IO (Maybe HexString) +getBlockHash pool b znet = do + r <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + bl <- from $ table @ZcashBlock + where_ $ + bl ^. ZcashBlockHeight ==. val b &&. bl ^. ZcashBlockNetwork ==. + val znet + pure $ bl ^. ZcashBlockHash + case r of + Nothing -> return Nothing + Just (Value h) -> return $ Just $ getHex h + -- | Save a transaction to the data model saveTransaction :: ConnectionPool -- ^ the database path @@ -886,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 @@ -950,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 @@ -972,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)) @@ -983,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 @@ -1005,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) @@ -1184,6 +1226,61 @@ getTrNotes pool tr = do where_ (tnotes ^. WalletTrNoteScript ==. val s) pure tnotes +getTrFilteredNotes :: + ConnectionPool + -> [HexStringDB] + -> TransparentReceiver + -> IO [Entity WalletTrNote] +getTrFilteredNotes pool txs tr = do + let s = + BS.concat + [ BS.pack [0x76, 0xA9, 0x14] + , (toBytes . tr_bytes) tr + , BS.pack [0x88, 0xAC] + ] + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + (wt :& tnotes) <- + from $ table @WalletTransaction `innerJoin` table @WalletTrNote `on` + (\(wt :& tnotes) -> + wt ^. WalletTransactionId ==. tnotes ^. WalletTrNoteTx) + where_ (tnotes ^. WalletTrNoteScript ==. val s) + where_ (wt ^. WalletTransactionTxId `in_` valList txs) + pure tnotes + +traceTrDag :: ConnectionPool -> Entity WalletTrNote -> IO [Entity WalletTrNote] +traceTrDag pool note = do + trSpend <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + trSpends <- from $ table @WalletTrSpend + where_ (trSpends ^. WalletTrSpendNote ==. val (entityKey note)) + pure trSpends + case trSpend of + Nothing -> return [] + Just tnote -> do + nxtChg <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + nts <- from $ table @WalletTrNote + where_ + (nts ^. WalletTrNoteTx ==. val (walletTrSpendTx $ entityVal tnote) &&. + nts ^. + WalletTrNoteChange ==. + val True) + pure nts + case nxtChg of + Nothing -> return [] + Just nxt -> do + nxtSearch <- traceTrDag pool nxt + return $ nxt : nxtSearch + getSapNotes :: ConnectionPool -> SaplingReceiver -> IO [Entity WalletSapNote] getSapNotes pool sr = do runNoLoggingT $ @@ -1194,6 +1291,57 @@ getSapNotes pool sr = do where_ (snotes ^. WalletSapNoteRecipient ==. val (getBytes sr)) pure snotes +getSapFilteredNotes :: + ConnectionPool + -> [HexStringDB] + -> SaplingReceiver + -> IO [Entity WalletSapNote] +getSapFilteredNotes pool txs sr = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + (wt :& snotes) <- + from $ table @WalletTransaction `innerJoin` table @WalletSapNote `on` + (\(wt :& snotes) -> + wt ^. WalletTransactionId ==. snotes ^. WalletSapNoteTx) + where_ (snotes ^. WalletSapNoteRecipient ==. val (getBytes sr)) + where_ (wt ^. WalletTransactionTxId `in_` valList txs) + pure snotes + +traceSapDag :: + ConnectionPool -> Entity WalletSapNote -> IO [Entity WalletSapNote] +traceSapDag pool note = do + sapSpend <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + sapSpends <- from $ table @WalletSapSpend + where_ (sapSpends ^. WalletSapSpendNote ==. val (entityKey note)) + pure sapSpends + case sapSpend of + Nothing -> return [] + Just snote -> do + nxtChg <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + nts <- from $ table @WalletSapNote + where_ + (nts ^. WalletSapNoteTx ==. + val (walletSapSpendTx $ entityVal snote) &&. + nts ^. + WalletSapNoteChange ==. + val True) + pure nts + case nxtChg of + Nothing -> return [] + Just nxt -> do + nxtSearch <- traceSapDag pool nxt + return $ nxt : nxtSearch + getOrchNotes :: ConnectionPool -> OrchardReceiver -> IO [Entity WalletOrchNote] getOrchNotes pool o = do runNoLoggingT $ @@ -1204,6 +1352,57 @@ getOrchNotes pool o = do where_ (onotes ^. WalletOrchNoteRecipient ==. val (getBytes o)) pure onotes +getOrchFilteredNotes :: + ConnectionPool + -> [HexStringDB] + -> OrchardReceiver + -> IO [Entity WalletOrchNote] +getOrchFilteredNotes pool txs o = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + (wt :& onotes) <- + from $ table @WalletTransaction `innerJoin` table @WalletOrchNote `on` + (\(wt :& onotes) -> + wt ^. WalletTransactionId ==. onotes ^. WalletOrchNoteTx) + where_ (onotes ^. WalletOrchNoteRecipient ==. val (getBytes o)) + where_ (wt ^. WalletTransactionTxId `in_` valList txs) + pure onotes + +traceOrchDag :: + ConnectionPool -> Entity WalletOrchNote -> IO [Entity WalletOrchNote] +traceOrchDag pool note = do + orchSpend <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + orchSpends <- from $ table @WalletOrchSpend + where_ (orchSpends ^. WalletOrchSpendNote ==. val (entityKey note)) + pure orchSpends + case orchSpend of + Nothing -> return [] + Just onote -> do + nxtChg <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + nts <- from $ table @WalletOrchNote + where_ + (nts ^. WalletOrchNoteTx ==. + val (walletOrchSpendTx $ entityVal onote) &&. + nts ^. + WalletOrchNoteChange ==. + val True) + pure nts + case nxtChg of + Nothing -> return [] + Just nxt -> do + nxtSearch <- traceOrchDag pool nxt + return $ nxt : nxtSearch + getWalletNotes :: ConnectionPool -- ^ database path -> Entity WalletAddress @@ -1248,47 +1447,66 @@ getWalletTransactions pool w = do case tReceiver of Nothing -> return [] Just tR -> liftIO $ getTrNotes pool tR - trChgNotes <- - case ctReceiver of + sapNotes <- + case sReceiver of Nothing -> return [] - Just tR -> liftIO $ getTrNotes pool tR + Just sR -> liftIO $ getSapNotes pool sR + orchNotes <- + case oReceiver of + Nothing -> return [] + Just oR -> liftIO $ getOrchNotes pool oR + clearUserTx (entityKey w) + mapM_ addTr trNotes + mapM_ addSap sapNotes + mapM_ addOrch orchNotes trSpends <- PS.retryOnBusy $ flip PS.runSqlPool pool $ do select $ do trSpends <- from $ table @WalletTrSpend where_ - (trSpends ^. WalletTrSpendNote `in_` - valList (map entityKey (trNotes <> trChgNotes))) + (trSpends ^. WalletTrSpendNote `in_` valList (map entityKey trNotes)) pure trSpends - sapNotes <- - case sReceiver of - Nothing -> return [] - Just sR -> liftIO $ getSapNotes pool sR - sapChgNotes <- - case csReceiver of - Nothing -> return [] - Just sR -> liftIO $ getSapNotes pool sR - sapSpends <- mapM (getSapSpends . entityKey) (sapNotes <> sapChgNotes) - orchNotes <- - case oReceiver of - Nothing -> return [] - Just oR -> liftIO $ getOrchNotes pool oR - orchChgNotes <- - case coReceiver of - Nothing -> return [] - Just oR -> liftIO $ getOrchNotes pool oR - orchSpends <- mapM (getOrchSpends . entityKey) (orchNotes <> orchChgNotes) - clearUserTx (entityKey w) - mapM_ addTr trNotes - mapM_ addTr trChgNotes - mapM_ addSap sapNotes - mapM_ addSap sapChgNotes - mapM_ addOrch orchNotes - mapM_ addOrch orchChgNotes + sapSpends <- mapM (getSapSpends . entityKey) sapNotes + orchSpends <- mapM (getOrchSpends . entityKey) orchNotes mapM_ subTSpend trSpends mapM_ subSSpend $ catMaybes sapSpends mapM_ subOSpend $ catMaybes orchSpends + foundTxs <- getTxs $ entityKey w + trChgNotes <- + case ctReceiver of + Nothing -> return [] + Just tR -> liftIO $ getTrFilteredNotes pool foundTxs tR + trChgNotes' <- liftIO $ mapM (traceTrDag pool) trChgNotes + trChgSpends <- + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + trS <- from $ table @WalletTrSpend + where_ + (trS ^. WalletTrSpendNote `in_` + valList (map entityKey (trChgNotes <> concat trChgNotes'))) + pure trS + sapChgNotes <- + case csReceiver of + Nothing -> return [] + Just sR -> liftIO $ getSapFilteredNotes pool foundTxs sR + sapChgNotes' <- liftIO $ mapM (traceSapDag pool) sapChgNotes + sapChgSpends <- + mapM (getSapSpends . entityKey) (sapChgNotes <> concat sapChgNotes') + orchChgNotes <- + case coReceiver of + Nothing -> return [] + Just oR -> liftIO $ getOrchFilteredNotes pool foundTxs oR + orchChgNotes' <- liftIO $ mapM (traceOrchDag pool) orchChgNotes + orchChgSpends <- + mapM (getOrchSpends . entityKey) (orchChgNotes <> concat orchChgNotes') + mapM_ addTr (trChgNotes <> concat trChgNotes') + mapM_ addSap (sapChgNotes <> concat sapChgNotes') + mapM_ addOrch (orchChgNotes <> concat orchChgNotes') + mapM_ subTSpend trChgSpends + mapM_ subSSpend $ catMaybes sapChgSpends + mapM_ subOSpend $ catMaybes orchChgSpends where clearUserTx :: WalletAddressId -> NoLoggingT IO () clearUserTx waId = do @@ -1298,6 +1516,16 @@ getWalletTransactions pool w = do u <- from $ table @UserTx where_ (u ^. UserTxAddress ==. val waId) return () + getTxs :: WalletAddressId -> NoLoggingT IO [HexStringDB] + getTxs waId = do + res <- + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + t <- from $ table @UserTx + where_ (t ^. UserTxAddress ==. val waId) + return (t ^. UserTxHex) + return $ map (\(Value x) -> x) res getSapSpends :: WalletSapNoteId -> NoLoggingT IO (Maybe (Entity WalletSapSpend)) getSapSpends n = do @@ -1577,12 +1805,16 @@ getUnspentSapNotes pool = do where_ (n ^. WalletSapNoteSpent ==. val False) pure n -getSaplingCmus :: Pool SqlBackend -> ShieldOutputId -> IO [Value HexStringDB] -getSaplingCmus pool zt = do +getSaplingCmus :: + ConnectionPool + -> ShieldOutputId + -> ShieldOutputId + -> IO [Value HexStringDB] +getSaplingCmus pool zt m = do PS.runSqlPool (select $ do n <- from $ table @ShieldOutput - where_ (n ^. ShieldOutputId >. val zt) + where_ (n ^. ShieldOutputId >. val zt &&. n ^. ShieldOutputId <=. val m) orderBy [asc $ n ^. ShieldOutputId] pure $ n ^. ShieldOutputCmu) pool @@ -1590,15 +1822,30 @@ getSaplingCmus pool zt = do getMaxSaplingNote :: Pool SqlBackend -> IO ShieldOutputId getMaxSaplingNote pool = do flip PS.runSqlPool pool $ do - x <- + maxBlock <- selectOne $ do - n <- from $ table @ShieldOutput - where_ (n ^. ShieldOutputId >. val (toSqlKey 0)) - orderBy [desc $ n ^. ShieldOutputId] - pure (n ^. ShieldOutputId) - case x of + blks <- from $ table @ZcashBlock + where_ $ blks ^. ZcashBlockHeight >. val 0 + orderBy [desc $ blks ^. ZcashBlockHeight] + pure $ blks ^. ZcashBlockHeight + case maxBlock of Nothing -> return $ toSqlKey 0 - Just (Value y) -> return y + Just (Value mb) -> do + x <- + selectOne $ do + (blks :& txs :& n) <- + from $ table @ZcashBlock `innerJoin` table @ZcashTransaction `on` + (\(blks :& txs) -> + blks ^. ZcashBlockId ==. txs ^. ZcashTransactionBlockId) `innerJoin` + table @ShieldOutput `on` + (\(_ :& txs :& n) -> + txs ^. ZcashTransactionId ==. n ^. ShieldOutputTx) + where_ (blks ^. ZcashBlockHeight <=. val (mb - 5)) + orderBy [desc $ n ^. ShieldOutputId] + pure (n ^. ShieldOutputId) + case x of + Nothing -> return $ toSqlKey 0 + Just (Value y) -> return y updateSapNoteRecord :: Pool SqlBackend @@ -1626,12 +1873,13 @@ getUnspentOrchNotes pool = do where_ (n ^. WalletOrchNoteSpent ==. val False) pure n -getOrchardCmxs :: Pool SqlBackend -> OrchActionId -> IO [Value HexStringDB] -getOrchardCmxs pool zt = do +getOrchardCmxs :: + ConnectionPool -> OrchActionId -> OrchActionId -> IO [Value HexStringDB] +getOrchardCmxs pool zt m = do PS.runSqlPool (select $ do n <- from $ table @OrchAction - where_ (n ^. OrchActionId >. val zt) + where_ (n ^. OrchActionId >. val zt &&. n ^. OrchActionId <=. val m) orderBy [asc $ n ^. OrchActionId] pure $ n ^. OrchActionCmx) pool @@ -1643,6 +1891,7 @@ getMaxOrchardNote pool = do selectOne $ do blks <- from $ table @ZcashBlock where_ $ blks ^. ZcashBlockHeight >. val 0 + orderBy [desc $ blks ^. ZcashBlockHeight] pure $ blks ^. ZcashBlockHeight case maxBlock of Nothing -> return $ toSqlKey 0 @@ -1837,6 +2086,51 @@ getUnconfPoolBalance pool za = do let oBal = sum oAmts return $ AccountBalance tBal sBal oBal +rewindWalletTransactions :: ConnectionPool -> Int -> IO () +rewindWalletTransactions pool b = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + delete $ do + _ <- from $ table @UserTx + return () + oldTxs <- + select $ do + txs <- from $ table @WalletTransaction + where_ $ txs ^. WalletTransactionBlock >. val b + pure txs + let oldKeys = map entityKey oldTxs + delete $ do + x <- from $ table @WalletOrchSpend + where_ $ x ^. WalletOrchSpendTx `in_` valList oldKeys + return () + delete $ do + x <- from $ table @WalletOrchNote + where_ $ x ^. WalletOrchNoteTx `in_` valList oldKeys + return () + delete $ do + x <- from $ table @WalletSapSpend + where_ $ x ^. WalletSapSpendTx `in_` valList oldKeys + return () + delete $ do + x <- from $ table @WalletSapNote + where_ $ x ^. WalletSapNoteTx `in_` valList oldKeys + return () + delete $ do + x <- from $ table @WalletTrSpend + where_ $ x ^. WalletTrSpendTx `in_` valList oldKeys + return () + delete $ do + x <- from $ table @WalletTrNote + where_ $ x ^. WalletTrNoteTx `in_` valList oldKeys + return () + delete $ do + txs <- from $ table @WalletTransaction + where_ $ txs ^. WalletTransactionBlock >. val b + return () + update $ \w -> do + set w [ZcashWalletLastSync =. val b] + clearWalletTransactions :: ConnectionPool -> IO () clearWalletTransactions pool = do runNoLoggingT $ @@ -1874,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 () @@ -2079,8 +2376,8 @@ selectUnspentNotes pool za amt = do selectUnspentNotesV2 :: ConnectionPool -> ZcashAccountId - -> Integer - -> Int + -> Int64 + -> [Int] -> PrivacyPolicy -> IO (Either @@ -2091,27 +2388,40 @@ selectUnspentNotesV2 :: selectUnspentNotesV2 pool za amt recv policy = do case policy of Full -> - case recv of - 4 -> do - orchNotes <- getWalletUnspentOrchNotes pool za - let (a1, oList) = checkOrchard (fromIntegral amt) orchNotes - if a1 > 0 - then return $ - Left $ PrivacyPolicyError "Not enough notes for Full privacy" - else return $ Right ([], [], oList) - 3 -> do - sapNotes <- getWalletUnspentSapNotes pool za - let (a2, sList) = checkSapling (fromIntegral amt) sapNotes - if a2 > 0 - then return $ - Left $ PrivacyPolicyError "Not enough notes for Full privacy" - else return $ Right ([], sList, []) - _anyOther -> - return $ - Left $ PrivacyPolicyError "Receiver not capable of Full privacy" + if elem 1 recv || elem 2 recv || elem 5 recv || elem 6 recv + then return $ + Left $ PrivacyPolicyError "Receiver not capable of Full privacy" + else if elem 4 recv && elem 3 recv + then return $ + Left $ + PrivacyPolicyError + "Combination of receivers not allowed for Full privacy" + else if 4 `elem` recv + then do + orchNotes <- getWalletUnspentOrchNotes pool za + let (a1, oList) = + checkOrchard (fromIntegral amt) orchNotes + if a1 > 0 + then return $ + Left $ + PrivacyPolicyError + "Not enough notes for Full privacy" + else return $ Right ([], [], oList) + else do + sapNotes <- getWalletUnspentSapNotes pool za + let (a2, sList) = + checkSapling (fromIntegral amt) sapNotes + if a2 > 0 + then return $ + Left $ + PrivacyPolicyError + "Not enough notes for Full privacy" + else return $ Right ([], sList, []) Medium -> - if recv > 2 - then do + if elem 1 recv || elem 2 recv || elem 5 recv || elem 6 recv + then return $ + Left $ PrivacyPolicyError "Receiver not capable of Medium privacy" + else do orchNotes <- getWalletUnspentOrchNotes pool za let (a1, oList) = checkOrchard (fromIntegral amt) orchNotes if a1 > 0 @@ -2124,27 +2434,16 @@ selectUnspentNotesV2 pool za amt recv policy = do PrivacyPolicyError "Not enough notes for Medium privacy" else return $ Right ([], sList, oList) else return $ Right ([], [], oList) - else return $ - Left $ PrivacyPolicyError "Receiver not capable of Medium privacy" Low -> - if recv == 0 + if 0 `elem` recv then return $ Left ZHError else do - case recv of - 3 -> do - sapNotes <- getWalletUnspentSapNotes pool za - let (a1, sList) = checkSapling (fromIntegral amt) sapNotes - if a1 > 0 - then do - orchNotes <- getWalletUnspentOrchNotes pool za - let (a2, oList) = checkOrchard a1 orchNotes - if a2 > 0 - then return $ - Left $ - PrivacyPolicyError "Not enough notes for Low privacy" - else return $ Right ([], sList, oList) - else return $ Right ([], sList, []) - _anyOther -> do + if elem 5 recv || elem 6 recv + then return $ + Left $ + PrivacyPolicyError + "Exchange addresses not supported with Low privacy" + else do orchNotes <- getWalletUnspentOrchNotes pool za let (a1, oList) = checkOrchard (fromIntegral amt) orchNotes if a1 > 0 @@ -2152,27 +2451,27 @@ selectUnspentNotesV2 pool za amt recv policy = do sapNotes <- getWalletUnspentSapNotes pool za let (a2, sList) = checkSapling a1 sapNotes if a2 > 0 - then return $ - Left $ - PrivacyPolicyError "Not enough notes for Low privacy" + then do + trNotes <- getWalletUnspentTrNotes pool za + let (a3, tList) = checkTransparent a2 trNotes + if a3 > 0 + then return $ Left InsufficientFunds + else return $ Right (tList, sList, oList) else return $ Right ([], sList, oList) else return $ Right ([], [], oList) None -> do - orchNotes <- getWalletUnspentOrchNotes pool za - let (a1, oList) = checkOrchard (fromIntegral amt) orchNotes - if a1 > 0 - then do - sapNotes <- getWalletUnspentSapNotes pool za - let (a2, sList) = checkSapling a1 sapNotes - if a2 > 0 - then do - trNotes <- getWalletUnspentTrNotes pool za - let (a3, tList) = checkTransparent a2 trNotes - if a3 > 0 - then return $ Left InsufficientFunds - else return $ Right (tList, sList, oList) - else return $ Right ([], sList, oList) - else return $ Right ([], [], oList) + if elem 3 recv || elem 4 recv + then return $ + Left $ + PrivacyPolicyError + "Shielded recipients not compatible with privacy policy." + else do + trNotes <- getWalletUnspentTrNotes pool za + let (a3, tList) = checkTransparent (fromIntegral amt) trNotes + if a3 > 0 + then return $ + Left $ PrivacyPolicyError "Insufficient transparent funds" + else return $ Right (tList, [], []) where checkTransparent :: Int64 -> [Entity WalletTrNote] -> (Int64, [Entity WalletTrNote]) @@ -2235,6 +2534,19 @@ saveConfs pool b c = do set bl [ZcashBlockConf =. val c] where_ $ bl ^. ZcashBlockHeight ==. val b +getReceivers :: ConnectionPool -> [Entity WalletTrNote] -> IO [WalletAddressId] +getReceivers pool ns = do + r <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ + distinct $ do + t <- from $ table @WalletTrNote + where_ (t ^. WalletTrNoteId `in_` valList (map entityKey ns)) + return (t ^. WalletTrNoteAddress) + return $ map (\(Value x) -> x) r + -- | Helper function to extract a Unified Address from the database readUnifiedAddressDB :: WalletAddress -> Maybe UnifiedAddress readUnifiedAddressDB = @@ -2327,13 +2639,364 @@ finalizeOperation pool op status result = do ] where_ (ops ^. OperationId ==. val op) --- | Rewind the data store to a given block height -rewindWalletData :: ConnectionPool -> Int -> IO () -rewindWalletData pool b = do - runNoLoggingT $ +-- * Chain sync +-- | Check if the wallet is currently running a sync +isSyncing :: ConnectionPool -> IO Bool +isSyncing pool = do + s <- + runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ + selectOne $ do + r <- from $ table @ChainSync + where_ $ r ^. ChainSyncStatus ==. val Processing + pure r + case s of + Nothing -> return False + Just _ -> return True + +-- | Record the start of a sync +startSync :: ConnectionPool -> IO () +startSync pool = do + start <- getCurrentTime + _ <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ + upsert (ChainSync "Internal" start Nothing Processing) [] + return () + +-- | Complete a sync +completeSync :: ConnectionPool -> ZenithStatus -> IO () +completeSync pool st = do + end <- getCurrentTime + _ <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ + update $ \s -> do + set s [ChainSyncEnd =. val (Just end), ChainSyncStatus =. val st] + where_ (s ^. ChainSyncName ==. val "Internal") + return () + +-- | Rewind the data store to a given block height +rewindWalletData :: ConnectionPool -> Int -> ZcashNetDB -> NoLoggingT IO () +rewindWalletData pool b net = do + logDebugN "Starting transaction rewind" + liftIO $ rewindWalletTransactions pool b + logDebugN "Completed transaction rewind" + logDebugN "Starting data store rewind" + _ <- + runStderrLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + oldBlocks <- + select $ do + blk <- from $ table @ZcashBlock + where_ + (blk ^. ZcashBlockHeight >. val b &&. blk ^. ZcashBlockNetwork ==. + val net) + pure blk + let oldBlkKeys = map entityKey oldBlocks + oldTxs <- + select $ do + txs <- from $ table @ZcashTransaction + where_ $ txs ^. ZcashTransactionBlockId `in_` valList oldBlkKeys + pure txs + let oldTxKeys = map entityKey oldTxs + delete $ do + x <- from $ table @TransparentNote + where_ $ x ^. TransparentNoteTx `in_` valList oldTxKeys + logDebugN "Completed TransparentNote delete" + _ <- + runStderrLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + oldBlocks <- + select $ do + blk <- from $ table @ZcashBlock + where_ + (blk ^. ZcashBlockHeight >. val b &&. blk ^. ZcashBlockNetwork ==. + val net) + pure blk + let oldBlkKeys = map entityKey oldBlocks + oldTxs <- + select $ do + txs <- from $ table @ZcashTransaction + where_ $ txs ^. ZcashTransactionBlockId `in_` valList oldBlkKeys + pure txs + let oldTxKeys = map entityKey oldTxs + delete $ do + x <- from $ table @TransparentSpend + where_ $ x ^. TransparentSpendTx `in_` valList oldTxKeys + logDebugN "Completed TransparentSpend delete" + _ <- + runStderrLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + oldBlocks <- + select $ do + blk <- from $ table @ZcashBlock + where_ + (blk ^. ZcashBlockHeight >. val b &&. blk ^. ZcashBlockNetwork ==. + val net) + pure blk + let oldBlkKeys = map entityKey oldBlocks + oldTxs <- + select $ do + txs <- from $ table @ZcashTransaction + where_ $ txs ^. ZcashTransactionBlockId `in_` valList oldBlkKeys + pure txs + let oldTxKeys = map entityKey oldTxs + delete $ do + x <- from $ table @ShieldOutput + where_ $ x ^. ShieldOutputTx `in_` valList oldTxKeys + logDebugN "Completed ShieldOutput delete" + _ <- + runStderrLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + oldBlocks <- + select $ do + blk <- from $ table @ZcashBlock + where_ + (blk ^. ZcashBlockHeight >. val b &&. blk ^. ZcashBlockNetwork ==. + val net) + pure blk + let oldBlkKeys = map entityKey oldBlocks + oldTxs <- + select $ do + txs <- from $ table @ZcashTransaction + where_ $ txs ^. ZcashTransactionBlockId `in_` valList oldBlkKeys + pure txs + let oldTxKeys = map entityKey oldTxs + delete $ do + x <- from $ table @ShieldSpend + where_ $ x ^. ShieldSpendTx `in_` valList oldTxKeys + logDebugN "Completed ShieldSpend delete" + _ <- + runStderrLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + oldBlocks <- + select $ do + blk <- from $ table @ZcashBlock + where_ + (blk ^. ZcashBlockHeight >. val b &&. blk ^. ZcashBlockNetwork ==. + val net) + pure blk + let oldBlkKeys = map entityKey oldBlocks + oldTxs <- + select $ do + txs <- from $ table @ZcashTransaction + where_ $ txs ^. ZcashTransactionBlockId `in_` valList oldBlkKeys + pure txs + let oldTxKeys = map entityKey oldTxs + delete $ do + x <- from $ table @OrchAction + where_ $ x ^. OrchActionTx `in_` valList oldTxKeys + logDebugN "Completed OrchAction delete" + _ <- + runStderrLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + oldBlocks <- + select $ do + blk <- from $ table @ZcashBlock + where_ + (blk ^. ZcashBlockHeight >. val b &&. blk ^. ZcashBlockNetwork ==. + val net) + pure blk + let oldBlkKeys = map entityKey oldBlocks + oldTxs <- + select $ do + txs <- from $ table @ZcashTransaction + where_ $ txs ^. ZcashTransactionBlockId `in_` valList oldBlkKeys + pure txs + let oldTxKeys = map entityKey oldTxs + delete $ do + x <- from $ table @ZcashTransaction + where_ $ x ^. ZcashTransactionId `in_` valList oldTxKeys + logDebugN "Completed ZcashTransaction delete" + _ <- + runStderrLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + delete $ do + blk <- from $ table @ZcashBlock + where_ $ + (blk ^. ZcashBlockHeight >. val b) &&. + (blk ^. ZcashBlockNetwork ==. val net) + logDebugN "Completed data store rewind" + {- + -_ <- liftIO $ clearTrees pool + -logDebugN "Cleared commitment trees" + -} + 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 + 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 + truncOrchTree <- truncateTree (maybe InvalidTree fst orchardTree) oaIx + _ <- liftIO $ upsertOrchardTree pool b truncOrchTree + logDebugN $ "Truncated Orchard tree at index " <> T.pack (show oaIx) + +clearTrees :: ConnectionPool -> IO () +clearTrees pool = + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do delete $ do - blk <- from $ table @ZcashBlock - where_ $ blk ^. ZcashBlockHeight >=. val b - clearWalletTransactions pool + tr <- from $ table @TreeStore + return () + +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 $ sOutputs ^. ShieldOutputId] + 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 $ oActions ^. OrchActionId] + 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 () diff --git a/src/Zenith/GUI.hs b/src/Zenith/GUI.hs index 6f76bac..5face1c 100644 --- a/src/Zenith/GUI.hs +++ b/src/Zenith/GUI.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} module Zenith.GUI where @@ -10,13 +11,20 @@ import Codec.QRCode import Codec.QRCode.JuicyPixels import Control.Concurrent (threadDelay) import Control.Exception (throwIO, try) -import Control.Monad (unless, when) +import Control.Monad (forM_, unless, when) import Control.Monad.IO.Class (liftIO) -import Control.Monad.Logger (runFileLoggingT, runNoLoggingT) +import Control.Monad.Logger + ( LoggingT + , NoLoggingT + , logDebugN + , runNoLoggingT + , runStderrLoggingT + ) import Data.Aeson import qualified Data.ByteString as BS import Data.HexString (toText) import Data.Maybe (fromMaybe, isJust, isNothing) +import Data.Scientific (Scientific, fromFloatDigits) import qualified Data.Text as T import qualified Data.Text.Encoding as E import Data.Time.Clock.POSIX (posixSecondsToUTCTime) @@ -25,10 +33,11 @@ import Database.Persist import Lens.Micro ((&), (+~), (.~), (?~), (^.), set) import Lens.Micro.TH import Monomer + import qualified Monomer.Lens as L import System.Directory (getHomeDirectory) import System.FilePath (()) -import Text.Printf +import Text.Printf (printf) import Text.Wrap (FillScope(..), FillStrategy(..), WrapSettings(..), wrapText) import TextShow hiding (toText) import ZcashHaskell.Keys (generateWalletSeedPhrase) @@ -37,12 +46,16 @@ import ZcashHaskell.Orchard , isValidUnifiedAddress , parseAddress ) -import ZcashHaskell.Transparent (encodeTransparentReceiver) +import ZcashHaskell.Transparent + ( decodeTransparentAddress + , encodeTransparentReceiver + ) import ZcashHaskell.Types ( BlockResponse(..) , Scope(..) , ToBytes(..) , UnifiedAddress(..) + , ValidAddress(..) , ZcashNet(..) , ZebraGetBlockChainInfo(..) , ZebraGetInfo(..) @@ -55,15 +68,24 @@ import Zenith.Scanner (checkIntegrity, processTx, rescanZebra, updateConfs) import Zenith.Types hiding (ZcashAddress(..)) import Zenith.Utils ( displayAmount + , getChainTip + , getZcashPrice , isRecipientValidGUI , isValidString , isZecAddressValid , jsonNumber , padWithZero + , parseZcashPayment , showAddress , validBarValue ) +data VkTypeDef + = VkNone + | VkFull + | VkIncoming + deriving (Eq, Show) + data AppEvent = AppInit | ShowMsg !T.Text @@ -74,6 +96,7 @@ data AppEvent | AccountClicked | MenuClicked | NewClicked + | ViewingKeysClicked | NewAddress !(Maybe (Entity ZcashAccount)) | NewAccount !(Maybe (Entity ZcashWallet)) | NewWallet @@ -82,7 +105,7 @@ data AppEvent | SwitchAddr !Int | SwitchAcc !Int | SwitchWal !Int - | UpdateBalance !(Integer, Integer) + | UpdateBalance !(Integer, Integer, Integer, Integer) | CopyAddr !(Maybe (Entity WalletAddress)) | LoadTxs ![Entity UserTx] | LoadAddrs ![Entity WalletAddress] @@ -130,6 +153,21 @@ data AppEvent | CloseShield | ShowDeShield | CloseDeShield + | SendDeShield + | SendShield + | StartSync + | TreeSync + | ShowFIATBalance + | DisplayFIATBalance Double Double + | CloseFIATBalance + | ShowViewingKey !VkTypeDef !T.Text + | CopyViewingKey !T.Text !T.Text + | CloseShowVK + | DisplayPaymentURI + | ClosePaymentURI + | DisplayPayUsingURI + | ClosePayUsingURI + | ProcIfValidURI deriving (Eq, Show) data AppModel = AppModel @@ -189,6 +227,16 @@ data AppModel = AppModel , _tBalanceValid :: !Bool , _sBalance :: !Integer , _sBalanceValid :: !Bool + , _displayFIATBalance :: !Bool + , _zPrice :: !Double + , _aBal :: !Double + , _viewingKeyPopup :: !Bool + , _viewingKeyDisplay :: !Bool + , _vkTypeName :: !T.Text + , _vkData :: !T.Text + , _paymentURIDisplay :: !Bool + , _usepmtURIOverlay :: !Bool + , _uriString :: !T.Text } deriving (Eq, Show) makeLenses ''AppModel @@ -232,12 +280,16 @@ buildUI wenv model = widgetTree , modalOverlay `nodeVisible` isJust (model ^. modalMsg) , adrbookOverlay `nodeVisible` model ^. showAdrBook , newAdrBkOverlay `nodeVisible` model ^. newAdrBkEntry + , dfBalOverlay `nodeVisible` model ^. displayFIATBalance , showABAddressOverlay (model ^. abdescrip) (model ^. abaddress) `nodeVisible` model ^. showABAddress , updateABAddressOverlay (model ^. abdescrip) (model ^. abaddress) `nodeVisible` model ^. updateABAddress + , showVKOverlay `nodeVisible` model ^. viewingKeyDisplay + , paymentURIOverlay `nodeVisible` model ^. paymentURIDisplay + , pmtUsingURIOverlay `nodeVisible` model ^. usepmtURIOverlay , shieldOverlay `nodeVisible` model ^. shieldZec , deShieldOverlay `nodeVisible` model ^. deShieldZec , msgAdrBookOverlay `nodeVisible` isJust (model ^. msgAB) @@ -309,6 +361,35 @@ buildUI wenv model = widgetTree [bgColor white, borderB 1 gray, padding 3] , box_ [alignLeft, onClick ShowDeShield] (label "De-Shield ZEC") `styleBasic` [bgColor white, borderB 1 gray, padding 3] + , box_ + [alignLeft] + (vstack + [ box_ + [alignLeft, onClick ViewingKeysClicked] + (hstack + [ label "Viewing Keys" + , filler + , widgetIf (not $ model ^. viewingKeyPopup) $ + remixIcon remixMenuUnfoldFill + , widgetIf (model ^. viewingKeyPopup) $ + remixIcon remixMenuFoldFill + ]) + , widgetIf (model ^. viewingKeyPopup) $ + animSlideIn viewingKeysBox + ]) `styleBasic` + [bgColor white, borderB 1 gray, padding 3] + , box_ + [alignLeft, onClick ShowFIATBalance] + (label + ("Balance in " <> + T.toUpper (c_currencyCode (model ^. configuration)))) `styleBasic` + [bgColor white, borderB 1 gray, padding 3] + , box_ [alignLeft, onClick DisplayPaymentURI] (label "Create URI") `styleBasic` + [bgColor white, borderB 1 gray, padding 3] + , box_ + [alignLeft, onClick DisplayPayUsingURI] + (label "Pay using URI") `styleBasic` + [bgColor white, borderB 1 gray, padding 3] ]) `styleBasic` [bgColor btnColor, padding 3] newBox = @@ -328,6 +409,29 @@ buildUI wenv model = widgetTree (hstack [label "Wallet", filler]) `styleBasic` [bgColor white, borderB 1 gray, padding 3] ]) + viewingKeysBox = + box_ + [alignMiddle] + (vstack + [ box_ + [ alignLeft + , onClick + (ShowViewingKey + VkFull + "VKFull->ztestsapling1tgjr4zppwk4ne8xy6gdq4z2gwq7dmf5jq8z2ctpn8nlmtse0a74fa5z0m8z383gmpgqz6q6duu4") + ] + (hstack [label "Full VK", filler]) `styleBasic` + [bgColor white, borderB 1 gray, padding 3] + , box_ + [ alignLeft + , onClick $ + (ShowViewingKey + VkIncoming + "VKIncoming->ztestsapling1tgjr4zppwk4ne8xy6gdq4z2gwq7dmf5jq8z2ctpn8nlmtse0a74fa5z0m8z383gmpgqz6q6duu4") + ] + (hstack [label "Incoming VK", filler]) `styleBasic` + [bgColor white, borderB 1 gray, padding 3] + ]) walletButton = hstack [ label "Wallet: " `styleBasic` [textFont "Bold", textColor white] @@ -740,7 +844,7 @@ buildUI wenv model = widgetTree box (label (fromMaybe "?" $ model ^. modalMsg) `styleBasic` [textSize 12, textFont "Bold"]) `styleBasic` - [bgColor (white & L.a .~ 0.5)] + [bgColor (white & L.a .~ 0.7)] txOverlay = case model ^. showTx of Nothing -> alert CloseTx $ label "N/A" @@ -974,8 +1078,51 @@ buildUI wenv model = widgetTree , label_ (txtWrapN (fromMaybe "" (model ^. msgAB)) 64) [multiline] , filler ] + dfBalOverlay = + alert CloseFIATBalance $ + vstack + [ box_ + [] + (label + ("Account Balance in " <> + (T.toUpper (c_currencyCode (model ^. configuration)))) `styleBasic` + [textFont "Bold", textSize 12, textColor white]) `styleBasic` + [bgColor btnColor, radius 2, padding 3] + , filler + , (label + ("1 ZEC = " <> + (T.pack (printf "%.2f" (model ^. zPrice))) <> + " " <> (T.toUpper (c_currencyCode (model ^. configuration))))) `styleBasic` + [] + , filler + , (label + ((T.pack (printf "%.8f" (model ^. aBal)) <> + " ZEC = " <> + (T.pack (printf "%.2f" ((model ^. zPrice) * (model ^. aBal)))) <> + " " <> (T.toUpper (c_currencyCode (model ^. configuration)))))) `styleBasic` + [] + ] + showVKOverlay = + alert CloseShowVK $ + vstack + [ box_ + [] + (label ((model ^. vkTypeName) <> " Viewing Key") `styleBasic` + [textFont "Bold", textColor white, textSize 12, padding 3]) `styleBasic` + [bgColor btnColor, radius 2, padding 3] + , spacer + , hstack + [filler, label_ (txtWrapN (model ^. vkData) 64) [multiline], filler] + , spacer + , hstack + [ filler + , button "Copy to Clipboard" $ + CopyViewingKey (model ^. vkTypeName) (model ^. vkData) + , filler + ] + ] shieldOverlay = - box + box (vstack [ filler , hstack @@ -988,41 +1135,23 @@ buildUI wenv model = widgetTree (label "Shield Zcash" `styleBasic` [textFont "Bold", textSize 12]) , separatorLine `styleBasic` [fgColor btnColor] - , spacer - , hstack - [ filler - , label ("Amount : " ) `styleBasic` - [width 50, textFont "Bold"] - , spacer - , label (displayAmount (model ^. network) 100 ) `styleBasic` - [width 50, textFont "Bold"] - , filler --- , spacer --- , numericField_ --- sendAmount --- [ decimals 8 --- , minValue 0.0 --- , maxValue --- (fromIntegral (model ^. tBalance) / 100000000.0) --- , validInput tBalanceValid --- , onChange CheckAmount --- ] `styleBasic` --- [ width 150 --- , styleIf --- (not $ model ^. tBalanceValid) --- (textColor red) --- ] - ] + , spacer + , label + ("Shield " <> + displayAmount (model ^. network) (model ^. tBalance) <> + "?") `styleBasic` + [width 50, textFont "Regular"] , spacer , box_ [alignMiddle] (hstack - [ filler - , mainButton "Proceed" NotImplemented `nodeEnabled` True --- (model ^. amountValid && model ^. recipientValid) - , spacer - , mainButton "Cancel" CloseShield `nodeEnabled` True - , filler + [ filler + , mainButton "Proceed" SendShield `nodeEnabled` + True + , spacer + , mainButton "Cancel" CloseShield `nodeEnabled` + True + , filler ]) ]) `styleBasic` [radius 4, border 2 btnColor, bgColor white, padding 4] @@ -1046,44 +1175,58 @@ buildUI wenv model = widgetTree [textFont "Bold", textSize 12]) , separatorLine `styleBasic` [fgColor btnColor] , spacer - , hstack - [ (label "Total Transparent : " `styleBasic` [ textFont "Bold" ]) - , (label "0.00" ) - ] - , spacer - , hstack - [ (label "Total Shielded : " `styleBasic` [ textFont "Bold" ]) - , (label "0.00" ) - ] - , spacer - , hstack - [ label "Amount:" `styleBasic` - [width 50, textFont "Bold"] - , spacer - , numericField_ - sendAmount - [ decimals 8 - , minValue 0.0 - , maxValue - (fromIntegral (model ^. sBalance) / 100000000.0) - , validInput sBalanceValid - , onChange CheckAmount - ] `styleBasic` - [ width 150 - , styleIf - (not $ model ^. sBalanceValid) - (textColor red) - ] - ] + , box_ + [] + (vstack + [ hstack + [ label "Total Transparent : " `styleBasic` + [textFont "Bold"] + , label + (displayAmount + (model ^. network) + (model ^. tBalance)) + ] + , spacer + , hstack + [ label "Total Shielded : " `styleBasic` + [textFont "Bold"] + , label + (displayAmount + (model ^. network) + (model ^. sBalance)) + ] + , spacer + , hstack + [ label "Amount:" `styleBasic` + [width 50, textFont "Bold"] + , spacer + , numericField_ + sendAmount + [ decimals 8 + , minValue 0.0 + , maxValue + (fromIntegral (model ^. sBalance) / + 100000000.0) + , validInput sBalanceValid + , onChange CheckAmount + ] `styleBasic` + [ width 150 + , styleIf + (not $ model ^. sBalanceValid) + (textColor red) + ] + ] + ]) , spacer , box_ [alignMiddle] (hstack - [ filler - , mainButton "Proceed" NotImplemented `nodeEnabled` True --- (model ^. amountValid && model ^. recipientValid) - , spacer - , mainButton "Cancel" CloseDeShield `nodeEnabled` True + [ filler + , mainButton "Proceed" SendDeShield `nodeEnabled` + True + , spacer + , mainButton "Cancel" CloseDeShield `nodeEnabled` + True , filler ]) ]) `styleBasic` @@ -1093,7 +1236,106 @@ buildUI wenv model = widgetTree , filler ]) `styleBasic` [bgColor (white & L.a .~ 0.5)] -notImplemented = NotImplemented + paymentURIOverlay = + box + (vstack + [ filler + , hstack + [ filler + , box_ + [] + (vstack + [ box_ + [alignMiddle] + (label "Create URI" `styleBasic` + [textColor white, textFont "Bold", textSize 12]) `styleBasic` + [bgColor btnColor] + , separatorLine `styleBasic` [fgColor btnColor] + , spacer + , hstack + [ label "Amount:" `styleBasic` + [width 50, textFont "Bold"] + , spacer + , numericField_ + sendAmount + [ decimals 8 + , minValue 0.0 + , maxValue + (fromIntegral (model ^. balance) / 100000000.0) + , validInput amountValid + , onChange CheckAmount + ] `styleBasic` + [ width 150 + , styleIf + (not $ model ^. amountValid) + (textColor red) + ] + ] + , hstack + [ label "Memo:" `styleBasic` + [width 50, textFont "Bold"] + , spacer + , textArea sendMemo `styleBasic` + [width 150, height 40] + ] + , spacer + , box_ + [alignMiddle] + (hstack + [ spacer + , mainButton "Create URI" NotImplemented `nodeEnabled` + True + , spacer + , button "Cancel" ClosePaymentURI + , spacer + ]) + ]) `styleBasic` + [radius 4, border 2 btnColor, bgColor white, padding 4] + , filler + ] + , filler + ]) `styleBasic` + [bgColor (white & L.a .~ 0.5)] + pmtUsingURIOverlay = + box + (vstack + [ filler + , hstack + [ filler + , box_ + [] + (vstack + [ box_ + [alignMiddle] + (label "Pay using URI" `styleBasic` + [textColor white, textFont "Bold", textSize 12]) `styleBasic` + [bgColor btnColor] + , separatorLine `styleBasic` [fgColor btnColor] + , spacer + , hstack + [ label "URI :" `styleBasic` + [width 30, textFont "Bold"] + , spacer + , textArea uriString `styleBasic` + [width 170, height 30] + ] + , spacer + , box_ + [alignMiddle] + (hstack + [ spacer + , button "Cancel" ClosePayUsingURI + , spacer + , mainButton "Process" ProcIfValidURI + , spacer + ]) + ]) `styleBasic` + [radius 4, border 2 btnColor, bgColor white, padding 4] + , filler + ] + , filler + ]) `styleBasic` + [bgColor (white & L.a .~ 0.5)] generateQRCodes :: Config -> IO () generateQRCodes config = do @@ -1216,6 +1458,14 @@ handleEvent wenv node model evt = False ] ConfirmCancel -> [Model $ model & confirmTitle .~ Nothing & mainInput .~ ""] + ViewingKeysClicked -> + [Model $ model & viewingKeyPopup .~ not (model ^. viewingKeyPopup)] + NewAddress vk -> + [ Model $ + model & confirmTitle ?~ "New Address" & confirmCancel .~ "Cancel" & + menuPopup .~ + False + ] ShowSeed -> [Model $ model & showSeed .~ True & menuPopup .~ False] ShowSend -> [ Model $ @@ -1236,7 +1486,7 @@ handleEvent wenv node model evt = (model ^. network) (entityKey acc) (zcashWalletLastSync $ entityVal wal) - (model ^. sendAmount) + (fromFloatDigits $ model ^. sendAmount) (model ^. sendRecipient) (model ^. sendMemo) (model ^. privacyChoice) @@ -1294,11 +1544,13 @@ handleEvent wenv node model evt = UpdateBalance <$> do dbPool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration case selectAccount i of - Nothing -> return (0, 0) + Nothing -> return (0, 0, 0, 0) Just acc -> do b <- getBalance dbPool $ entityKey acc u <- getUnconfirmedBalance dbPool $ entityKey acc - return (b, u) + s <- getShieldedBalance dbPool $ entityKey acc + t <- getTransparentBalance dbPool $ entityKey acc + return (b, u, s, t) , Event $ SetPool OrchardPool ] SwitchWal i -> @@ -1310,9 +1562,9 @@ handleEvent wenv node model evt = Nothing -> return [] Just wal -> runNoLoggingT $ getAccounts dbPool $ entityKey wal ] - UpdateBalance (b, u) -> + UpdateBalance (b, u, s, t) -> [ Model $ - model & balance .~ b & unconfBalance .~ + model & balance .~ b & sBalance .~ s & tBalance .~ t & unconfBalance .~ (if u == 0 then Nothing else Just u) @@ -1362,7 +1614,7 @@ handleEvent wenv node model evt = else [Event $ NewAccount currentWallet] LoadWallets a -> if not (null a) - then [ Model $ model & wallets .~ a + then [ Model $ model & wallets .~ a & modalMsg .~ Nothing , Event $ SwitchWal $ model ^. selWallet ] else [Event NewWallet] @@ -1372,33 +1624,39 @@ handleEvent wenv node model evt = CloseTxId -> [Model $ model & showId .~ Nothing] ShowTx i -> [Model $ model & showTx ?~ i] TickUp -> - if (model ^. timer) < 90 - then [Model $ model & timer .~ (1 + model ^. timer)] - else if (model ^. barValue) == 1.0 - then [ Model $ model & timer .~ 0 & barValue .~ 0.0 - , Producer $ - scanZebra - (c_dbPath $ model ^. configuration) - (c_zebraHost $ model ^. configuration) - (c_zebraPort $ model ^. configuration) - (model ^. network) - ] - else [Model $ model & timer .~ 0] + if isNothing (model ^. modalMsg) + then if (model ^. timer) < 90 + then [Model $ model & timer .~ (1 + model ^. timer)] + else if (model ^. barValue) == 1.0 + then [ Model $ + model & timer .~ 0 & barValue .~ 0.0 & modalMsg ?~ + "Downloading blocks..." + , Producer $ + runNoLoggingT . + scanZebra + (c_dbPath $ model ^. configuration) + (c_zebraHost $ model ^. configuration) + (c_zebraPort $ model ^. configuration) + (model ^. network) + ] + else [Model $ model & timer .~ 0] + else [Model $ model & timer .~ 0] + TreeSync -> [Model $ model & modalMsg ?~ "Updating commitment trees..."] + StartSync -> + [ Model $ model & modalMsg ?~ "Updating wallet..." + , Task $ do + case currentWallet of + Nothing -> return $ ShowError "No wallet available" + Just cW -> do + runNoLoggingT $ syncWallet (model ^. configuration) cW + pool <- + runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration + wL <- getWallets pool (model ^. network) + return $ LoadWallets wL + ] SyncVal i -> if (i + model ^. barValue) >= 0.999 - then [ Model $ model & barValue .~ 1.0 & modalMsg .~ Nothing - , Task $ do - case currentWallet of - Nothing -> return $ ShowError "No wallet available" - Just cW -> do - runFileLoggingT "zenith.log" $ - syncWallet (model ^. configuration) cW - pool <- - runNoLoggingT $ - initPool $ c_dbPath $ model ^. configuration - wL <- getWallets pool (model ^. network) - return $ LoadWallets wL - ] + then [Model $ model & barValue .~ 1.0 & modalMsg .~ Nothing] else [ Model $ model & barValue .~ validBarValue (i + model ^. barValue) & modalMsg ?~ @@ -1468,6 +1726,11 @@ handleEvent wenv node model evt = , setClipboardData $ ClipboardText a , Event $ ShowMessage "Address copied!!" ] + CopyViewingKey t v -> + [ setClipboardData ClipboardEmpty + , setClipboardData $ ClipboardText v + , Event $ ShowMessage (t <> " viewing key copied!!") + ] DeleteABEntry a -> [ Task $ deleteAdrBook (model ^. configuration) a , Model $ @@ -1483,9 +1746,101 @@ handleEvent wenv node model evt = model & msgAB ?~ "Function not implemented..." & menuPopup .~ False ] CloseMsgAB -> [Model $ model & msgAB .~ Nothing & inError .~ False] - ShowShield -> [ Model $ model & shieldZec .~ True & menuPopup .~ False ] + CloseShowVK -> + [ Model $ + model & vkTypeName .~ "" & vkData .~ "" & viewingKeyDisplay .~ False + ] + -- + -- Show Balance in FIAT + -- + DisplayFIATBalance zpr abal -> + [ Model $ + model & zPrice .~ zpr & aBal .~ abal & displayFIATBalance .~ True & + menuPopup .~ + False + ] + ShowFIATBalance -> + if model ^. network == MainNet + then [Task $ sfBalance (model ^. configuration)] + else [ Model $ model & zPrice .~ 0.0 & aBal .~ 0.0 + , Event $ ShowError "Balance conversion not available for TestNet" + ] + CloseFIATBalance -> [Model $ model & displayFIATBalance .~ False] + -- + -- Show Viewing Keys + -- + ShowViewingKey vkType vkText -> + case vkType of + VkFull -> + [ Model $ + model & vkTypeName .~ "Full" & vkData .~ vkText & viewingKeyDisplay .~ + True & + menuPopup .~ + False + ] + VkIncoming -> + [ Model $ + model & vkTypeName .~ "Incoming" & vkData .~ vkText & + viewingKeyDisplay .~ + True & + menuPopup .~ + False + ] + -- + -- Display PaymentURI Form + -- + DisplayPaymentURI -> + [ Model $ + model & paymentURIDisplay .~ True & uriString .~ "" & menuPopup .~ False + ] + ClosePaymentURI -> [Model $ model & paymentURIDisplay .~ False] + -- + -- Display Pay using URI Form + -- + DisplayPayUsingURI -> + [Model $ model & usepmtURIOverlay .~ True & menuPopup .~ False] + ClosePayUsingURI -> [Model $ model & usepmtURIOverlay .~ False] + ProcIfValidURI -> do + let zp = parseZcashPayment $ T.unpack (model ^. uriString) + case zp of + Right p -> do + case uriAmount p of + Just a -> + [ Model $ + model & usepmtURIOverlay .~ False & openSend .~ True & + privacyChoice .~ + Full & + recipientValid .~ + False & + sendRecipient .~ + T.pack (uriAddress p) & + sendAmount .~ + realToFrac a & + sendMemo .~ + (uriMemo p) + , Event $ ClosePaymentURI + ] + Nothing -> + [ Model $ + model & usepmtURIOverlay .~ False & openSend .~ False & + uriString .~ + "" + , Event $ ShowError "Invalid URI" + ] + Left e -> + [ Model $ + model & usepmtURIOverlay .~ False & openSend .~ False & uriString .~ + "" + , Event $ ShowError "Invalid URI" + ] + -- + -- + ShowShield -> + if model ^. tBalance > 0 + then [Model $ model & shieldZec .~ True & menuPopup .~ False] + else [Event $ ShowError "No transparent funds in this account"] CloseShield -> [Model $ model & shieldZec .~ False] - ShowDeShield -> [ Model $ model & deShieldZec .~ True & menuPopup .~ False ] + ShowDeShield -> [Model $ model & deShieldZec .~ True & menuPopup .~ False] CloseDeShield -> [Model $ model & deShieldZec .~ False] LoadAbList a -> [Model $ model & abaddressList .~ a] UpdateABDescrip d a -> @@ -1499,6 +1854,31 @@ handleEvent wenv node model evt = abList <- getAdrBook dbPool $ model ^. network return $ LoadAbList abList ] + SendDeShield -> + case currentAccount of + Nothing -> + [Event $ ShowError "No account available", Event CloseDeShield] + Just acc -> + [ Producer $ + deshieldTransaction + (model ^. configuration) + (model ^. network) + (entityKey acc) + currentAddress + (fromFloatDigits $ model ^. sendAmount) + , Event CloseDeShield + ] + SendShield -> + case currentAccount of + Nothing -> [Event $ ShowError "No account available", Event CloseShield] + Just acc -> + [ Producer $ + shieldTransaction + (model ^. configuration) + (model ^. network) + (entityKey acc) + , Event CloseShield + ] where currentWallet = if null (model ^. wallets) @@ -1612,33 +1992,77 @@ handleEvent wenv node model evt = pool <- runNoLoggingT $ initPool $ c_dbPath config res <- liftIO $ updateAdrsInAdrBook pool d a a return $ ShowMessage "Address Book entry updated!!" + -- + dbal :: Integer -> Double + dbal a = fromIntegral a + -- + sfBalance :: Config -> IO AppEvent + sfBalance config = do + zpr <- liftIO $ getZcashPrice $ c_currencyCode config + case zpr of + Just zp -> do + let zbal = (dbal (model ^. balance)) / 100000000 + return $ DisplayFIATBalance zp zbal + Nothing -> + return $ + ShowMessage + ("Currency not supported [" <> c_currencyCode config <> "]") + -- + procIfValidURI :: T.Text -> IO AppEvent + procIfValidURI ustr = do + return $ ShowSend --- model & recipientValid .~ ((model ^. privacyChoice) == Low) ] -scanZebra :: T.Text -> T.Text -> Int -> ZcashNet -> (AppEvent -> IO ()) -> IO () +scanZebra :: + T.Text + -> T.Text + -> Int + -> ZcashNet + -> (AppEvent -> IO ()) + -> NoLoggingT IO () scanZebra dbPath zHost zPort net sendMsg = do bStatus <- liftIO $ checkBlockChain zHost zPort - pool <- runNoLoggingT $ initPool dbPath - b <- liftIO $ getMinBirthdayHeight pool - dbBlock <- getMaxBlock pool $ ZcashNetDB net - chkBlock <- checkIntegrity dbPath zHost zPort dbBlock 1 - unless (chkBlock == dbBlock) $ rewindWalletData pool chkBlock - let sb = - if chkBlock == dbBlock - then max dbBlock b - else max chkBlock b - if sb > zgb_blocks bStatus || sb < 1 - then sendMsg (ShowError "Invalid starting block for scan") + pool <- liftIO $ runNoLoggingT $ initPool dbPath + b <- liftIO $ getMinBirthdayHeight pool $ ZcashNetDB net + dbBlock <- liftIO $ getMaxBlock pool $ ZcashNetDB net + chkBlock <- liftIO $ checkIntegrity dbPath zHost zPort net dbBlock 1 + logDebugN $ "dbBlock: " <> T.pack (show dbBlock) + logDebugN $ "chkBlock: " <> T.pack (show chkBlock) + syncChk <- liftIO $ isSyncing pool + if syncChk + then liftIO $ sendMsg (ShowError "Sync already in progress") else do - let bList = [(sb + 1) .. (zgb_blocks bStatus)] - if not (null bList) - then do - let step = (1.0 :: Float) / fromIntegral (length bList) - mapM_ (processBlock pool step) bList - else sendMsg (SyncVal 1.0) - confUp <- try $ updateConfs zHost zPort pool :: IO (Either IOError ()) - case confUp of - Left _e0 -> sendMsg (ShowError "Failed to update unconfirmed transactions") - Right _ -> return () + let sb = + if chkBlock == dbBlock + then max dbBlock b + else max chkBlock b + unless (chkBlock == dbBlock || chkBlock == 1) $ + rewindWalletData pool sb $ ZcashNetDB net + if sb > zgb_blocks bStatus || sb < 1 + then liftIO $ sendMsg (ShowError "Invalid starting block for scan") + else do + let bList = [(sb + 1) .. (zgb_blocks bStatus)] + if not (null bList) + then do + let step = (1.0 :: Float) / fromIntegral (length bList) + _ <- liftIO $ startSync pool + mapM_ (liftIO . processBlock pool step) bList + confUp <- + liftIO $ try $ updateConfs zHost zPort pool :: NoLoggingT + IO + (Either IOError ()) + case confUp of + Left _e0 -> do + _ <- liftIO $ completeSync pool Failed + liftIO $ + sendMsg + (ShowError "Failed to update unconfirmed transactions") + Right _ -> do + liftIO $ sendMsg TreeSync + _ <- updateCommitmentTrees pool zHost zPort $ ZcashNetDB net + _ <- liftIO $ completeSync pool Successful + logDebugN "Starting wallet sync" + liftIO $ sendMsg StartSync + else liftIO $ sendMsg (SyncVal 1.0) where processBlock :: ConnectionPool -> Float -> Int -> IO () processBlock pool step bl = do @@ -1650,7 +2074,9 @@ scanZebra dbPath zHost zPort net sendMsg = do "getblock" [Data.Aeson.String $ showt bl, jsonNumber 1] case r of - Left e1 -> sendMsg (ShowError $ showt e1) + Left e1 -> do + _ <- completeSync pool Failed + sendMsg (ShowError $ showt e1) Right blk -> do r2 <- liftIO $ @@ -1660,7 +2086,9 @@ scanZebra dbPath zHost zPort net sendMsg = do "getblock" [Data.Aeson.String $ showt bl, jsonNumber 0] case r2 of - Left e2 -> sendMsg (ShowError $ showt e2) + Left e2 -> do + _ <- completeSync pool Failed + sendMsg (ShowError $ showt e2) Right hb -> do let blockTime = getBlockTime hb bi <- @@ -1674,12 +2102,89 @@ scanZebra dbPath zHost zPort net sendMsg = do mapM_ (processTx zHost zPort bi pool) $ bl_txs blk sendMsg (SyncVal step) +shieldTransaction :: + Config -> ZcashNet -> ZcashAccountId -> (AppEvent -> IO ()) -> IO () +shieldTransaction config znet accId sendMsg = do + sendMsg $ ShowModal "Shielding funds..." + let dbPath = c_dbPath config + let zHost = c_zebraHost config + let zPort = c_zebraPort config + pool <- runNoLoggingT $ initPool dbPath + bl <- getChainTip zHost zPort + res <- runNoLoggingT $ shieldTransparentNotes pool zHost zPort znet accId bl + forM_ res $ \case + Left e -> sendMsg $ ShowError $ T.pack (show e) + Right rawTx -> do + sendMsg $ ShowMsg "Transaction ready, sending to Zebra..." + resp <- + makeZebraCall + zHost + zPort + "sendrawtransaction" + [Data.Aeson.String $ toText rawTx] + case resp of + Left e1 -> sendMsg $ ShowError $ "Zebra error: " <> T.pack (show e1) + Right txId -> sendMsg $ ShowTxId txId + +deshieldTransaction :: + Config + -> ZcashNet + -> ZcashAccountId + -> Maybe (Entity WalletAddress) + -> Scientific + -> (AppEvent -> IO ()) + -> IO () +deshieldTransaction config znet accId addR pnote sendMsg = do + case addR of + Nothing -> sendMsg $ ShowError "No address available" + Just addr -> do + sendMsg $ ShowModal "De-shielding funds..." + let dbPath = c_dbPath config + let zHost = c_zebraHost config + let zPort = c_zebraPort config + pool <- runNoLoggingT $ initPool dbPath + bl <- getChainTip zHost zPort + let tAddrMaybe = + Transparent <$> + ((decodeTransparentAddress . + E.encodeUtf8 . encodeTransparentReceiver znet) =<< + (t_rec =<< + (isValidUnifiedAddress . + E.encodeUtf8 . getUA . walletAddressUAddress) + (entityVal addr))) + case tAddrMaybe of + Nothing -> sendMsg $ ShowError "No transparent address available" + Just tAddr -> do + res <- + runNoLoggingT $ + deshieldNotes + pool + zHost + zPort + znet + accId + bl + (ProposedNote (ValidAddressAPI tAddr) pnote Nothing) + case res of + Left e -> sendMsg $ ShowError $ T.pack (show e) + Right rawTx -> do + sendMsg $ ShowModal "Transaction ready, sending to Zebra..." + resp <- + makeZebraCall + zHost + zPort + "sendrawtransaction" + [Data.Aeson.String $ toText rawTx] + case resp of + Left e1 -> sendMsg $ ShowError $ "Zebra error: " <> showt e1 + Right txId -> sendMsg $ ShowTxId txId + sendTransaction :: Config -> ZcashNet -> ZcashAccountId -> Int - -> Float + -> Scientific -> T.Text -> T.Text -> PrivacyPolicy @@ -1695,8 +2200,22 @@ sendTransaction config znet accId bl amt ua memo policy sendMsg = do let zPort = c_zebraPort config pool <- runNoLoggingT $ initPool dbPath res <- - runFileLoggingT "zenith.log" $ - prepareTxV2 pool zHost zPort znet accId bl amt addr memo policy + runNoLoggingT $ + prepareTxV2 + pool + zHost + zPort + znet + accId + bl + [ ProposedNote + (ValidAddressAPI addr) + amt + (if memo == "" + then Nothing + else Just memo) + ] + policy case res of Left e -> sendMsg $ ShowError $ T.pack $ show e Right rawTx -> do @@ -1778,6 +2297,14 @@ runZenithGUI config = do then getUnconfirmedBalance pool $ entityKey $ head accList else return 0 abList <- getAdrBook pool (zgb_net chainInfo) + shieldBal <- + if not (null accList) + then getShieldedBalance pool $ entityKey $ head accList + else return 0 + transBal <- + if not (null accList) + then getTransparentBalance pool $ entityKey $ head accList + else return 0 let model = AppModel config @@ -1837,10 +2364,20 @@ runZenithGUI config = do Full False False - 0 + transBal False - 0 + shieldBal False + False + 0.0 + 0.0 + False + False + "" + "" + False + False + "" startApp model handleEvent buildUI (params hD) Left _e -> print "Zebra not available" where diff --git a/src/Zenith/RPC.hs b/src/Zenith/RPC.hs index e3434e7..f0e6e30 100644 --- a/src/Zenith/RPC.hs +++ b/src/Zenith/RPC.hs @@ -8,21 +8,28 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DerivingStrategies #-} module Zenith.RPC where +import Control.Concurrent (forkIO) import Control.Exception (try) +import Control.Monad (unless, when) import Control.Monad.IO.Class (liftIO) -import Control.Monad.Logger (runNoLoggingT) +import Control.Monad.Logger (runFileLoggingT, runNoLoggingT, runStderrLoggingT) import Data.Aeson +import qualified Data.HexString as H import Data.Int import Data.Scientific (floatingOrInteger) import qualified Data.Text as T import qualified Data.Text.Encoding as E +import Data.Time.Clock (getCurrentTime) import qualified Data.UUID as U +import Data.UUID.V4 (nextRandom) import qualified Data.Vector as V import Database.Esqueleto.Experimental - ( entityKey + ( ConnectionPool + , entityKey , entityVal , fromSqlKey , toSqlKey @@ -31,43 +38,73 @@ import Servant import Text.Read (readMaybe) import ZcashHaskell.Keys (generateWalletSeedPhrase) import ZcashHaskell.Orchard (parseAddress) -import ZcashHaskell.Types (RpcError(..), Scope(..), ZcashNet(..)) -import Zenith.Core (createCustomWalletAddress, createZcashAccount) +import ZcashHaskell.Types + ( BlockResponse(..) + , RpcError(..) + , Scope(..) + , ZcashNet(..) + , ZebraGetBlockChainInfo(..) + ) +import ZcashHaskell.Utils (getBlockTime, makeZebraCall) +import Zenith.Core + ( checkBlockChain + , createCustomWalletAddress + , createZcashAccount + , prepareTxV2 + , syncWallet + , updateCommitmentTrees + ) import Zenith.DB ( Operation(..) , ZcashAccount(..) + , ZcashBlock(..) , ZcashWallet(..) + , completeSync + , finalizeOperation , findNotesByAddress , getAccountById , getAccounts , getAddressById , getAddresses , getExternalAddresses + , getLastSyncBlock , getMaxAccount , getMaxAddress + , getMaxBlock + , getMinBirthdayHeight , getOperation , getPoolBalance , getUnconfPoolBalance , getWalletNotes , getWallets , initPool + , isSyncing + , rewindWalletData , saveAccount , saveAddress + , saveBlock + , saveOperation , saveWallet + , startSync , toZcashAccountAPI , toZcashAddressAPI , toZcashWalletAPI , walletExists ) +import Zenith.Scanner (checkIntegrity, processTx, updateConfs) import Zenith.Types ( AccountBalance(..) , Config(..) + , HexStringDB(..) , PhraseDB(..) + , PrivacyPolicy(..) + , ProposedNote(..) , ZcashAccountAPI(..) , ZcashAddressAPI(..) , ZcashNetDB(..) , ZcashNoteAPI(..) , ZcashWalletAPI(..) + , ZenithStatus(..) , ZenithUuid(..) ) import Zenith.Utils (jsonNumber) @@ -83,6 +120,7 @@ data ZenithMethod | GetNewAccount | GetNewAddress | GetOperationStatus + | SendMany | UnknownMethod deriving (Eq, Prelude.Show) @@ -97,6 +135,7 @@ instance ToJSON ZenithMethod where toJSON GetNewAccount = Data.Aeson.String "getnewaccount" toJSON GetNewAddress = Data.Aeson.String "getnewaddress" toJSON GetOperationStatus = Data.Aeson.String "getoperationstatus" + toJSON SendMany = Data.Aeson.String "sendmany" toJSON UnknownMethod = Data.Aeson.Null instance FromJSON ZenithMethod where @@ -112,6 +151,7 @@ instance FromJSON ZenithMethod where "getnewaccount" -> pure GetNewAccount "getnewaddress" -> pure GetNewAddress "getoperationstatus" -> pure GetOperationStatus + "sendmany" -> pure SendMany _ -> pure UnknownMethod data ZenithParams @@ -125,6 +165,7 @@ data ZenithParams | NameIdParams !T.Text !Int | NewAddrParams !Int !T.Text !Bool !Bool | OpParams !ZenithUuid + | SendParams !Int ![ProposedNote] !PrivacyPolicy | TestParams !T.Text deriving (Eq, Prelude.Show) @@ -148,6 +189,8 @@ instance ToJSON ZenithParams where [Data.Aeson.String "ExcludeTransparent" | t] toJSON (OpParams i) = Data.Aeson.Array $ V.fromList [Data.Aeson.String $ U.toText $ getUuid i] + toJSON (SendParams i ns p) = + Data.Aeson.Array $ V.fromList [jsonNumber i, toJSON ns, toJSON p] data ZenithResponse = InfoResponse !T.Text !ZenithInfo @@ -159,6 +202,7 @@ data ZenithResponse | NewItemResponse !T.Text !Int64 | NewAddrResponse !T.Text !ZcashAddressAPI | OpResponse !T.Text !Operation + | SendResponse !T.Text !U.UUID | ErrorResponse !T.Text !Double !T.Text deriving (Eq, Prelude.Show) @@ -179,6 +223,7 @@ instance ToJSON ZenithResponse where toJSON (NewItemResponse i ix) = packRpcResponse i ix toJSON (NewAddrResponse i a) = packRpcResponse i a toJSON (OpResponse i u) = packRpcResponse i u + toJSON (SendResponse i o) = packRpcResponse i o instance FromJSON ZenithResponse where parseJSON = @@ -258,6 +303,10 @@ instance FromJSON ZenithResponse where case floatingOrInteger k of Left _e -> fail "Unknown value" Right k' -> pure $ NewItemResponse i k' + String s -> do + case U.fromText s of + Nothing -> fail "Unknown value" + Just u -> pure $ SendResponse i u _anyOther -> fail "Malformed JSON" Just e1 -> pure $ ErrorResponse i (ecode e1) (emessage e1) @@ -416,6 +465,30 @@ instance FromJSON RpcCall where Nothing -> pure $ RpcCall v i GetOperationStatus BadParams else pure $ RpcCall v i GetOperationStatus BadParams _anyOther -> pure $ RpcCall v i GetOperationStatus BadParams + SendMany -> do + p <- obj .: "params" + case p of + Array a -> + if V.length a >= 2 + then do + acc <- parseJSON $ a V.! 0 + x <- parseJSON $ a V.! 1 + case x of + String _ -> do + x' <- parseJSON $ a V.! 1 + y <- parseJSON $ a V.! 2 + if not (null y) + then pure $ RpcCall v i SendMany (SendParams acc y x') + else pure $ RpcCall v i SendMany BadParams + Array _ -> do + x' <- parseJSON $ a V.! 1 + if not (null x') + then pure $ + RpcCall v i SendMany (SendParams acc x' Full) + else pure $ RpcCall v i SendMany BadParams + _anyOther -> pure $ RpcCall v i SendMany BadParams + else pure $ RpcCall v i SendMany BadParams + _anyOther -> pure $ RpcCall v i SendMany BadParams type ZenithRPC = "status" :> Get '[ JSON] Value :<|> BasicAuth "zenith-realm" Bool :> ReqBody @@ -573,27 +646,35 @@ zenithServer state = getinfo :<|> handleRPC case parameters req of NameParams t -> do let dbPath = w_dbPath state - sP <- liftIO generateWalletSeedPhrase pool <- liftIO $ runNoLoggingT $ initPool dbPath - r <- - liftIO $ - saveWallet pool $ - ZcashWallet - t - (ZcashNetDB $ w_network state) - (PhraseDB sP) - (w_startBlock state) - 0 - case r of - Nothing -> - return $ - ErrorResponse - (callId req) - (-32007) - "Entity with that name already exists." - Just r' -> - return $ - NewItemResponse (callId req) $ fromSqlKey $ entityKey r' + syncChk <- liftIO $ isSyncing pool + if syncChk + then return $ + ErrorResponse + (callId req) + (-32012) + "The Zenith server is syncing, please try again later." + else do + sP <- liftIO generateWalletSeedPhrase + r <- + liftIO $ + saveWallet pool $ + ZcashWallet + t + (ZcashNetDB $ w_network state) + (PhraseDB sP) + (w_startBlock state) + 0 + case r of + Nothing -> + return $ + ErrorResponse + (callId req) + (-32007) + "Entity with that name already exists." + Just r' -> + return $ + NewItemResponse (callId req) $ fromSqlKey $ entityKey r' _anyOtherParams -> return $ ErrorResponse (callId req) (-32602) "Invalid params" GetNewAccount -> @@ -601,34 +682,45 @@ zenithServer state = getinfo :<|> handleRPC NameIdParams t i -> do let dbPath = w_dbPath state pool <- liftIO $ runNoLoggingT $ initPool dbPath - w <- liftIO $ walletExists pool i - case w of - Just w' -> do - aIdx <- liftIO $ getMaxAccount pool $ entityKey w' - nAcc <- - liftIO - (try $ createZcashAccount t (aIdx + 1) w' :: IO - (Either IOError ZcashAccount)) - case nAcc of - Left e -> + syncChk <- liftIO $ isSyncing pool + if syncChk + then return $ + ErrorResponse + (callId req) + (-32012) + "The Zenith server is syncing, please try again later." + else do + w <- liftIO $ walletExists pool i + case w of + Just w' -> do + aIdx <- liftIO $ getMaxAccount pool $ entityKey w' + nAcc <- + liftIO + (try $ createZcashAccount t (aIdx + 1) w' :: IO + (Either IOError ZcashAccount)) + case nAcc of + Left e -> + return $ + ErrorResponse (callId req) (-32010) $ T.pack $ show e + Right nAcc' -> do + r <- liftIO $ saveAccount pool nAcc' + case r of + Nothing -> + return $ + ErrorResponse + (callId req) + (-32007) + "Entity with that name already exists." + Just x -> + return $ + NewItemResponse (callId req) $ + fromSqlKey $ entityKey x + Nothing -> return $ - ErrorResponse (callId req) (-32010) $ T.pack $ show e - Right nAcc' -> do - r <- liftIO $ saveAccount pool nAcc' - case r of - Nothing -> - return $ - ErrorResponse - (callId req) - (-32007) - "Entity with that name already exists." - Just x -> - return $ - NewItemResponse (callId req) $ - fromSqlKey $ entityKey x - Nothing -> - return $ - ErrorResponse (callId req) (-32008) "Wallet does not exist." + ErrorResponse + (callId req) + (-32008) + "Wallet does not exist." _anyOtherParams -> return $ ErrorResponse (callId req) (-32602) "Invalid params" GetNewAddress -> @@ -637,35 +729,49 @@ zenithServer state = getinfo :<|> handleRPC let dbPath = w_dbPath state let net = w_network state pool <- liftIO $ runNoLoggingT $ initPool dbPath - acc <- liftIO $ getAccountById pool $ toSqlKey $ fromIntegral i - case acc of - Just acc' -> do - maxAddr <- - liftIO $ getMaxAddress pool (entityKey acc') External - newAddr <- - liftIO $ - createCustomWalletAddress - n - (maxAddr + 1) - net - External - acc' - s - t - dbAddr <- liftIO $ saveAddress pool newAddr - case dbAddr of - Just nAddr -> do - return $ - NewAddrResponse (callId req) (toZcashAddressAPI nAddr) + syncChk <- liftIO $ isSyncing pool + if syncChk + then return $ + ErrorResponse + (callId req) + (-32012) + "The Zenith server is syncing, please try again later." + else do + acc <- + liftIO $ getAccountById pool $ toSqlKey $ fromIntegral i + case acc of + Just acc' -> do + maxAddr <- + liftIO $ getMaxAddress pool (entityKey acc') External + newAddr <- + liftIO $ + createCustomWalletAddress + n + (maxAddr + 1) + net + External + acc' + s + t + dbAddr <- liftIO $ saveAddress pool newAddr + case dbAddr of + Just nAddr -> do + return $ + NewAddrResponse + (callId req) + (toZcashAddressAPI nAddr) + Nothing -> + return $ + ErrorResponse + (callId req) + (-32007) + "Entity with that name already exists." Nothing -> return $ ErrorResponse (callId req) - (-32007) - "Entity with that name already exists." - Nothing -> - return $ - ErrorResponse (callId req) (-32006) "Account does not exist." + (-32006) + "Account does not exist." _anyOtherParams -> return $ ErrorResponse (callId req) (-32602) "Invalid params" GetOperationStatus -> @@ -682,6 +788,89 @@ zenithServer state = getinfo :<|> handleRPC ErrorResponse (callId req) (-32009) "Operation ID not found" _anyOtherParams -> return $ ErrorResponse (callId req) (-32602) "Invalid params" + SendMany -> + case parameters req of + SendParams a ns p -> do + let dbPath = w_dbPath state + let zHost = w_host state + let zPort = w_port state + let znet = w_network state + pool <- liftIO $ runNoLoggingT $ initPool dbPath + syncChk <- liftIO $ isSyncing pool + if syncChk + then return $ + ErrorResponse + (callId req) + (-32012) + "The Zenith server is syncing, please try again later." + else do + opid <- liftIO nextRandom + startTime <- liftIO getCurrentTime + opkey <- + liftIO $ + saveOperation pool $ + Operation + (ZenithUuid opid) + startTime + Nothing + Processing + Nothing + case opkey of + Nothing -> + return $ + ErrorResponse (callId req) (-32010) "Internal Error" + Just opkey' -> do + acc <- + liftIO $ getAccountById pool $ toSqlKey $ fromIntegral a + case acc of + Just acc' -> do + bl <- + liftIO $ + getLastSyncBlock + pool + (zcashAccountWalletId $ entityVal acc') + _ <- + liftIO $ + forkIO $ do + res <- + liftIO $ + runNoLoggingT $ + prepareTxV2 + pool + zHost + zPort + znet + (entityKey acc') + bl + ns + p + case res of + Left e -> + finalizeOperation pool opkey' Failed $ + T.pack $ show e + Right rawTx -> do + zebraRes <- + makeZebraCall + zHost + zPort + "sendrawtransaction" + [Data.Aeson.String $ H.toText rawTx] + case zebraRes of + Left e1 -> + finalizeOperation pool opkey' Failed $ + T.pack $ show e1 + Right txId -> + finalizeOperation pool opkey' Successful $ + "Tx ID: " <> H.toText txId + return $ SendResponse (callId req) opid + Nothing -> + return $ + ErrorResponse + (callId req) + (-32006) + "Account does not exist." + _anyOtherParams -> + return $ ErrorResponse (callId req) (-32602) "Invalid params" authenticate :: Config -> BasicAuthCheck Bool authenticate config = BasicAuthCheck check @@ -694,3 +883,71 @@ authenticate config = BasicAuthCheck check packRpcResponse :: ToJSON a => T.Text -> a -> Value packRpcResponse i x = object ["jsonrpc" .= ("2.0" :: String), "id" .= i, "result" .= x] + +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 $ ZcashNetDB net + dbBlock <- getMaxBlock pool $ ZcashNetDB net + chkBlock <- checkIntegrity dbPath zHost zPort net dbBlock 1 + syncChk <- isSyncing pool + unless syncChk $ do + let sb = + if chkBlock == dbBlock + then max dbBlock b + else max chkBlock b + unless (chkBlock == dbBlock || chkBlock == 1) $ + runNoLoggingT $ rewindWalletData pool sb $ ZcashNetDB net + unless (sb > zgb_blocks bStatus || sb < 1) $ do + let bList = [(sb + 1) .. (zgb_blocks bStatus)] + unless (null bList) $ do + _ <- startSync pool + mapM_ (processBlock pool) bList + confUp <- try $ updateConfs zHost zPort pool :: IO (Either IOError ()) + case confUp of + Left _e0 -> do + _ <- completeSync pool Failed + return () + Right _ -> do + wals <- getWallets pool net + _ <- + runNoLoggingT $ + updateCommitmentTrees pool zHost zPort $ ZcashNetDB net + runNoLoggingT $ + mapM_ + (syncWallet (Config dbPath zHost zPort "user" "pwd" 8080 "usd")) + wals + _ <- completeSync pool Successful + return () + where + processBlock :: ConnectionPool -> Int -> IO () + processBlock pool bl = do + r <- + makeZebraCall + zHost + zPort + "getblock" + [Data.Aeson.String $ T.pack (show bl), jsonNumber 1] + case r of + Left _ -> completeSync pool Failed + Right blk -> do + r2 <- + makeZebraCall + zHost + zPort + "getblock" + [Data.Aeson.String $ T.pack (show bl), jsonNumber 0] + case r2 of + Left _ -> completeSync pool Failed + Right hb -> do + let blockTime = getBlockTime hb + bi <- + saveBlock pool $ + ZcashBlock + (fromIntegral $ bl_height blk) + (HexStringDB $ bl_hash blk) + (fromIntegral $ bl_confirmations blk) + blockTime + (ZcashNetDB net) + mapM_ (processTx zHost zPort bi pool) $ bl_txs blk diff --git a/src/Zenith/Scanner.hs b/src/Zenith/Scanner.hs index e6241b0..7208bab 100644 --- a/src/Zenith/Scanner.hs +++ b/src/Zenith/Scanner.hs @@ -12,6 +12,7 @@ import Control.Monad.Logger , logInfoN , runFileLoggingT , runNoLoggingT + , runStderrLoggingT ) import Data.Aeson import Data.HexString @@ -31,12 +32,13 @@ 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 , clearWalletData , clearWalletTransactions + , completeSync , getBlock , getMaxBlock , getMinBirthdayHeight @@ -47,9 +49,16 @@ import Zenith.DB , saveBlock , saveConfs , saveTransaction + , startSync , updateWalletSync , upgradeQrTable ) +import Zenith.Types + ( Config(..) + , HexStringDB(..) + , ZcashNetDB(..) + , ZenithStatus(..) + ) import Zenith.Types (Config(..), HexStringDB(..), ZcashNetDB(..)) import Zenith.Utils (jsonNumber) @@ -74,8 +83,9 @@ rescanZebra host port dbFilePath = do upgradeQrTable pool1 clearWalletTransactions pool1 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" @@ -99,6 +109,8 @@ rescanZebra host port dbFilePath = do {-mapM_ (processBlock host port pool2 pg2 znet) bl2 `concurrently_`-} {-mapM_ (processBlock host port pool3 pg3 znet) bl3-} print "Please wait..." + _ <- completeSync pool1 Successful + _ <- runNoLoggingT $ updateCommitmentTrees pool1 host port znet print "Rescan complete" -- | Function to process a raw block and extract the transaction information @@ -119,7 +131,9 @@ processBlock host port pool pg net b = do "getblock" [Data.Aeson.String $ T.pack $ show b, jsonNumber 1] case r of - Left e -> liftIO $ throwIO $ userError e + Left e -> do + _ <- completeSync pool Failed + liftIO $ throwIO $ userError e Right blk -> do r2 <- liftIO $ @@ -129,7 +143,9 @@ processBlock host port pool pg net b = do "getblock" [Data.Aeson.String $ T.pack $ show b, jsonNumber 0] case r2 of - Left e2 -> liftIO $ throwIO $ userError e2 + Left e2 -> do + _ <- completeSync pool Failed + liftIO $ throwIO $ userError e2 Right hb -> do let blockTime = getBlockTime hb bi <- @@ -160,7 +176,9 @@ processTx host port bt pool t = do "getrawtransaction" [Data.Aeson.String $ toText t, jsonNumber 1] case r of - Left e -> liftIO $ throwIO $ userError e + Left e -> do + _ <- completeSync pool Failed + liftIO $ throwIO $ userError e Right rawTx -> do case readZebraTransaction (ztr_hex rawTx) of Nothing -> return () @@ -223,7 +241,7 @@ clearSync config = do w <- getWallets pool $ zgb_net chainInfo liftIO $ mapM_ (updateWalletSync pool 0 . entityKey) w w' <- liftIO $ getWallets pool $ zgb_net chainInfo - r <- runFileLoggingT "zenith.log" $ mapM (syncWallet config) w' + r <- runNoLoggingT $ mapM (syncWallet config) w' liftIO $ print r -- | Detect chain re-orgs @@ -231,10 +249,11 @@ checkIntegrity :: T.Text -- ^ Database path -> T.Text -- ^ Zebra host -> Int -- ^ Zebra port + -> ZcashNet -- ^ the network to scan -> Int -- ^ The block to start the check -> Int -- ^ depth -> IO Int -checkIntegrity dbP zHost zPort b d = +checkIntegrity dbP zHost zPort znet b d = if b < 1 then return 1 else do @@ -248,10 +267,10 @@ checkIntegrity dbP zHost zPort b d = Left e -> throwIO $ userError e Right blk -> do pool <- runNoLoggingT $ initPool dbP - dbBlk <- getBlock pool b + dbBlk <- getBlock pool b $ ZcashNetDB znet case dbBlk of - Nothing -> throwIO $ userError "Block mismatch, rescan needed" + Nothing -> return 1 Just dbBlk' -> if bl_hash blk == getHex (zcashBlockHash $ entityVal dbBlk') then return b - else checkIntegrity dbP zHost zPort (b - 5 * d) (d + 1) + else checkIntegrity dbP zHost zPort znet (b - 5 * d) (d + 1) diff --git a/src/Zenith/Tree.hs b/src/Zenith/Tree.hs new file mode 100644 index 0000000..042421b --- /dev/null +++ b/src/Zenith/Tree.hs @@ -0,0 +1,400 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE UndecidableInstances #-} + +module Zenith.Tree where + +import Codec.Borsh +import Control.Monad.Logger (NoLoggingT, logDebugN) +import Data.HexString +import Data.Int (Int32, Int64, Int8) +import Data.Maybe (fromJust, isNothing) +import qualified Data.Text as T +import qualified GHC.Generics as GHC +import qualified Generics.SOP as SOP +import ZcashHaskell.Orchard (combineOrchardNodes, getOrchardNodeValue) +import ZcashHaskell.Sapling (combineSaplingNodes, getSaplingNodeValue) +import ZcashHaskell.Types (MerklePath(..), OrchardTree(..), SaplingTree(..)) + +type Level = Int8 + +maxLevel :: Level +maxLevel = 32 + +type Position = Int32 + +class Monoid v => + Measured a v + where + measure :: a -> Position -> Int64 -> v + +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 + +type OrchardCommitment = HexString + +instance Measured OrchardCommitment OrchardNode where + measure oc p i = + case getOrchardNodeValue (hexBytes oc) of + 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 + | PrunedBranch !v + | Branch !v !(Tree v) !(Tree v) + | 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 = "()" + show (Leaf v) = "(" ++ show v ++ ")" + show (PrunedBranch v) = "{" ++ show v ++ "}" + show (Branch s x y) = + "<" ++ show (getHash 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 _) Branch {} = InvalidTree + (<>) (Leaf _) (PrunedBranch _) = InvalidTree + (<>) (PrunedBranch x) EmptyLeaf = PrunedBranch $ x <> 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 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 w) + | getLevel s == getLevel w = branch (Branch s x y) (PrunedBranch w) + | otherwise = InvalidTree + (<>) (Branch s x y) (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) + | getLevel s == getLevel s1 = branch (Branch s x y) (Branch s1 x1 y1) + | 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 -> Int32 -> 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 + then tree + else mkSubTree maxLevel 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 + where + p = 1 + getPosition (value tree) + +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 + +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 :: 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 + +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 -> NoLoggingT IO (Tree v) +truncateTree (Branch s x y) i + | getLevel s == 1 && getIndex (value x) == i = do + logDebugN $ T.pack $ show (getLevel s) ++ " Trunc to left leaf" + return $ branch x EmptyLeaf + | getLevel s == 1 && getIndex (value y) == i = do + logDebugN $ T.pack $ show (getLevel s) ++ " Trunc to right leaf" + return $ branch x y + | getIndex (value x) >= i = do + logDebugN $ + T.pack $ + show (getLevel s) ++ + ": " ++ show i ++ " left i: " ++ show (getIndex (value x)) + l <- truncateTree x i + return $ branch (l) (getEmptyRoot (getLevel (value x))) + | getIndex (value y) /= 0 && getIndex (value y) >= i = do + logDebugN $ + T.pack $ + show (getLevel s) ++ + ": " ++ show i ++ " right i: " ++ show (getIndex (value y)) + r <- truncateTree y i + return $ branch x (r) + | otherwise = do + logDebugN $ + T.pack $ + show (getLevel s) ++ + ": " ++ + show (getIndex (value x)) ++ " catchall " ++ show (getIndex (value y)) + return InvalidTree +truncateTree x _ = return x + +countLeaves :: Node v => Tree v -> Int64 +countLeaves (Branch s x y) = + if isFull s + then 2 ^ getLevel s + else countLeaves x + countLeaves y +countLeaves (PrunedBranch x) = + if isFull x + then 2 ^ getLevel x + else 0 +countLeaves (Leaf _) = 1 +countLeaves EmptyLeaf = 0 +countLeaves InvalidTree = 0 + +batchAppend :: + Measured a v + => Node v => Monoid v => Tree v -> [(Int32, (a, Int64))] -> Tree v +batchAppend x [] = x +batchAppend (Branch s x y) notes + | isFull s = InvalidTree + | isFull (value x) = branch x (batchAppend y notes) + | otherwise = + branch + (batchAppend x (take leftSide notes)) + (batchAppend y (drop leftSide notes)) + where + leftSide = fromIntegral $ 2 ^ getLevel (value x) - countLeaves x +batchAppend (PrunedBranch k) notes + | isFull k = InvalidTree + | otherwise = + branch + (batchAppend (getEmptyRoot (getLevel k - 1)) (take leftSide notes)) + (batchAppend (getEmptyRoot (getLevel k - 1)) (drop leftSide notes)) + where + leftSide = fromIntegral $ 2 ^ (getLevel k - 1) +batchAppend EmptyLeaf notes + | length notes == 1 = + leaf (fst $ snd $ head notes) (fst $ head notes) (snd $ snd $ head notes) + | otherwise = InvalidTree +batchAppend _ notes = InvalidTree + +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 + , 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 + 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 + +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 = fromIntegral $ orchardSize tree - 1 diff --git a/src/Zenith/Types.hs b/src/Zenith/Types.hs index 8b7762f..da2b4f5 100644 --- a/src/Zenith/Types.hs +++ b/src/Zenith/Types.hs @@ -17,19 +17,30 @@ import qualified Data.ByteString.Char8 as C import Data.HexString import Data.Int (Int64) import Data.Maybe (fromMaybe) +import Data.Scientific (Scientific) import qualified Data.Text as T import qualified Data.Text.Encoding as E import Data.Text.Encoding.Error (lenientDecode) import qualified Data.UUID as U import Database.Persist.TH import GHC.Generics +import ZcashHaskell.Orchard (encodeUnifiedAddress, parseAddress) +import ZcashHaskell.Sapling (encodeSaplingAddress) +import ZcashHaskell.Transparent + ( encodeExchangeAddress + , encodeTransparentReceiver + ) import ZcashHaskell.Types - ( OrchardSpendingKey(..) + ( ExchangeAddress(..) + , OrchardSpendingKey(..) , Phrase(..) , Rseed(..) + , SaplingAddress(..) , SaplingSpendingKey(..) , Scope(..) + , TransparentAddress(..) , TransparentSpendingKey + , ValidAddress(..) , ZcashNet(..) ) @@ -101,6 +112,7 @@ data Config = Config , c_zenithUser :: !BS.ByteString , c_zenithPwd :: !BS.ByteString , c_zenithPort :: !Int + , c_currencyCode :: !T.Text } deriving (Eq, Prelude.Show) data ZcashPool @@ -207,9 +219,54 @@ data PrivacyPolicy $(deriveJSON defaultOptions ''PrivacyPolicy) +newtype ValidAddressAPI = ValidAddressAPI + { getVA :: ValidAddress + } deriving newtype (Eq, Show) + +instance ToJSON ValidAddressAPI where + toJSON (ValidAddressAPI va) = + case va of + Unified ua -> Data.Aeson.String $ encodeUnifiedAddress ua + Sapling sa -> + maybe + Data.Aeson.Null + Data.Aeson.String + (encodeSaplingAddress (net_type sa) (sa_receiver sa)) + Transparent ta -> + Data.Aeson.String $ + encodeTransparentReceiver (ta_network ta) (ta_receiver ta) + Exchange ea -> + maybe + Data.Aeson.Null + Data.Aeson.String + (encodeExchangeAddress (ex_network ea) (ex_address ea)) + +data ProposedNote = ProposedNote + { pn_addr :: !ValidAddressAPI + , pn_amt :: !Scientific + , pn_memo :: !(Maybe T.Text) + } deriving (Eq, Prelude.Show) + +instance FromJSON ProposedNote where + parseJSON = + withObject "ProposedNote" $ \obj -> do + a <- obj .: "address" + n <- obj .: "amount" + m <- obj .:? "memo" + case parseAddress (E.encodeUtf8 a) of + Nothing -> fail "Invalid address" + Just a' -> + if n > 0 && n < 21000000 + then pure $ ProposedNote (ValidAddressAPI a') n m + else fail "Invalid amount" + +instance ToJSON ProposedNote where + toJSON (ProposedNote a n m) = + object ["address" .= a, "amount" .= n, "memo" .= m] + data ShieldDeshieldOp - = Shield - | Deshield + = Shield + | Deshield deriving (Eq, Show, Read, Ord) -- ** `zebrad` @@ -451,3 +508,12 @@ encodeHexText' t = if T.length t > 0 then C.unpack . B64.encode $ E.encodeUtf8 t else C.unpack . B64.encode $ E.encodeUtf8 "Sent from Zenith" + +-- | Define a data structure for the parsed components +data ZcashPaymentURI = ZcashPaymentURI + { uriAddress :: String + , uriAmount :: Maybe Double + , uriMemo :: T.Text + , uriLabel :: Maybe String + , uriMessage :: Maybe String + } deriving (Show, Eq) diff --git a/src/Zenith/Utils.hs b/src/Zenith/Utils.hs index b9355f0..396e4f6 100644 --- a/src/Zenith/Utils.hs +++ b/src/Zenith/Utils.hs @@ -2,37 +2,59 @@ module Zenith.Utils where +import Control.Exception (SomeException, try) +import Control.Monad (when) import Data.Aeson +import qualified Data.Aeson.Key as K +import qualified Data.Aeson.KeyMap as KM +import Data.Aeson.Types (parseMaybe) +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString.Lazy.Char8 as BL import Data.Char (isAlphaNum, isSpace) import Data.Functor (void) import Data.Maybe import Data.Ord (clamp) import Data.Scientific (Scientific(..), scientific) +import Data.Scientific (Scientific, toRealFloat) import qualified Data.Text as T import qualified Data.Text.Encoding as E +import qualified Data.Text.Encoding as TE +import Network.HTTP.Simple import System.Directory import System.Process (createProcess_, shell) +import Text.Printf (printf) +import Text.Read (readMaybe) import Text.Regex.Posix -import ZcashHaskell.Orchard (encodeUnifiedAddress, isValidUnifiedAddress, parseAddress) +import ZcashHaskell.Orchard + ( encodeUnifiedAddress + , isValidUnifiedAddress + , parseAddress + ) import ZcashHaskell.Sapling (decodeSaplingAddress, isValidShieldedAddress) import ZcashHaskell.Transparent ( decodeExchangeAddress , decodeTransparentAddress ) import ZcashHaskell.Types - ( SaplingAddress(..) + ( ExchangeAddress(..) + , ExchangeAddress(..) + , SaplingAddress(..) , TransparentAddress(..) , UnifiedAddress(..) - , ZcashNet(..) , ValidAddress(..) - , ExchangeAddress(..) + , ValidAddress(..) + , ZcashNet(..) ) +import ZcashHaskell.Utils (makeZebraCall) import Zenith.Types ( AddressGroup(..) + , PrivacyPolicy(..) , UnifiedAddressDB(..) , ZcashAddress(..) + , ZcashPaymentURI(..) , ZcashPool(..) - , PrivacyPolicy(..) ) -- | Helper function to convert numbers into JSON @@ -47,7 +69,7 @@ displayZec s | abs s < 100000000 = show (fromIntegral s / 100000) ++ " mZEC" | otherwise = show (fromIntegral s / 100000000) ++ " ZEC " --- | Helper function to display small amounts of ZEC +-- | Helper function to display small amounts of TAZ displayTaz :: Integer -> String displayTaz s | abs s < 100 = show s ++ " tazs" @@ -127,9 +149,9 @@ isRecipientValid a = do isUnifiedAddressValid :: T.Text -> Bool isUnifiedAddressValid ua = - case isValidUnifiedAddress (E.encodeUtf8 ua) of - Just _a1 -> True - Nothing -> False + case isValidUnifiedAddress (E.encodeUtf8 ua) of + Just _a1 -> True + Nothing -> False isSaplingAddressValid :: T.Text -> Bool isSaplingAddressValid sa = isValidShieldedAddress (E.encodeUtf8 sa) @@ -137,8 +159,8 @@ isSaplingAddressValid sa = isValidShieldedAddress (E.encodeUtf8 sa) isTransparentAddressValid :: T.Text -> Bool isTransparentAddressValid ta = case decodeTransparentAddress (E.encodeUtf8 ta) of - Just _a3 -> True - Nothing -> False + Just _a3 -> True + Nothing -> False isExchangeAddressValid :: T.Text -> Bool isExchangeAddressValid xa = @@ -147,40 +169,44 @@ isExchangeAddressValid xa = Nothing -> False isRecipientValidGUI :: PrivacyPolicy -> T.Text -> Bool -isRecipientValidGUI p a = do +isRecipientValidGUI p a = do let adr = parseAddress (E.encodeUtf8 a) - case p of - Full -> case adr of - Just a -> - case a of - Unified ua -> True - Sapling sa -> True - _ -> False - Nothing -> False - Medium -> case adr of - Just a -> - case a of - Unified ua -> True - Sapling sa -> True - _ -> False - Nothing -> False - Low -> case adr of - Just a -> - case a of - Unified ua -> True - Sapling sa -> True - Transparent ta -> True - _ -> False - Nothing -> False - None -> case adr of - Just a -> - case a of - Transparent ta -> True - Exchange ea -> True - _ -> False - Nothing -> False + case p of + Full -> + case adr of + Just a -> + case a of + Unified ua -> True + Sapling sa -> True + _ -> False + Nothing -> False + Medium -> + case adr of + Just a -> + case a of + Unified ua -> True + Sapling sa -> True + _ -> False + Nothing -> False + Low -> + case adr of + Just a -> + case a of + Unified ua -> True + Sapling sa -> True + Transparent ta -> True + _ -> False + Nothing -> False + None -> + case adr of + Just a -> + case a of + Transparent ta -> True + Exchange ea -> True + _ -> False + Nothing -> False -isZecAddressValid :: T.Text -> Bool +isZecAddressValid :: T.Text -> Bool isZecAddressValid a = do case isValidUnifiedAddress (E.encodeUtf8 a) of Just _a1 -> True @@ -232,3 +258,73 @@ padWithZero n s isEmpty :: [a] -> Bool isEmpty [] = True isEmpty _ = False + +getChainTip :: T.Text -> Int -> IO Int +getChainTip zHost zPort = do + r <- makeZebraCall zHost zPort "getblockcount" [] + case r of + Left e1 -> pure 0 + Right i -> pure i + +-- Function to fetch Zcash price from CoinGecko +getZcashPrice :: T.Text -> IO (Maybe Double) +getZcashPrice currency = do + let url = + "https://api.coingecko.com/api/v3/simple/price?ids=zcash&vs_currencies=" <> + T.unpack currency + response <- httpJSONEither (parseRequest_ url) + case getResponseBody response of + Right (Object obj) + -- Extract "zcash" object + -> do + case KM.lookup "zcash" obj of + Just (Object zcashObj) + -- Extract the currency price + -> + case KM.lookup (K.fromText (T.toLower currency)) zcashObj of + Just (Number price) -> return (Just (toRealFloat price)) + _ -> return Nothing + _ -> return Nothing + _ -> return Nothing + +-- Parse memo result to convert it to a ByteString +processEither :: Either String BC.ByteString -> BC.ByteString +processEither (Right bs) = bs +processEither (Left e) = BC.pack e -- Returns the error message + +-- Parse the query string into key-value pairs +parseQuery :: String -> [(String, String)] +parseQuery query = map (breakOn '=') (splitOn '&' query) + where + splitOn :: Char -> String -> [String] + splitOn _ [] = [""] + splitOn delim (c:cs) + | c == delim = "" : rest + | otherwise = (c : head rest) : tail rest + where + rest = splitOn delim cs + breakOn :: Char -> String -> (String, String) + breakOn delim str = (key, drop 1 value) + where + (key, value) = span (/= delim) str + +-- Parse a ZIP-321 encoded string into a ZcashPayment structure +parseZcashPayment :: String -> Either String ZcashPaymentURI +parseZcashPayment input + | not (T.isPrefixOf "zcash:" (T.pack input)) = + Left "Invalid scheme: must start with 'zcash:'" + | otherwise = + let (addrPart, queryPart) = break (== '?') (drop 6 input) + queryParams = parseQuery (drop 1 queryPart) + in Right + ZcashPaymentURI + { uriAddress = addrPart + , uriAmount = lookup "amount" queryParams >>= readMaybe + , uriMemo = + case lookup "memo" queryParams of + Just m -> + T.pack (BC.unpack (processEither $ B64.decode $ BC.pack m)) + _ -> "" + , uriLabel = lookup "label" queryParams + , uriMessage = lookup "message" queryParams + } diff --git a/test/ServerSpec.hs b/test/ServerSpec.hs index 7a7daf9..f4af956 100644 --- a/test/ServerSpec.hs +++ b/test/ServerSpec.hs @@ -7,7 +7,7 @@ import Control.Monad.Logger (runNoLoggingT) import Data.Aeson import qualified Data.ByteString as BS import Data.Configurator -import Data.Maybe (fromMaybe) +import Data.Maybe (fromJust, fromMaybe) import qualified Data.Text as T import qualified Data.Text.Encoding as E import Data.Time.Clock (getCurrentTime) @@ -18,7 +18,7 @@ import Servant import System.Directory import Test.HUnit hiding (State) import Test.Hspec -import ZcashHaskell.Orchard (isValidUnifiedAddress) +import ZcashHaskell.Orchard (isValidUnifiedAddress, parseAddress) import ZcashHaskell.Types ( ZcashNet(..) , ZebraGetBlockChainInfo(..) @@ -39,6 +39,9 @@ import Zenith.RPC ) import Zenith.Types ( Config(..) + , PrivacyPolicy(..) + , ProposedNote(..) + , ValidAddressAPI(..) , ZcashAccountAPI(..) , ZcashAddressAPI(..) , ZcashWalletAPI(..) @@ -55,7 +58,16 @@ main = do zebraPort <- require config "zebraPort" zebraHost <- require config "zebraHost" nodePort <- require config "nodePort" - let myConfig = Config dbFilePath zebraHost zebraPort nodeUser nodePwd nodePort + currencyCode <- require config "currencyCode" + let myConfig = + Config + dbFilePath + zebraHost + zebraPort + nodeUser + nodePwd + nodePort + currencyCode hspec $ do describe "RPC methods" $ do beforeAll_ (startAPI myConfig) $ do @@ -572,6 +584,107 @@ main = do Left e -> assertFailure e Right (ErrorResponse i c m) -> c `shouldBe` (-32009) Right _ -> assertFailure "unexpected response" + describe "Send tx" $ do + describe "sendmany" $ do + it "bad credentials" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + "baduser" + "idontknow" + SendMany + BlankParams + res `shouldBe` Left "Invalid credentials" + describe "correct credentials" $ do + it "invalid account" $ do + let uaRead = + parseAddress + "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + SendMany + (SendParams + 17 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + (Just "A cool memo") + ] + Full) + case res of + Left e -> assertFailure e + Right (ErrorResponse i c m) -> c `shouldBe` (-32006) + it "valid account, empty notes" $ do + let uaRead = + parseAddress + "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + SendMany + (SendParams 1 [] Full) + case res of + Left e -> assertFailure e + Right (ErrorResponse i c m) -> c `shouldBe` (-32602) + it "valid account, single output" $ do + let uaRead = + parseAddress + "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + SendMany + (SendParams + 1 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 5.0 + (Just "A cool memo") + ] + Full) + case res of + Left e -> assertFailure e + Right (SendResponse i o) -> o `shouldNotBe` U.nil + it "valid account, multiple outputs" $ do + let uaRead = + parseAddress + "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" + let uaRead2 = + parseAddress + "ztestsapling136jp8z89v2jh6kqd5rs4dtvlxym90m43svzdwzxaplyvc5ttzppytpvx80ncllcsqzpmukxjl3y" + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + SendMany + (SendParams + 1 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 5.0 + (Just "A cool memo") + , ProposedNote + (ValidAddressAPI $ fromJust uaRead2) + 1.0 + (Just "Not so cool memo") + ] + Full) + case res of + Left e -> assertFailure e + Right (SendResponse i o) -> o `shouldNotBe` U.nil startAPI :: Config -> IO () startAPI config = do diff --git a/test/Spec.hs b/test/Spec.hs index 79c7aaa..699fb25 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,20 +1,41 @@ {-# LANGUAGE OverloadedStrings #-} +import Codec.Borsh import Control.Monad (when) -import Control.Monad.Logger (runFileLoggingT, runNoLoggingT) +import Control.Monad.Logger (runNoLoggingT, runNoLoggingT) +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 as T 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 (isValidUnifiedAddress, parseAddress) +import ZcashHaskell.Orchard + ( addOrchardNodeGetRoot + , getOrchardFrontier + , getOrchardNodeValue + , getOrchardPathAnchor + , getOrchardRootTest + , getOrchardTreeAnchor + , getOrchardTreeParts + , isValidUnifiedAddress + , parseAddress + ) import ZcashHaskell.Sapling ( decodeSaplingOutputEsk , encodeSaplingAddress + , getSaplingFrontier , getSaplingNotePosition + , getSaplingPathAnchor + , getSaplingRootTest + , getSaplingTreeAnchor + , getSaplingTreeParts , getSaplingWitness , isValidShieldedAddress , updateSaplingCommitmentTree @@ -22,22 +43,34 @@ import ZcashHaskell.Sapling import ZcashHaskell.Transparent ( decodeExchangeAddress , decodeTransparentAddress + , encodeExchangeAddress ) import ZcashHaskell.Types ( DecodedNote(..) + , MerklePath(..) + , OrchardCommitmentTree(..) + , OrchardFrontier(..) , OrchardSpendingKey(..) + , OrchardTree(..) , Phrase(..) , SaplingCommitmentTree(..) + , SaplingFrontier(..) , SaplingReceiver(..) , SaplingSpendingKey(..) + , SaplingTree(..) , Scope(..) , ShieldedOutput(..) , TxError(..) + , UnifiedAddress(..) + , ValidAddress(..) , ZcashNet(..) ) +import ZcashHaskell.Utils (f4Jumble, makeZebraCall, readZebraTransaction) import Zenith.Core import Zenith.DB +import Zenith.Tree import Zenith.Types +import Zenith.Utils main :: IO () main = do @@ -123,55 +156,6 @@ main = do let ua = "utest1mvlny48qd4x94w8vz5u2lrxx0enuquajt72yekgq24p6pjaky3czk6m7x358h7g900ex6gzvdehaekl96qnakjzw8yaasp8y0u3j5jnlfd33trduznh6k3fcn5ek9qc857fgz8ehm37etx94sj58nrkc0k5hurxnuxpcpms3j8uy2t8kt2vy6vetvsfxxdhtjq0yqulqprvh7mf2u3x" isValidUnifiedAddress ua `shouldNotBe` Nothing - describe "Function tests" $ do - describe "Sapling Decoding" $ do - let sk = - SaplingSpendingKey - "\ETX}\195.\SUB\NUL\NUL\NUL\128\NUL\203\"\229IL\CANJ*\209\EM\145\228m\172\&4\SYNNl\DC3\161\147\SO\157\238H\192\147eQ\143L\201\216\163\180\147\145\156Zs+\146>8\176`ta\161\223\SO\140\177\b;\161\SO\236\151W\148<\STX\171|\DC2\172U\195(I\140\146\214\182\137\211\228\159\128~bV\STXy{m'\224\175\221\219\180!\ENQ_\161\132\240?\255\236\"6\133\181\170t\181\139\143\207\170\211\ENQ\167a\184\163\243\246\140\158t\155\133\138X\a\241\200\140\EMT\GS~\175\249&z\250\214\231\239mi\223\206\STX\t\EM<{V~J\253FB" - let tree = - SaplingCommitmentTree $ - hexString - "01818f2bd58b1e392334d0565181cc7843ae09e3533b2a50a8f1131af657340a5c001001161f962245812ba5e1804fd0a336bc78fa4ee4441a8e0f1525ca5da1b285d35101120f45afa700b8c1854aa8b9c8fe8ed92118ef790584bfcb926078812a10c83a00000000012f4f72c03f8c937a94919a01a07f21165cc8394295291cb888ca91ed003810390107114fe4bb4cd08b47f6ae47477c182d5da9fe5c189061808c1091e9bf3b4524000001447d6b9100cddd5f80c8cf4ddee2b87eba053bd987465aec2293bd0514e68b0d015f6c95e75f4601a0a31670a7deb970fc8988c611685161d2e1629d0a1a0ebd07015f8b9205e0514fa235d75c150b87e23866b882b39786852d1ab42aab11d31a4a0117ddeb3a5f8d2f6b2d0a07f28f01ab25e03a05a9319275bb86d72fcaef6fc01501f08f39275112dd8905b854170b7f247cf2df18454d4fa94e6e4f9320cca05f24011f8322ef806eb2430dc4a7a41c1b344bea5be946efc7b4349c1c9edb14ff9d39" - let nextTree = - SaplingCommitmentTree $ - hexString - "01bd8a3f3cfc964332a2ada8c09a0da9dfc24174befb938abb086b9be5ca049e4900100000019f0d7efb00169bb2202152d3266059d208ab17d14642c3339f9075e997160657000000012f4f72c03f8c937a94919a01a07f21165cc8394295291cb888ca91ed003810390107114fe4bb4cd08b47f6ae47477c182d5da9fe5c189061808c1091e9bf3b4524000001447d6b9100cddd5f80c8cf4ddee2b87eba053bd987465aec2293bd0514e68b0d015f6c95e75f4601a0a31670a7deb970fc8988c611685161d2e1629d0a1a0ebd07015f8b9205e0514fa235d75c150b87e23866b882b39786852d1ab42aab11d31a4a0117ddeb3a5f8d2f6b2d0a07f28f01ab25e03a05a9319275bb86d72fcaef6fc01501f08f39275112dd8905b854170b7f247cf2df18454d4fa94e6e4f9320cca05f24011f8322ef806eb2430dc4a7a41c1b344bea5be946efc7b4349c1c9edb14ff9d39" - it "Sapling is decoded correctly" $ do - so <- - runSqlite "zenith.db" $ - selectList [ShieldOutputTx ==. toSqlKey 38318] [] - let cmus = map (getHex . shieldOutputCmu . entityVal) so - let pos = - getSaplingNotePosition <$> - (getSaplingWitness =<< - updateSaplingCommitmentTree tree (head cmus)) - let pos1 = getSaplingNotePosition <$> getSaplingWitness tree - let pos2 = getSaplingNotePosition <$> getSaplingWitness nextTree - case pos of - Nothing -> assertFailure "couldn't get note position" - Just p -> do - print p - print pos1 - print pos2 - let dn = - decodeSaplingOutputEsk - sk - (ShieldedOutput - (getHex $ shieldOutputCv $ entityVal $ head so) - (getHex $ shieldOutputCmu $ entityVal $ head so) - (getHex $ shieldOutputEphKey $ entityVal $ head so) - (getHex $ shieldOutputEncCipher $ entityVal $ head so) - (getHex $ shieldOutputOutCipher $ entityVal $ head so) - (getHex $ shieldOutputProof $ entityVal $ head so)) - TestNet - External - p - case dn of - Nothing -> assertFailure "couldn't decode Sap output" - Just d -> - a_nullifier d `shouldBe` - hexString - "6c5d1413c63a9a88db71c3f41dc12cd60197ee742fc75b217215e7144db48bd3" describe "Note selection for Tx" $ do it "Value less than balance" $ do pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" @@ -181,10 +165,6 @@ main = do pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" let res = selectUnspentNotes pool (toSqlKey 1) 84000000 res `shouldThrow` anyIOException - it "Fee calculation" $ do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - res <- selectUnspentNotes pool (toSqlKey 1) 14000000 - calculateTxFee res 3 `shouldBe` 20000 describe "Testing validation" $ do it "Unified" $ do let a = @@ -235,303 +215,926 @@ main = do a `shouldBe` Just "ztestsapling1tgjr4zppwk4ne8xy6gdq4z2gwq7dmf5jq8z2ctpn8nlmtse0a74fa5z0m8z383gmpgqz6q6duu4" - describe "Notes" $ do - xit "Check Orchard notes" $ do + 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" + 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 0 0 :: Tree OrchardNode + getLevel (value n) `shouldBe` 0 + it "Create minimal tree" $ do + let t = leaf cmx1 0 0 <> EmptyLeaf :: Tree OrchardNode + 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 OrchardNode)) `shouldBe` + getOrchardRootTest 32 + it "Validate tree with one leaf" $ do + let n = leaf cmx1 0 1 :: Tree OrchardNode + let n1 = root n + getHash (value n1) `shouldBe` addOrchardNodeGetRoot 32 (hexBytes cmx1) + it "Validate size of tree from Zebra" $ do + let tree = + OrchardCommitmentTree $ + hexString + "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" + case getOrchardTreeParts tree of + Nothing -> assertFailure "Failed to get parts" + Just t1 -> 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 getOrchardTreeParts tree of + Nothing -> assertFailure "Failed to get frontier" + Just t1 -> do + length (ot_parents t1) `shouldBe` 31 + it "Create 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 + 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 + {- + -getHash (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 + getHash (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 + 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) + 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 pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - oNotes <- getWalletUnspentOrchNotes pool (toSqlKey 1) - oNotes `shouldBe` [] - xit "Check Sapling notes" $ do + maxBlock <- getMaxBlock pool $ ZcashNetDB TestNet + dbTree <- getOrchardTree pool + case dbTree of + Nothing -> assertFailure "failed to get tree from DB" + Just (oTree, oSync) -> do + let startBlock = oSync - 5 + zebraTreesIn <- + getCommitmentTrees + pool + "localhost" + 18232 + (ZcashNetDB TestNet) + startBlock + ix <- getOrchardActionAtBlock pool (ZcashNetDB TestNet) startBlock + case ix of + Nothing -> assertFailure "couldn't find index at block" + Just i -> do + updatedTree <- runNoLoggingT $ truncateTree oTree i + let finalAnchor = + getOrchardTreeAnchor $ + OrchardCommitmentTree $ ztiOrchard zebraTreesIn + getHash (value updatedTree) `shouldBe` finalAnchor + it "Counting leaves in tree" $ do + let tree = + OrchardCommitmentTree $ + hexString + "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" + case getOrchardTreeParts tree of + Nothing -> assertFailure "Failed to get tree parts" + Just t1 -> do + let newTree = mkOrchardTree t1 + countLeaves newTree `shouldBe` + fromIntegral (1 + getPosition (value newTree)) + it "Validate large load" $ do pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - oNotes <- getWalletUnspentSapNotes pool (toSqlKey 4) - oNotes `shouldBe` [] - xit "Check transparent notes" $ do + maxBlock <- getMaxBlock pool $ ZcashNetDB TestNet + let startBlock = maxBlock - 310000 + zebraTreesIn <- + getCommitmentTrees + pool + "localhost" + 18232 + (ZcashNetDB TestNet) + startBlock + zebraTreesOut <- + getCommitmentTrees + pool + "localhost" + 18232 + (ZcashNetDB TestNet) + maxBlock + case getOrchardTreeParts $ + OrchardCommitmentTree $ ztiOrchard zebraTreesIn of + Nothing -> assertFailure "Failed to get tree parts" + Just t1 -> do + let newTree = mkOrchardTree t1 + oAct <- getOrchardActions pool startBlock $ ZcashNetDB TestNet + let cmxs = + map + (\(_, y) -> + ( getHex $ orchActionCmx $ entityVal y + , fromSqlKey $ entityKey y)) + oAct + let posCmx = zip [(getPosition (value newTree) + 1) ..] cmxs + let updatedTree = batchAppend newTree posCmx + let finalAnchor = + getOrchardTreeAnchor $ + OrchardCommitmentTree $ ztiOrchard zebraTreesOut + getHash (value updatedTree) `shouldBe` finalAnchor + it "Validate tree from DB" $ do pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - oNotes <- getWalletUnspentTrNotes pool (toSqlKey 1) - oNotes `shouldBe` [] - describe "Creating Tx" $ do - describe "Full" $ do - it "To Orchard" $ do - let uaRead = - parseAddress - "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" - case uaRead of - Nothing -> assertFailure "wrong address" - Just ua -> do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - tx <- - runFileLoggingT "zenith.log" $ - prepareTxV2 - pool - "localhost" - 18232 - TestNet - (toSqlKey 1) - 3001331 - 0.005 - (fromJust uaRead) - "Sending memo to orchard" - Full - case tx of - Left e -> assertFailure $ show e - Right h -> h `shouldNotBe` (hexString "deadbeef") - it "To Sapling" $ do - let uaRead = - parseAddress - "ztestsapling136jp8z89v2jh6kqd5rs4dtvlxym90m43svzdwzxaplyvc5ttzppytpvx80ncllcsqzpmukxjl3y" - case uaRead of - Nothing -> assertFailure "wrong address" - Just ua -> do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - tx <- - runFileLoggingT "zenith.log" $ - prepareTxV2 - pool - "localhost" - 18232 - TestNet - (toSqlKey 4) - 3001331 - 0.005 - (fromJust uaRead) - "Sending memo to sapling" - Full - case tx of - Left e -> assertFailure $ show e - Right h -> h `shouldNotBe` (hexString "deadbeef") - it "To Transparent" $ do - let uaRead = parseAddress "tmAmSa4AauSFuJieeanRBjkfnah45ysGtgZ" - case uaRead of - Nothing -> assertFailure "wrong address" - Just ua -> do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - tx <- - runFileLoggingT "zenith.log" $ - prepareTxV2 - pool - "localhost" - 18232 - TestNet - (toSqlKey 4) - 3001331 - 0.005 - (fromJust uaRead) - "" - Full - tx `shouldBe` - Left - (PrivacyPolicyError "Receiver not capable of Full privacy") - describe "Medium" $ do - it "To Orchard" $ do - let uaRead = - parseAddress - "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" - case uaRead of - Nothing -> assertFailure "wrong address" - Just ua -> do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - tx <- - runFileLoggingT "zenith.log" $ - prepareTxV2 - pool - "localhost" - 18232 - TestNet - (toSqlKey 1) - 3001372 - 0.005 - (fromJust uaRead) - "Sending memo to orchard" - Medium - case tx of - Left e -> assertFailure $ show e - Right h -> h `shouldNotBe` (hexString "deadbeef") - it "To Sapling" $ do - let uaRead = - parseAddress - "ztestsapling136jp8z89v2jh6kqd5rs4dtvlxym90m43svzdwzxaplyvc5ttzppytpvx80ncllcsqzpmukxjl3y" - case uaRead of - Nothing -> assertFailure "wrong address" - Just ua -> do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - tx <- - runFileLoggingT "zenith.log" $ - prepareTxV2 - pool - "localhost" - 18232 - TestNet - (toSqlKey 1) - 3001372 - 0.005 - (fromJust uaRead) - "Sending memo to orchard" - Medium - case tx of - Left e -> assertFailure $ show e - Right h -> h `shouldNotBe` (hexString "deadbeef") - it "To Transparent" $ do - let uaRead = parseAddress "tmAmSa4AauSFuJieeanRBjkfnah45ysGtgZ" - case uaRead of - Nothing -> assertFailure "wrong address" - Just ua -> do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - tx <- - runFileLoggingT "zenith.log" $ - prepareTxV2 - pool - "localhost" - 18232 - TestNet - (toSqlKey 4) - 3001331 - 0.005 - (fromJust uaRead) - "" - Medium - tx `shouldBe` - Left - (PrivacyPolicyError "Receiver not capable of Medium privacy") - describe "Low" $ do - it "To Orchard" $ do - let uaRead = - parseAddress - "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" - case uaRead of - Nothing -> assertFailure "wrong address" - Just ua -> do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - tx <- - runFileLoggingT "zenith.log" $ - prepareTxV2 - pool - "localhost" - 18232 - TestNet - (toSqlKey 1) - 3001372 - 0.005 - (fromJust uaRead) - "Sending memo to orchard" - Low - case tx of - Left e -> assertFailure $ show e - Right h -> h `shouldNotBe` (hexString "deadbeef") - it "To Sapling" $ do - let uaRead = - parseAddress - "ztestsapling136jp8z89v2jh6kqd5rs4dtvlxym90m43svzdwzxaplyvc5ttzppytpvx80ncllcsqzpmukxjl3y" - case uaRead of - Nothing -> assertFailure "wrong address" - Just ua -> do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - tx <- - runFileLoggingT "zenith.log" $ - prepareTxV2 - pool - "localhost" - 18232 - TestNet - (toSqlKey 1) - 3001372 - 0.005 - (fromJust uaRead) - "Sending memo to orchard" - Low - case tx of - Left e -> assertFailure $ show e - Right h -> h `shouldNotBe` (hexString "deadbeef") - it "To Transparent" $ do - let uaRead = parseAddress "tmAmSa4AauSFuJieeanRBjkfnah45ysGtgZ" - case uaRead of - Nothing -> assertFailure "wrong address" - Just ua -> do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - tx <- - runFileLoggingT "zenith.log" $ - prepareTxV2 - pool - "localhost" - 18232 - TestNet - (toSqlKey 1) - 3001372 - 0.005 - (fromJust uaRead) - "" - Low - case tx of - Left e -> assertFailure $ show e - Right h -> h `shouldNotBe` (hexString "deadbeef") - describe "None" $ do - it "To Orchard" $ do - let uaRead = - parseAddress - "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" - case uaRead of - Nothing -> assertFailure "wrong address" - Just ua -> do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - tx <- - runFileLoggingT "zenith.log" $ - prepareTxV2 - pool - "localhost" - 18232 - TestNet - (toSqlKey 1) - 3001372 - 0.005 - (fromJust uaRead) - "Sending memo to orchard" - None - tx `shouldBe` - Left - (PrivacyPolicyError - "Receiver not compatible with privacy policy") - it "To Sapling" $ do - let uaRead = - parseAddress - "ztestsapling136jp8z89v2jh6kqd5rs4dtvlxym90m43svzdwzxaplyvc5ttzppytpvx80ncllcsqzpmukxjl3y" - case uaRead of - Nothing -> assertFailure "wrong address" - Just ua -> do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - tx <- - runFileLoggingT "zenith.log" $ - prepareTxV2 - pool - "localhost" - 18232 - TestNet - (toSqlKey 1) - 3001372 - 0.005 - (fromJust uaRead) - "Sending memo to orchard" - None - tx `shouldBe` - Left - (PrivacyPolicyError - "Receiver not compatible with privacy policy") - it "To Transparent" $ do - let uaRead = parseAddress "tmAmSa4AauSFuJieeanRBjkfnah45ysGtgZ" - case uaRead of - Nothing -> assertFailure "wrong address" - Just ua -> do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - tx <- - runFileLoggingT "zenith.log" $ - prepareTxV2 - pool - "localhost" - 18232 - TestNet - (toSqlKey 1) - 3001372 - 0.005 - (fromJust uaRead) - "" - None - case tx of - Left e -> assertFailure $ show e - Right h -> h `shouldNotBe` (hexString "deadbeef") + 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 "TEX address" $ do + it "from UA" $ do + let addr = + parseAddress + "utest1fqtne08sdgmae0g0un7j3h6ss9gafguprv0yvkxv4trxxsdxx467pxkkc98cpsyk5r2enwwpn3p5c6aw537wyvlz20hs7vcqc4uhm22yfjnrsm8hy2hjjrscvhk2ac32rzndu94hh28gdl62wqgy3yev7w0gj9lmmz6yasghmle6tllx4yjv9sjt0xml66y9lyxc4rkk6q425nc5gxa" + case addr of + Nothing -> assertFailure "failed to parse address" + Just (Unified ua) -> + case (encodeExchangeAddress (ua_net ua) =<< (t_rec ua)) of + Nothing -> assertFailure "failed to encode TEX" + Just tex -> + tex `shouldBe` "textest1jze8c9jxxrpct34tpe4pvquz8nvxsxt6gawqqf" + Just _ -> assertFailure "no transparent receiver" + describe "Creating Tx" $ do + describe "Full" $ do + it "To Orchard" $ do + let uaRead = + parseAddress + "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" + case uaRead of + Nothing -> assertFailure "wrong address" + Just ua -> do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + tx <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 3) + 3026170 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + (Just "Sending memo to orchard") + ] + Full + case tx of + Left e -> assertFailure $ show e + Right h -> h `shouldNotBe` hexString "deadbeef" + it "To Sapling" $ do + let uaRead = + parseAddress + "ztestsapling136jp8z89v2jh6kqd5rs4dtvlxym90m43svzdwzxaplyvc5ttzppytpvx80ncllcsqzpmukxjl3y" + case uaRead of + Nothing -> assertFailure "wrong address" + Just ua -> do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + tx <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 4) + 3001331 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + (Just "Sending memo to sapling") + ] + Full + case tx of + Left e -> assertFailure $ show e + Right h -> h `shouldNotBe` hexString "deadbeef" + it "To Transparent" $ do + let uaRead = parseAddress "tmAmSa4AauSFuJieeanRBjkfnah45ysGtgZ" + case uaRead of + Nothing -> assertFailure "wrong address" + Just ua -> do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + tx <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 4) + 3001331 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + Nothing + ] + Full + tx `shouldBe` + Left (PrivacyPolicyError "Receiver not capable of Full privacy") + it "To mixed shielded receivers" $ do + let uaRead = + parseAddress + "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" + let uaRead2 = + parseAddress + "ztestsapling136jp8z89v2jh6kqd5rs4dtvlxym90m43svzdwzxaplyvc5ttzppytpvx80ncllcsqzpmukxjl3y" + case uaRead of + Nothing -> assertFailure "wrong address" + Just ua -> do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + tx <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 1) + 3001331 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + (Just "Sending memo to orchard") + , ProposedNote + (ValidAddressAPI $ fromJust uaRead2) + 0.004 + Nothing + ] + Full + tx `shouldBe` + Left + (PrivacyPolicyError + "Combination of receivers not allowed for Full privacy") + describe "Medium" $ do + it "To Orchard" $ do + let uaRead = + parseAddress + "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" + case uaRead of + Nothing -> assertFailure "wrong address" + Just ua -> do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + tx <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 1) + 3001372 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + (Just "Sending memo to orchard") + ] + Medium + case tx of + Left e -> assertFailure $ show e + Right h -> h `shouldNotBe` hexString "deadbeef" + it "To Sapling" $ do + let uaRead = + parseAddress + "ztestsapling136jp8z89v2jh6kqd5rs4dtvlxym90m43svzdwzxaplyvc5ttzppytpvx80ncllcsqzpmukxjl3y" + case uaRead of + Nothing -> assertFailure "wrong address" + Just ua -> do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + tx <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 1) + 3001372 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + (Just "Sending memo to sapling") + ] + Medium + case tx of + Left e -> assertFailure $ show e + Right h -> h `shouldNotBe` (hexString "00") + it "To Transparent" $ do + let uaRead = parseAddress "tmAmSa4AauSFuJieeanRBjkfnah45ysGtgZ" + case uaRead of + Nothing -> assertFailure "wrong address" + Just ua -> do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + tx <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 4) + 3001331 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + Nothing + ] + Medium + tx `shouldBe` + Left + (PrivacyPolicyError "Receiver not capable of Medium privacy") + it "To mixed shielded receivers" $ do + let uaRead = + parseAddress + "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" + let uaRead2 = + parseAddress + "ztestsapling136jp8z89v2jh6kqd5rs4dtvlxym90m43svzdwzxaplyvc5ttzppytpvx80ncllcsqzpmukxjl3y" + case uaRead of + Nothing -> assertFailure "wrong address" + Just ua -> do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + tx <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 1) + 3001331 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + (Just "Sending memo to orchard") + , ProposedNote + (ValidAddressAPI $ fromJust uaRead2) + 0.004 + Nothing + ] + Medium + case tx of + Left e -> assertFailure $ show e + Right h -> h `shouldNotBe` (hexString "deadbeef") + describe "Low" $ do + it "To Orchard" $ do + let uaRead = + parseAddress + "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" + case uaRead of + Nothing -> assertFailure "wrong address" + Just ua -> do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + tx <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 1) + 3001372 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + Nothing + ] + Low + case tx of + Left e -> assertFailure $ show e + Right h -> h `shouldNotBe` (hexString "deadbeef") + it "To Sapling" $ do + let uaRead = + parseAddress + "ztestsapling136jp8z89v2jh6kqd5rs4dtvlxym90m43svzdwzxaplyvc5ttzppytpvx80ncllcsqzpmukxjl3y" + case uaRead of + Nothing -> assertFailure "wrong address" + Just ua -> do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + tx <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 1) + 3001372 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + Nothing + ] + Low + case tx of + Left e -> assertFailure $ show e + Right h -> h `shouldNotBe` (hexString "deadbeef") + it "To Transparent" $ do + let uaRead = parseAddress "tmAmSa4AauSFuJieeanRBjkfnah45ysGtgZ" + case uaRead of + Nothing -> assertFailure "wrong address" + Just ua -> do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + tx <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 1) + 3001372 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + Nothing + ] + Low + case tx of + Left e -> assertFailure $ show e + Right h -> h `shouldNotBe` (hexString "deadbeef") + describe "None" $ do + it "To Orchard" $ do + let uaRead = + parseAddress + "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" + case uaRead of + Nothing -> assertFailure "wrong address" + Just ua -> do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + tx <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 1) + 3001372 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + Nothing + ] + None + tx `shouldBe` + Left + (PrivacyPolicyError + "Shielded recipients not compatible with privacy policy.") + it "To Sapling" $ do + let uaRead = + parseAddress + "ztestsapling136jp8z89v2jh6kqd5rs4dtvlxym90m43svzdwzxaplyvc5ttzppytpvx80ncllcsqzpmukxjl3y" + case uaRead of + Nothing -> assertFailure "wrong address" + Just ua -> do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + tx <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 1) + 3001372 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + Nothing + ] + None + tx `shouldBe` + Left + (PrivacyPolicyError + "Shielded recipients not compatible with privacy policy.") + it "To Transparent" $ do + let uaRead = parseAddress "tmAmSa4AauSFuJieeanRBjkfnah45ysGtgZ" + case uaRead of + Nothing -> assertFailure "wrong address" + Just ua -> do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + tx <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 1) + 3001372 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + Nothing + ] + None + case tx of + Left e -> assertFailure $ show e + Right h -> h `shouldNotBe` hexString "deadbeef" + describe "Call CoinGecko to get ZEC price" $ do + it "Testing for USD " $ do + price <- getZcashPrice $ T.pack "usd" + case price of + Just p -> p `shouldNotBe` 0.0 + Nothing -> assertFailure "Failed to get ZEC price" + describe "Parse an URI payment string (all fields filled) " $ do + it ("Parsing URI -> " ++ "zcash:ztestsapling10yy2ex5....") $ do + let zcashURI2 = + "zcash:ztestsapling10yy2ex5dcqkclhc7z7yrnjq2z6feyjad56ptwlfgmy77dmaqqrl9gyhprdx59qgmsnyfska2kez?amount=100&memo=SGVsbG8sIFdvcmxkIQ==&message=Test" + case parseZcashPayment zcashURI2 of + Right p -> do + print p + (uriAmount p) `shouldBe` Just 100.0 + Left e -> assertFailure $ "Error: " ++ e + describe + "Parse an URI payment string (just address and amount fields provided) " $ do + it ("Parsing URI -> " ++ "zcash:ztestsapling10yy2ex5....") $ do + let zcashURI3 = + "zcash:ztestsapling10yy2ex5dcqkclhc7z7yrnjq2z6feyjad56ptwlfgmy77dmaqqrl9gyhprdx59qgmsnyfska2kez?amount=100" + case parseZcashPayment zcashURI3 of + Right p -> do + print p + (uriAmount p) `shouldBe` Just 100.0 + Left e -> assertFailure $ "Error: " ++ e + describe "Parse an URI payment string (invalid URI provided) " $ do + it ("Parsing URI -> " ++ "zcash:ztestsapling10yy2ex5....") $ do + let zcashURI3 = + "z:ztestsapling10yy2ex5dcqkclhc7z7yrnjq2z6feyjad56ptwlfgmy77dmaqqrl9gyhprdx59qgmsnyfska2kez?amount=100" + case parseZcashPayment zcashURI3 of + Right p -> do + print p + (uriAmount p) `shouldBe` Just 100.0 + Left e -> assertFailure $ "Error: " ++ e diff --git a/zcash-haskell b/zcash-haskell index 003293c..cfa862e 160000 --- a/zcash-haskell +++ b/zcash-haskell @@ -1 +1 @@ -Subproject commit 003293cc3f978c146824d0695c5c458cf2cc9bb5 +Subproject commit cfa862ec9495e810e7296fa6fe724b46dbe0ee52 diff --git a/zenith-openrpc.json b/zenith-openrpc.json index 8fb37da..53cb005 100644 --- a/zenith-openrpc.json +++ b/zenith-openrpc.json @@ -132,6 +132,7 @@ ], "errors": [ { "$ref": "#/components/errors/ZebraNotAvailable" }, + { "$ref": "#/components/errors/ZenithBusy" }, { "$ref": "#/components/errors/DuplicateName" } ] }, @@ -228,6 +229,7 @@ "errors": [ { "$ref": "#/components/errors/ZebraNotAvailable" }, { "$ref": "#/components/errors/DuplicateName" }, + { "$ref": "#/components/errors/ZenithBusy" }, { "$ref": "#/components/errors/InvalidWallet" } ] }, @@ -444,6 +446,7 @@ ], "errors": [ { "$ref": "#/components/errors/InvalidAccount" }, + { "$ref": "#/components/errors/ZenithBusy" }, { "$ref": "#/components/errors/DuplicateName" } ] }, @@ -593,10 +596,11 @@ { "name": "sendmany", "summary": "Send transaction(s)", - "description": "Send one or more transactions by specifying the source account, the recipient address, the amount, the shielded memo (optional) and the privacy policy (optional).", - "tags": [{"$ref": "#/components/tags/draft"},{"$ref": "#/components/tags/wip"}], + "description": "Send one transaction by specifying the source account, the privacy policy (optional, default 'Full') and an array of proposed outputs. Each output needs a recipient address, an amount and an optional shielded memo.", + "tags": [], "params": [ { "$ref": "#/components/contentDescriptors/AccountId"}, + { "$ref": "#/components/contentDescriptors/PrivacyPolicy"}, { "$ref": "#/components/contentDescriptors/TxRequestArray"} ], "paramStructure": "by-position", @@ -610,14 +614,19 @@ "examples": [ { "name": "Send a transaction", - "summary": "Send one transaction", - "description": "Send a single transaction", + "summary": "Send a transaction", + "description": "Send a transaction with one output", "params": [ { "name": "Account index", "summary": "The index for the account to use", "value": "1" }, + { + "name": "Privacy Policy", + "summary": "The selected privacy policy", + "value": "Full" + }, { "name": "Transaction request", "summary": "The transaction to attempt", @@ -640,7 +649,7 @@ ], "errors": [ { "$ref": "#/components/errors/ZebraNotAvailable" }, - { "$ref": "#/components/errors/InvalidRecipient" }, + { "$ref": "#/components/errors/ZenithBusy" }, { "$ref": "#/components/errors/InvalidAccount" } ] }, @@ -736,6 +745,16 @@ "type": "array", "items": { "$ref": "#/components/schemas/TxRequest"} } + }, + "PrivacyPolicy": { + "name": "Privacy Policy", + "summary": "The chosen privacy policy to use for the transaction", + "description": "The privacy policy to use for the transaction. `Full` policy allows shielded funds to be transferred within their shielded pools. `Medium` policy allows shielded funds to cross shielded pools. `Low` allows deshielding transactions into transparent receivers but not to exchange addresses. `None` allows for transparent funds to be spent to transparent addresses and exchange addresses.", + "required": false, + "schema": { + "type": "string", + "enum": ["None", "Low", "Medium", "Full"] + } } }, "schemas": { @@ -814,8 +833,7 @@ "properties": { "address": { "type": "string", "description": "Recipient's address (unified, Sapling or transparent)" }, "amount": { "type": "number", "description": "The amount to send in ZEC"}, - "memo": { "type": "string", "description": "The shielded memo to include, if applicable"}, - "privacy": { "type": "string", "enum": ["None", "Low", "Medium", "Full"], "description": "The privacy policy to use for the transaction. `Full` policy allows shielded funds to be transferred within their shielded pools. `Medium` policy allows shielded funds to cross shielded pools and deshielding transactions. `Low` allows to spend transparent funds into shielded pools. `None` allows for transparent funds to be spent to transparent addresses."} + "memo": { "type": "string", "description": "The shielded memo to include, if applicable"} } } }, @@ -872,6 +890,10 @@ "InvalidRecipient": { "code": -32011, "message": "The provided recipient address is not valid." + }, + "ZenithBusy": { + "code": -32012, + "message": "The Zenith server is syncing, please try again later." } } } diff --git a/zenith.cabal b/zenith.cabal index c6de5c3..5f7be4b 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: @@ -49,6 +50,7 @@ library , base >=4.12 && <5 , base64-bytestring , binary + , borsh , brick , bytestring , configurator @@ -58,6 +60,7 @@ library , exceptions , filepath , ghc + , generics-sop , haskoin-core , hexstring , http-client @@ -93,6 +96,7 @@ library , vty-crossplatform , word-wrap , zcash-haskell + , unordered-containers --pkgconfig-depends: rustzcash_wrapper default-language: Haskell2010 @@ -124,9 +128,12 @@ executable zenithserver build-depends: base >=4.12 && <5 , configurator + , monad-logger , wai-extra , warp , servant-server + , text + , unix , zcash-haskell , zenith pkgconfig-depends: rustzcash_wrapper @@ -141,8 +148,11 @@ test-suite zenith-tests build-depends: base >=4.12 && <5 , bytestring + , aeson , configurator , monad-logger + , borsh + , aeson , data-default , sort , text diff --git a/zenith.cfg b/zenith.cfg index efedae5..4b1d448 100644 --- a/zenith.cfg +++ b/zenith.cfg @@ -1,5 +1,38 @@ +# +# Zenith Configuration File +# +# ------------------------------------------------------------- +# nodeUser - +# ------------------------------------------------------------- nodeUser = "user" +# ------------------------------------------------------------- +# nodePwd - nodePwd = "superSecret" -dbFilePath = "zenith.db" +# ------------------------------------------------------------- +# dbFileName - contains the SQLite database name used for +# keeping all Zenith's data +# default = zenith.db +# +dbFileName = "zenith.db" +# ------------------------------------------------------------- +# zebraHost - Zebra IP +# Default - "127.0.0.1" zebraHost = "127.0.0.1" +# ------------------------------------------------------------- +# zebraPort - Port used for access Zebra API endpoints +# must be the same port configured for your +# Zebra node zebraPort = 18232 +# ------------------------------------------------------------- +# currencyCode - ISO 4217 currency code +# +# Example of currency codes are: +# +# United States -> currencyCode = "usd" +# Canada -> currencyCode = "cnd" +# Australia -> currencyCode = "aud" +# Euro Region -> currencyCode = "eur" +# Great Britain -> currencyCode = "gbp" +# Japan -> currencyCode = "jpy" +# +currencyCode = "usd"