From 281682ac18f609074175c177d16e50cc1db528fe Mon Sep 17 00:00:00 2001 From: pitmutt Date: Thu, 21 Nov 2024 15:39:18 +0000 Subject: [PATCH] Milestone 3: RPC server, ZIP-320 (#104) This PR contains the following changes: - New RPC server for programmatic access to the wallet. - Support for ZIP-320, TEX addresses and shielding/de-shielding of funds - Native Haskell implementation of the Zcash commitment trees Co-authored-by: Rene Vergara A. Reviewed-on: https://git.vergara.tech///Vergara_Tech/zenith/pulls/104 Co-authored-by: pitmutt Co-committed-by: pitmutt --- .gitmodules | 2 +- CHANGELOG.md | 31 + app/Main.hs | 17 +- app/Server.hs | 91 +++ app/ZenScan.hs | 2 +- cabal.project.freeze | 41 +- src/Zenith/CLI.hs | 757 ++++++++++++++---- src/Zenith/Core.hs | 1386 +++++++++++++++++++++++--------- src/Zenith/DB.hs | 1682 ++++++++++++++++++++++++++++++++++----- src/Zenith/GUI.hs | 1087 +++++++++++++++++++------ src/Zenith/GUI/Theme.hs | 3 + src/Zenith/RPC.hs | 953 ++++++++++++++++++++++ src/Zenith/Scanner.hs | 202 +++-- src/Zenith/Tree.hs | 400 ++++++++++ src/Zenith/Types.hs | 199 ++++- src/Zenith/Utils.hs | 146 +++- src/Zenith/Zcashd.hs | 7 +- test/ServerSpec.hs | 754 ++++++++++++++++++ test/Spec.hs | 1010 +++++++++++++++++++++-- zcash-haskell | 2 +- zenith-openrpc.json | 900 +++++++++++++++++++++ zenith.cabal | 79 +- 22 files changed, 8598 insertions(+), 1153 deletions(-) create mode 100644 app/Server.hs create mode 100644 src/Zenith/RPC.hs create mode 100644 src/Zenith/Tree.hs create mode 100644 test/ServerSpec.hs create mode 100644 zenith-openrpc.json 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 20fa1a2..3f041b4 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,37 @@ 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). +## [0.7.0.0-beta] + +### Added + +- RPC module + - OpenRPC specification + - `listwallets` RPC method + - `listaccounts` RPC method + - `listaddresses` RPC method + - `listreceived` RPC method + - `getbalance` RPC method + - `getnewwallet` RPC method + - `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] ### Added diff --git a/app/Main.hs b/app/Main.hs index 0b6a6f0..f3d4b4c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -19,8 +19,8 @@ import System.IO import Text.Read (readMaybe) import ZcashHaskell.Types import Zenith.CLI -import Zenith.Core (clearSync, testSync) import Zenith.GUI (runZenithGUI) +import Zenith.Scanner (clearSync, rescanZebra) import Zenith.Types (Config(..), ZcashAddress(..), ZcashPool(..), ZcashTx(..)) import Zenith.Utils import Zenith.Zcashd @@ -204,12 +204,15 @@ main :: IO () main = do config <- load ["$(HOME)/Zenith/zenith.cfg"] args <- getArgs - dbFilePath <- require config "dbFilePath" - {-nodeUser <- require config "nodeUser"-} - {-nodePwd <- require config "nodePwd"-} + dbFileName <- require config "dbFileName" + nodeUser <- require config "nodeUser" + nodePwd <- require config "nodePwd" zebraPort <- require config "zebraPort" zebraHost <- require config "zebraHost" - let myConfig = Config dbFilePath zebraHost zebraPort + nodePort <- require config "nodePort" + dbFP <- getZenithPath + let dbFilePath = T.pack $ dbFP ++ dbFileName + let myConfig = Config dbFilePath zebraHost zebraPort nodeUser nodePwd nodePort if not (null args) then do case head args @@ -226,7 +229,8 @@ main = do of "gui" -> runZenithGUI myConfig "tui" -> runZenithTUI myConfig - "rescan" -> clearSync myConfig + "rescan" -> rescanZebra zebraHost zebraPort dbFilePath + "resync" -> clearSync myConfig _ -> printUsage else printUsage @@ -236,4 +240,5 @@ printUsage = do putStrLn "Available commands:" {-putStrLn "legacy\tLegacy CLI for zcashd"-} putStrLn "tui\tTUI for zebrad" + putStrLn "gui\tGUI for zebrad" putStrLn "rescan\tRescan the existing wallet(s)" diff --git a/app/Server.hs b/app/Server.hs new file mode 100644 index 0000000..7944fe3 --- /dev/null +++ b/app/Server.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Server where + +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 (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"] + dbFileName <- require config "dbFileName" + nodeUser <- require config "nodeUser" + nodePwd <- require config "nodePwd" + zebraPort <- require config "zebraPort" + zebraHost <- require config "zebraHost" + nodePort <- require config "nodePort" + dbFP <- getZenithPath + let dbFilePath = T.pack $ dbFP ++ dbFileName + let myConfig = Config dbFilePath zebraHost zebraPort nodeUser nodePwd nodePort + let ctx = authenticate myConfig :. EmptyContext + w <- try $ checkZebra zebraHost zebraPort :: IO (Either IOError ZebraGetInfo) + case w of + Right zebra -> do + bc <- + try $ checkBlockChain zebraHost zebraPort :: IO + (Either IOError ZebraGetBlockChainInfo) + case bc of + Left e1 -> throwIO e1 + Right chainInfo -> do + x <- initDb dbFilePath + case x of + Left e2 -> throwIO $ userError e2 + Right x' -> do + when x' $ rescanZebra zebraHost zebraPort dbFilePath + 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/app/ZenScan.hs b/app/ZenScan.hs index 05059ca..24b09fe 100644 --- a/app/ZenScan.hs +++ b/app/ZenScan.hs @@ -4,7 +4,7 @@ module ZenScan where import Control.Monad.Logger (runNoLoggingT) import Data.Configurator -import Zenith.Scanner (scanZebra) +import Zenith.Scanner (rescanZebra) main :: IO () main = do diff --git a/cabal.project.freeze b/cabal.project.freeze index 175cc2c..b836f57 100644 --- a/cabal.project.freeze +++ b/cabal.project.freeze @@ -41,8 +41,8 @@ constraints: any.Cabal ==3.10.3.0, any.authenticate-oauth ==1.7, any.auto-update ==0.2.1, any.base ==4.18.2.1, - any.base-compat ==0.14.0, - any.base-compat-batteries ==0.14.0, + any.base-compat ==0.13.1, + any.base-compat-batteries ==0.13.1, any.base-orphans ==0.9.2, any.base16 ==1.0, any.base16-bytestring ==1.0.2.0, @@ -59,9 +59,12 @@ constraints: any.Cabal ==3.10.3.0, any.blaze-builder ==0.4.2.3, any.blaze-html ==0.9.2.0, any.blaze-markup ==0.8.3.0, + any.boring ==0.2.2, + boring +tagged, any.borsh ==0.3.0, any.brick ==2.4, brick -demos, + any.bsb-http-chunked ==0.0.0.4, any.byteorder ==1.0.4, any.bytes ==0.17.3, any.bytestring ==0.11.5.3, @@ -90,6 +93,7 @@ constraints: any.Cabal ==3.10.3.0, config-ini -enable-doctests, any.configurator ==0.3.0.0, configurator -developer, + any.constraints ==0.14.2, any.containers ==0.6.7, any.contravariant ==1.5.5, contravariant +semigroups +statevar +tagged, @@ -113,6 +117,7 @@ constraints: any.Cabal ==3.10.3.0, any.data-default-instances-dlist ==0.0.1, any.data-default-instances-old-locale ==0.0.1, any.data-fix ==0.3.4, + any.dec ==0.0.6, any.deepseq ==1.4.8.1, any.directory ==1.3.8.4, any.distributive ==0.6.2.1, @@ -129,6 +134,7 @@ constraints: any.Cabal ==3.10.3.0, any.exceptions ==0.10.7, any.extra ==1.7.16, any.fast-logger ==3.2.3, + any.file-embed ==0.0.16.0, any.filepath ==1.4.300.1, any.fixed ==0.3, any.foreign-rust ==0.1.0, @@ -169,7 +175,12 @@ constraints: any.Cabal ==3.10.3.0, any.http-client-tls ==0.3.6.3, any.http-conduit ==2.3.8.3, http-conduit +aeson, + any.http-date ==0.0.11, + any.http-media ==0.8.1.1, + any.http-semantics ==0.1.2, any.http-types ==0.12.4, + any.http2 ==5.2.6, + http2 -devel -h2spec, any.indexed-traversable ==0.1.4, any.indexed-traversable-instances ==0.1.2, any.integer-conversion ==0.1.1, @@ -196,6 +207,7 @@ constraints: any.Cabal ==3.10.3.0, any.microlens-mtl ==0.2.0.3, any.microlens-th ==0.4.3.15, any.mime-types ==0.1.2.0, + any.mmorph ==1.2.0, any.monad-control ==1.0.3.1, any.monad-logger ==0.3.40, monad-logger +template_haskell, @@ -210,9 +222,13 @@ constraints: any.Cabal ==3.10.3.0, nanovg -examples -gl2 -gles3 -stb_truetype, any.network ==3.2.1.0, network -devel, + any.network-byte-order ==0.1.7, + any.network-control ==0.1.1, any.network-uri ==2.6.4.2, any.old-locale ==1.0.0.7, any.old-time ==1.1.0.4, + any.optparse-applicative ==0.18.1.0, + optparse-applicative +process, any.os-string ==2.0.6, any.parallel ==3.2.2.0, any.parsec ==3.1.16.1, @@ -225,6 +241,9 @@ constraints: any.Cabal ==3.10.3.0, persistent-sqlite -build-sanity-exe +full-text-search +have-usleep +json1 -systemlib +uri-filenames -use-pkgconfig -use-stat3 +use-stat4, any.persistent-template ==2.12.0.0, any.pretty ==1.1.3.6, + any.prettyprinter ==1.7.1, + prettyprinter -buildreadme +text, + any.prettyprinter-ansi-terminal ==1.1.3, any.primitive ==0.9.0.0, any.process ==1.6.19.0, any.profunctors ==5.6.2, @@ -236,6 +255,7 @@ constraints: any.Cabal ==3.10.3.0, any.quickcheck-io ==0.2.0, any.quickcheck-transformer ==0.3.1.2, any.random ==1.2.1.2, + any.recv ==0.1.0, any.reflection ==2.1.8, reflection -slow +template-haskell, any.regex-base ==0.94.0.2, @@ -260,8 +280,15 @@ constraints: any.Cabal ==3.10.3.0, semigroups +binary +bytestring -bytestring-builder +containers +deepseq +hashable +tagged +template-haskell +text +transformers +unordered-containers, any.serialise ==0.2.6.1, serialise +newtime15, + any.servant ==0.20.1, + any.servant-server ==0.20, any.silently ==1.2.5.3, + any.simple-sendfile ==0.2.32, + simple-sendfile +allow-bsd -fallback, + any.singleton-bool ==0.1.8, any.socks ==0.6.1, + any.some ==1.0.6, + some +newtype-unsafe, any.sop-core ==0.5.0.2, any.sort ==1.0.0.0, any.split ==0.2.5, @@ -296,6 +323,7 @@ constraints: any.Cabal ==3.10.3.0, any.time-compat ==1.9.7, any.time-locale-compat ==0.1.1.5, time-locale-compat -old-locale, + any.time-manager ==0.1.0, any.tls ==2.1.0, tls -devel, any.transformers ==0.6.1.0, @@ -326,9 +354,18 @@ constraints: any.Cabal ==3.10.3.0, any.vty-crossplatform ==0.4.0.0, vty-crossplatform -demos, any.vty-unix ==0.2.0.0, + any.wai ==3.2.4, + any.wai-app-static ==3.1.9, + wai-app-static +crypton -print, + any.wai-extra ==3.1.15, + wai-extra -build-example, + any.wai-logger ==2.4.0, + any.warp ==3.4.1, + warp +allow-sendfilefd -network-bytestring -warp-debug +x509, any.wide-word ==0.1.6.0, any.witherable ==0.5, any.word-wrap ==0.5, + any.word8 ==0.1.3, any.wreq ==0.5.4.3, wreq -aws -developer +doctest -httpbin, any.zlib ==0.7.1.0, diff --git a/src/Zenith/CLI.hs b/src/Zenith/CLI.hs index b10b7e0..c2fa1a7 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 @@ -10,16 +11,15 @@ import qualified Brick.BChan as BC import qualified Brick.Focus as F import Brick.Forms ( Form(..) - , FormFieldState , (@@=) , allFieldsValid - , editShowableField , editShowableFieldWithValidate , editTextField , focusedFormInputAttr , handleFormEvent , invalidFormInputAttr , newForm + , radioField , renderForm , setFieldValid , updateFormState @@ -42,7 +42,6 @@ import Brick.Widgets.Core , joinBorders , padAll , padBottom - , padLeft , padTop , setAvailableSize , str @@ -63,13 +62,20 @@ import qualified Brick.Widgets.Edit as E import qualified Brick.Widgets.List as L import qualified Brick.Widgets.ProgressBar as P import Control.Concurrent (forkIO, threadDelay) -import Control.Exception (catch, throw, throwIO, try) -import Control.Monad (forever, void) +import Control.Exception (throw, throwIO, try) +import Control.Monad (forM_, forever, unless, void, when) import Control.Monad.IO.Class (liftIO) -import Control.Monad.Logger (LoggingT, runFileLoggingT, runNoLoggingT) +import Control.Monad.Logger + ( LoggingT + , NoLoggingT + , logDebugN + , 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) @@ -83,10 +89,13 @@ import Lens.Micro.Mtl import Lens.Micro.TH import System.Hclip import Text.Printf -import Text.Wrap (FillScope(..), FillStrategy(..), WrapSettings(..), wrapText) -import ZcashHaskell.Keys (generateWalletSeedPhrase, getWalletSeed) -import ZcashHaskell.Orchard (getSaplingFromUA, isValidUnifiedAddress) -import ZcashHaskell.Sapling (decodeSaplingAddress, isValidShieldedAddress) +import Text.Wrap (FillScope(..), FillStrategy(..), WrapSettings(..)) +import ZcashHaskell.Keys (generateWalletSeedPhrase) +import ZcashHaskell.Orchard + ( getSaplingFromUA + , isValidUnifiedAddress + , parseAddress + ) import ZcashHaskell.Transparent ( decodeTransparentAddress , encodeTransparentReceiver @@ -95,19 +104,26 @@ import ZcashHaskell.Types import ZcashHaskell.Utils (getBlockTime, makeZebraCall) import Zenith.Core import Zenith.DB -import Zenith.Scanner (processTx, updateConfs) +import Zenith.Scanner (checkIntegrity, processTx, rescanZebra, updateConfs) import Zenith.Types ( Config(..) + , HexStringDB(..) , PhraseDB(..) + , PrivacyPolicy(..) + , ProposedNote(..) + , ShieldDeshieldOp(..) , UnifiedAddressDB(..) + , ValidAddressAPI(..) , ZcashNetDB(..) + , ZenithStatus(..) ) import Zenith.Utils ( displayTaz , displayZec + , getChainTip , isRecipientValid + , isRecipientValidGUI , jsonNumber - , parseAddress , showAddress , validBarValue ) @@ -126,6 +142,14 @@ data Name | ABList | DescripField | AddressField + | PrivacyNoneField + | PrivacyLowField + | PrivacyMediumField + | PrivacyFullField + | ShieldField + | DeshieldField + | TotalTranspField + | TotalShieldedField deriving (Eq, Show, Ord) data DialogInput = DialogInput @@ -136,8 +160,9 @@ makeLenses ''DialogInput data SendInput = SendInput { _sendTo :: !T.Text - , _sendAmt :: !Float + , _sendAmt :: !Scientific , _sendMemo :: !T.Text + , _policyField :: !PrivacyPolicy } deriving (Show) makeLenses ''SendInput @@ -149,6 +174,12 @@ data AdrBookEntry = AdrBookEntry makeLenses ''AdrBookEntry +newtype ShDshEntry = ShDshEntry + { _shAmt :: Scientific + } deriving (Show) + +makeLenses ''ShDshEntry + data DialogType = WName | AName @@ -161,6 +192,8 @@ data DialogType | AdrBookForm | AdrBookUpdForm | AdrBookDelForm + | DeshieldForm + | ShieldForm data DisplayType = AddrDisplay @@ -178,6 +211,9 @@ data Tick | TickMsg !String | TickTx !HexString +data DropDownItem = + DropdownItem String + data State = State { _network :: !ZcashNet , _wallets :: !(L.List Name (Entity ZcashWallet)) @@ -206,6 +242,9 @@ data State = State , _abCurAdrs :: !T.Text -- used for address book CRUD operations , _sentTx :: !(Maybe HexString) , _unconfBalance :: !Integer + , _deshieldForm :: !(Form ShDshEntry () Name) + , _tBalance :: !Integer + , _sBalance :: !Integer } makeLenses ''State @@ -222,11 +261,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 @@ -253,17 +292,24 @@ 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))) <=> - C.hCenter - (hBox - [ capCommand "W" "allets" - , capCommand "A" "ccounts" - , capCommand "V" "iew address" - , capCommand "S" "end Tx" - , capCommand2 "Address " "B" "ook" - , capCommand "Q" "uit" - , capCommand "?" " Help" - , str $ show (st ^. timer) - ]) + (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) + ]) + ]) listBox :: Show e => String -> L.List Name e -> Widget Name listBox titleLabel l = C.vCenter $ @@ -329,7 +375,7 @@ 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", "q"] + map (C.hCenter . str) ["?", "Esc", "w", "a", "v", "s", "b", "d", "q"] actionList = map (hLimit 40 . str) @@ -340,6 +386,7 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] , "View address" , "Send Tx" , "Address Book" + , "Shield/De-Shield" , "Quit" ] inputDialog :: State -> Widget Name @@ -386,6 +433,37 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] (renderForm (st ^. txForm) <=> C.hCenter (hBox [capCommand "↲ " "Send", capCommand " " "Cancel"])) + DeshieldForm -> + D.renderDialog + (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) + (C.hCenter + (str $ + "Shield " ++ + if st ^. network == MainNet + then displayZec (st ^. tBalance) + else displayTaz (st ^. tBalance) ++ "?") <=> + C.hCenter + (hBox [capCommand "P" "roceed", capCommand " " "Cancel"])) Blank -> emptyWidget -- Address Book List AdrBook -> @@ -450,7 +528,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 @@ -610,14 +688,34 @@ mkInputForm = mkSendForm :: Integer -> SendInput -> Form SendInput e Name mkSendForm bal = newForm - [ label "To: " @@= editTextField sendTo RecField (Just 1) + [ label "Privacy Level :" @@= + radioField + policyField + [ (Full, PrivacyFullField, "Full") + , (Medium, PrivacyMediumField, "Medium") + , (Low, PrivacyLowField, "Low") + , (None, PrivacyNoneField, "None") + ] + , label "To: " @@= editTextField sendTo RecField (Just 1) , label "Amount: " @@= editShowableFieldWithValidate sendAmt AmtField (isAmountValid 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 + +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 @@ -722,19 +820,32 @@ abSelAttr = A.attrName "abselected" abMBarAttr :: A.AttrName abMBarAttr = A.attrName "menubar" -scanZebra :: T.Text -> T.Text -> Int -> Int -> BC.BChan Tick -> IO () -scanZebra dbP zHost zPort b eChan = do - _ <- liftIO $ initDb dbP +scanZebra :: + T.Text + -> T.Text + -> Int + -> Int + -> BC.BChan Tick + -> ZcashNet + -> NoLoggingT IO () +scanZebra dbP zHost zPort b eChan znet = do bStatus <- liftIO $ checkBlockChain zHost zPort - pool <- runNoLoggingT $ initPool dbP - dbBlock <- runNoLoggingT $ getMaxBlock pool - confUp <- try $ updateConfs zHost zPort pool :: IO (Either IOError ()) - case confUp of - Left _e0 -> - liftIO $ - BC.writeBChan eChan $ TickMsg "Failed to update unconfirmed transactions" - Right _ -> do - let sb = max dbBlock b + pool <- liftIO $ runNoLoggingT $ initPool dbP + dbBlock <- liftIO $ getMaxBlock pool $ ZcashNetDB znet + 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 + 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 liftIO $ @@ -746,8 +857,28 @@ scanZebra dbP zHost zPort b eChan = do let step = (1.0 :: Float) / fromIntegral (zgb_blocks bStatus - (sb + 1)) - mapM_ (processBlock pool step) bList - else liftIO $ BC.writeBChan eChan $ TickVal 1.0 + _ <- 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 @@ -759,7 +890,9 @@ scanZebra dbP zHost zPort b eChan = 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 $ @@ -769,19 +902,21 @@ scanZebra dbP zHost zPort b eChan = 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 - mapM_ (runNoLoggingT . processTx zHost zPort blockTime pool) $ - bl_txs $ addTime blk blockTime + bi <- + saveBlock pool $ + ZcashBlock + (fromIntegral $ bl_height blk) + (HexStringDB $ bl_hash blk) + (fromIntegral $ bl_confirmations blk) + blockTime + (ZcashNetDB znet) + mapM_ (processTx zHost zPort bi pool) $ bl_txs blk liftIO $ BC.writeBChan eChan $ TickVal step - addTime :: BlockResponse -> Int -> BlockResponse - addTime bl t = - BlockResponse - (bl_confirmations bl) - (bl_height bl) - (fromIntegral t) - (bl_txs bl) appEvent :: BT.BrickEvent Name Tick -> BT.EventM Name State () appEvent (BT.AppEvent t) = do @@ -791,7 +926,35 @@ 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) + 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 () @@ -814,26 +977,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 $ - syncWallet - (Config (s ^. dbPath) (s ^. zebraHost) (s ^. zebraPort)) - 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 @@ -847,21 +993,27 @@ appEvent (BT.AppEvent t) = do AdrBookForm -> return () AdrBookUpdForm -> return () AdrBookDelForm -> return () + DeshieldForm -> return () + ShieldForm -> 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 $ + runNoLoggingT $ scanZebra (s ^. dbPath) (s ^. zebraHost) (s ^. zebraPort) sBlock (s ^. eventDispatch) + (s ^. network) BT.modify $ set timer 0 return () else BT.modify $ set timer $ 1 + s ^. timer @@ -1063,7 +1215,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 $ @@ -1078,6 +1231,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 @@ -1091,8 +1245,103 @@ appEvent (BT.VtyEvent e) = do fs <- BT.gets formState BT.modify $ setFieldValid - (isRecipientValid (fs ^. sendTo)) + (isRecipientValidGUI + (fs ^. policyField) + (fs ^. sendTo)) RecField + 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') [] -> @@ -1110,7 +1359,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 @@ -1125,7 +1374,8 @@ appEvent (BT.VtyEvent e) = do (SendInput (addressBookAbaddress (entityVal a)) 0.0 - "") + "" + Full) BT.modify $ set dialogBox SendTx _ -> do BT.modify $ @@ -1275,6 +1525,53 @@ 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 any other event Blank -> do case e of @@ -1297,10 +1594,61 @@ appEvent (BT.VtyEvent e) = do V.EvKey (V.KChar 's') [] -> do BT.modify $ set txForm $ - mkSendForm (s ^. balance) (SendInput "" 0.0 "") + mkSendForm (s ^. balance) (SendInput "" 0.0 "" Full) BT.modify $ set dialogBox SendTx V.EvKey (V.KChar 'b') [] -> BT.modify $ set dialogBox AdrBook + 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') [] -> 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 ev -> case r of Just AList -> @@ -1315,6 +1663,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 @@ -1363,75 +1713,94 @@ runZenithTUI config = do case bc of Left e1 -> throwIO e1 Right chainInfo -> do - initDb dbFilePath - walList <- getWallets pool $ zgb_net chainInfo - accList <- - if not (null walList) - then runNoLoggingT $ getAccounts pool $ entityKey $ head walList - else return [] - addrList <- - if not (null accList) - then runNoLoggingT $ getAddresses pool $ entityKey $ head accList - else return [] - txList <- - if not (null addrList) - then getUserTx pool $ entityKey $ head addrList - else return [] - let block = + x <- initDb dbFilePath + _ <- upgradeQrTable pool + case x of + Left e2 -> throwIO $ userError e2 + Right x' -> do + when x' $ rescanZebra host port dbFilePath + walList <- getWallets pool $ zgb_net chainInfo + accList <- if not (null walList) - then zcashWalletLastSync $ entityVal $ head walList - else 0 - abookList <- getAdrBook pool $ zgb_net chainInfo - bal <- - if not (null accList) - then getBalance pool $ entityKey $ head accList - else return 0 - uBal <- - if not (null accList) - then getUnconfirmedBalance pool $ entityKey $ head accList - else return 0 - eventChan <- BC.newBChan 10 - _ <- - forkIO $ - forever $ do - BC.writeBChan eventChan (TickVal 0.0) - threadDelay 1000000 - let buildVty = VC.mkVty V.defaultConfig - initialVty <- buildVty - void $ - M.customMain initialVty buildVty (Just eventChan) theApp $ - State - (zgb_net chainInfo) - (L.list WList (Vec.fromList walList) 1) - (L.list AcList (Vec.fromList accList) 0) - (L.list AList (Vec.fromList addrList) 1) - (L.list TList (Vec.fromList txList) 1) - ("Start up Ok! Connected to Zebra " ++ - (T.unpack . zgi_build) zebra ++ " on port " ++ show port ++ ".") - False - (if null walList - then WName - else Blank) - True - (mkInputForm $ DialogInput "Main") - (F.focusRing [AList, TList]) - (zgb_blocks chainInfo) - dbFilePath - host - port - MsgDisplay - block - bal - 1.0 - eventChan - 0 - (mkSendForm 0 $ SendInput "" 0.0 "") - (L.list ABList (Vec.fromList abookList) 1) - (mkNewABForm (AdrBookEntry "" "")) - "" - Nothing - uBal - Left e -> do + then runNoLoggingT $ + getAccounts pool $ entityKey $ head walList + else return [] + addrList <- + if not (null accList) + then runNoLoggingT $ + getAddresses pool $ entityKey $ head accList + else return [] + txList <- + if not (null addrList) + then getUserTx pool $ entityKey $ head addrList + else return [] + let block = + if not (null walList) + then zcashWalletLastSync $ entityVal $ head walList + else 0 + abookList <- getAdrBook pool $ zgb_net chainInfo + bal <- + if not (null accList) + then getBalance pool $ entityKey $ head accList + else return 0 + uBal <- + 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 $ + forever $ do + BC.writeBChan eventChan (TickVal 0.0) + threadDelay 1000000 + let buildVty = VC.mkVty V.defaultConfig + initialVty <- buildVty + void $ + M.customMain initialVty buildVty (Just eventChan) theApp $ + State + (zgb_net chainInfo) + (L.list WList (Vec.fromList walList) 1) + (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 " ++ + (T.unpack . zgi_build) zebra ++ + " on port " ++ show port ++ ".") + False + (if null walList + then WName + else Blank) + True + (mkInputForm $ DialogInput "Main") + (F.focusRing [AList, TList]) + (zgb_blocks chainInfo) + dbFilePath + host + port + MsgDisplay + block + bal + 1.0 + eventChan + 0 + (mkSendForm 0 $ SendInput "" 0.0 "" Full) + (L.list ABList (Vec.fromList abookList) 1) + (mkNewABForm (AdrBookEntry "" "")) + "" + Nothing + uBal + (mkDeshieldForm 0 (ShDshEntry 0.0)) + tBal + sBal + Left _e -> do print $ "No Zebra node available on port " <> show port <> ". Check your configuration." @@ -1450,7 +1819,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 @@ -1641,22 +2010,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 parseAddress 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 @@ -1666,3 +2050,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 abfb476..835a00d 100644 --- a/src/Zenith/Core.hs +++ b/src/Zenith/Core.hs @@ -4,47 +4,41 @@ module Zenith.Core where import Control.Exception (throwIO, try) -import Control.Monad (forM, when) +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 , encodeUnifiedAddress , genOrchardReceiver , genOrchardSpendingKey + , getOrchardFrontier , getOrchardNotePosition + , getOrchardTreeParts , getOrchardWitness , isValidUnifiedAddress , updateOrchardCommitmentTree @@ -55,7 +49,9 @@ import ZcashHaskell.Sapling , genSaplingInternalAddress , genSaplingPaymentAddress , genSaplingSpendingKey + , getSaplingFrontier , getSaplingNotePosition + , getSaplingTreeParts , getSaplingWitness , updateSaplingCommitmentTree , updateSaplingWitness @@ -68,16 +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(..) ) @@ -107,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 @@ -223,6 +238,47 @@ createWalletAddress n i zNet scope za = do encodeUnifiedAddress $ UnifiedAddress zNet oRec sRec (Just tRec)) (ScopeDB scope) +-- | Create an external unified address for the given account and index with custom receivers +createCustomWalletAddress :: + T.Text -- ^ The address nickname + -> Int -- ^ The address' index + -> ZcashNet -- ^ The network for this address + -> Scope -- ^ External or Internal + -> Entity ZcashAccount -- ^ The Zcash account that the address will be attached to + -> Bool -- ^ Exclude Sapling + -> Bool -- ^ Exclude Transparent + -> IO WalletAddress +createCustomWalletAddress n i zNet scope za exSap exTr = do + let oRec = + genOrchardReceiver i scope $ + getOrchSK $ zcashAccountOrchSpendKey $ entityVal za + let sRec = + if exSap + then Nothing + else case scope of + External -> + genSaplingPaymentAddress i $ + getSapSK $ zcashAccountSapSpendKey $ entityVal za + Internal -> + genSaplingInternalAddress $ + getSapSK $ zcashAccountSapSpendKey $ entityVal za + tRec <- + if exTr + then return Nothing + else Just <$> + genTransparentReceiver + i + scope + (getTranSK $ zcashAccountTPrivateKey $ entityVal za) + return $ + WalletAddress + i + (entityKey za) + n + (UnifiedAddressDB $ + encodeUnifiedAddress $ UnifiedAddress zNet oRec sRec tRec) + (ScopeDB scope) + -- * Wallet -- | Find the Sapling notes that match the given spending key findSaplingOutputs :: @@ -230,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 - 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) @@ -313,7 +361,7 @@ findSaplingOutputs config b znet za = do (getHex $ shieldOutputProof $ entityVal s)) n scope - pos + (fromIntegral pos) -- | Get Orchard actions findOrchardActions :: @@ -328,65 +376,53 @@ findOrchardActions config b znet za = do let zebraPort = c_zebraPort config let zn = getNet znet pool <- runNoLoggingT $ initPool dbPath - tList <- getOrchardActions pool b - trees <- getCommitmentTrees zebraHost zebraPort (b - 1) - let sT = OrchardCommitmentTree $ ztiOrchard trees - decryptNotes sT zn pool tList - orchNotes <- getWalletOrchNotes pool (entityKey za) - findOrchSpends pool (entityKey za) orchNotes + tList <- getOrchardActions pool b znet + sT <- getOrchardTree pool + case sT of + Nothing -> throwIO $ userError "Failed to read Orchard commitment tree" + Just (sT', treeSync) -> do + mapM_ (decryptNotes sT' zn pool) tList + orchNotes <- getWalletOrchNotes pool (entityKey za) + findOrchSpends pool (entityKey za) orchNotes where decryptNotes :: - OrchardCommitmentTree + 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 @@ -409,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 @@ -427,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 @@ -438,177 +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 - spParams <- liftIO $ BS.readFile "sapling-spend.params" - outParams <- liftIO $ BS.readFile "sapling-output.params" - if show (md5 $ LBS.fromStrict spParams) /= - "0f44c12ef115ae019decf18ade583b20" - then logErrorN "Can't validate sapling parameters" - else logInfoN "Valid Sapling spend params" - if show (md5 $ LBS.fromStrict outParams) /= - "924daf81b87a81bbbb9c7d18562046c8" - then logErrorN "Can't validate sapling parameters" - else logInfoN "Valid Sapling output params" - --print $ BS.length spParams - --print $ BS.length outParams - logDebugN "Read Sapling params" - 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 - (SaplingSpendParams spParams) - (SaplingOutputParams outParams) - 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 - (SaplingSpendParams spParams) - (SaplingOutputParams outParams) - 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] @@ -645,12 +861,392 @@ prepareTx pool zebraHost zebraPort zn za bh amt ua memo = do flipTxId (fromIntegral $ walletTrNotePosition $ entityVal n)) (RawTxOut - (walletTrNoteValue $ entityVal n) + (fromIntegral $ walletTrNoteValue $ entityVal n) + (walletTrNoteScript $ entityVal n)) + +-- | Prepare a transaction for sending +prepareTxV2 :: + ConnectionPool + -> T.Text + -> Int + -> ZcashNet + -> ZcashAccountId + -> Int + -> [ProposedNote] + -> PrivacyPolicy + -> NoLoggingT IO (Either TxError HexString) +prepareTxV2 pool zebraHost zebraPort zn za bh pnotes policy = do + accRead <- liftIO $ getAccountById pool za + let recipients = map extractReceiver pnotes + logDebugN $ T.pack $ show recipients + logDebugN $ T.pack $ "Target block: " ++ show bh + 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 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 $ + 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 + fee) + (map (\(x, _, _, _) -> x) recipients) + policy + case finalNotePlan of + Right (tList1, sList1, oList1) -> do + logDebugN $ T.pack $ "selected notes with fee" ++ show fee + logDebugN $ T.pack $ show tList1 + logDebugN $ T.pack $ show sList1 + logDebugN $ T.pack $ show oList1 + tSpends1 <- + liftIO $ + prepTSpends + (getTranSK $ zcashAccountTPrivateKey $ entityVal acc) + tList1 + sSpends1 <- + 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 + recipients + (noteTotal1 - fee - fromIntegral zats) + policy + logDebugN $ T.pack $ show outgoing' + case outgoing' of + Left e -> return $ Left e + Right outgoing -> do + 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 + 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, Int64, T.Text)] + -> Int64 + -> PrivacyPolicy + -> IO (Either TxError [OutgoingNote]) + 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 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) + 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 + 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) + 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 + 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) + let cnote = + OutgoingNote + 1 + BS.empty + (toBytes $ tr_bytes chgRcvr) + (fromIntegral chg) + "" + True + let onotes = map (prepareOutgoingNote (entityVal acc)) recvs + return $ Right $ cnote : onotes + getTotalAmount :: + ( [Entity WalletTrNote] + , [Entity WalletSapNote] + , [Entity WalletOrchNote]) + -> Int64 + 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 + 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) @@ -661,11 +1257,18 @@ prepareTx pool zebraHost zebraPort zn za bh amt ua memo = 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) @@ -676,100 +1279,149 @@ prepareTx pool zebraHost zebraPort zn za bh amt ua memo = 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 - -> IO () + -> NoLoggingT IO () syncWallet config w = do startTime <- liftIO getCurrentTime + logDebugN $ T.pack $ show startTime let walletDb = c_dbPath config - pool <- runNoLoggingT $ initPool walletDb - accs <- runNoLoggingT $ getAccounts pool $ entityKey w - addrs <- concat <$> mapM (runNoLoggingT . getAddresses pool . entityKey) accs + let znet = zcashWalletNetwork $ entityVal w + pool <- liftIO $ runNoLoggingT $ initPool walletDb + accs <- liftIO $ runNoLoggingT $ getAccounts pool $ entityKey w + addrs <- + concat <$> + mapM (liftIO . runNoLoggingT . getAddresses pool . entityKey) accs + logDebugN $ "addrs: " <> T.pack (show addrs) intAddrs <- - concat <$> mapM (runNoLoggingT . getInternalAddresses pool . entityKey) accs - chainTip <- runNoLoggingT $ getMaxBlock pool - let lastBlock = zcashWalletLastSync $ entityVal w + concat <$> + mapM (liftIO . runNoLoggingT . getInternalAddresses pool . entityKey) accs + chainTip <- liftIO $ getMaxBlock pool znet + logDebugN $ "chain tip: " <> T.pack (show chainTip) + lastBlock <- liftIO $ getLastSyncBlock pool $ entityKey w + logDebugN $ "last block: " <> T.pack (show lastBlock) let startBlock = if lastBlock > 0 then lastBlock - else zcashWalletBirthdayHeight $ entityVal w - mapM_ (liftIO . findTransparentNotes pool startBlock) addrs - mapM_ (liftIO . findTransparentNotes pool startBlock) intAddrs + 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 - _ <- updateSaplingWitnesses pool - _ <- updateOrchardWitnesses pool + logDebugN "processed orchard actions" _ <- liftIO $ updateWalletSync pool chainTip (entityKey w) - mapM_ (runNoLoggingT . getWalletTransactions pool) addrs + logDebugN "updated wallet lastSync" + mapM_ (liftIO . runNoLoggingT . getWalletTransactions pool) addrs -testSync :: Config -> IO () -testSync config = do - let dbPath = c_dbPath config - _ <- initDb dbPath - pool <- runNoLoggingT $ initPool dbPath - w <- getWallets pool TestNet - r <- mapM (syncWallet config) w - liftIO $ print r - {-let uaRead =-} - {-isValidUnifiedAddress-} - {-"utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax"-} - {-case uaRead of-} - {-Nothing -> print "wrong address"-} - {-Just ua -> do-} - {-startTime <- getCurrentTime-} - {-print startTime-} - {-tx <--} - {-prepareTx-} - {-"zenith.db"-} - {-"127.0.0.1"-} - {-18232-} - {-TestNet-} - {-(toSqlKey 1)-} - {-2820897-} - {-0.04-} - {-ua-} - {-"sent with Zenith, test"-} - {-print tx-} - {-endTime <- getCurrentTime-} - {-print endTime-} - -{-testSend :: IO ()-} -{-testSend = do-} -clearSync :: Config -> IO () -clearSync config = do - let dbPath = c_dbPath config - pool <- runNoLoggingT $ initPool dbPath - _ <- initDb dbPath - _ <- clearWalletTransactions pool - w <- getWallets pool TestNet - liftIO $ mapM_ (updateWalletSync pool 0 . entityKey) w - w' <- liftIO $ getWallets pool TestNet - r <- mapM (syncWallet config) w' - liftIO $ print r +-- | 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 aea3c5a..dfbedf9 100644 --- a/src/Zenith/DB.hs +++ b/src/Zenith/DB.hs @@ -18,18 +18,28 @@ module Zenith.DB where -import Control.Exception (throwIO) -import Control.Monad (forM_, when) +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 Data.Bifunctor (bimap) +import Control.Monad.Logger + ( LoggingT + , NoLoggingT + , logDebugN + , logErrorN + , runNoLoggingT + , runStderrLoggingT + ) import qualified Data.ByteString as BS import Data.HexString +import Data.Int import Data.List (group, sort) import Data.Maybe (catMaybes, fromJust, isJust) import Data.Pool (Pool) import qualified Data.Text as T import qualified Data.Text.Encoding as TE +import Data.Time.Clock (UTCTime, getCurrentTime) +import qualified Data.UUID as U import Data.Word import Database.Esqueleto.Experimental import qualified Database.Persist.Sqlite as PS @@ -40,17 +50,24 @@ import Haskoin.Transaction.Common , TxOut(..) , txHashToHex ) -import qualified Lens.Micro as ML ((&), (.~), (^.)) -import ZcashHaskell.Orchard (isValidUnifiedAddress) +import System.Directory (doesFileExist, getHomeDirectory, removeFile) +import System.FilePath (()) +import ZcashHaskell.Orchard + ( compareAddress + , getSaplingFromUA + , isValidUnifiedAddress + ) +import ZcashHaskell.Transparent (encodeTransparentReceiver) import ZcashHaskell.Types ( DecodedNote(..) + , ExchangeAddress(..) , OrchardAction(..) , OrchardBundle(..) - , OrchardSpendingKey(..) + , OrchardReceiver(..) , OrchardWitness(..) + , SaplingAddress(..) , SaplingBundle(..) - , SaplingCommitmentTree(..) - , SaplingSpendingKey(..) + , SaplingReceiver(..) , SaplingWitness(..) , Scope(..) , ShieldedOutput(..) @@ -60,22 +77,31 @@ import ZcashHaskell.Types , TransparentAddress(..) , TransparentBundle(..) , TransparentReceiver(..) + , TxError(..) , UnifiedAddress(..) - , ZcashNet - , decodeHexText + , ValidAddress(..) + , ZcashNet(..) ) +import Zenith.Tree (OrchardNode(..), SaplingNode(..), Tree(..), truncateTree) import Zenith.Types - ( Config(..) + ( AccountBalance(..) , HexStringDB(..) , OrchardSpendingKeyDB(..) , PhraseDB(..) + , PrivacyPolicy(..) , RseedDB(..) , SaplingSpendingKeyDB(..) , ScopeDB(..) , TransparentSpendingKeyDB , UnifiedAddressDB(..) + , ZcashAccountAPI(..) + , ZcashAddressAPI(..) , ZcashNetDB(..) + , ZcashNoteAPI(..) , ZcashPool(..) + , ZcashWalletAPI(..) + , ZenithStatus(..) + , ZenithUuid(..) ) share @@ -128,24 +154,24 @@ share tx WalletTransactionId OnDeleteCascade OnUpdateCascade accId ZcashAccountId OnDeleteCascade OnUpdateCascade address WalletAddressId OnDeleteCascade OnUpdateCascade - value Word64 + value Int64 spent Bool script BS.ByteString change Bool - position Word64 - UniqueTNote tx script + position Int + UniqueTNote tx accId script deriving Show Eq WalletTrSpend tx WalletTransactionId OnDeleteCascade OnUpdateCascade note WalletTrNoteId OnDeleteCascade OnUpdateCascade accId ZcashAccountId OnDeleteCascade OnUpdateCascade - value Word64 + value Int64 UniqueTrSpend tx accId deriving Show Eq WalletSapNote tx WalletTransactionId OnDeleteCascade OnUpdateCascade accId ZcashAccountId OnDeleteCascade OnUpdateCascade - value Word64 + value Int64 recipient BS.ByteString memo T.Text spent Bool @@ -161,18 +187,18 @@ share tx WalletTransactionId OnDeleteCascade OnUpdateCascade note WalletSapNoteId OnDeleteCascade OnUpdateCascade accId ZcashAccountId OnDeleteCascade OnUpdateCascade - value Word64 + value Int64 UniqueSapSepnd tx accId deriving Show Eq WalletOrchNote tx WalletTransactionId OnDeleteCascade OnUpdateCascade accId ZcashAccountId OnDeleteCascade OnUpdateCascade - value Word64 + value Int64 recipient BS.ByteString memo T.Text spent Bool nullifier HexStringDB - position Word64 + position Int64 witness HexStringDB change Bool witPos OrchActionId OnDeleteIgnore OnUpdateIgnore @@ -184,25 +210,31 @@ share tx WalletTransactionId OnDeleteCascade OnUpdateCascade note WalletOrchNoteId OnDeleteCascade OnUpdateCascade accId ZcashAccountId OnDeleteCascade OnUpdateCascade - value Word64 + value Int64 UniqueOrchSpend tx accId deriving Show Eq - ZcashTransaction - block Int - txId HexStringDB + ZcashBlock + height Int + hash HexStringDB conf Int time Int - UniqueTx block txId + network ZcashNetDB + UniqueBlock height network + deriving Show Eq + ZcashTransaction + blockId ZcashBlockId OnDeleteCascade OnUpdateCascade + txId HexStringDB + UniqueTx blockId txId deriving Show Eq TransparentNote - tx ZcashTransactionId - value Word64 + tx ZcashTransactionId OnDeleteCascade OnUpdateCascade + value Int64 script BS.ByteString position Int UniqueTNPos tx position deriving Show Eq TransparentSpend - tx ZcashTransactionId + tx ZcashTransactionId OnDeleteCascade OnUpdateCascade outPointHash HexStringDB outPointIndex Word64 script BS.ByteString @@ -211,7 +243,7 @@ share UniqueTSPos tx position deriving Show Eq OrchAction - tx ZcashTransactionId + tx ZcashTransactionId OnDeleteCascade OnUpdateCascade nf HexStringDB rk HexStringDB cmx HexStringDB @@ -224,7 +256,7 @@ share UniqueOAPos tx position deriving Show Eq ShieldOutput - tx ZcashTransactionId + tx ZcashTransactionId OnDeleteCascade OnUpdateCascade cv HexStringDB cmu HexStringDB ephKey HexStringDB @@ -235,7 +267,7 @@ share UniqueSOPos tx position deriving Show Eq ShieldSpend - tx ZcashTransactionId + tx ZcashTransactionId OnDeleteCascade OnUpdateCascade cv HexStringDB anchor HexStringDB nullifier HexStringDB @@ -260,15 +292,188 @@ share abaddress T.Text UniqueABA abaddress deriving Show Eq + Operation json + uuid ZenithUuid + start UTCTime + end UTCTime Maybe + status ZenithStatus + 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 +-- | @ZcashWallet@ +toZcashWalletAPI :: Entity ZcashWallet -> ZcashWalletAPI +toZcashWalletAPI w = + ZcashWalletAPI + (fromIntegral $ fromSqlKey $ entityKey w) + (zcashWalletName $ entityVal w) + (getNet $ zcashWalletNetwork $ entityVal w) + (zcashWalletBirthdayHeight $ entityVal w) + (zcashWalletLastSync $ entityVal w) + +-- | @ZcashAccount@ +toZcashAccountAPI :: Entity ZcashAccount -> ZcashAccountAPI +toZcashAccountAPI a = + ZcashAccountAPI + (fromIntegral $ fromSqlKey $ entityKey a) + (fromIntegral $ fromSqlKey $ zcashAccountWalletId $ entityVal a) + (zcashAccountName $ entityVal a) + +-- | @WalletAddress@ +toZcashAddressAPI :: Entity WalletAddress -> ZcashAddressAPI +toZcashAddressAPI a = + ZcashAddressAPI + (fromIntegral $ fromSqlKey $ entityKey a) + (fromIntegral $ fromSqlKey $ walletAddressAccId $ entityVal a) + (walletAddressName $ entityVal a) + (getUA $ walletAddressUAddress $ entityVal a) + (getSaplingFromUA $ + TE.encodeUtf8 $ getUA $ walletAddressUAddress $ entityVal a) + (case t_rec =<< + (isValidUnifiedAddress . TE.encodeUtf8 . getUA . walletAddressUAddress) + (entityVal a) of + Nothing -> Nothing + Just tRec -> + Just $ + encodeTransparentReceiver + (maybe + TestNet + ua_net + ((isValidUnifiedAddress . + TE.encodeUtf8 . getUA . walletAddressUAddress) $ + entityVal a)) + tRec) + +-- | @WalletTrNote@ +trToZcashNoteAPI :: ConnectionPool -> Entity WalletTrNote -> IO ZcashNoteAPI +trToZcashNoteAPI pool n = do + t <- getWalletTransaction pool $ walletTrNoteTx $ entityVal n + case t of + Nothing -> throwIO $ userError "Unable to find transaction" + Just t' -> do + return $ + ZcashNoteAPI + (getHex $ walletTransactionTxId $ entityVal t') -- tx ID + Zenith.Types.TransparentPool -- pool + (fromIntegral (walletTrNoteValue (entityVal n)) / 100000000.0) -- zec + (walletTrNoteValue $ entityVal n) -- zats + "" -- memo + (walletTransactionConf (entityVal t') >= 10) -- confirmed + (walletTransactionBlock $ entityVal t') -- blockheight + (walletTransactionTime $ entityVal t') -- blocktime + (walletTrNotePosition $ entityVal n) -- outindex + (walletTrNoteChange $ entityVal n) -- change + +-- | @WalletSapNote@ +sapToZcashNoteAPI :: ConnectionPool -> Entity WalletSapNote -> IO ZcashNoteAPI +sapToZcashNoteAPI pool n = do + t <- getWalletTransaction pool $ walletSapNoteTx $ entityVal n + oi <- getSaplingOutIndex pool $ walletSapNoteWitPos $ entityVal n + case t of + Nothing -> throwIO $ userError "Unable to find transaction" + Just t' -> do + return $ + ZcashNoteAPI + (getHex $ walletTransactionTxId $ entityVal t') -- tx ID + Zenith.Types.SaplingPool -- pool + (fromIntegral (walletSapNoteValue (entityVal n)) / 100000000.0) -- zec + (walletSapNoteValue $ entityVal n) -- zats + (walletSapNoteMemo $ entityVal n) -- memo + (walletTransactionConf (entityVal t') >= 10) -- confirmed + (walletTransactionBlock $ entityVal t') -- blockheight + (walletTransactionTime $ entityVal t') -- blocktime + oi -- outindex + (walletSapNoteChange $ entityVal n) -- change + +-- | @WalletOrchNote@ +orchToZcashNoteAPI :: ConnectionPool -> Entity WalletOrchNote -> IO ZcashNoteAPI +orchToZcashNoteAPI pool n = do + t <- getWalletTransaction pool $ walletOrchNoteTx $ entityVal n + oi <- getOrchardOutIndex pool $ walletOrchNoteWitPos $ entityVal n + case t of + Nothing -> throwIO $ userError "Unable to find transaction" + Just t' -> do + return $ + ZcashNoteAPI + (getHex $ walletTransactionTxId $ entityVal t') -- tx ID + OrchardPool + (fromIntegral (walletOrchNoteValue (entityVal n)) / 100000000.0) -- zec + (walletOrchNoteValue $ entityVal n) -- zats + (walletOrchNoteMemo $ entityVal n) -- memo + (walletTransactionConf (entityVal t') >= 10) -- confirmed + (walletTransactionBlock $ entityVal t') -- blockheight + (walletTransactionTime $ entityVal t') -- blocktime + oi -- outindex + (walletOrchNoteChange $ entityVal n) -- change + -- * Database functions -- | Initializes the database initDb :: T.Text -- ^ The database path to check - -> IO () + -> IO (Either String Bool) initDb dbName = do - PS.runSqlite dbName $ do runMigration migrateAll + j <- + try $ PS.runSqlite dbName $ runMigrationQuiet migrateAll :: IO + (Either SomeException [T.Text]) + case j of + Left _e1 -> do + pool <- runNoLoggingT $ initPool dbName + wallets <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do select . from $ table @ZcashWallet + accounts <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do select . from $ table @ZcashAccount + abook <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do select . from $ table @AddressBook + hDir <- getHomeDirectory + let backupDb = hDir "Zenith/.backup.db" + checkDbFile <- doesFileExist backupDb + when checkDbFile $ removeFile backupDb + _ <- PS.runSqlite (T.pack backupDb) $ runMigrationQuiet migrateAll + backupPool <- runNoLoggingT $ initPool $ T.pack backupDb + _ <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool backupPool $ insertMany_ $ entityVal <$> wallets + _ <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool backupPool $ insertMany_ $ entityVal <$> accounts + _ <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool backupPool $ insertMany_ $ entityVal <$> abook + clearWalletTransactions pool + clearWalletData pool + m <- + try $ PS.runSqlite dbName $ runMigrationUnsafeQuiet migrateAll :: IO + (Either SomeException [T.Text]) + case m of + Left e2 -> return $ Left $ "Failed to migrate data tables" ++ show e2 + Right _ -> do + return $ Right True + Right _ -> do + return $ Right False initPool :: T.Text -> NoLoggingT IO ConnectionPool initPool dbPath = do @@ -293,6 +498,36 @@ getWallets pool n = where_ (wallets ^. ZcashWalletNetwork ==. val (ZcashNetDB n)) pure wallets +walletExists :: ConnectionPool -> Int -> IO (Maybe (Entity ZcashWallet)) +walletExists pool n = + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + wallets <- from $ table @ZcashWallet + where_ (wallets ^. ZcashWalletId ==. val (toSqlKey $ fromIntegral n)) + pure wallets + +getNetwork :: ConnectionPool -> WalletAddressId -> IO ZcashNet +getNetwork pool a = do + n <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + (wallet :& acc :& addr) <- + from $ table @ZcashWallet `innerJoin` table @ZcashAccount `on` + (\(wallet :& acc) -> + wallet ^. ZcashWalletId ==. acc ^. ZcashAccountWalletId) `innerJoin` + table @WalletAddress `on` + (\(_ :& acc :& addr) -> + acc ^. ZcashAccountId ==. addr ^. WalletAddressAccId) + where_ (addr ^. WalletAddressId ==. val a) + pure $ wallet ^. ZcashWalletNetwork + case n of + Nothing -> throwIO $ userError "Failed to find wallet" + Just (Value n') -> return $ getNet n' + -- | Save a new wallet to the database saveWallet :: ConnectionPool -- ^ The database path to use @@ -367,19 +602,21 @@ saveAccount pool a = -- | Returns the largest block in storage getMaxBlock :: Pool SqlBackend -- ^ The database pool - -> NoLoggingT IO Int -getMaxBlock pool = do + -> ZcashNetDB + -> IO Int +getMaxBlock pool net = do b <- + runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do selectOne $ do - txs <- from $ table @ZcashTransaction - where_ (txs ^. ZcashTransactionBlock >. val 0) - orderBy [desc $ txs ^. ZcashTransactionBlock] - pure txs + bls <- from $ table @ZcashBlock + where_ (bls ^. ZcashBlockNetwork ==. val net) + orderBy [desc $ bls ^. ZcashBlockHeight] + pure bls case b of Nothing -> return $ -1 - Just x -> return $ zcashTransactionBlock $ entityVal x + Just x -> return $ zcashBlockHeight $ entityVal x -- | Returns a list of addresses associated with the given account getAddresses :: @@ -470,19 +707,53 @@ 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 -> 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 &&. 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 - -> Int -- ^ block time + -> ZcashBlockId -- ^ The block the transaction is in -> Transaction -- ^ The transaction to save -> NoLoggingT IO (Key ZcashTransaction) -saveTransaction pool t wt = +saveTransaction pool bi wt = PS.retryOnBusy $ flip PS.runSqlPool pool $ do let ix = [0 ..] - w <- - insert $ - ZcashTransaction (tx_height wt) (HexStringDB $ tx_id wt) (tx_conf wt) t + w <- insert $ ZcashTransaction bi (HexStringDB $ tx_id wt) when (isJust $ tx_transpBundle wt) $ do _ <- insertMany_ $ @@ -561,15 +832,20 @@ saveTransaction pool t wt = getZcashTransactions :: ConnectionPool -- ^ The database path -> Int -- ^ Block + -> ZcashNet -- ^ Network -> IO [Entity ZcashTransaction] -getZcashTransactions pool b = +getZcashTransactions pool b net = runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do select $ do - txs <- from $ table @ZcashTransaction - where_ $ txs ^. ZcashTransactionBlock >. val b - orderBy [asc $ txs ^. ZcashTransactionBlock] + (blks :& txs) <- + from $ table @ZcashBlock `innerJoin` table @ZcashTransaction `on` + (\(blks :& txs) -> + blks ^. ZcashBlockId ==. txs ^. ZcashTransactionBlockId) + where_ (blks ^. ZcashBlockHeight >. val b) + where_ (blks ^. ZcashBlockNetwork ==. val (ZcashNetDB net)) + orderBy [asc $ blks ^. ZcashBlockHeight] return txs -- ** QR codes @@ -607,6 +883,32 @@ getQrCode pool zp wId = do return qrs return $ entityVal <$> r +upgradeQrTable :: ConnectionPool -> IO () +upgradeQrTable pool = do + r <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ + selectOne $ do + qrs <- from $ table @QrCode + where_ $ qrs ^. QrCodeVersion ==. val OrchardPool + return countRows + unless (maybe 0 (\(Value x) -> x) r > (0 :: Int)) $ do + _ <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + rawExecute + "update qr_code set version = ? where version = ?" + [PersistText "OrchardPool", PersistText "Orchard"] + rawExecute + "update qr_code set version = ? where version = ?" + [PersistText "SaplingPool", PersistText "Sapling"] + rawExecute + "update qr_code set version = ? where version = ?" + [PersistText "TransparentPool", PersistText "Transparent"] + return () + -- * Wallet -- | Get the block of the last transaction known to the wallet getMaxWalletBlock :: @@ -626,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 @@ -666,29 +970,37 @@ saveWalletTransaction pool za zt = do runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do - t <- - upsert - (WalletTransaction - (zcashTransactionTxId zT') - za - (zcashTransactionBlock zT') - (zcashTransactionConf zT') - (zcashTransactionTime zT')) - [] - return $ entityKey t + b <- + selectOne $ do + blks <- from $ table @ZcashBlock + where_ (blks ^. ZcashBlockId ==. val (zcashTransactionBlockId zT')) + pure blks + case b of + Nothing -> + throw $ userError "invalid block for saving wallet transaction" + Just blk -> do + t <- + upsert + (WalletTransaction + (zcashTransactionTxId zT') + za + (zcashBlockHeight $ entityVal blk) + (zcashBlockConf $ entityVal blk) + (zcashBlockTime $ entityVal blk)) + [] + return $ entityKey t -- | Save a @WalletSapNote@ 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 @@ -703,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)) @@ -714,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 @@ -736,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) @@ -748,9 +1059,10 @@ saveWalletOrchNote pool wId pos wit ch za zt dn = do findTransparentNotes :: ConnectionPool -- ^ The database path -> Int -- ^ Starting block + -> ZcashNetDB -- ^ Network to use -> Entity WalletAddress -> IO () -findTransparentNotes pool b t = do +findTransparentNotes pool b net t = do let tReceiver = t_rec =<< readUnifiedAddressDB (entityVal t) case tReceiver of Just tR -> do @@ -765,13 +1077,17 @@ findTransparentNotes pool b t = do PS.retryOnBusy $ flip PS.runSqlPool pool $ do select $ do - (txs :& tNotes) <- - from $ table @ZcashTransaction `innerJoin` table @TransparentNote `on` - (\(txs :& tNotes) -> + (blks :& txs :& tNotes) <- + from $ table @ZcashBlock `innerJoin` table @ZcashTransaction `on` + (\(blks :& txs) -> + blks ^. ZcashBlockId ==. txs ^. ZcashTransactionBlockId) `innerJoin` + table @TransparentNote `on` + (\(_ :& txs :& tNotes) -> txs ^. ZcashTransactionId ==. tNotes ^. TransparentNoteTx) - where_ (txs ^. ZcashTransactionBlock >. val b) + where_ (blks ^. ZcashBlockHeight >. val b) + where_ (blks ^. ZcashBlockNetwork ==. val net) where_ (tNotes ^. TransparentNoteScript ==. val s) - pure (txs, tNotes) + pure (blks, txs, tNotes) mapM_ (saveWalletTrNote pool @@ -787,10 +1103,11 @@ saveWalletTrNote :: -> Scope -> ZcashAccountId -> WalletAddressId - -> (Entity ZcashTransaction, Entity TransparentNote) + -> (Entity ZcashBlock, Entity ZcashTransaction, Entity TransparentNote) -> IO () -saveWalletTrNote pool ch za wa (zt, tn) = do +saveWalletTrNote pool ch za wa (blk, zt, tn) = do let zT' = entityVal zt + let b = entityVal blk runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do @@ -799,9 +1116,9 @@ saveWalletTrNote pool ch za wa (zt, tn) = do (WalletTransaction (zcashTransactionTxId zT') za - (zcashTransactionBlock zT') - (zcashTransactionConf zT') - (zcashTransactionTime zT')) + (zcashBlockHeight b) + (zcashBlockConf b) + (zcashBlockTime b)) [] insert_ $ WalletTrNote @@ -823,17 +1140,22 @@ saveSapNote pool wsn = getShieldedOutputs :: ConnectionPool -- ^ database path -> Int -- ^ block + -> ZcashNetDB -- ^ network to use -> IO [(Entity ZcashTransaction, Entity ShieldOutput)] -getShieldedOutputs pool b = +getShieldedOutputs pool b net = runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do select $ do - (txs :& sOutputs) <- - from $ table @ZcashTransaction `innerJoin` table @ShieldOutput `on` - (\(txs :& sOutputs) -> + (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_ (txs ^. ZcashTransactionBlock >=. val b) + where_ (blks ^. ZcashBlockHeight >=. val b) + where_ (blks ^. ZcashBlockNetwork ==. val net) orderBy [ asc $ txs ^. ZcashTransactionId , asc $ sOutputs ^. ShieldOutputPosition @@ -844,21 +1166,269 @@ getShieldedOutputs pool b = getOrchardActions :: ConnectionPool -- ^ database path -> Int -- ^ block + -> ZcashNetDB -- ^ network to use -> IO [(Entity ZcashTransaction, Entity OrchAction)] -getOrchardActions pool b = +getOrchardActions pool b net = runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do select $ do - (txs :& oActions) <- - from $ table @ZcashTransaction `innerJoin` table @OrchAction `on` - (\(txs :& oActions) -> + (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_ (txs ^. ZcashTransactionBlock >=. val b) + where_ (blks ^. ZcashBlockHeight >=. val b) + where_ (blks ^. ZcashBlockNetwork ==. val net) orderBy [asc $ txs ^. ZcashTransactionId, asc $ oActions ^. OrchActionPosition] pure (txs, oActions) +findNotesByAddress :: + ConnectionPool -> ValidAddress -> Entity WalletAddress -> IO [ZcashNoteAPI] +findNotesByAddress pool va addr = do + let ua = + isValidUnifiedAddress + ((TE.encodeUtf8 . getUA . walletAddressUAddress . entityVal) addr) + case ua of + Just ua' -> do + if compareAddress va ua' + then do + case va of + Unified _ -> getWalletNotes pool addr + ZcashHaskell.Types.Sapling s -> do + n <- getSapNotes pool $ sa_receiver s + mapM (sapToZcashNoteAPI pool) n + ZcashHaskell.Types.Transparent t -> do + n <- getTrNotes pool $ ta_receiver t + mapM (trToZcashNoteAPI pool) n + Exchange e -> do + n <- getTrNotes pool $ ex_address e + mapM (trToZcashNoteAPI pool) n + else return [] + Nothing -> return [] + +getTrNotes :: ConnectionPool -> TransparentReceiver -> IO [Entity WalletTrNote] +getTrNotes pool 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 + tnotes <- from $ table @WalletTrNote + 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 $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + snotes <- from $ table @WalletSapNote + 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 $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + onotes <- from $ table @WalletOrchNote + 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 + -> IO [ZcashNoteAPI] +getWalletNotes pool w = do + let w' = entityVal w + let tReceiver = t_rec =<< readUnifiedAddressDB w' + let sReceiver = s_rec =<< readUnifiedAddressDB w' + let oReceiver = o_rec =<< readUnifiedAddressDB w' + trNotes <- + case tReceiver of + Nothing -> return [] + Just tR -> getTrNotes pool tR + sapNotes <- + case sReceiver of + Nothing -> return [] + Just sR -> getSapNotes pool sR + orchNotes <- + case oReceiver of + Nothing -> return [] + Just oR -> getOrchNotes pool oR + trNotes' <- mapM (trToZcashNoteAPI pool) trNotes + sapNotes' <- mapM (sapToZcashNoteAPI pool) sapNotes + orchNotes' <- mapM (orchToZcashNoteAPI pool) orchNotes + return $ trNotes' <> sapNotes' <> orchNotes' + -- | Get the transactions belonging to the given address getWalletTransactions :: ConnectionPool -- ^ database path @@ -876,96 +1446,67 @@ getWalletTransactions pool w = do trNotes <- case tReceiver of Nothing -> return [] - Just tR -> do - let s = - BS.concat - [ BS.pack [0x76, 0xA9, 0x14] - , (toBytes . tr_bytes) tR - , BS.pack [0x88, 0xAC] - ] - PS.retryOnBusy $ - flip PS.runSqlPool pool $ do - select $ do - tnotes <- from $ table @WalletTrNote - where_ (tnotes ^. WalletTrNoteScript ==. val s) - pure tnotes - trChgNotes <- - case ctReceiver of + Just tR -> liftIO $ getTrNotes pool tR + sapNotes <- + case sReceiver of Nothing -> return [] - Just tR -> do - let s1 = - BS.concat - [ BS.pack [0x76, 0xA9, 0x14] - , (toBytes . tr_bytes) tR - , BS.pack [0x88, 0xAC] - ] - PS.retryOnBusy $ - flip PS.runSqlPool pool $ do - select $ do - tnotes <- from $ table @WalletTrNote - where_ (tnotes ^. WalletTrNoteScript ==. val s1) - pure tnotes + 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 -> do - PS.retryOnBusy $ - flip PS.runSqlPool pool $ do - select $ do - snotes <- from $ table @WalletSapNote - where_ (snotes ^. WalletSapNoteRecipient ==. val (getBytes sR)) - pure snotes - sapChgNotes <- - case csReceiver of - Nothing -> return [] - Just sR -> do - PS.retryOnBusy $ - flip PS.runSqlPool pool $ do - select $ do - snotes <- from $ table @WalletSapNote - where_ (snotes ^. WalletSapNoteRecipient ==. val (getBytes sR)) - pure snotes - sapSpends <- mapM (getSapSpends . entityKey) (sapNotes <> sapChgNotes) - orchNotes <- - case oReceiver of - Nothing -> return [] - Just oR -> do - PS.retryOnBusy $ - flip PS.runSqlPool pool $ do - select $ do - onotes <- from $ table @WalletOrchNote - where_ (onotes ^. WalletOrchNoteRecipient ==. val (getBytes oR)) - pure onotes - orchChgNotes <- - case coReceiver of - Nothing -> return [] - Just oR -> do - PS.retryOnBusy $ - flip PS.runSqlPool pool $ do - select $ do - onotes <- from $ table @WalletOrchNote - where_ (onotes ^. WalletOrchNoteRecipient ==. val (getBytes oR)) - pure onotes - 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 @@ -975,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 @@ -1087,6 +1638,19 @@ getWalletTransactions pool w = do where_ (t ^. UserTxId ==. val (entityKey uTx)) return () +getWalletTransaction :: + ConnectionPool + -> WalletTransactionId + -> IO (Maybe (Entity WalletTransaction)) +getWalletTransaction pool i = + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + trs <- from $ table @WalletTransaction + where_ (trs ^. WalletTransactionId ==. val i) + pure trs + getUserTx :: ConnectionPool -> WalletAddressId -> IO [Entity UserTx] getUserTx pool aId = do runNoLoggingT $ @@ -1146,7 +1710,7 @@ findTransparentSpends pool za = do (trSpends ^. TransparentSpendOutPointHash ==. val flipTxId) where_ (trSpends ^. TransparentSpendOutPointIndex ==. - val (walletTrNotePosition $ entityVal n)) + val (fromIntegral $ walletTrNotePosition $ entityVal n)) pure (tx, trSpends) if null s then return () @@ -1241,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 @@ -1254,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 @@ -1290,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 @@ -1303,15 +1887,30 @@ getOrchardCmxs pool zt = do getMaxOrchardNote :: Pool SqlBackend -> IO OrchActionId getMaxOrchardNote pool = do flip PS.runSqlPool pool $ do - x <- + maxBlock <- selectOne $ do - n <- from $ table @OrchAction - where_ (n ^. OrchActionId >. val (toSqlKey 0)) - orderBy [desc $ n ^. OrchActionId] - pure (n ^. OrchActionId) - 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 @OrchAction `on` + (\(_ :& txs :& n) -> + txs ^. ZcashTransactionId ==. n ^. OrchActionTx) + where_ (blks ^. ZcashBlockHeight <=. val (mb - 5)) + orderBy [desc $ n ^. OrchActionId] + pure (n ^. OrchActionId) + case x of + Nothing -> return $ toSqlKey 0 + Just (Value y) -> return y updateOrchNoteRecord :: Pool SqlBackend @@ -1373,15 +1972,51 @@ upsertWalTx :: => ZcashTransaction -> ZcashAccountId -> SqlPersistT m (Entity WalletTransaction) -upsertWalTx zt za = - upsert - (WalletTransaction - (zcashTransactionTxId zt) - za - (zcashTransactionBlock zt) - (zcashTransactionConf zt) - (zcashTransactionTime zt)) - [] +upsertWalTx zt za = do + blk <- + selectOne $ do + blks <- from $ table @ZcashBlock + where_ (blks ^. ZcashBlockId ==. val (zcashTransactionBlockId zt)) + pure blks + case blk of + Nothing -> throw $ userError "Invalid block for transaction" + Just b -> + upsert + (WalletTransaction + (zcashTransactionTxId zt) + za + (zcashBlockHeight $ entityVal b) + (zcashBlockConf $ entityVal b) + (zcashBlockTime $ entityVal b)) + [] + +getSaplingOutIndex :: ConnectionPool -> ShieldOutputId -> IO Int +getSaplingOutIndex pool i = do + o <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + sout <- from $ table @ShieldOutput + where_ (sout ^. ShieldOutputId ==. val i) + pure $ sout ^. ShieldOutputPosition + case o of + Nothing -> throwIO $ userError "couldn't find shielded output" + Just (Value o') -> return o' + +getOrchardOutIndex :: ConnectionPool -> OrchActionId -> IO Int +getOrchardOutIndex pool i = do + o <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + sout <- from $ table @OrchAction + where_ (sout ^. OrchActionId ==. val i) + pure $ sout ^. OrchActionPosition + case o of + Nothing -> throwIO $ userError "couldn't find orchard action" + Just (Value o') -> return o' getBalance :: ConnectionPool -> ZcashAccountId -> IO Integer getBalance pool za = do @@ -1425,6 +2060,77 @@ getUnconfirmedBalance pool za = do let oBal = sum oAmts return . fromIntegral $ tBal + sBal + oBal +getPoolBalance :: ConnectionPool -> ZcashAccountId -> IO AccountBalance +getPoolBalance pool za = do + trNotes <- getWalletUnspentTrNotes pool za + let tAmts = map (walletTrNoteValue . entityVal) trNotes + let tBal = sum tAmts + sapNotes <- getWalletUnspentSapNotes pool za + let sAmts = map (walletSapNoteValue . entityVal) sapNotes + let sBal = sum sAmts + orchNotes <- getWalletUnspentOrchNotes pool za + let oAmts = map (walletOrchNoteValue . entityVal) orchNotes + let oBal = sum oAmts + return $ AccountBalance tBal sBal oBal + +getUnconfPoolBalance :: ConnectionPool -> ZcashAccountId -> IO AccountBalance +getUnconfPoolBalance pool za = do + trNotes <- getWalletUnspentUnconfirmedTrNotes pool za + let tAmts = map (walletTrNoteValue . entityVal) trNotes + let tBal = sum tAmts + sapNotes <- getWalletUnspentUnconfirmedSapNotes pool za + let sAmts = map (walletSapNoteValue . entityVal) sapNotes + let sBal = sum sAmts + orchNotes <- getWalletUnspentUnconfirmedOrchNotes pool za + let oAmts = map (walletOrchNoteValue . entityVal) orchNotes + 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 $ @@ -1454,6 +2160,38 @@ clearWalletTransactions pool = do delete $ do _ <- from $ table @WalletTransaction return () + update $ \w -> do + set w [ZcashWalletLastSync =. val 0] + +clearWalletData :: ConnectionPool -> IO () +clearWalletData pool = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + delete $ do + _ <- from $ table @TreeStore + return () + delete $ do + _ <- from $ table @TransparentNote + return () + delete $ do + _ <- from $ table @TransparentSpend + return () + delete $ do + _ <- from $ table @OrchAction + return () + delete $ do + _ <- from $ table @ShieldOutput + return () + delete $ do + _ <- from $ table @ShieldSpend + return () + delete $ do + _ <- from $ table @ZcashTransaction + return () + delete $ do + _ <- from $ table @ZcashBlock + return () getWalletUnspentTrNotes :: ConnectionPool -> ZcashAccountId -> IO [Entity WalletTrNote] @@ -1610,7 +2348,7 @@ selectUnspentNotes pool za amt = do else return (tList, [], []) where checkTransparent :: - Word64 -> [Entity WalletTrNote] -> (Word64, [Entity WalletTrNote]) + Int64 -> [Entity WalletTrNote] -> (Int64, [Entity WalletTrNote]) checkTransparent x [] = (x, []) checkTransparent x (n:ns) = if walletTrNoteValue (entityVal n) < x @@ -1619,7 +2357,7 @@ selectUnspentNotes pool za amt = do snd (checkTransparent (x - walletTrNoteValue (entityVal n)) ns)) else (0, [n]) checkSapling :: - Word64 -> [Entity WalletSapNote] -> (Word64, [Entity WalletSapNote]) + Int64 -> [Entity WalletSapNote] -> (Int64, [Entity WalletSapNote]) checkSapling x [] = (x, []) checkSapling x (n:ns) = if walletSapNoteValue (entityVal n) < x @@ -1627,7 +2365,133 @@ selectUnspentNotes pool za amt = do , n : snd (checkSapling (x - walletSapNoteValue (entityVal n)) ns)) else (0, [n]) checkOrchard :: - Word64 -> [Entity WalletOrchNote] -> (Word64, [Entity WalletOrchNote]) + Int64 -> [Entity WalletOrchNote] -> (Int64, [Entity WalletOrchNote]) + checkOrchard x [] = (x, []) + checkOrchard x (n:ns) = + if walletOrchNoteValue (entityVal n) < x + then ( fst (checkOrchard (x - walletOrchNoteValue (entityVal n)) ns) + , n : snd (checkOrchard (x - walletOrchNoteValue (entityVal n)) ns)) + else (0, [n]) + +selectUnspentNotesV2 :: + ConnectionPool + -> ZcashAccountId + -> Int64 + -> [Int] + -> PrivacyPolicy + -> IO + (Either + TxError + ( [Entity WalletTrNote] + , [Entity WalletSapNote] + , [Entity WalletOrchNote])) +selectUnspentNotesV2 pool za amt recv policy = do + case policy of + Full -> + 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 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 + then do + sapNotes <- getWalletUnspentSapNotes pool za + let (a2, sList) = checkSapling a1 sapNotes + if a2 > 0 + then return $ + Left $ + PrivacyPolicyError "Not enough notes for Medium privacy" + else return $ Right ([], sList, oList) + else return $ Right ([], [], oList) + Low -> + if 0 `elem` recv + then return $ Left ZHError + else 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 + 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) + None -> do + 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]) + checkTransparent x [] = (x, []) + checkTransparent x (n:ns) = + if walletTrNoteValue (entityVal n) < x + then ( fst (checkTransparent (x - walletTrNoteValue (entityVal n)) ns) + , n : + snd (checkTransparent (x - walletTrNoteValue (entityVal n)) ns)) + else (0, [n]) + checkSapling :: + Int64 -> [Entity WalletSapNote] -> (Int64, [Entity WalletSapNote]) + checkSapling x [] = (x, []) + checkSapling x (n:ns) = + if walletSapNoteValue (entityVal n) < x + then ( fst (checkSapling (x - walletSapNoteValue (entityVal n)) ns) + , n : snd (checkSapling (x - walletSapNoteValue (entityVal n)) ns)) + else (0, [n]) + checkOrchard :: + Int64 -> [Entity WalletOrchNote] -> (Int64, [Entity WalletOrchNote]) checkOrchard x [] = (x, []) checkOrchard x (n:ns) = if walletOrchNoteValue (entityVal n) < x @@ -1666,6 +2530,22 @@ saveConfs pool b c = do update $ \t -> do set t [WalletTransactionConf =. val c] where_ $ t ^. WalletTransactionBlock ==. val b + update $ \bl -> 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 @@ -1724,3 +2604,399 @@ deleteAdrsFromAB pool ia = do rmdups :: Ord a => [a] -> [a] rmdups = map head . group . sort + +-- * Zenith Operations +-- | Get an operation by UUID +getOperation :: ConnectionPool -> U.UUID -> IO (Maybe (Entity Operation)) +getOperation pool uid = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + ops <- from $ table @Operation + where_ (ops ^. OperationUuid ==. val (ZenithUuid uid)) + pure ops + +-- | Save an operation +saveOperation :: ConnectionPool -> Operation -> IO (Maybe (Key Operation)) +saveOperation pool op = do + runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ insertUnique op + +-- | Finalize an operation with either a successful result or an error +finalizeOperation :: + ConnectionPool -> Key Operation -> ZenithStatus -> T.Text -> IO () +finalizeOperation pool op status result = do + tstamp <- getCurrentTime + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ + update $ \ops -> do + set + ops + [ OperationEnd =. val (Just tstamp) + , OperationStatus =. val status + , OperationResult =. val (Just result) + ] + where_ (ops ^. OperationId ==. val op) + +-- * 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 + 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 c0b4623..304d960 100644 --- a/src/Zenith/GUI.hs +++ b/src/Zenith/GUI.hs @@ -1,5 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} module Zenith.GUI where @@ -9,17 +11,24 @@ import Codec.QRCode import Codec.QRCode.JuicyPixels import Control.Concurrent (threadDelay) import Control.Exception (throwIO, try) +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 qualified Data.ByteString.Lazy as LBS import Data.HexString (toText) -import Data.Maybe (fromJust, fromMaybe, isJust, isNothing) +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) -import Database.Esqueleto.Experimental (ConnectionPool) +import Database.Esqueleto.Experimental (ConnectionPool, fromSqlKey) import Database.Persist import Lens.Micro ((&), (+~), (.~), (?~), (^.), set) import Lens.Micro.TH @@ -27,19 +36,25 @@ import Monomer import qualified Monomer.Lens as L import System.Directory (getHomeDirectory) import System.FilePath (()) -import System.Hclip import Text.Printf import Text.Wrap (FillScope(..), FillStrategy(..), WrapSettings(..), wrapText) import TextShow hiding (toText) 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 ( BlockResponse(..) - , Phrase(..) , Scope(..) , ToBytes(..) , UnifiedAddress(..) + , ValidAddress(..) , ZcashNet(..) , ZebraGetBlockChainInfo(..) , ZebraGetInfo(..) @@ -48,13 +63,16 @@ import ZcashHaskell.Utils (getBlockTime, makeZebraCall) import Zenith.Core import Zenith.DB import Zenith.GUI.Theme -import Zenith.Scanner (processTx, updateConfs) +import Zenith.Scanner (checkIntegrity, processTx, rescanZebra, updateConfs) import Zenith.Types hiding (ZcashAddress(..)) import Zenith.Utils ( displayAmount - , isRecipientValid + , getChainTip + , isRecipientValidGUI + , isValidString + , isZecAddressValid , jsonNumber - , parseAddress + , padWithZero , showAddress , validBarValue ) @@ -77,7 +95,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] @@ -102,6 +120,33 @@ data AppEvent | CheckRecipient !T.Text | CheckAmount !Float | ShowTxId !T.Text + | LoadAbList ![Entity AddressBook] + | ShowAdrBook + | CloseAdrBook + | NewAdrBkEntry + | CloseNewAdrBook + | NotImplemented + | CloseMsgAB + | CheckValidAddress !T.Text + | CheckValidDescrip !T.Text + | SaveNewABEntry + | UpdateABEntry !T.Text !T.Text + | CloseUpdABEntry + | ShowMessage !T.Text + | ShowABAddress !T.Text !T.Text + | CloseShowABAddress + | CopyABAdress !T.Text + | DeleteABEntry !T.Text + | UpdateABDescrip !T.Text !T.Text + | ResetRecipientValid + | ShowShield + | CloseShield + | ShowDeShield + | CloseDeShield + | SendDeShield + | SendShield + | StartSync + | TreeSync deriving (Eq, Show) data AppModel = AppModel @@ -144,6 +189,23 @@ data AppModel = AppModel , _amountValid :: !Bool , _showId :: !(Maybe T.Text) , _home :: !FilePath + , _showAdrBook :: !Bool + , _newAdrBkEntry :: !Bool + , _abdescrip :: !T.Text + , _abaddress :: !T.Text + , _abAddressValid :: !Bool + , _abDescripValid :: !Bool + , _abaddressList :: ![Entity AddressBook] + , _msgAB :: !(Maybe T.Text) + , _showABAddress :: !Bool + , _updateABAddress :: !Bool + , _privacyChoice :: !PrivacyPolicy + , _shieldZec :: !Bool + , _deShieldZec :: !Bool + , _tBalance :: !Integer + , _tBalanceValid :: !Bool + , _sBalance :: !Integer + , _sBalanceValid :: !Bool } deriving (Eq, Show) makeLenses ''AppModel @@ -185,6 +247,17 @@ buildUI wenv model = widgetTree , txIdOverlay `nodeVisible` isJust (model ^. showId) , msgOverlay `nodeVisible` isJust (model ^. msg) , modalOverlay `nodeVisible` isJust (model ^. modalMsg) + , adrbookOverlay `nodeVisible` model ^. showAdrBook + , newAdrBkOverlay `nodeVisible` model ^. newAdrBkEntry + , showABAddressOverlay (model ^. abdescrip) (model ^. abaddress) `nodeVisible` + model ^. + showABAddress + , updateABAddressOverlay (model ^. abdescrip) (model ^. abaddress) `nodeVisible` + model ^. + updateABAddress + , shieldOverlay `nodeVisible` model ^. shieldZec + , deShieldOverlay `nodeVisible` model ^. deShieldZec + , msgAdrBookOverlay `nodeVisible` isJust (model ^. msgAB) ] mainWindow = vstack @@ -247,6 +320,12 @@ buildUI wenv model = widgetTree [bgColor white, borderB 1 gray, padding 3] , box_ [alignLeft, onClick ShowSeed] (label "Backup Wallet") `styleBasic` [bgColor white, borderB 1 gray, padding 3] + , box_ [alignLeft, onClick ShowAdrBook] (label "Address Book") `styleBasic` + [bgColor white, borderB 1 gray, padding 3] + , box_ [alignLeft, onClick ShowShield] (label "Shield ZEC") `styleBasic` + [bgColor white, borderB 1 gray, padding 3] + , box_ [alignLeft, onClick ShowDeShield] (label "De-Shield ZEC") `styleBasic` + [bgColor white, borderB 1 gray, padding 3] ]) `styleBasic` [bgColor btnColor, padding 3] newBox = @@ -373,43 +452,43 @@ buildUI wenv model = widgetTree [ vstack [ tooltip "Unified" $ box_ - [onClick (SetPool Orchard)] + [onClick (SetPool OrchardPool)] (remixIcon remixShieldCheckFill `styleBasic` [ textSize 14 , padding 4 , styleIf - (model ^. selPool == Orchard) + (model ^. selPool == OrchardPool) (bgColor btnColor) , styleIf - (model ^. selPool == Orchard) + (model ^. selPool == OrchardPool) (textColor white) ]) , filler , tooltip "Legacy Shielded" $ box_ - [onClick (SetPool Sapling)] + [onClick (SetPool SaplingPool)] (remixIcon remixShieldLine `styleBasic` [ textSize 14 , padding 4 , styleIf - (model ^. selPool == Sapling) + (model ^. selPool == SaplingPool) (bgColor btnColor) , styleIf - (model ^. selPool == Sapling) + (model ^. selPool == SaplingPool) (textColor white) ]) , filler , tooltip "Transparent" $ box_ - [onClick (SetPool Transparent)] + [onClick (SetPool TransparentPool)] (remixIcon remixEyeLine `styleBasic` [ textSize 14 , padding 4 , styleIf - (model ^. selPool == Transparent) + (model ^. selPool == TransparentPool) (bgColor btnColor) , styleIf - (model ^. selPool == Transparent) + (model ^. selPool == TransparentPool) (textColor white) ]) ] `styleBasic` @@ -422,10 +501,10 @@ buildUI wenv model = widgetTree (hstack [ label (case model ^. selPool of - Orchard -> "Unified" - Sapling -> "Legacy Shielded" - Transparent -> "Transparent" - Sprout -> "Unknown") `styleBasic` + OrchardPool -> "Unified" + SaplingPool -> "Legacy Shielded" + TransparentPool -> "Transparent" + SproutPool -> "Unknown") `styleBasic` [textColor white] , remixIcon remixFileCopyFill `styleBasic` [textSize 14, padding 4, textColor white] @@ -561,7 +640,28 @@ buildUI wenv model = widgetTree , separatorLine `styleBasic` [fgColor btnColor] , spacer , hstack - [ label "To:" `styleBasic` [width 50] + [ label "Privacy Level:" `styleBasic` + [width 70, textFont "Bold"] + , spacer + , label "Full " `styleBasic` [width 40] + , radio Full privacyChoice + , spacer + , label "Medium " `styleBasic` [width 40] + , radio Medium privacyChoice + ] + , hstack + [ label " " `styleBasic` + [width 70, textFont "Bold"] + , spacer + , label "Low " `styleBasic` [width 40] + , radio Low privacyChoice + , spacer + , label "None " `styleBasic` [width 40] + , radio None privacyChoice + ] + , spacer + , hstack + [ label "To:" `styleBasic` [width 50, textFont "Bold"] , spacer , textField_ sendRecipient [onChange CheckRecipient] `styleBasic` [ width 150 @@ -571,7 +671,8 @@ buildUI wenv model = widgetTree ] ] , hstack - [ label "Amount:" `styleBasic` [width 50] + [ label "Amount:" `styleBasic` + [width 50, textFont "Bold"] , spacer , numericField_ sendAmount @@ -589,12 +690,14 @@ buildUI wenv model = widgetTree ] ] , hstack - [ label "Memo:" `styleBasic` [width 50] + [ label "Memo:" `styleBasic` + [width 50, textFont "Bold"] , spacer , textArea sendMemo `styleBasic` [width 150, height 40] ] , spacer + -- Radio button group for privacy level , box_ [alignMiddle] (hstack @@ -654,7 +757,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" @@ -750,6 +853,261 @@ buildUI wenv model = widgetTree ] ]) `styleBasic` [padding 2, bgColor white, width 280, borderB 1 gray, borderT 1 gray] + -- | + -- | Address Book overlays + -- | + adrbookOverlay = + alert CloseAdrBook $ + vstack + [ box_ + [] + (label "Address Book" `styleBasic` + [textFont "Bold", textSize 12, textColor white]) `styleBasic` + [bgColor btnColor, radius 2, padding 3] + , boxShadow $ + box_ + [alignMiddle] + (vstack + [ vscroll + (vstack (zipWith abookRow [0 ..] (model ^. abaddressList))) `nodeKey` + "txScroll" + ]) `styleBasic` + [radius 2, padding 3, bgColor white] + , spacer + , hstack [button "New" NewAdrBkEntry] + ] + abookRow :: Int -> Entity AddressBook -> WidgetNode AppModel AppEvent + abookRow idx ab = + box_ + [ onClick $ + ShowABAddress + (addressBookAbdescrip $ entityVal ab) + (addressBookAbaddress $ entityVal ab) + , alignLeft + ] + (hstack + [ label (T.pack $ padWithZero 3 $ show (fromSqlKey (entityKey ab))) `styleBasic` + [textFont "Bold"] + , spacer + , label (addressBookAbdescrip $ entityVal ab) + ]) `styleBasic` + [padding 2, borderB 1 gray] + newAdrBkOverlay = + alert CloseNewAdrBook $ + vstack + [ box_ + [] + (label "New Address Book Entry" `styleBasic` + [textFont "Bold", textSize 10, textColor white]) `styleBasic` + [bgColor btnColor, radius 2, padding 3] + , spacer + , hstack + [ label "Description: " `styleBasic` [width 80] + , spacer + , textField_ abdescrip [onChange CheckValidDescrip] `styleBasic` + [ width 320 + , styleIf (not $ model ^. abDescripValid) (textColor red) + ] + ] + , spacer + , hstack + [ label "Address:" `styleBasic` [width 50] + , spacer + , textField_ abaddress [onChange CheckValidAddress] `styleBasic` + [ width 350 + , styleIf (not $ model ^. abAddressValid) (textColor red) + ] + ] + , spacer + , hstack + [ button "Save" SaveNewABEntry `nodeEnabled` + ((model ^. abAddressValid) && (model ^. abDescripValid)) + , spacer + , button "Cancel" CloseNewAdrBook `nodeEnabled` True + ] + ] + updateABAddressOverlay abd aba = + alert CloseUpdABEntry $ + vstack + [ box_ + [] + (label "Edit Address Description" `styleBasic` + [textFont "Bold", textSize 10, textColor white]) `styleBasic` + [bgColor btnColor, radius 2, padding 3] + , spacer + , hstack + [ label "Description:" `styleBasic` [width 80] + , spacer + , textField_ abdescrip [onChange CheckValidDescrip] `styleBasic` + [ width 320 + , styleIf (not $ model ^. abDescripValid) (textColor red) + ] + ] + , spacer + , hstack + [ filler + , button "Save" (UpdateABDescrip abd aba) `nodeEnabled` + (model ^. abDescripValid) + , spacer + , button "Cancel" CloseUpdABEntry `nodeEnabled` True + , filler + ] + ] + showABAddressOverlay abd aba = + alert CloseShowABAddress $ + vstack + [ box_ + [] + (label "Address Book Entry" `styleBasic` + [textFont "Bold", textColor white, textSize 12, padding 3]) `styleBasic` + [bgColor btnColor, radius 2, padding 3] + , spacer + , hstack + [ filler + , label (txtWrapN abd 64) `styleBasic` [textFont "Bold"] + , filler + ] + , spacer + , hstack [filler, label_ (txtWrapN aba 64) [multiline], filler] + , spacer + , hstack + [ filler + , button "Edit Description" $ UpdateABEntry abd aba + , spacer + , button "Copy Address" $ CopyABAdress aba + , spacer + , button "Delete Entry" $ DeleteABEntry aba + , filler + ] + ] + msgAdrBookOverlay = + alert CloseMsgAB $ + hstack + [ filler + , remixIcon remixErrorWarningFill `styleBasic` + [textSize 32, textColor btnColor] `nodeVisible` + (model ^. inError) + , spacer + , label_ (txtWrapN (fromMaybe "" (model ^. msgAB)) 64) [multiline] + , filler + ] + shieldOverlay = + box + (vstack + [ filler + , hstack + [ filler + , box_ + [] + (vstack + [ box_ + [alignMiddle] + (label "Shield Zcash" `styleBasic` + [textFont "Bold", textSize 12]) + , separatorLine `styleBasic` [fgColor btnColor] + , spacer + , label + ("Shield " <> + displayAmount (model ^. network) (model ^. tBalance) <> + "?") `styleBasic` + [width 50, textFont "Regular"] + , spacer + , box_ + [alignMiddle] + (hstack + [ filler + , mainButton "Proceed" SendShield `nodeEnabled` + True + , spacer + , mainButton "Cancel" CloseShield `nodeEnabled` + True + , filler + ]) + ]) `styleBasic` + [radius 4, border 2 btnColor, bgColor white, padding 4] + , filler + ] + , filler + ]) `styleBasic` + [bgColor (white & L.a .~ 0.5)] + deShieldOverlay = + box + (vstack + [ filler + , hstack + [ filler + , box_ + [] + (vstack + [ box_ + [alignMiddle] + (label "De-Shield Zcash" `styleBasic` + [textFont "Bold", textSize 12]) + , separatorLine `styleBasic` [fgColor btnColor] + , spacer + , 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" SendDeShield `nodeEnabled` + True + , spacer + , mainButton "Cancel" CloseDeShield `nodeEnabled` + True + , filler + ]) + ]) `styleBasic` + [radius 4, border 2 btnColor, bgColor white, padding 4] + , filler + ] + , filler + ]) `styleBasic` + [bgColor (white & L.a .~ 0.5)] + +notImplemented = NotImplemented generateQRCodes :: Config -> IO () generateQRCodes config = do @@ -764,9 +1122,9 @@ generateQRCodes config = do if not (null s) then return () else do - generateOneQr pool Orchard wAddr - generateOneQr pool Sapling wAddr - generateOneQr pool Transparent wAddr + generateOneQr pool OrchardPool wAddr + generateOneQr pool SaplingPool wAddr + generateOneQr pool TransparentPool wAddr generateOneQr :: ConnectionPool -> ZcashPool -> Entity WalletAddress -> IO () generateOneQr p zp wAddr = @@ -801,7 +1159,7 @@ generateQRCodes config = do dispAddr :: ZcashPool -> WalletAddress -> Maybe T.Text dispAddr zp w = case zp of - Transparent -> + TransparentPool -> T.append "zcash:" . encodeTransparentReceiver (maybe @@ -813,11 +1171,12 @@ generateQRCodes config = do (t_rec =<< (isValidUnifiedAddress . E.encodeUtf8 . getUA . walletAddressUAddress) w) - Sapling -> + SaplingPool -> T.append "zcash:" <$> (getSaplingFromUA . E.encodeUtf8 . getUA . walletAddressUAddress) w - Orchard -> Just $ (T.append "zcash:" . getUA . walletAddressUAddress) w - Sprout -> Nothing + OrchardPool -> + Just $ (T.append "zcash:" . getUA . walletAddressUAddress) w + SproutPool -> Nothing handleEvent :: WidgetEnv AppModel AppEvent @@ -872,7 +1231,11 @@ handleEvent wenv node model evt = ] ConfirmCancel -> [Model $ model & confirmTitle .~ Nothing & mainInput .~ ""] ShowSeed -> [Model $ model & showSeed .~ True & menuPopup .~ False] - ShowSend -> [Model $ model & openSend .~ True] + ShowSend -> + [ Model $ + model & openSend .~ True & privacyChoice .~ Full & recipientValid .~ + False + ] SendTx -> case currentAccount of Nothing -> [Event $ ShowError "No account available", Event CancelSend] @@ -887,9 +1250,10 @@ handleEvent wenv node model evt = (model ^. network) (entityKey acc) (zcashWalletLastSync $ entityVal wal) - (model ^. sendAmount) + (fromFloatDigits $ model ^. sendAmount) (model ^. sendRecipient) (model ^. sendMemo) + (model ^. privacyChoice) , Event CancelSend ] CancelSend -> @@ -931,7 +1295,7 @@ handleEvent wenv node model evt = Just wAddr -> getUserTx dbPool $ entityKey wAddr ] SwitchQr q -> [Model $ model & qrCodeWidget .~ q] - SwitchAddr i -> [Model $ model & selAddr .~ i, Event $ SetPool Orchard] + SwitchAddr i -> [Model $ model & selAddr .~ i, Event $ SetPool OrchardPool] SwitchAcc i -> [ Model $ model & selAcc .~ i , Task $ @@ -944,12 +1308,14 @@ 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) - , Event $ SetPool Orchard + s <- getShieldedBalance dbPool $ entityKey acc + t <- getTransparentBalance dbPool $ entityKey acc + return (b, u, s, t) + , Event $ SetPool OrchardPool ] SwitchWal i -> [ Model $ model & selWallet .~ i & selAcc .~ 0 & selAddr .~ 0 @@ -960,9 +1326,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) @@ -972,14 +1338,15 @@ handleEvent wenv node model evt = , setClipboardData $ ClipboardText $ case model ^. selPool of - Orchard -> maybe "None" (getUA . walletAddressUAddress . entityVal) a - Sapling -> + OrchardPool -> + maybe "None" (getUA . walletAddressUAddress . entityVal) a + SaplingPool -> fromMaybe "None" $ (getSaplingFromUA . E.encodeUtf8 . getUA . walletAddressUAddress . entityVal) =<< a - Sprout -> "None" - Transparent -> + SproutPool -> "None" + TransparentPool -> maybe "None" (encodeTransparentReceiver (model ^. network)) $ t_rec =<< (isValidUnifiedAddress . @@ -1002,7 +1369,7 @@ handleEvent wenv node model evt = if not (null a) then [ Model $ model & addresses .~ a , Event $ SwitchAddr $ model ^. selAddr - , Event $ SetPool Orchard + , Event $ SetPool OrchardPool ] else [Event $ NewAddress currentAccount] LoadAccs a -> @@ -1011,7 +1378,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] @@ -1021,45 +1388,167 @@ 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) - ] - 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 - syncWallet (model ^. configuration) cW - return $ SwitchAddr (model ^. selAddr) - , Task $ do - 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 ?~ ("Wallet Sync: " <> T.pack (printf "%.2f%%" (model ^. barValue * 100))) ] - CheckRecipient a -> [Model $ model & recipientValid .~ isRecipientValid a] + ResetRecipientValid -> [Model $ model & recipientValid .~ False] + CheckRecipient a -> + [ Model $ + model & recipientValid .~ isRecipientValidGUI (model ^. privacyChoice) a + ] CheckAmount i -> [ Model $ model & amountValid .~ (i < (fromIntegral (model ^. balance) / 100000000.0)) ] ShowTxId tx -> [Model $ model & showId ?~ tx & modalMsg .~ Nothing] + -- | + -- | Address Book Events + -- | + CheckValidAddress a -> + [Model $ model & abAddressValid .~ isZecAddressValid a] + CheckValidDescrip a -> [Model $ model & abDescripValid .~ isValidString a] + ShowAdrBook -> + if null (model ^. abaddressList) + then [Model $ model & newAdrBkEntry .~ True & menuPopup .~ False] + else [Model $ model & showAdrBook .~ True & menuPopup .~ False] + CloseAdrBook -> [Model $ model & showAdrBook .~ False] + NewAdrBkEntry -> + [Model $ model & newAdrBkEntry .~ True & menuPopup .~ False] + CloseNewAdrBook -> do + [Model $ model & newAdrBkEntry .~ False] + UpdateABEntry d a -> + [ Model $ + model & abdescrip .~ d & abaddress .~ a & updateABAddress .~ True & + abDescripValid .~ + True & + menuPopup .~ + False + ] + CloseUpdABEntry -> do + [Model $ model & updateABAddress .~ False] + SaveNewABEntry -> + [ Task $ + saveAddrBook + (model ^. configuration) + (ZcashNetDB (model ^. network)) + (model ^. abdescrip) + (model ^. abaddress) + , Model $ + model & abdescrip .~ "" & abaddress .~ "" & newAdrBkEntry .~ False + , Task $ do + dbPool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration + abList <- getAdrBook dbPool $ model ^. network + return $ LoadAbList abList + ] + ShowABAddress d a -> + [ Model $ + model & abdescrip .~ d & abaddress .~ a & showABAddress .~ True & + menuPopup .~ + False + ] + CloseShowABAddress -> + [Model $ model & showABAddress .~ False & inError .~ False] + CopyABAdress a -> + [ setClipboardData ClipboardEmpty + , setClipboardData $ ClipboardText a + , Event $ ShowMessage "Address copied!!" + ] + DeleteABEntry a -> + [ Task $ deleteAdrBook (model ^. configuration) a + , Model $ + model & abdescrip .~ "" & abaddress .~ "" & showABAddress .~ False + , Task $ do + dbPool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration + abList <- getAdrBook dbPool $ model ^. network + return $ LoadAbList abList + ] + ShowMessage a -> [Model $ model & msgAB ?~ a & menuPopup .~ False] + NotImplemented -> + [ Model $ + model & msgAB ?~ "Function not implemented..." & menuPopup .~ False + ] + CloseMsgAB -> [Model $ model & msgAB .~ Nothing & inError .~ False] + 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] + CloseDeShield -> [Model $ model & deShieldZec .~ False] + LoadAbList a -> [Model $ model & abaddressList .~ a] + UpdateABDescrip d a -> + [ Task $ updAddrBookDescrip (model ^. configuration) d a + , Model $ + model & abdescrip .~ "" & abaddress .~ "" & updateABAddress .~ False & + showABAddress .~ + False + , Task $ do + dbPool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration + 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) @@ -1147,28 +1636,84 @@ handleEvent wenv node model evt = Just _ -> do wL <- getWallets pool (model ^. network) return $ LoadWallets wL + -- | + -- | Address Book -> save new entry into database + -- | + saveAddrBook :: Config -> ZcashNetDB -> T.Text -> T.Text -> IO AppEvent + saveAddrBook config n d a = do + pool <- runNoLoggingT $ initPool $ c_dbPath config + res <- liftIO $ saveAdrsInAdrBook pool $ AddressBook n d a + case res of + Nothing -> return $ ShowMessage "Error saving AddressBook entry..." + Just _ -> return $ ShowMessage "New Address Book entry added!!" + -- | + -- | Address Book -> save new entry into database + -- | + deleteAdrBook :: Config -> T.Text -> IO AppEvent + deleteAdrBook config a = do + pool <- runNoLoggingT $ initPool $ c_dbPath config + res <- liftIO $ deleteAdrsFromAB pool a + return $ ShowMessage "Address Book entry deleted!!" + -- | + -- | Address Book -> save new entry into database + -- | + updAddrBookDescrip :: Config -> T.Text -> T.Text -> IO AppEvent + updAddrBookDescrip config d a = do + pool <- runNoLoggingT $ initPool $ c_dbPath config + res <- liftIO $ updateAdrsInAdrBook pool d a a + return $ ShowMessage "Address Book entry updated!!" -scanZebra :: T.Text -> T.Text -> Int -> (AppEvent -> IO ()) -> IO () -scanZebra dbPath zHost zPort sendMsg = do - _ <- liftIO $ initDb dbPath +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 <- runNoLoggingT $ getMaxBlock pool - let sb = max dbBlock b - confUp <- try $ updateConfs zHost zPort pool :: IO (Either IOError ()) - case confUp of - Left _e0 -> sendMsg (ShowError "Failed to update unconfirmed transactions") - Right _ -> do + 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 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 sendMsg (ShowError "Invalid starting block for scan") + 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) - mapM_ (processBlock pool step) bList - else sendMsg (SyncVal 1.0) + _ <- 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 @@ -1180,7 +1725,9 @@ scanZebra dbPath zHost zPort 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 $ @@ -1190,42 +1737,136 @@ scanZebra dbPath zHost zPort 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 - mapM_ (runNoLoggingT . processTx zHost zPort blockTime pool) $ - bl_txs $ addTime blk blockTime + 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 sendMsg (SyncVal step) - addTime :: BlockResponse -> Int -> BlockResponse - addTime bl t = - BlockResponse - (bl_confirmations bl) - (bl_height bl) - (fromIntegral t) - (bl_txs bl) + +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 -> (AppEvent -> IO ()) -> IO () -sendTransaction config znet accId bl amt ua memo sendMsg = do +sendTransaction config znet accId bl amt ua memo policy sendMsg = do sendMsg $ ShowModal "Preparing transaction..." - case parseAddress ua znet of + case parseAddress (E.encodeUtf8 ua) of Nothing -> sendMsg $ ShowError "Incorrect address" - Just outUA -> do + Just addr -> do let dbPath = c_dbPath config let zHost = c_zebraHost config let zPort = c_zebraPort config pool <- runNoLoggingT $ initPool dbPath res <- - runFileLoggingT "zenith.log" $ - prepareTx pool zHost zPort znet accId bl amt outUA memo + 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 @@ -1246,6 +1887,9 @@ timeTicker sendMsg = do threadDelay $ 1000 * 1000 timeTicker sendMsg +txtWrapN :: T.Text -> Int -> T.Text +txtWrapN t n = wrapText (WrapSettings False True NoFill FillAfterFirst) n t + txtWrap :: T.Text -> T.Text txtWrap = wrapText (WrapSettings False True NoFill FillAfterFirst) 32 @@ -1268,128 +1912,115 @@ runZenithGUI config = do case bc of Left e1 -> throwIO e1 Right chainInfo -> do - initDb dbFilePath - generateQRCodes config - walList <- getWallets pool $ zgb_net chainInfo - accList <- - if not (null walList) - then runNoLoggingT $ - getAccounts pool $ entityKey $ head walList - else return [] - addrList <- - if not (null accList) - then runNoLoggingT $ - getAddresses pool $ entityKey $ head accList - else return [] - txList <- - if not (null addrList) - then getUserTx pool $ entityKey $ head addrList - else return [] - qr <- - if not (null addrList) - then getQrCode pool Orchard $ entityKey $ head addrList - else return Nothing - bal <- - if not (null accList) - then getBalance pool $ entityKey $ head accList - else return 0 - unconfBal <- - if not (null accList) - then getUnconfirmedBalance pool $ entityKey $ head accList - else return 0 - let model = - AppModel - config - (zgb_net chainInfo) - walList - 0 - accList - 0 - addrList - 0 - txList - 0 - Nothing - True - bal - (if unconfBal == 0 - then Nothing - else Just unconfBal) - Orchard - qr - False - False - False - False - "" - Nothing - "" - "" - (SaveAddress $ - if not (null accList) - then Just (head accList) - else Nothing) - False - False - Nothing - Nothing - 0 - 1.0 - False - "" - 0.0 - "" - False - False - Nothing - hD - startApp model handleEvent buildUI (params hD) - Left e -> do - initDb dbFilePath - let model = - AppModel - config - TestNet - [] - 0 - [] - 0 - [] - 0 - [] - 0 - (Just $ - "Couldn't connect to Zebra on " <> - host <> ":" <> showt port <> ". Check your configuration.") - False - 314259000 - (Just 30000) - Orchard - Nothing - False - False - False - False - "" - Nothing - "" - "" - (SaveAddress Nothing) - False - False - Nothing - Nothing - 0 - 1.0 - False - "" - 0.0 - "" - False - False - Nothing - hD - startApp model handleEvent buildUI (params hD) + x <- initDb dbFilePath + _ <- upgradeQrTable pool + case x of + Left e2 -> throwIO $ userError e2 + Right x' -> do + when x' $ rescanZebra host port dbFilePath + generateQRCodes config + walList <- getWallets pool $ zgb_net chainInfo + accList <- + if not (null walList) + then runNoLoggingT $ + getAccounts pool $ entityKey $ head walList + else return [] + addrList <- + if not (null accList) + then runNoLoggingT $ + getAddresses pool $ entityKey $ head accList + else return [] + txList <- + if not (null addrList) + then getUserTx pool $ entityKey $ head addrList + else return [] + qr <- + if not (null addrList) + then getQrCode pool OrchardPool $ + entityKey $ head addrList + else return Nothing + bal <- + if not (null accList) + then getBalance pool $ entityKey $ head accList + else return 0 + unconfBal <- + if not (null accList) + 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 + (zgb_net chainInfo) + walList + 0 + accList + 0 + addrList + 0 + txList + 0 + Nothing + True + bal + (if unconfBal == 0 + then Nothing + else Just unconfBal) + OrchardPool + qr + False + False + False + False + "" + Nothing + "" + "" + (SaveAddress $ + if not (null accList) + then Just (head accList) + else Nothing) + False + False + Nothing + Nothing + 0 + 1.0 + False + "" + 0.0 + "" + False + False + Nothing + hD + False + False + "" + "" + False + False + abList + Nothing + False + False + Full + False + False + transBal + False + shieldBal + False + startApp model handleEvent buildUI (params hD) + Left _e -> print "Zebra not available" where params hd = [ appWindowTitle "Zenith - Zcash Full Node Wallet" diff --git a/src/Zenith/GUI/Theme.hs b/src/Zenith/GUI/Theme.hs index 6b59ef3..2e2cd4b 100644 --- a/src/Zenith/GUI/Theme.hs +++ b/src/Zenith/GUI/Theme.hs @@ -49,6 +49,9 @@ zenithTheme = L.active . L.btnStyle . L.text ?~ baseTextStyle & + L.disabled . + L.btnStyle . L.text ?~ + baseTextStyle & L.basic . L.btnMainStyle . L.text ?~ hiliteTextStyle & diff --git a/src/Zenith/RPC.hs b/src/Zenith/RPC.hs new file mode 100644 index 0000000..a32fb8f --- /dev/null +++ b/src/Zenith/RPC.hs @@ -0,0 +1,953 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# 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 (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 + ( ConnectionPool + , entityKey + , entityVal + , fromSqlKey + , toSqlKey + ) +import Servant +import Text.Read (readMaybe) +import ZcashHaskell.Keys (generateWalletSeedPhrase) +import ZcashHaskell.Orchard (parseAddress) +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) + +data ZenithMethod + = GetInfo + | ListWallets + | ListAccounts + | ListAddresses + | ListReceived + | GetBalance + | GetNewWallet + | GetNewAccount + | GetNewAddress + | GetOperationStatus + | SendMany + | UnknownMethod + deriving (Eq, Prelude.Show) + +instance ToJSON ZenithMethod where + toJSON GetInfo = Data.Aeson.String "getinfo" + toJSON ListWallets = Data.Aeson.String "listwallets" + toJSON ListAccounts = Data.Aeson.String "listaccounts" + toJSON ListAddresses = Data.Aeson.String "listaddresses" + toJSON ListReceived = Data.Aeson.String "listreceived" + toJSON GetBalance = Data.Aeson.String "getbalance" + toJSON GetNewWallet = Data.Aeson.String "getnewwallet" + 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 + parseJSON = + withText "ZenithMethod" $ \case + "getinfo" -> pure GetInfo + "listwallets" -> pure ListWallets + "listaccounts" -> pure ListAccounts + "listaddresses" -> pure ListAddresses + "listreceived" -> pure ListReceived + "getbalance" -> pure GetBalance + "getnewwallet" -> pure GetNewWallet + "getnewaccount" -> pure GetNewAccount + "getnewaddress" -> pure GetNewAddress + "getoperationstatus" -> pure GetOperationStatus + "sendmany" -> pure SendMany + _ -> pure UnknownMethod + +data ZenithParams + = BlankParams + | BadParams + | AccountsParams !Int + | AddressesParams !Int + | NotesParams !T.Text + | BalanceParams !Int64 + | NameParams !T.Text + | NameIdParams !T.Text !Int + | NewAddrParams !Int !T.Text !Bool !Bool + | OpParams !ZenithUuid + | SendParams !Int ![ProposedNote] !PrivacyPolicy + | TestParams !T.Text + deriving (Eq, Prelude.Show) + +instance ToJSON ZenithParams where + toJSON BlankParams = Data.Aeson.Array V.empty + toJSON BadParams = Data.Aeson.Null + toJSON (AccountsParams n) = Data.Aeson.Array $ V.fromList [jsonNumber n] + toJSON (AddressesParams n) = Data.Aeson.Array $ V.fromList [jsonNumber n] + toJSON (TestParams t) = Data.Aeson.Array $ V.fromList [Data.Aeson.String t] + toJSON (NotesParams t) = Data.Aeson.Array $ V.fromList [Data.Aeson.String t] + toJSON (NameParams t) = Data.Aeson.Array $ V.fromList [Data.Aeson.String t] + toJSON (NameIdParams t i) = + Data.Aeson.Array $ V.fromList [Data.Aeson.String t, jsonNumber i] + toJSON (BalanceParams n) = + Data.Aeson.Array $ V.fromList [jsonNumber $ fromIntegral n] + toJSON (NewAddrParams a n s t) = + Data.Aeson.Array $ + V.fromList $ + [jsonNumber a, Data.Aeson.String n] <> + [Data.Aeson.String "ExcludeSapling" | s] <> + [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 + | WalletListResponse !T.Text ![ZcashWalletAPI] + | AccountListResponse !T.Text ![ZcashAccountAPI] + | AddressListResponse !T.Text ![ZcashAddressAPI] + | NoteListResponse !T.Text ![ZcashNoteAPI] + | BalanceResponse !T.Text !AccountBalance !AccountBalance + | 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) + +instance ToJSON ZenithResponse where + toJSON (InfoResponse t i) = packRpcResponse t i + toJSON (WalletListResponse i w) = packRpcResponse i w + toJSON (AccountListResponse i a) = packRpcResponse i a + toJSON (AddressListResponse i a) = packRpcResponse i a + toJSON (NoteListResponse i n) = packRpcResponse i n + toJSON (ErrorResponse i c m) = + object + [ "jsonrpc" .= ("2.0" :: String) + , "id" .= i + , "error" .= object ["code" .= c, "message" .= m] + ] + toJSON (BalanceResponse i c u) = + packRpcResponse i $ object ["confirmed" .= c, "unconfirmed" .= u] + 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 = + withObject "ZenithResponse" $ \obj -> do + jr <- obj .: "jsonrpc" + i <- obj .: "id" + e <- obj .:? "error" + r <- obj .:? "result" + if jr /= ("2.0" :: String) + then fail "Malformed JSON" + else do + case e of + Nothing -> do + case r of + Nothing -> fail "Malformed JSON" + Just r1 -> + case r1 of + Object k -> do + v <- k .:? "version" + v5 <- k .:? "unconfirmed" + v6 <- k .:? "ua" + v7 <- k .:? "uuid" + case (v :: Maybe String) of + Just _v' -> do + k1 <- parseJSON r1 + pure $ InfoResponse i k1 + Nothing -> + case (v5 :: Maybe AccountBalance) of + Just _v5' -> do + k6 <- parseJSON r1 + j1 <- k6 .: "confirmed" + j2 <- k6 .: "unconfirmed" + pure $ BalanceResponse i j1 j2 + Nothing -> + case (v6 :: Maybe String) of + Just _v6' -> do + k7 <- parseJSON r1 + pure $ NewAddrResponse i k7 + Nothing -> + case (v7 :: Maybe U.UUID) of + Just _v7' -> do + k8 <- parseJSON r1 + pure $ OpResponse i k8 + Nothing -> fail "Unknown object" + Array n -> do + if V.null n + then fail "Malformed JSON" + else do + case V.head n of + Object n' -> do + v1 <- n' .:? "lastSync" + v2 <- n' .:? "wallet" + v3 <- n' .:? "ua" + v4 <- n' .:? "amountZats" + case (v1 :: Maybe Int) of + Just _v1' -> do + k2 <- parseJSON r1 + pure $ WalletListResponse i k2 + Nothing -> + case (v2 :: Maybe Int) of + Just _v2' -> do + k3 <- parseJSON r1 + pure $ AccountListResponse i k3 + Nothing -> + case (v3 :: Maybe String) of + Just _v3' -> do + k4 <- parseJSON r1 + pure $ AddressListResponse i k4 + Nothing -> + case (v4 :: Maybe Int) of + Just _v4' -> do + k5 <- parseJSON r1 + pure $ NoteListResponse i k5 + Nothing -> fail "Unknown object" + _anyOther -> fail "Malformed JSON" + Number k -> do + 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) + +data ZenithInfo = ZenithInfo + { zi_version :: !T.Text + , zi_network :: !ZcashNet + , zi_zebra :: !T.Text + } deriving (Eq, Prelude.Show) + +instance ToJSON ZenithInfo where + toJSON (ZenithInfo v n z) = + object ["version" .= v, "network" .= n, "zebraVersion" .= z] + +instance FromJSON ZenithInfo where + parseJSON = + withObject "ZenithInfo" $ \obj -> do + v <- obj .: "version" + n <- obj .: "network" + z <- obj .: "zebraVersion" + pure $ ZenithInfo v n z + +-- | A type to model Zenith RPC calls +data RpcCall = RpcCall + { jsonrpc :: !T.Text + , callId :: !T.Text + , method :: !ZenithMethod + , parameters :: !ZenithParams + } deriving (Eq, Prelude.Show) + +instance ToJSON RpcCall where + toJSON (RpcCall jr i m p) = + object ["jsonrpc" .= jr, "id" .= i, "method" .= m, "params" .= p] + +instance FromJSON RpcCall where + parseJSON = + withObject "RpcCall" $ \obj -> do + v <- obj .: "jsonrpc" + i <- obj .: "id" + m <- obj .: "method" + case m of + UnknownMethod -> pure $ RpcCall v i UnknownMethod BlankParams + ListWallets -> do + p <- obj .: "params" + if null (p :: [Value]) + then pure $ RpcCall v i ListWallets BlankParams + else pure $ RpcCall v i ListWallets BadParams + GetInfo -> do + p <- obj .: "params" + if null (p :: [Value]) + then pure $ RpcCall v i GetInfo BlankParams + else pure $ RpcCall v i GetInfo BadParams + ListAccounts -> do + p <- obj .: "params" + case p of + Array a -> + if V.length a == 1 + then do + w <- parseJSON $ V.head a + pure $ RpcCall v i ListAccounts (AccountsParams w) + else pure $ RpcCall v i ListAccounts BadParams + _anyOther -> pure $ RpcCall v i ListAccounts BadParams + ListAddresses -> do + p <- obj .: "params" + case p of + Array a -> + if V.length a == 1 + then do + x <- parseJSON $ V.head a + pure $ RpcCall v i ListAddresses (AddressesParams x) + else pure $ RpcCall v i ListAddresses BadParams + _anyOther -> pure $ RpcCall v i ListAddresses BadParams + ListReceived -> do + p <- obj .: "params" + case p of + Array a -> + if V.length a == 1 + then do + x <- parseJSON $ V.head a + pure $ RpcCall v i ListReceived (NotesParams x) + else pure $ RpcCall v i ListReceived BadParams + _anyOther -> pure $ RpcCall v i ListReceived BadParams + GetBalance -> do + p <- obj .: "params" + case p of + Array a -> + if V.length a == 1 + then do + x <- parseJSON $ V.head a + pure $ RpcCall v i GetBalance (BalanceParams x) + else pure $ RpcCall v i GetBalance BadParams + _anyOther -> pure $ RpcCall v i GetBalance BadParams + GetNewWallet -> do + p <- obj .: "params" + case p of + Array a -> + if V.length a == 1 + then do + x <- parseJSON $ V.head a + pure $ RpcCall v i GetNewWallet (NameParams x) + else pure $ RpcCall v i GetNewWallet BadParams + _anyOther -> pure $ RpcCall v i GetNewWallet BadParams + GetNewAccount -> do + p <- obj .: "params" + case p of + Array a -> + if V.length a == 2 + then do + x <- parseJSON $ a V.! 0 + y <- parseJSON $ a V.! 1 + pure $ RpcCall v i GetNewAccount (NameIdParams x y) + else pure $ RpcCall v i GetNewAccount BadParams + _anyOther -> pure $ RpcCall v i GetNewAccount BadParams + GetNewAddress -> do + p <- obj .: "params" + case p of + Array a -> + if V.length a >= 2 + then do + x <- parseJSON $ a V.! 0 + y <- parseJSON $ a V.! 1 + (sap, tr) <- + case a V.!? 2 of + Nothing -> return (False, False) + Just s -> do + s' <- parseJSON s + case s' of + ("ExcludeSapling" :: String) -> do + case a V.!? 3 of + Nothing -> return (True, False) + Just t -> do + t' <- parseJSON t + return + (True, t' == ("ExcludeTransparent" :: String)) + ("ExcludeTransparent" :: String) -> do + case a V.!? 3 of + Nothing -> return (False, True) + Just t -> do + t' <- parseJSON t + return + (t' == ("ExcludeSapling" :: String), True) + _anyOther -> return (False, False) + pure $ RpcCall v i GetNewAddress (NewAddrParams x y sap tr) + else pure $ RpcCall v i GetNewAddress BadParams + _anyOther -> pure $ RpcCall v i GetNewAddress BadParams + GetOperationStatus -> do + p <- obj .: "params" + case p of + Array a -> + if V.length a == 1 + then do + x <- parseJSON $ a V.! 0 + case U.fromText x of + Just u -> do + pure $ + RpcCall v i GetOperationStatus (OpParams $ ZenithUuid u) + 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 + '[ JSON] + RpcCall :> Post '[ JSON] ZenithResponse + +data State = State + { w_network :: !ZcashNet + , w_host :: !T.Text + , w_port :: !Int + , w_dbPath :: !T.Text + , w_build :: !T.Text + , w_startBlock :: !Int + } + +zenithServer :: State -> Server ZenithRPC +zenithServer state = getinfo :<|> handleRPC + where + getinfo :: Handler Value + getinfo = + return $ + object + [ "version" .= ("0.7.0.0-beta" :: String) + , "network" .= ("testnet" :: String) + ] + handleRPC :: Bool -> RpcCall -> Handler ZenithResponse + handleRPC isAuth req = + case method req of + UnknownMethod -> + return $ ErrorResponse (callId req) (-32601) "Method not found" + ListWallets -> + case parameters req of + BlankParams -> do + pool <- liftIO $ runNoLoggingT $ initPool $ w_dbPath state + walList <- liftIO $ getWallets pool $ w_network state + if not (null walList) + then return $ + WalletListResponse + (callId req) + (map toZcashWalletAPI walList) + else return $ + ErrorResponse + (callId req) + (-32001) + "No wallets available. Please create one first" + _anyOther -> + return $ ErrorResponse (callId req) (-32602) "Invalid params" + ListAccounts -> + case parameters req of + AccountsParams w -> do + let dbPath = w_dbPath state + pool <- liftIO $ runNoLoggingT $ initPool dbPath + wl <- liftIO $ walletExists pool w + case wl of + Just wl' -> do + accList <- + liftIO $ runNoLoggingT $ getAccounts pool (entityKey wl') + if not (null accList) + then return $ + AccountListResponse + (callId req) + (map toZcashAccountAPI accList) + else return $ + ErrorResponse + (callId req) + (-32002) + "No accounts available for this wallet. Please create one first" + Nothing -> + return $ + ErrorResponse (callId req) (-32008) "Wallet does not exist." + _anyOther -> + return $ ErrorResponse (callId req) (-32602) "Invalid params" + ListAddresses -> + case parameters req of + AddressesParams a -> do + let dbPath = w_dbPath state + pool <- liftIO $ runNoLoggingT $ initPool dbPath + addrList <- + liftIO $ + runNoLoggingT $ getAddresses pool (toSqlKey $ fromIntegral a) + if not (null addrList) + then return $ + AddressListResponse + (callId req) + (map toZcashAddressAPI addrList) + else return $ + ErrorResponse + (callId req) + (-32003) + "No addresses available for this account. Please create one first" + _anyOther -> + return $ ErrorResponse (callId req) (-32602) "Invalid params" + GetInfo -> + case parameters req of + BlankParams -> + return $ + InfoResponse + (callId req) + (ZenithInfo "0.7.0.0-beta" (w_network state) (w_build state)) + _anyOtherParams -> + return $ ErrorResponse (callId req) (-32602) "Invalid params" + ListReceived -> + case parameters req of + NotesParams x -> do + case (readMaybe (T.unpack x) :: Maybe Int64) of + Just x' -> do + let dbPath = w_dbPath state + pool <- liftIO $ runNoLoggingT $ initPool dbPath + a <- liftIO $ getAddressById pool $ toSqlKey x' + case a of + Just a' -> do + nList <- liftIO $ getWalletNotes pool a' + return $ NoteListResponse (callId req) nList + Nothing -> + return $ + ErrorResponse + (callId req) + (-32004) + "Address does not belong to the wallet" + Nothing -> + case parseAddress (E.encodeUtf8 x) of + Nothing -> + return $ + ErrorResponse + (callId req) + (-32005) + "Unable to parse address" + Just x' -> do + let dbPath = w_dbPath state + pool <- liftIO $ runNoLoggingT $ initPool dbPath + addrs <- liftIO $ getExternalAddresses pool + nList <- + liftIO $ + concat <$> mapM (findNotesByAddress pool x') addrs + return $ NoteListResponse (callId req) nList + _anyOtherParams -> + return $ ErrorResponse (callId req) (-32602) "Invalid params" + GetBalance -> + case parameters req of + BalanceParams i -> do + let dbPath = w_dbPath state + pool <- liftIO $ runNoLoggingT $ initPool dbPath + acc <- liftIO $ getAccountById pool $ toSqlKey i + case acc of + Just acc' -> do + c <- liftIO $ getPoolBalance pool $ entityKey acc' + u <- liftIO $ getUnconfPoolBalance pool $ entityKey acc' + return $ BalanceResponse (callId req) c u + Nothing -> + return $ + ErrorResponse (callId req) (-32006) "Account does not exist." + _anyOtherParams -> + return $ ErrorResponse (callId req) (-32602) "Invalid params" + GetNewWallet -> + case parameters req of + NameParams t -> do + let dbPath = w_dbPath 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 + 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 -> + case parameters req of + NameIdParams t i -> do + let dbPath = w_dbPath 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 + 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) + (-32008) + "Wallet does not exist." + _anyOtherParams -> + return $ ErrorResponse (callId req) (-32602) "Invalid params" + GetNewAddress -> + case parameters req of + NewAddrParams i n s t -> do + let dbPath = w_dbPath state + let net = 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 + 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) + (-32006) + "Account does not exist." + _anyOtherParams -> + return $ ErrorResponse (callId req) (-32602) "Invalid params" + GetOperationStatus -> + case parameters req of + OpParams u -> do + let dbPath = w_dbPath state + pool <- liftIO $ runNoLoggingT $ initPool dbPath + op <- liftIO $ getOperation pool $ getUuid u + case op of + Just o -> do + return $ OpResponse (callId req) $ entityVal o + Nothing -> + return $ + 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 + where + check (BasicAuthData username password) = + if username == c_zenithUser config && password == c_zenithPwd config + then return $ Authorized True + else return Unauthorized + +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)) + 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 09f7ccc..50d6235 100644 --- a/src/Zenith/Scanner.hs +++ b/src/Zenith/Scanner.hs @@ -2,29 +2,28 @@ module Zenith.Scanner where +import Control.Concurrent.Async (concurrently_, withAsync) import Control.Exception (throwIO, try) -import qualified Control.Monad.Catch as CM (try) +import Control.Monad (when) import Control.Monad.IO.Class (liftIO) import Control.Monad.Logger - ( LoggingT - , NoLoggingT + ( NoLoggingT , logErrorN , logInfoN , runNoLoggingT + , runStderrLoggingT ) import Data.Aeson import Data.HexString -import Data.Maybe import qualified Data.Text as T import Data.Time (getCurrentTime) import Database.Persist.Sqlite -import GHC.Utils.Monad (concatMapM) -import Lens.Micro ((&), (.~), (^.), set) import System.Console.AsciiProgress import ZcashHaskell.Types ( BlockResponse(..) , RawZebraTx(..) , Transaction(..) + , ZcashNet(..) , ZebraGetBlockChainInfo(..) , ZebraTxResponse(..) , fromRawOBundle @@ -32,59 +31,85 @@ import ZcashHaskell.Types , fromRawTBundle ) import ZcashHaskell.Utils (getBlockTime, makeZebraCall, readZebraTransaction) -import Zenith.Core (checkBlockChain) +import Zenith.Core (checkBlockChain, syncWallet, updateCommitmentTrees) import Zenith.DB - ( getMaxBlock + ( ZcashBlock(..) + , ZcashBlockId + , clearWalletData + , clearWalletTransactions + , completeSync + , getBlock + , getMaxBlock + , getMinBirthdayHeight , getUnconfirmedBlocks + , getWallets , initDb + , initPool + , saveBlock , saveConfs , saveTransaction + , startSync + , updateWalletSync + , upgradeQrTable + ) +import Zenith.Types + ( Config(..) + , HexStringDB(..) + , ZcashNetDB(..) + , ZenithStatus(..) ) import Zenith.Utils (jsonNumber) -- | Function to scan the Zcash blockchain through the Zebra node and populate the Zenith database -scanZebra :: - Int -- ^ Starting block - -> T.Text -- ^ Host +rescanZebra :: + T.Text -- ^ Host -> Int -- ^ Port -> T.Text -- ^ Path to database file - -> NoLoggingT IO () -scanZebra b host port dbFilePath = do - _ <- liftIO $ initDb dbFilePath - startTime <- liftIO getCurrentTime - logInfoN $ "Started sync: " <> T.pack (show startTime) + -> IO () +rescanZebra host port dbFilePath = do bc <- - liftIO $ try $ checkBlockChain host port :: NoLoggingT - IO + try $ checkBlockChain host port :: IO (Either IOError ZebraGetBlockChainInfo) case bc of - Left e -> logErrorN $ T.pack (show e) + Left e -> print e Right bStatus -> do - let dbInfo = - mkSqliteConnectionInfo dbFilePath & extraPragmas .~ - ["read_uncommited = true"] - pool <- createSqlitePoolFromInfo dbInfo 5 - dbBlock <- getMaxBlock pool + let znet = ZcashNetDB $ zgb_net bStatus + pool1 <- runNoLoggingT $ initPool dbFilePath + {-pool2 <- runNoLoggingT $ initPool dbFilePath-} + {-pool3 <- runNoLoggingT $ initPool dbFilePath-} + _ <- initDb dbFilePath + upgradeQrTable pool1 + clearWalletTransactions pool1 + clearWalletData pool1 + _ <- startSync pool1 + dbBlock <- getMaxBlock pool1 znet + 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" else do - liftIO $ - print $ - "Scanning from " ++ - show (sb + 1) ++ " to " ++ show (zgb_blocks bStatus) - let bList = [(sb + 1) .. (zgb_blocks bStatus)] - displayConsoleRegions $ do - pg <- - liftIO $ - newProgressBar def {pgTotal = fromIntegral $ length bList} - txList <- - CM.try $ mapM_ (processBlock host port pool pg) bList :: NoLoggingT - IO - (Either IOError ()) - case txList of - Left e1 -> logErrorN $ T.pack (show e1) - Right txList' -> logInfoN "Finished scan" + print $ + "Scanning from " ++ show sb ++ " to " ++ show (zgb_blocks bStatus) + let bList = [sb .. (zgb_blocks bStatus)] + {- + let batch = length bList `div` 3 + let bl1 = take batch bList + let bl2 = take batch $ drop batch bList + let bl3 = drop (2 * batch) bList + -} + _ <- + displayConsoleRegions $ do + pg1 <- newProgressBar def {pgTotal = fromIntegral $ length bList} + {-pg2 <- newProgressBar def {pgTotal = fromIntegral $ length bl2}-} + {-pg3 <- newProgressBar def {pgTotal = fromIntegral $ length bl3}-} + mapM_ (processBlock host port pool1 pg1 znet) bList + {-`concurrently_`-} + {-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 processBlock :: @@ -92,9 +117,10 @@ processBlock :: -> Int -- ^ Port for `zebrad` -> ConnectionPool -- ^ DB file path -> ProgressBar -- ^ Progress bar + -> ZcashNetDB -- ^ the network -> Int -- ^ The block number to process - -> NoLoggingT IO () -processBlock host port pool pg b = do + -> IO () +processBlock host port pool pg net b = do r <- liftIO $ makeZebraCall @@ -103,7 +129,9 @@ processBlock host port pool pg 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 $ @@ -113,29 +141,30 @@ processBlock host port pool pg 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 - mapM_ (processTx host port blockTime pool) $ - bl_txs $ addTime blk blockTime + bi <- + saveBlock pool $ + ZcashBlock + (fromIntegral $ bl_height blk) + (HexStringDB $ bl_hash blk) + (fromIntegral $ bl_confirmations blk) + blockTime + net + mapM_ (processTx host port bi pool) $ bl_txs blk liftIO $ tick pg - where - addTime :: BlockResponse -> Int -> BlockResponse - addTime bl t = - BlockResponse - (bl_confirmations bl) - (bl_height bl) - (fromIntegral t) - (bl_txs bl) -- | Function to process a raw transaction processTx :: T.Text -- ^ Host name for `zebrad` -> Int -- ^ Port for `zebrad` - -> Int -- ^ Block time + -> ZcashBlockId -- ^ Block ID -> ConnectionPool -- ^ DB file path -> HexString -- ^ transaction id - -> NoLoggingT IO () + -> IO () processTx host port bt pool t = do r <- liftIO $ @@ -145,12 +174,15 @@ 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 () Just rzt -> do _ <- + runNoLoggingT $ saveTransaction pool bt $ Transaction t @@ -184,3 +216,59 @@ updateConfs host port pool = do Left e -> throwIO $ userError e Right blk -> do saveConfs pool b $ fromInteger $ bl_confirmations blk + +clearSync :: Config -> IO () +clearSync config = do + let zHost = c_zebraHost config + let zPort = c_zebraPort config + let dbPath = c_dbPath config + pool <- runNoLoggingT $ initPool dbPath + bc <- + try $ checkBlockChain zHost zPort :: IO + (Either IOError ZebraGetBlockChainInfo) + case bc of + Left e1 -> throwIO e1 + Right chainInfo -> do + x <- initDb dbPath + _ <- upgradeQrTable pool + case x of + Left e2 -> throwIO $ userError e2 + Right x' -> do + when x' $ rescanZebra zHost zPort dbPath + _ <- clearWalletTransactions pool + w <- getWallets pool $ zgb_net chainInfo + liftIO $ mapM_ (updateWalletSync pool 0 . entityKey) w + w' <- liftIO $ getWallets pool $ zgb_net chainInfo + r <- runNoLoggingT $ mapM (syncWallet config) w' + liftIO $ print r + +-- | Detect chain re-orgs +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 znet b d = + if b < 1 + then return 1 + else do + r <- + makeZebraCall + zHost + zPort + "getblock" + [Data.Aeson.String $ T.pack $ show b, jsonNumber 1] + case r of + Left e -> throwIO $ userError e + Right blk -> do + pool <- runNoLoggingT $ initPool dbP + dbBlk <- getBlock pool b $ ZcashNetDB znet + case dbBlk of + Nothing -> return 1 + Just dbBlk' -> + if bl_hash blk == getHex (zcashBlockHash $ entityVal dbBlk') + then return b + 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 6176c17..f71b6c3 100644 --- a/src/Zenith/Types.hs +++ b/src/Zenith/Types.hs @@ -10,23 +10,37 @@ module Zenith.Types where import Data.Aeson +import Data.Aeson.TH (deriveJSON) import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as B64 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(..) ) @@ -42,6 +56,9 @@ newtype ZcashNetDB = ZcashNetDB { getNet :: ZcashNet } deriving newtype (Eq, Show, Read) +instance ToJSON ZcashNetDB where + toJSON (ZcashNetDB z) = toJSON z + derivePersistField "ZcashNetDB" newtype UnifiedAddressDB = UnifiedAddressDB @@ -92,8 +109,165 @@ data Config = Config { c_dbPath :: !T.Text , c_zebraHost :: !T.Text , c_zebraPort :: !Int + , c_zenithUser :: !BS.ByteString + , c_zenithPwd :: !BS.ByteString + , c_zenithPort :: !Int } deriving (Eq, Prelude.Show) +data ZcashPool + = TransparentPool + | SproutPool + | SaplingPool + | OrchardPool + deriving (Show, Read, Eq) + +derivePersistField "ZcashPool" + +instance ToJSON ZcashPool where + toJSON zp = + case zp of + TransparentPool -> Data.Aeson.String "p2pkh" + SproutPool -> Data.Aeson.String "sprout" + SaplingPool -> Data.Aeson.String "sapling" + OrchardPool -> Data.Aeson.String "orchard" + +instance FromJSON ZcashPool where + parseJSON = + withText "ZcashPool" $ \case + "p2pkh" -> return TransparentPool + "sprout" -> return SproutPool + "sapling" -> return SaplingPool + "orchard" -> return OrchardPool + _ -> fail "Not a known Zcash pool" + +newtype ZenithUuid = ZenithUuid + { getUuid :: U.UUID + } deriving newtype (Show, Eq, Read, ToJSON, FromJSON) + +derivePersistField "ZenithUuid" + +-- ** API types +data ZcashWalletAPI = ZcashWalletAPI + { zw_index :: !Int + , zw_name :: !T.Text + , zw_network :: !ZcashNet + , zw_birthday :: !Int + , zw_lastSync :: !Int + } deriving (Eq, Prelude.Show) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop 3} ''ZcashWalletAPI) + +data ZcashAccountAPI = ZcashAccountAPI + { za_index :: !Int + , za_wallet :: !Int + , za_name :: !T.Text + } deriving (Eq, Prelude.Show) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop 3} ''ZcashAccountAPI) + +data ZcashAddressAPI = ZcashAddressAPI + { zd_index :: !Int + , zd_account :: !Int + , zd_name :: !T.Text + , zd_ua :: !T.Text + , zd_legacy :: !(Maybe T.Text) + , zd_transparent :: !(Maybe T.Text) + } deriving (Eq, Prelude.Show) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop 3} ''ZcashAddressAPI) + +data ZcashNoteAPI = ZcashNoteAPI + { zn_txid :: !HexString + , zn_pool :: !ZcashPool + , zn_amount :: !Float + , zn_amountZats :: !Int64 + , zn_memo :: !T.Text + , zn_confirmed :: !Bool + , zn_blockheight :: !Int + , zn_blocktime :: !Int + , zn_outindex :: !Int + , zn_change :: !Bool + } deriving (Eq, Prelude.Show) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop 3} ''ZcashNoteAPI) + +data AccountBalance = AccountBalance + { acb_transparent :: !Int64 + , acb_sapling :: !Int64 + , acb_orchard :: !Int64 + } deriving (Eq, Prelude.Show) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop 4} ''AccountBalance) + +data ZenithStatus + = Processing + | Failed + | Successful + deriving (Eq, Prelude.Show, Read) + +$(deriveJSON defaultOptions ''ZenithStatus) + +derivePersistField "ZenithStatus" + +data PrivacyPolicy + = None + | Low + | Medium + | Full + deriving (Eq, Show, Read, Ord) + +$(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 + deriving (Eq, Show, Read, Ord) + -- ** `zebrad` -- | Type for modeling the tree state response data ZebraTreeInfo = ZebraTreeInfo @@ -138,24 +312,6 @@ instance FromJSON AddressSource where "mnemonic_seed" -> return MnemonicSeed _ -> fail "Not a known address source" -data ZcashPool - = Transparent - | Sprout - | Sapling - | Orchard - deriving (Show, Read, Eq, Generic, ToJSON) - -derivePersistField "ZcashPool" - -instance FromJSON ZcashPool where - parseJSON = - withText "ZcashPool" $ \case - "p2pkh" -> return Transparent - "sprout" -> return Sprout - "sapling" -> return Sapling - "orchard" -> return Orchard - _ -> fail "Not a known Zcash pool" - data ZcashAddress = ZcashAddress { source :: AddressSource , pool :: [ZcashPool] @@ -203,7 +359,8 @@ instance FromJSON AddressGroup where Nothing -> return [] Just x -> do x' <- x .:? "addresses" - return $ maybe [] (map (ZcashAddress s1 [Transparent] Nothing)) x' + return $ + maybe [] (map (ZcashAddress s1 [TransparentPool] Nothing)) x' processSapling k s2 = case k of Nothing -> return [] @@ -211,7 +368,7 @@ instance FromJSON AddressGroup where where processOneSapling sx = withObject "Sapling" $ \oS -> do oS' <- oS .: "addresses" - return $ map (ZcashAddress sx [Sapling] Nothing) oS' + return $ map (ZcashAddress sx [SaplingPool] Nothing) oS' processUnified u = case u of Nothing -> return [] diff --git a/src/Zenith/Utils.hs b/src/Zenith/Utils.hs index eedf02d..c3b74ee 100644 --- a/src/Zenith/Utils.hs +++ b/src/Zenith/Utils.hs @@ -3,28 +3,38 @@ module Zenith.Utils where import Data.Aeson +import Data.Char (isAlphaNum, isSpace) import Data.Functor (void) import Data.Maybe import Data.Ord (clamp) import Data.Scientific (Scientific(..), scientific) import qualified Data.Text as T import qualified Data.Text.Encoding as E +import System.Directory import System.Process (createProcess_, shell) import Text.Regex.Posix -import ZcashHaskell.Orchard (encodeUnifiedAddress, isValidUnifiedAddress) +import ZcashHaskell.Orchard + ( encodeUnifiedAddress + , isValidUnifiedAddress + , parseAddress + ) import ZcashHaskell.Sapling (decodeSaplingAddress, isValidShieldedAddress) import ZcashHaskell.Transparent ( decodeExchangeAddress , decodeTransparentAddress ) import ZcashHaskell.Types - ( SaplingAddress(..) + ( ExchangeAddress(..) + , SaplingAddress(..) , TransparentAddress(..) , UnifiedAddress(..) + , ValidAddress(..) , ZcashNet(..) ) +import ZcashHaskell.Utils (makeZebraCall) import Zenith.Types ( AddressGroup(..) + , PrivacyPolicy(..) , UnifiedAddressDB(..) , ZcashAddress(..) , ZcashPool(..) @@ -69,9 +79,9 @@ getAddresses ag = agtransparent ag <> agsapling ag <> agunified ag -- | Helper function to validate potential Zcash addresses validateAddress :: T.Text -> Maybe ZcashPool validateAddress txt --(tReg || sReg && isJust chk) || (uReg && isJust chk) - | tReg = Just Transparent - | sReg && chkS = Just Sapling - | uReg && chk = Just Orchard + | tReg = Just TransparentPool + | sReg && chkS = Just SaplingPool + | uReg && chk = Just OrchardPool | otherwise = Nothing where transparentRegex = "^t1[a-zA-Z0-9]{33}$" :: String @@ -83,6 +93,13 @@ validateAddress txt --(tReg || sReg && isJust chk) || (uReg && isJust chk) chk = isJust $ isValidUnifiedAddress $ E.encodeUtf8 txt chkS = isValidShieldedAddress $ E.encodeUtf8 txt +-- | Return True if Address is valid +validateAddressBool :: T.Text -> Bool +validateAddressBool a = do + case (validateAddress a) of + Nothing -> False + _ -> True + -- | Copy an address to the clipboard copyAddress :: ZcashAddress -> IO () copyAddress a = @@ -90,12 +107,18 @@ copyAddress a = createProcess_ "toClipboard" $ shell $ "echo " ++ T.unpack (addy a) ++ " | xclip -r -selection clipboard" +-- | Get current user and build zenith path +getZenithPath :: IO String +getZenithPath = do + homeDirectory <- getHomeDirectory + return (homeDirectory ++ "/Zenith/") + -- | Bound a value to the 0..1 range, used for progress reporting on UIs validBarValue :: Float -> Float validBarValue = clamp (0, 1) isRecipientValid :: T.Text -> Bool -isRecipientValid a = +isRecipientValid a = do case isValidUnifiedAddress (E.encodeUtf8 a) of Just _a1 -> True Nothing -> @@ -103,12 +126,84 @@ isRecipientValid a = (case decodeTransparentAddress (E.encodeUtf8 a) of Just _a3 -> True Nothing -> - case decodeExchangeAddress a of + case decodeExchangeAddress (E.encodeUtf8 a) of Just _a4 -> True Nothing -> False) -parseAddress :: T.Text -> ZcashNet -> Maybe UnifiedAddress -parseAddress a znet = +isUnifiedAddressValid :: T.Text -> Bool +isUnifiedAddressValid ua = + case isValidUnifiedAddress (E.encodeUtf8 ua) of + Just _a1 -> True + Nothing -> False + +isSaplingAddressValid :: T.Text -> Bool +isSaplingAddressValid sa = isValidShieldedAddress (E.encodeUtf8 sa) + +isTransparentAddressValid :: T.Text -> Bool +isTransparentAddressValid ta = + case decodeTransparentAddress (E.encodeUtf8 ta) of + Just _a3 -> True + Nothing -> False + +isExchangeAddressValid :: T.Text -> Bool +isExchangeAddressValid xa = + case decodeExchangeAddress (E.encodeUtf8 xa) of + Just _a4 -> True + Nothing -> False + +isRecipientValidGUI :: PrivacyPolicy -> T.Text -> Bool +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 + +isZecAddressValid :: T.Text -> Bool +isZecAddressValid a = do + case isValidUnifiedAddress (E.encodeUtf8 a) of + Just _a1 -> True + Nothing -> + isValidShieldedAddress (E.encodeUtf8 a) || + (case decodeTransparentAddress (E.encodeUtf8 a) of + Just _a3 -> True + Nothing -> + case decodeExchangeAddress (E.encodeUtf8 a) of + Just _a4 -> True + Nothing -> False) + +parseAddressUA :: T.Text -> ZcashNet -> Maybe UnifiedAddress +parseAddressUA a znet = case isValidUnifiedAddress (E.encodeUtf8 a) of Just a1 -> Just a1 Nothing -> @@ -120,3 +215,36 @@ parseAddress a znet = Just a3 -> Just $ UnifiedAddress znet Nothing Nothing (Just $ ta_receiver a3) Nothing -> Nothing + +isValidContent :: String -> Bool +isValidContent [] = False -- an empty string is invalid +isValidContent (x:xs) + | not (isAlphaNum x) = False -- string must start with an alphanumeric character + | otherwise = allValidChars xs -- process the rest of the string + where + allValidChars :: String -> Bool + allValidChars [] = True -- if we got here, string is valid + allValidChars (y:ys) + | isAlphaNum y || isSpace y = allValidChars ys -- char is valid, continue + | otherwise = False -- found an invalid character, return false + +isValidString :: T.Text -> Bool +isValidString c = do + let a = T.unpack c + isValidContent a + +padWithZero :: Int -> String -> String +padWithZero n s + | (length s) >= n = s + | otherwise = padWithZero n ("0" ++ 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 diff --git a/src/Zenith/Zcashd.hs b/src/Zenith/Zcashd.hs index bc4c2d2..8d402b9 100644 --- a/src/Zenith/Zcashd.hs +++ b/src/Zenith/Zcashd.hs @@ -123,9 +123,10 @@ sendTx user pwd fromAddy toAddy amount memo = do if source fromAddy /= ImportedWatchOnly then do let privacyPolicy - | valAdd == Just Transparent = "AllowRevealedRecipients" + | valAdd == Just TransparentPool = "AllowRevealedRecipients" | isNothing (account fromAddy) && - elem Transparent (pool fromAddy) = "AllowRevealedSenders" + elem TransparentPool (pool fromAddy) = + "AllowRevealedSenders" | otherwise = "AllowRevealedAmounts" let pd = case memo of @@ -301,7 +302,7 @@ sendWithUri user pwd fromAddy uri repTo = do let addType = validateAddress $ T.pack parsedAddress case addType of Nothing -> putStrLn " Invalid address" - Just Transparent -> do + Just TransparentPool -> do putStrLn $ " Address is valid: " ++ parsedAddress case (readMaybe parsedAmount :: Maybe Double) of Nothing -> putStrLn " Invalid amount." diff --git a/test/ServerSpec.hs b/test/ServerSpec.hs new file mode 100644 index 0000000..882b5e0 --- /dev/null +++ b/test/ServerSpec.hs @@ -0,0 +1,754 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Control.Concurrent (forkIO, threadDelay) +import Control.Exception (SomeException, throwIO, try) +import Control.Monad (when) +import Control.Monad.Logger (runNoLoggingT) +import Data.Aeson +import qualified Data.ByteString as BS +import Data.Configurator +import Data.Maybe (fromJust, fromMaybe) +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 Network.HTTP.Simple +import Network.Wai.Handler.Warp (run) +import Servant +import System.Directory +import Test.HUnit hiding (State) +import Test.Hspec +import ZcashHaskell.Orchard (isValidUnifiedAddress, parseAddress) +import ZcashHaskell.Types + ( ZcashNet(..) + , ZebraGetBlockChainInfo(..) + , ZebraGetInfo(..) + ) +import Zenith.Core (checkBlockChain, checkZebra) +import Zenith.DB (Operation(..), initDb, initPool, saveOperation) +import Zenith.RPC + ( RpcCall(..) + , State(..) + , ZenithInfo(..) + , ZenithMethod(..) + , ZenithParams(..) + , ZenithRPC(..) + , ZenithResponse(..) + , authenticate + , zenithServer + ) +import Zenith.Types + ( Config(..) + , PrivacyPolicy(..) + , ProposedNote(..) + , ValidAddressAPI(..) + , ZcashAccountAPI(..) + , ZcashAddressAPI(..) + , ZcashWalletAPI(..) + , ZenithStatus(..) + , ZenithUuid(..) + ) + +main :: IO () +main = do + config <- load ["$(HOME)/Zenith/zenith.cfg"] + let dbFilePath = "test.db" + 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 + hspec $ do + describe "RPC methods" $ do + beforeAll_ (startAPI myConfig) $ do + describe "getinfo" $ do + it "bad credentials" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + "baduser" + "idontknow" + GetInfo + BlankParams + res `shouldBe` Left "Invalid credentials" + it "correct credentials" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + GetInfo + BlankParams + case res of + Left e -> assertFailure e + Right r -> + r `shouldBe` + InfoResponse "zh" (ZenithInfo "0.7.0.0-beta" TestNet "v1.9.0") + describe "Wallets" $ do + describe "listwallet" $ do + it "bad credentials" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + "baduser" + "idontknow" + ListWallets + BlankParams + res `shouldBe` Left "Invalid credentials" + it "correct credentials, no wallet" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + ListWallets + BlankParams + case res of + Left e -> assertFailure e + Right r -> + r `shouldBe` + ErrorResponse + "zh" + (-32001) + "No wallets available. Please create one first" + describe "getnewwallet" $ do + it "bad credentials" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + "baduser" + "idontknow" + GetNewWallet + BlankParams + res `shouldBe` Left "Invalid credentials" + describe "correct credentials" $ do + it "no params" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + GetNewWallet + BlankParams + case res of + Left e -> assertFailure e + Right r -> + r `shouldBe` ErrorResponse "zh" (-32602) "Invalid params" + it "Valid params" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + GetNewWallet + (NameParams "Main") + case res of + Left e -> assertFailure e + Right r -> r `shouldBe` NewItemResponse "zh" 1 + it "duplicate name" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + GetNewWallet + (NameParams "Main") + case res of + Left e -> assertFailure e + Right r -> + r `shouldBe` + ErrorResponse + "zh" + (-32007) + "Entity with that name already exists." + describe "listwallet" $ do + it "wallet exists" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + ListWallets + BlankParams + case res of + Left e -> assertFailure e + Right (WalletListResponse i k) -> + zw_name (head k) `shouldBe` "Main" + Right _ -> assertFailure "Unexpected response" + describe "Accounts" $ do + describe "listaccounts" $ do + it "bad credentials" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + "baduser" + "idontknow" + ListAccounts + BlankParams + res `shouldBe` Left "Invalid credentials" + describe "correct credentials" $ do + it "invalid wallet" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + ListAccounts + (AccountsParams 17) + case res of + Left e -> assertFailure e + Right r -> + r `shouldBe` + ErrorResponse "zh" (-32008) "Wallet does not exist." + it "valid wallet, no accounts" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + ListAccounts + (AccountsParams 1) + case res of + Left e -> assertFailure e + Right r -> + r `shouldBe` + ErrorResponse + "zh" + (-32002) + "No accounts available for this wallet. Please create one first" + describe "getnewaccount" $ do + it "invalid credentials" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + "baduser" + "idontknow" + GetNewAccount + BlankParams + res `shouldBe` Left "Invalid credentials" + describe "correct credentials" $ do + it "invalid wallet" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + GetNewAccount + (NameIdParams "Personal" 17) + case res of + Left e -> assertFailure e + Right r -> + r `shouldBe` + ErrorResponse "zh" (-32008) "Wallet does not exist." + it "valid wallet" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + GetNewAccount + (NameIdParams "Personal" 1) + case res of + Left e -> assertFailure e + Right r -> r `shouldBe` NewItemResponse "zh" 1 + it "valid wallet, duplicate name" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + GetNewAccount + (NameIdParams "Personal" 1) + case res of + Left e -> assertFailure e + Right r -> + r `shouldBe` + ErrorResponse + "zh" + (-32007) + "Entity with that name already exists." + describe "listaccounts" $ do + it "valid wallet" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + ListAccounts + (AccountsParams 1) + case res of + Left e -> assertFailure e + Right r -> + r `shouldBe` + AccountListResponse "zh" [ZcashAccountAPI 1 1 "Personal"] + describe "Addresses" $ do + describe "listaddresses" $ do + it "bad credentials" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + "baduser" + "idontknow" + ListAddresses + BlankParams + res `shouldBe` Left "Invalid credentials" + it "correct credentials, no addresses" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + ListAddresses + (AddressesParams 1) + case res of + Left e -> assertFailure e + Right r -> + r `shouldBe` + ErrorResponse + "zh" + (-32003) + "No addresses available for this account. Please create one first" + describe "getnewaddress" $ do + it "bad credentials" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + "baduser" + "idontknow" + GetNewAddress + BlankParams + res `shouldBe` Left "Invalid credentials" + describe "correct credentials" $ do + it "invalid account" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + GetNewAddress + (NewAddrParams 17 "Business" False False) + case res of + Left e -> assertFailure e + Right r -> + r `shouldBe` + ErrorResponse "zh" (-32006) "Account does not exist." + it "valid account" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + GetNewAddress + (NewAddrParams 1 "Business" False False) + case res of + Left e -> assertFailure e + Right (NewAddrResponse i a) -> zd_name a `shouldBe` "Business" + Right _ -> assertFailure "unexpected response" + it "valid account, duplicate name" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + GetNewAddress + (NewAddrParams 1 "Business" False False) + case res of + Left e -> assertFailure e + Right r -> + r `shouldBe` + ErrorResponse + "zh" + (-32007) + "Entity with that name already exists." + it "valid account, no sapling" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + GetNewAddress + (NewAddrParams 1 "NoSapling" True False) + case res of + Left e -> assertFailure e + Right (NewAddrResponse i a) -> zd_legacy a `shouldBe` Nothing + Right _ -> assertFailure "unexpected response" + it "valid account, no transparent" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + GetNewAddress + (NewAddrParams 1 "NoTransparent" False True) + case res of + Left e -> assertFailure e + Right (NewAddrResponse i a) -> + zd_transparent a `shouldBe` Nothing + Right _ -> assertFailure "unexpected response" + it "valid account, orchard only" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + GetNewAddress + (NewAddrParams 1 "OrchOnly" True True) + case res of + Left e -> assertFailure e + Right (NewAddrResponse i a) -> + a `shouldSatisfy` + (\b -> + (zd_transparent b == Nothing) && (zd_legacy b == Nothing)) + Right _ -> assertFailure "unexpected response" + describe "listaddresses" $ do + it "correct credentials, addresses exist" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + ListAddresses + (AddressesParams 1) + case res of + Left e -> assertFailure e + Right (AddressListResponse i a) -> length a `shouldBe` 4 + describe "Notes" $ do + describe "listreceived" $ do + it "bad credentials" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + "baduser" + "idontknow" + ListReceived + BlankParams + res `shouldBe` Left "Invalid credentials" + describe "correct credentials" $ do + it "no parameters" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + ListReceived + BlankParams + case res of + Left e -> assertFailure e + Right (ErrorResponse i c m) -> c `shouldBe` (-32602) + it "unknown index" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + ListReceived + (NotesParams "17") + case res of + Left e -> assertFailure e + Right (ErrorResponse i c m) -> c `shouldBe` (-32004) + describe "Balance" $ do + describe "getbalance" $ do + it "bad credentials" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + "baduser" + "idontknow" + GetBalance + BlankParams + res `shouldBe` Left "Invalid credentials" + describe "correct credentials" $ do + it "no parameters" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + GetBalance + BlankParams + case res of + Left e -> assertFailure e + Right (ErrorResponse i c m) -> c `shouldBe` (-32602) + it "unknown index" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + GetBalance + (BalanceParams 17) + case res of + Left e -> assertFailure e + Right (ErrorResponse i c m) -> c `shouldBe` (-32006) + describe "Operations" $ do + describe "getoperationstatus" $ do + it "bad credentials" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + "baduser" + "idontknow" + GetOperationStatus + BlankParams + res `shouldBe` Left "Invalid credentials" + describe "correct credentials" $ do + it "invalid ID" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + GetOperationStatus + (NameParams "badId") + case res of + Left e -> assertFailure e + Right (ErrorResponse i c m) -> c `shouldBe` (-32602) + it "valid ID" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + GetOperationStatus + (OpParams + (ZenithUuid $ + fromMaybe U.nil $ + U.fromText "bd2aa95a-db51-4cc4-9fea-0f9cf79003a4")) + case res of + Left e -> assertFailure e + Right (OpResponse i o) -> + operationUuid o `shouldBe` + (ZenithUuid $ + fromMaybe U.nil $ + U.fromText "bd2aa95a-db51-4cc4-9fea-0f9cf79003a4") + Right _ -> assertFailure "unexpected response" + it "valid ID not found" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + GetOperationStatus + (OpParams + (ZenithUuid $ + fromMaybe U.nil $ + U.fromText "bd2aa95a-db51-4cc4-9fea-0f9cf79003a5")) + case res of + 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 + putStrLn "Starting test RPC server" + checkDbFile <- doesFileExist "test.db" + when checkDbFile $ removeFile "test.db" + let ctx = authenticate config :. EmptyContext + w <- + try $ checkZebra (c_zebraHost config) (c_zebraPort config) :: IO + (Either IOError ZebraGetInfo) + case w of + Right zebra -> do + bc <- + try $ checkBlockChain (c_zebraHost config) (c_zebraPort config) :: IO + (Either IOError ZebraGetBlockChainInfo) + case bc of + Left e1 -> throwIO e1 + Right chainInfo -> do + x <- initDb "test.db" + case x of + Left e2 -> throwIO $ userError e2 + Right x' -> do + pool <- runNoLoggingT $ initPool "test.db" + ts <- getCurrentTime + y <- + saveOperation + pool + (Operation + (ZenithUuid $ + fromMaybe U.nil $ + U.fromText "bd2aa95a-db51-4cc4-9fea-0f9cf79003a4") + ts + Nothing + Processing + Nothing) + let myState = + State + (zgb_net chainInfo) + (c_zebraHost config) + (c_zebraPort config) + "test.db" + (zgi_build zebra) + (zgb_blocks chainInfo) + forkIO $ + run (c_zenithPort config) $ + serveWithContext + (Servant.Proxy :: Servant.Proxy ZenithRPC) + ctx + (zenithServer myState) + threadDelay 1000000 + putStrLn "Test server is up!" + +-- | Make a Zebra RPC call +makeZenithCall :: + T.Text -- ^ Hostname for `zebrad` + -> Int -- ^ Port for `zebrad` + -> BS.ByteString + -> BS.ByteString + -> ZenithMethod -- ^ RPC method to call + -> ZenithParams -- ^ List of parameters + -> IO (Either String ZenithResponse) +makeZenithCall host port usr pwd m params = do + let payload = RpcCall "2.0" "zh" m params + let myRequest = + setRequestBodyJSON payload $ + setRequestPort port $ + setRequestHost (E.encodeUtf8 host) $ + setRequestBasicAuth usr pwd $ setRequestMethod "POST" defaultRequest + r <- httpJSONEither myRequest + case getResponseStatusCode r of + 403 -> return $ Left "Invalid credentials" + 200 -> + case getResponseBody r of + Left e -> return $ Left $ show e + Right r' -> return $ Right r' + e -> return $ Left $ show e ++ show (getResponseBody r) diff --git a/test/Spec.hs b/test/Spec.hs index 35fb3a1..ca66599 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,19 +1,40 @@ {-# LANGUAGE OverloadedStrings #-} +import Codec.Borsh import Control.Monad (when) -import Control.Monad.Logger (runNoLoggingT) +import Control.Monad.Logger (runFileLoggingT, runNoLoggingT) +import Data.Aeson +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS import Data.HexString +import Data.List (foldl') +import Data.Maybe (fromJust) 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) +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 @@ -21,20 +42,32 @@ 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 main :: IO () @@ -121,68 +154,15 @@ 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 "zenith.db" + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" res <- selectUnspentNotes pool (toSqlKey 1) 14000000 res `shouldNotBe` ([], [], []) it "Value greater than balance" $ do - pool <- runNoLoggingT $ initPool "zenith.db" + 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 "zenith.db" - res <- selectUnspentNotes pool (toSqlKey 1) 14000000 - calculateTxFee res 3 `shouldBe` 20000 describe "Testing validation" $ do it "Unified" $ do let a = @@ -195,7 +175,7 @@ main = do (case decodeTransparentAddress (E.encodeUtf8 a) of Just _a3 -> True Nothing -> - case decodeExchangeAddress a of + case decodeExchangeAddress (E.encodeUtf8 a) of Just _a4 -> True Nothing -> False)) it "Sapling" $ do @@ -209,7 +189,7 @@ main = do (case decodeTransparentAddress (E.encodeUtf8 a) of Just _a3 -> True Nothing -> - case decodeExchangeAddress a of + case decodeExchangeAddress (E.encodeUtf8 a) of Just _a4 -> True Nothing -> False)) it "Transparent" $ do @@ -222,7 +202,7 @@ main = do (case decodeTransparentAddress (E.encodeUtf8 a) of Just _a3 -> True Nothing -> - case decodeExchangeAddress a of + case decodeExchangeAddress (E.encodeUtf8 a) of Just _a4 -> True Nothing -> False)) it "Check Sapling Address" $ do @@ -233,21 +213,893 @@ main = do a `shouldBe` Just "ztestsapling1tgjr4zppwk4ne8xy6gdq4z2gwq7dmf5jq8z2ctpn8nlmtse0a74fa5z0m8z383gmpgqz6q6duu4" - {-describe "Creating Tx" $ do-} - {-xit "To Orchard" $ do-} - {-let uaRead =-} - {-isValidUnifiedAddress-} - {-"utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax"-} - {-case uaRead of-} - {-Nothing -> assertFailure "wrong address"-} - {-Just ua -> do-} - {-tx <--} - {-prepareTx-} - {-"zenith.db"-} - {-TestNet-} - {-(toSqlKey 1)-} - {-2819811-} - {-0.04-} - {-ua-} - {-"sent with Zenith, test"-} - {-tx `shouldBe` Right (hexString "deadbeef")-} + 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" + 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 <- + runFileLoggingT "test.log" $ 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" + 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" + 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 <- + runFileLoggingT "zenith.log" $ + 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 <- + runFileLoggingT "zenith.log" $ + 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 <- + runFileLoggingT "zenith.log" $ + 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 <- + runFileLoggingT "zenith.log" $ + 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 <- + runFileLoggingT "zenith.log" $ + 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 <- + runFileLoggingT "zenith.log" $ + 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 <- + runFileLoggingT "zenith.log" $ + 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 <- + runFileLoggingT "zenith.log" $ + 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 <- + runFileLoggingT "zenith.log" $ + 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 <- + runFileLoggingT "zenith.log" $ + 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 <- + runFileLoggingT "zenith.log" $ + 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 <- + runFileLoggingT "zenith.log" $ + 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 <- + runFileLoggingT "zenith.log" $ + 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 <- + runFileLoggingT "zenith.log" $ + 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" diff --git a/zcash-haskell b/zcash-haskell index e807441..d45bd7d 160000 --- a/zcash-haskell +++ b/zcash-haskell @@ -1 +1 @@ -Subproject commit e8074419cfb54559a4c09731ad2448d5930869a2 +Subproject commit d45bd7dcf3c3cf4e893900a1774d24b14bf56591 diff --git a/zenith-openrpc.json b/zenith-openrpc.json new file mode 100644 index 0000000..53cb005 --- /dev/null +++ b/zenith-openrpc.json @@ -0,0 +1,900 @@ +{ + "openrpc": "1.0.0-rc1", + "info": { + "version": "0.7.0.0-beta", + "title": "Zenith RPC", + "description": "The RPC methods to interact with the Zenith Zcash wallet", + "license": { + "name": "MIT", + "url": "https://choosealicense.com/licenses/mit/" + } + }, + "servers": [ + { + "name": "Zenith RPC", + "summary": "The Zenith wallet RPC server", + "description": "This is the server that allows programmatic interaction with the Zenith Zcash wallet via RPC", + "url": "http://localhost:8234" + } + ], + "methods": [ + { + "name": "getinfo", + "summary": "Get basic Zenith information", + "description": "Get basic information about Zenith, such as the network it is running on and the version of Zebra it is connected to", + "tags": [], + "result" : { + "name": "Zenith information", + "schema": { "$ref": "#/components/schemas/ZenithInfo" } + }, + "params" : [], + "examples": [ + { + "name": "GetInfo example", + "summary": "Get information from Zenith", + "description": "Gets the status of the Zenith wallet server", + "params": [], + "result": { + "name": "GetInfo result", + "value": { + "version": "0.7.0.0-beta", + "network": "TestNet", + "zebraVersion": "v1.8.0" + } + } + + } + ], + "errors": [ + { "$ref": "#/components/errors/ZebraNotAvailable" } + ] + }, + { + "name": "listwallets", + "summary": "Get the list of available wallets", + "description": "Returns a list of available wallets per the network that the Zebra node is running on.", + "tags": [], + "result": { + "name": "Wallets", + "schema": { + "type": "array", + "items": { + "$ref": "#/components/schemas/ZcashWallet" + } + } + }, + "params": [], + "examples": [ + { + "name": "ListWallets example", + "summary": "Get list of wallets", + "description": "Get the list of wallets available in Zenith for the current network (Mainnet/Testnet)", + "params": [], + "result": { + "name": "ListWallets result", + "value": [ + { + "birthday": 2762066, + "index": 1, + "lastSync": 2919374, + "name": "Main", + "network": "TestNet" + }, + { + "birthday": 2798877, + "index": 2, + "lastSync": 2894652, + "name": "zcashd", + "network": "TestNet" + } + ] + } + + } + ], + "errors": [ + { "$ref": "#/components/errors/ZebraNotAvailable" }, + { "$ref": "#/components/errors/NoWallets" } + ] + }, + { + "name": "getnewwallet", + "summary": "Create a new wallet", + "description": "Create a new wallet for Zenith.", + "tags": [], + "params": [ + { "$ref": "#/components/contentDescriptors/Name"} + ], + "paramStructure": "by-position", + "result": { + "name": "Wallet", + "schema": { + "$ref": "#/components/contentDescriptors/WalletId" + } + }, + "examples": [ + { + "name": "GetNewWallet example", + "summary": "Create a wallet", + "description": "Creates a new wallet with the given name", + "params": [ + { + "name": "Wallet name", + "summary": "The user-friendly name for the wallet", + "value": "Main" + } + ], + "result": { + "name": "GetNewWallet result", + "value": 1 + } + } + ], + "errors": [ + { "$ref": "#/components/errors/ZebraNotAvailable" }, + { "$ref": "#/components/errors/ZenithBusy" }, + { "$ref": "#/components/errors/DuplicateName" } + ] + }, + { + "name": "listaccounts", + "summary": "List existing accounts for a wallet ID", + "description": "List existing accounts for the given wallet ID or provide an error if none", + "tags": [], + "result": { + "name": "Accounts", + "schema": { + "type": "array", + "items": { + "$ref": "#/components/schemas/ZcashAccount" + } + } + }, + "params": [{ "$ref": "#/components/contentDescriptors/WalletId"}], + "paramStructure": "by-position", + "examples": [ + { + "name": "ListAccounts example", + "summary": "Get list of accounts", + "description": "Get the list of accounts available in Zenith for the given wallet ID", + "params": [ + { + "name": "walletId", + "summary": "The integer ID of the wallet to use", + "value": 1 + } + ], + "result": { + "name": "ListAccounts result", + "value": [ + { + "index": 3, + "name": "Business", + "wallet": 1 + }, + { + "index": 1, + "name": "Savings", + "wallet": 1 + } + ] + } + + } + ], + "errors": [ + { "$ref": "#/components/errors/ZebraNotAvailable" }, + { "$ref": "#/components/errors/NoAccounts" } + ] + }, + { + "name": "getnewaccount", + "summary": "Create a new account", + "description": "Create a new account in the given wallet.", + "tags": [], + "params": [ + { "$ref": "#/components/contentDescriptors/Name"}, + { "$ref": "#/components/contentDescriptors/WalletId"} + ], + "paramStructure": "by-position", + "result": { + "name": "Account", + "schema": { + "$ref": "#/components/contentDescriptors/AccountId" + } + }, + "examples": [ + { + "name": "GetNewAccount example", + "summary": "Create an account", + "description": "Creates a new account with the given name", + "params": [ + { + "name": "Account name", + "summary": "The user-friendly name for the Account", + "value": "Personal" + }, + { + "name": "Wallet Id", + "summary": "The internal index of the Wallet to use", + "value": 1 + } + ], + "result": { + "name": "GetNewAccount result", + "value": 1 + } + } + ], + "errors": [ + { "$ref": "#/components/errors/ZebraNotAvailable" }, + { "$ref": "#/components/errors/DuplicateName" }, + { "$ref": "#/components/errors/ZenithBusy" }, + { "$ref": "#/components/errors/InvalidWallet" } + ] + }, + { + "name": "listaddresses", + "summary": "List existing addresses for an account ID", + "description": "List existing addresses for the given account ID or provide an error if none", + "tags": [], + "result": { + "name": "Addresses", + "schema": { + "type": "array", + "items": { + "$ref": "#/components/schemas/ZcashAddress" + } + } + }, + "params": [{ "$ref": "#/components/contentDescriptors/AccountId"}], + "paramStructure": "by-position", + "examples": [ + { + "name": "ListAddresses example", + "summary": "Get list of addresses", + "description": "Get the list of addresses available in Zenith for the given account ID", + "params": [ + { + "name": "accountId", + "summary": "The integer ID of the account to use", + "value": 1 + } + ], + "result": { + "name": "ListAddresses result", + "value": [ + { + "index": 3, + "account": 1, + "name": "Clothes", + "ua": "utest13dq4u4dnf3yddw8lq2n6zdclshra6xsp8zgkc5ydyu6k20zrsscmuex46qa4vh84rgd78sqnlleapznnz7mnzx9wv0unts8pv32paj8se5ca3kves2u4a89uy6e8cf4hnarxydxh7hq2e9uu39punfmm53k5h45xn9k3dx35la8j7munh9td7774m8gkqgc4mn40t69w20uu2gtks7a", + "legacy": "ztestsapling188csdsvhdny25am8ume03qr2026hdy03zpg5pq7jmmfxtxtct0e93p0rg80yfxvynqd4gwlwft5", + "transparent": "tmMouLwVfRYrF91fWjDJToivmsTWBhxfX4E" + }, + { + "index": 2, + "account": 1, + "name": "Vacation", + "ua": "utest1hhggl4nxfdx63evps6r7qz50cgacgtdpt9k7dl0734w63zn5qmrp6c2xdv9rkqyfkj6kgau4kz48xtm80e67l534qp02teqq86zuzetxql6z5v32yglg9n2un5zsu0hwcvaunzdfg5qnry6syh2dh9x8eu27de03j9pjfvrqda6acgtc6f0emdfh6r5jvfanmjml4ms5wwj9wfqmamq", + "legacy": "ztestsapling1mpup3xv2k9clxaf9wjcr0dt5gnmkprz9s9qsn298mqs356pf39wmh30q3pgsp0w5vyrmj6mrzw2", + "transparent": "tmX8qCB96Dq49YZkww3bSty7eZDA4Fq6F4R" + } + ] + } + + } + ], + "errors": [ + { "$ref": "#/components/errors/NoAddress" } + ] + }, + { + "name": "getnewaddress", + "summary": "Add a new address", + "description": "Derive a new address in the given account.", + "tags": [], + "params": [ + { "$ref": "#/components/contentDescriptors/AccountId"}, + { "$ref": "#/components/contentDescriptors/Name"}, + { "$ref": "#/components/contentDescriptors/ExcludeSapling"}, + { "$ref": "#/components/contentDescriptors/ExcludeTransparent"} + ], + "result": { + "name": "Address", + "schema": { + "$ref": "#/components/schemas/ZcashAddress" + } + }, + "examples": [ + { + "name": "GetNewAddress example", + "summary": "Get a new address for the given account", + "description": "Get a new address for the given account with an Orchard receiver, a Sapling receiver and a transparent receiver (default)", + "params": [ + { + "name": "Account Id", + "summary": "The account index", + "value": 1 + }, + { + "name": "Name", + "summary": "User-friendly name for the address", + "value": "AllRecvs" + } + ], + "result": + { + "name": "Default receivers", + "value": { + "index": 14, + "account": 1, + "name": "AllRecvs", + "ua": "utest1as2fhusjt5r7xl8963jnkkums6gue6qvu7fpw2cvrctwnwrku9r4av9zmmjt7mmet927cq9z4z0hq2w7tpm7qa8lzl5fyj6d83un6v3q78c76j7thpuzyzr260apm8xvjua5fvmrfzy59mpurec7tfamp6nd6eq95pe8vzm69hfsfea29u4v3a6lyuaah20c4k6rvf9skz35ct2r54z", + "legacy": "ztestsapling1esn0wamf8w3nz2juwryscc3l8e5xtll6aewx0r2h5xtmrpnzsw2k23lec65agn8v59r72v2krrh", + "transparent": "tmMteg5HxFnmn4mbm2UNEGzWgLX16bGLg16" + } + } + }, + { + "name": "GetNewAddress - no transparent", + "summary": "Get a new address for the given account with no transparent receiver", + "description": "Get a new address for the given account with an Orchard receiver, a Sapling receiver and *no* transparent receiver (default)", + "params": [ + { + "name": "Account Id", + "summary": "The account index", + "value": 1 + }, + { + "name": "Name", + "summary": "User-friendly name for the address", + "value": "NoTransparent" + }, + { + "name": "ExcludeTransparent", + "summary": "Option to exclude transparent receivers from the address", + "value": "ExcludeTransparent" + } + ], + "result": + { + "name": "NoTransparent", + "value": { + "index": 15, + "account": 1, + "name": "NoTransparent", + "ua": "utest1l0t3uzadaxa4jg7qatsfwqdvfp0qtedyyall65hm2nzwnwdmcvd7j4z6wdrftpsjxv8aw4qh0hka3wdqj0z48xrhg356dlapy36ug6tt20tkzavwccjfup8wy8sdkcc60rpf400mwek73n0ph9jyw9ae60rm5jt8rx75nzhyuymern2t", + "legacy": "ztestsapling1vp3kzw7rqldfvaw5edfgqq66qm0xnexmscwnys220403mqqh9uyl0sqsye37aelrese42y8ecnx", + "transparent": null + } + } + }, + { + "name": "GetNewAddress - no Sapling", + "summary": "Get a new address for the given account with no Sapling receiver", + "description": "Get a new address for the given account with an Orchard receiver and a transparent receiver, and *no* Sapling receiver.", + "params": [ + { + "name": "Account Id", + "summary": "The account index", + "value": 1 + }, + { + "name": "Name", + "summary": "User-friendly name for the address", + "value": "NoSapling" + }, + { + "name": "ExcludeSapling", + "summary": "Option to exclude Sapling receivers from the address", + "value": "ExcludeSapling" + } + ], + "result": + { + "name": "NoSapling", + "value": { + "index": 16, + "account": 3, + "name": "NoSapling", + "ua": "utest14yvw4msvn9r5nggv2s0yye8phqwrhsx8ddfvpg30zp4gtf928myaua8jwxssl7frr8eagvcrsa8tuu9dlh7cvksv3lkudvyrq2ysrtzate0dud7x0zhgz26wqccn8w7346v4kfagv3e", + "legacy": null, + "transparent": "tmQ7z6q46NLQXpeNkfeRL6wJwJWA4picf6b" + } + } + }, + { + "name": "GetNewAddress - Orchard only", + "summary": "Get a new address for the given account with only an Orchard receiver", + "description": "Get a new address for the given account with an Orchard receiver and *no* transparent receiver, and *no* Sapling receiver.", + "params": [ + { + "name": "Account Id", + "summary": "The account index", + "value": 1 + }, + { + "name": "Name", + "summary": "User-friendly name for the address", + "value": "OrchardOnly" + }, + { + "name": "ExcludeSapling", + "summary": "Option to exclude Sapling receivers from the address", + "value": "ExcludeSapling" + }, + { + "name": "ExcludeTransparent", + "summary": "Option to exclude transparent receivers from the address", + "value": "ExcludeTransparent" + } + ], + "result": + { + "name": "OrchardOnly", + "value": { + "index": 17, + "account": 3, + "name": "OrchardOnly", + "ua": "utest1890l0xjxcsapk0u7jnqdglzwp04rt4r8zfvh7qx6a76fq96fyxg9xysvklwjymm9xuxzk0578pvv3yzv0w8l5x4run96mahky5defw0m", + "legacy": null, + "transparent": null + } + } + } + ], + "errors": [ + { "$ref": "#/components/errors/InvalidAccount" }, + { "$ref": "#/components/errors/ZenithBusy" }, + { "$ref": "#/components/errors/DuplicateName" } + ] + }, + { + "name": "getbalance", + "summary": "Get the balance of the given account", + "description": "Get the balance of the given account, including any unconfirmed balance.", + "tags": [], + "params": [{ "$ref": "#/components/contentDescriptors/AccountId"}], + "result": { + "name": "Balance", + "schema": { + "type": "object", + "properties": { + "confirmed": {"$ref": "#/components/schemas/Balance" }, + "unconfirmed": {"$ref": "#/components/schemas/Balance" } + } + } + }, + "examples": [ + { + "name": "GetBalance example", + "summary": "Get account balance", + "description": "Provides the balance for the current account, showing the balance for the transparent, Sapling and Orchard pools, both for confirmed notes and unconfirmed notes", + "params": [ + { + "name": "accountId", + "summary": "The integer ID of the account to use", + "value": 1 + } + ], + "result": { + "name": "GetBalance result", + "value":{ + "confirmed": { + "orchard": 22210259, + "sapling": 0, + "transparent": 0 + }, + "unconfirmed": { + "orchard": 0, + "sapling": 0, + "transparent": 0 + } + } + } + } + ], + "errors": [ + { "$ref": "#/components/errors/InvalidAccount" } + ] + }, + { + "name": "listreceived", + "summary": "List received transactions", + "description": "List transactions received by the given address.", + "tags": [], + "params": [{ "$ref": "#/components/contentDescriptors/Address"}], + "paramStructure": "by-position", + "result": { + "name": "Transactions", + "schema": { + "type": "array", + "items": { + "$ref": "#/components/schemas/ZcashNote" + } + } + }, + "examples": [ + { + "name": "ListReceived by Id", + "summary": "Get list of notes received by the address ID", + "description": "Provides the list of notes received by the address identified by the index provided as a parameter", + "params": [ + { + "name": "Address index", + "summary": "The index for the address to use", + "value": "1" + } + ], + "result": { + "name": "ListReceived by Id result", + "value": [ + { + "txid": "987fcdb9bd37cbb5b205a8336de60d043f7028bebaa372828d81f3da296c7ef9", + "pool": "p2pkh", + "amount": 0.13773064, + "amountZats": 13773064, + "memo": "", + "confirmed": true, + "blockheight": 2767099, + "blocktime": 1711132723, + "outindex": 0, + "change": false + }, + { + "txid": "186bdbc64f728c9d0be96082e946a9228153e24a70e20d8a82f0601da679e0c2", + "pool": "orchard", + "amount": 0.0005, + "amountZats": 50000, + "memo": "�", + "confirmed": true, + "blockheight": 2801820, + "blocktime": 1713399060, + "outindex": 0, + "change": false + } + ] + } + }, + { + "name": "ListReceived by Address", + "summary": "Get list of notes received by the address", + "description": "Provides the list of notes received by the address provided as a parameter", + "params": [ + { + "name": "Address", + "summary": "The address to use", + "value": "ztestsapling1mpup3xv2k9clxaf9wjcr0dt5gnmkprz9s9qsn298mqs356pf39wmh30q3pgsp0w5vyrmj6mrzw2" + } + ], + "result": { + "name": "ListReceived by Address result", + "value": [ + { + "txid": "2a104393d72d1e62c94654950a92931e786a1f04aa732512597638b5c4a69a91", + "pool": "sapling", + "amount": 0.11447195, + "amountZats": 11447195, + "memo": "�", + "confirmed": true, + "blockheight": 2800319, + "blocktime": 1713301802, + "outindex": 0, + "change": false + } + ] + } + } + ], + "errors": [ + { "$ref": "#/components/errors/ZebraNotAvailable" }, + { "$ref": "#/components/errors/UnknownAddress" }, + { "$ref": "#/components/errors/InvalidAddress" } + ] + }, + { + "name": "sendmany", + "summary": "Send transaction(s)", + "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", + "result": { + "name": "Operation ID(s)", + "schema": { + "type": "array", + "items": { "$ref": "#/components/contentDescriptors/OperationId"} + } + }, + "examples": [ + { + "name": "Send a 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", + "value": [ + { + "address": "utest13dq4u4dnf3yddw8lq2n6zdclshra6xsp8zgkc5ydyu6k20zrsscmuex46qa4vh84rgd78sqnlleapznnz7mnzx9wv0unts8pv32paj8se5ca3kves2u4a89uy6e8cf4hnarxydxh7hq2e9uu39punfmm53k5h45xn9k3dx35la8j7munh9td7774m8gkqgc4mn40t69w20uu2gtks7a", + "amount": 2.45, + "memo": "Simple transaction" + } + ] + } + ], + "result": { + "name": "SendMany result", + "value": [ + "3cc31c07-07cf-4a6e-9190-156c4b8c4088" + ] + } + } + ], + "errors": [ + { "$ref": "#/components/errors/ZebraNotAvailable" }, + { "$ref": "#/components/errors/ZenithBusy" }, + { "$ref": "#/components/errors/InvalidAccount" } + ] + }, + { + "name": "getoperationstatus", + "summary": "Get the status of a Zenith operation", + "description": "Get the status of the given operation", + "tags": [], + "params": [{ "$ref": "#/components/contentDescriptors/OperationId"}], + "paramStructure": "by-position", + "result": { + "name": "Operation", + "schema": { + "$ref": "#/components/schemas/Operation" + } + }, + "errors": [ + { "$ref": "#/components/errors/OpNotFound" } + ] + } + ], + "components": { + "contentDescriptors": { + "WalletId": { + "name": "Wallet ID", + "summary": "The wallet's internal index used for unique identification", + "description": "An Integer value that uniquely identifies a wallet in Zenith", + "required": true, + "schema": { + "type": "integer" + } + }, + "AccountId": { + "name": "Account ID", + "summary": "The account's internal index used for unique identification", + "description": "An Integer value that uniquely identifies an account in Zenith", + "required": true, + "schema": { + "type": "integer" + } + }, + "Address": { + "name": "Address identifier", + "summary": "The address identifier", + "description": "A string that identifies a specific address, either by its index or the [ZIP-316](https://zips.z.cash/zip-0316) encoded address itself", + "required": true, + "schema": { + "type": "string" + } + }, + "Name": { + "name": "Name", + "summary": "A user-friendly name", + "description": "A string that represents an entity in Zenith, like a wallet, an account or an address.", + "required": true, + "schema": { + "type": "string" + } + }, + "ExcludeSapling": { + "name": "ExcludeSapling", + "summary": "Setting that indicates that the new address requested should not contain a Sapling component", + "description": "When this parameter is present, Zenith will generate an address with no Sapling receiver", + "required": false, + "schema" : { + "type": "string" + } + }, + "ExcludeTransparent": { + "name": "ExcludeTransparent", + "summary": "Setting that indicates that the new address requested should not contain a Transparent component", + "description": "When this parameter is present, Zenith will generate an address with no Transparent receiver", + "required": false, + "schema" : { + "type": "string" + } + }, + "OperationId": { + "name": "Operation ID", + "summary": "A unique identifier for Zenith operations", + "description": "A [UUID](http://en.wikipedia.org/wiki/UUID) assigned to an operation (like sending a transaction) that can be used to query Zenith to see the status and outcome of the operation.", + "required": true, + "schema" : { + "type": "string" + } + }, + "TxRequestArray": { + "name": "Transaction Request Array", + "summary": "An array of proposed transactions", + "description": "An array of proposed new outgoing transactions, including the recipient's address, the amount in ZEC, the optional shielded memo, and the optional privacy level.", + "required": true, + "schema": { + "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": { + "ZenithInfo": { + "type": "object", + "properties": { + "version": { "type": "string", "description": "Zenith's version"}, + "network": { "type": "string", "description": "The network the wallet is connected to"}, + "zebraVersion": { "type": "string", "description": "The version of the Zebra node used by Zenith"} + } + }, + "ZcashWallet": { + "type": "object", + "properties": { + "index": { "type": "integer", "description": "Internal index of wallet"}, + "name": { "type": "string", "description": "User-friendly name of the wallet" }, + "network": { "type": "string", "description": "Network the wallet is for. Testnet or MainNet" }, + "birthday": { "type": "integer", "description": "Wallet's birthday height" }, + "lastSync": { "type": "integer", "description": "Last block the wallet is synced to" } + } + }, + "ZcashAccount": { + "type": "object", + "properties": { + "index": { "type": "integer", "description": "Internal index for account"}, + "wallet": { "type": "integer", "description": "ID of the wallet this account belongs to"}, + "name": { "type": "string", "description": "User-friendly name of the account"} + } + }, + "ZcashAddress": { + "type": "object", + "properties": { + "index": { "type": "integer", "description": "Internal index for address"}, + "account": { "type": "integer", "description": "ID of the account this address belongs to"}, + "name": { "type": "string", "description": "User-friendly name of the address"}, + "ua": { "type": "string", "description": "Unified address"}, + "legacy": { "type": "string", "description": "Legacy Sapling address"}, + "transparent": { "type": "string", "description": "Transparent address"} + } + }, + "ZcashNote": { + "type": "object", + "properties": { + "txid": { "type": "string", "description": "Transaction ID"}, + "pool": { "type": "string", "description": "Orchard, Sapling, or Transparent" }, + "amount" : { "type": "number", "description": "The amount of the note in ZEC"}, + "amountZats": { "type": "integer", "description": "The amount of the note in zats"}, + "memo": { "type": "string", "description": "The memo corresponding to the note, if any"}, + "confirmed": { "type": "boolean", "description": "If the note is confirmed per the thresholds in the configuration"}, + "blockheight": { "type": "integer", "description": "The block height containing the transaction"}, + "blocktime": { "type": "integer", "description": "The transaction time in seconds since epoch"}, + "outindex": { "type": "integer", "description": "The Sapling output index, or the Orchard action index"}, + "change": { "type": "boolean", "description": "True if this output was received by a change address"} + } + }, + "Balance": { + "type": "object", + "properties": { + "transparent": { "type": "integer", "description": "Confirmed transparent balance in zats." }, + "sapling": { "type": "integer", "description": "Confirmed Sapling balance in zats." }, + "orchard": { "type": "integer", "description": "Confirmed Orchard balance in zats." } + } + }, + "Operation": { + "type": "object", + "properties": { + "uuid": {"type": "string", "description": "Operation Identifier"}, + "start": {"type": "string", "description": "The date and time the operation started"}, + "end": {"type": ["string", "null"], "description": "The date and time the operation ended. If the operation is still running, this field is null"}, + "status": {"type": "string", "enum": ["Processing", "Failed", "Successful"], "description": "If the operation has started it will show Processing, once it completes it will show Failed or Successful depending on the outcome"}, + "result": {"type": ["string", "null"], "description": "For a succesful transaction operation, the transaction ID. For failed operations, the error message. For pending operations, this field is null."} + } + }, + "TxRequest": { + "type": "object", + "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"} + } + } + }, + "examples": {}, + "tags": { + "draft": {"name": "Draft"}, + "wip": {"name": "WIP"} + }, + "errors": { + "ZebraNotAvailable": { + "code": -32000, + "message": "Zebra not available" + }, + "NoWallets": { + "code": -32001, + "message": "No wallets available. Please create one first" + }, + "NoAccounts": { + "code": -32002, + "message": "No accounts available. Please create one first" + }, + "NoAddress": { + "code": -32003, + "message": "No addresses available for this account. Please create one first" + }, + "UnknownAddress": { + "code": -32004, + "message": "Address does not belong to the wallet" + }, + "InvalidAddress": { + "code": -32005, + "message": "Unable to parse address" + }, + "InvalidAccount": { + "code": -32006, + "message": "Account does not exist." + }, + "DuplicateName": { + "code": -32007, + "message": "Entity with that name already exists." + }, + "InvalidWallet": { + "code": -32008, + "message": "Wallet does not exist." + }, + "OpNotFound": { + "code": -32009, + "message": "Operation ID not found." + }, + "InternalError": { + "code": -32010, + "message": "Varies" + }, + "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 2aacd50..5ee487b 100644 --- a/zenith.cabal +++ b/zenith.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: zenith -version: 0.6.0.0-beta +version: 0.7.0.0-beta license: MIT license-file: LICENSE author: Rene Vergara @@ -35,56 +35,65 @@ library Zenith.Utils Zenith.Zcashd Zenith.Scanner + Zenith.RPC + Zenith.Tree hs-source-dirs: src build-depends: Clipboard + , Hclip + , JuicyPixels , aeson , array , ascii-progress + , async , base >=4.12 && <5 , base64-bytestring + , binary + , borsh , brick , bytestring + , configurator , data-default , directory - , filepath , esqueleto - , resource-pool - , binary , exceptions - , monad-logger - , vty-crossplatform - , secp256k1-haskell >= 1 - , pureMD5 + , filepath , ghc + , generics-sop , haskoin-core , hexstring , http-client , http-conduit , http-types - , JuicyPixels - , qrcode-core - , qrcode-juicypixels , microlens , microlens-mtl , microlens-th + , monad-logger + , transformers , monomer , mtl , persistent - , Hclip , persistent-sqlite , persistent-template , process + , pureMD5 + , qrcode-core + , qrcode-juicypixels , regex-base , regex-compat , regex-posix + , resource-pool , scientific + , secp256k1-haskell >= 1 + , servant-server , text , text-show , time + , uuid , vector , vty + , vty-crossplatform , word-wrap , zcash-haskell --pkgconfig-depends: rustzcash_wrapper @@ -110,15 +119,21 @@ executable zenith pkgconfig-depends: rustzcash_wrapper default-language: Haskell2010 -executable zenscan - ghc-options: -main-is ZenScan -threaded -rtsopts -with-rtsopts=-N - main-is: ZenScan.hs +executable zenithserver + ghc-options: -main-is Server -threaded -rtsopts -with-rtsopts=-N + main-is: Server.hs hs-source-dirs: app build-depends: base >=4.12 && <5 , configurator , monad-logger + , wai-extra + , warp + , servant-server + , text + , unix + , zcash-haskell , zenith pkgconfig-depends: rustzcash_wrapper default-language: Haskell2010 @@ -132,8 +147,11 @@ test-suite zenith-tests build-depends: base >=4.12 && <5 , bytestring + , aeson , configurator , monad-logger + , borsh + , aeson , data-default , sort , text @@ -148,3 +166,34 @@ test-suite zenith-tests , zenith pkgconfig-depends: rustzcash_wrapper default-language: Haskell2010 + +test-suite zenithserver-tests + type: exitcode-stdio-1.0 + ghc-options: -threaded -rtsopts -with-rtsopts=-N + main-is: ServerSpec.hs + hs-source-dirs: + test + build-depends: + base >=4.12 && <5 + , bytestring + , aeson + , configurator + , monad-logger + , data-default + , sort + , text + , time + , uuid + , http-conduit + , persistent + , persistent-sqlite + , hspec + , hexstring + , warp + , servant-server + , HUnit + , directory + , zcash-haskell + , zenith + pkgconfig-depends: rustzcash_wrapper + default-language: Haskell2010