diff --git a/.gitignore b/.gitignore index 1c231fa..00967d7 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,7 @@ .stack-work/ *~ dist-newstyle/ +zenith.db +zenith.log +zenith.db-shm +zenith.db-wal diff --git a/.gitmodules b/.gitmodules index 53b8dda..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 = dev040 + branch = master diff --git a/CHANGELOG.md b/CHANGELOG.md index 2ebaabf..30d4a3d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,121 @@ 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.1.0-beta] + +### Changed + +- Removed workaround to obtain block time + +## [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 + +- GUI module +- Address list +- Transaction list +- Balance display +- Account selector +- Menu for new addresses, accounts, wallets +- Dialog to display and copy seed phrase +- Dialog to add new address +- Dialog to add new account +- Dialog to add new wallet +- Dialog to display transaction details and copy TX ID +- Dialog to send a new transaction +- Dialog to display Tx ID after successful broadcast +- Unconfirmed balance display on TUI and GUI +- Tracking of unconfirmed notes + +### Changed + +- Upgraded to GHC 9.6.5 +- Implemented config and data folder +- Improved the `configure` script for installation + +### Fixed + +- Validation of input of amount for sending in TUI + +### Removed + +- Legacy interface to `zcashd` + +## [0.5.3.1-beta] + +### Added + +- Docker image + +## [0.5.3.0-beta] + +### Added + +- Address Book functionality. Allows users to store frequently used zcash addresses and + generate transactions using them. + +### Changed + +- Improved formatting of sync progress + +### Fixed + +- Wallet sync when no new block has been detected on-chain. + +## [0.5.2.0-beta] + +### Changed + +- Update to `zcash-haskell-0.6.2.0` to increase performance of transaction creation + +### Fixed + +- Truncation of transaction ID when displaying a successfully sent transaction +- Missing command in menu for Send + +## [0.5.1.1-beta.1] + +### Changed + +- Installation instructions in README + +## [0.5.1.1-beta] + +### Added + +- Implement CLI changes to send transactions + ## [0.5.0.0] ### Added diff --git a/README.md b/README.md index efabca0..bce5523 100644 --- a/README.md +++ b/README.md @@ -21,6 +21,7 @@ Zenith is a wallet for the [Zebra](https://zfnd.org/zebra/) Zcash node . It has - Listing transactions for specific addresses, decoding memos for easy reading. - Copying addresses to the clipboard. - Sending transactions with shielded memo support. +- Address Book for storing frequently used zcash addresses ## Installation diff --git a/app/Main.hs b/app/Main.hs index 5911cfc..f3d4b4c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -11,18 +11,20 @@ import Data.Sort import qualified Data.Text as T import qualified Data.Text.IO as TIO import Data.Time.Clock.POSIX -import System.Console.StructuredCLI + +{-import System.Console.StructuredCLI-} import System.Environment (getArgs) import System.Exit 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 - + {- prompt :: String -> IO String prompt text = do putStr text @@ -196,21 +198,25 @@ processUri user pwd = _ -> False _ <- liftIO $ sendWithUri user pwd (addList !! (idx - 1)) u repTo return NoAction +-} main :: IO () main = do - config <- load ["zenith.cfg"] + config <- load ["$(HOME)/Zenith/zenith.cfg"] args <- getArgs - dbFilePath <- require config "dbFilePath" + 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 of - "legacy" -> do + case head args + {-"legacy" -> do checkServer nodeUser nodePwd void $ runCLI @@ -219,9 +225,12 @@ main = do { getBanner = " ______ _ _ _ \n |___ / (_) | | | \n / / ___ _ __ _| |_| |__ \n / / / _ \\ '_ \\| | __| '_ \\ \n / /_| __/ | | | | |_| | | |\n /_____\\___|_| |_|_|\\__|_| |_|\n Zcash Full Node CLI v0.4.0" } - (root nodeUser nodePwd) - "cli" -> runZenithCLI myConfig - "rescan" -> clearSync myConfig + (root nodeUser nodePwd) -} + of + "gui" -> runZenithGUI myConfig + "tui" -> runZenithTUI myConfig + "rescan" -> rescanZebra zebraHost zebraPort dbFilePath + "resync" -> clearSync myConfig _ -> printUsage else printUsage @@ -229,6 +238,7 @@ printUsage :: IO () printUsage = do putStrLn "zenith [command] [parameters]\n" putStrLn "Available commands:" - putStrLn "legacy\tLegacy CLI for zcashd" - putStrLn "cli\tCLI for zebrad" + {-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..e18e47c --- /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.8.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/assets/1F616_color.png b/assets/1F616_color.png new file mode 100644 index 0000000..ac48165 Binary files /dev/null and b/assets/1F616_color.png differ diff --git a/assets/1F928_color.png b/assets/1F928_color.png new file mode 100644 index 0000000..10095c0 Binary files /dev/null and b/assets/1F928_color.png differ diff --git a/assets/1F993.png b/assets/1F993.png new file mode 100644 index 0000000..290f365 Binary files /dev/null and b/assets/1F993.png differ diff --git a/assets/2620_color.png b/assets/2620_color.png new file mode 100644 index 0000000..ecfdc10 Binary files /dev/null and b/assets/2620_color.png differ diff --git a/assets/Atkinson-Hyperlegible-Bold-102.ttf b/assets/Atkinson-Hyperlegible-Bold-102.ttf new file mode 100644 index 0000000..14b7196 Binary files /dev/null and b/assets/Atkinson-Hyperlegible-Bold-102.ttf differ diff --git a/assets/Atkinson-Hyperlegible-BoldItalic-102.ttf b/assets/Atkinson-Hyperlegible-BoldItalic-102.ttf new file mode 100644 index 0000000..4532705 Binary files /dev/null and b/assets/Atkinson-Hyperlegible-BoldItalic-102.ttf differ diff --git a/assets/Atkinson-Hyperlegible-Font-License-2020-1104.pdf b/assets/Atkinson-Hyperlegible-Font-License-2020-1104.pdf new file mode 100644 index 0000000..afe27dc Binary files /dev/null and b/assets/Atkinson-Hyperlegible-Font-License-2020-1104.pdf differ diff --git a/assets/Atkinson-Hyperlegible-Italic-102.ttf b/assets/Atkinson-Hyperlegible-Italic-102.ttf new file mode 100644 index 0000000..89e5ce4 Binary files /dev/null and b/assets/Atkinson-Hyperlegible-Italic-102.ttf differ diff --git a/assets/Atkinson-Hyperlegible-Regular-102.ttf b/assets/Atkinson-Hyperlegible-Regular-102.ttf new file mode 100644 index 0000000..c4fa6fb Binary files /dev/null and b/assets/Atkinson-Hyperlegible-Regular-102.ttf differ diff --git a/assets/DejaVuSansMono-Bold.ttf b/assets/DejaVuSansMono-Bold.ttf new file mode 100644 index 0000000..b210eb5 Binary files /dev/null and b/assets/DejaVuSansMono-Bold.ttf differ diff --git a/assets/DejaVuSansMono-BoldOblique.ttf b/assets/DejaVuSansMono-BoldOblique.ttf new file mode 100644 index 0000000..3211064 Binary files /dev/null and b/assets/DejaVuSansMono-BoldOblique.ttf differ diff --git a/assets/DejaVuSansMono-Oblique.ttf b/assets/DejaVuSansMono-Oblique.ttf new file mode 100644 index 0000000..ff83b15 Binary files /dev/null and b/assets/DejaVuSansMono-Oblique.ttf differ diff --git a/assets/DejaVuSansMono.ttf b/assets/DejaVuSansMono.ttf new file mode 100644 index 0000000..041cffc Binary files /dev/null and b/assets/DejaVuSansMono.ttf differ diff --git a/assets/OpenMoji-color-glyf_colr_1.ttf b/assets/OpenMoji-color-glyf_colr_1.ttf new file mode 100644 index 0000000..86cf85b Binary files /dev/null and b/assets/OpenMoji-color-glyf_colr_1.ttf differ diff --git a/assets/Roboto-Regular.ttf b/assets/Roboto-Regular.ttf new file mode 100644 index 0000000..8c082c8 Binary files /dev/null and b/assets/Roboto-Regular.ttf differ diff --git a/assets/remixicon.ttf b/assets/remixicon.ttf new file mode 100644 index 0000000..22ce6de Binary files /dev/null and b/assets/remixicon.ttf differ diff --git a/cabal.project b/cabal.project index 217198a..d245ac1 100644 --- a/cabal.project +++ b/cabal.project @@ -2,7 +2,7 @@ packages: ./*.cabal zcash-haskell/zcash-haskell.cabal -with-compiler: ghc-9.4.8 +with-compiler: ghc-9.6.5 source-repository-package type: git diff --git a/cabal.project.freeze b/cabal.project.freeze new file mode 100644 index 0000000..34022e4 --- /dev/null +++ b/cabal.project.freeze @@ -0,0 +1,372 @@ +active-repositories: hackage.haskell.org:merge +constraints: any.Cabal ==3.10.3.0, + any.Cabal-syntax ==3.10.3.0, + any.Clipboard ==2.3.2.0, + any.HUnit ==1.6.2.0, + any.Hclip ==3.0.0.4, + any.JuicyPixels ==3.3.9, + JuicyPixels -mmap, + any.OneTuple ==0.4.2, + any.OpenGLRaw ==3.3.4.1, + OpenGLRaw -osandroid +usegles2 +useglxgetprocaddress +usenativewindowslibraries, + any.QuickCheck ==2.15.0.1, + QuickCheck -old-random +templatehaskell, + any.RSA ==2.4.1, + any.SHA ==1.6.4.4, + SHA -exe, + any.StateVar ==1.2.2, + any.X11 ==1.9.2, + any.adjunctions ==4.4.2, + any.aeson ==2.2.3.0, + aeson +ordered-keymap, + any.alex ==3.5.1.0, + any.ansi-terminal ==1.1.2, + ansi-terminal -example, + any.ansi-terminal-types ==1.1, + any.appar ==0.1.8, + any.array ==0.5.6.0, + any.ascii-progress ==0.3.3.0, + ascii-progress -examples, + any.asn1-encoding ==0.9.6, + any.asn1-parse ==0.9.5, + any.asn1-types ==0.3.4, + any.assoc ==1.1.1, + assoc -tagged, + any.async ==2.2.5, + async -bench, + any.attoparsec ==0.14.4, + attoparsec -developer, + any.attoparsec-aeson ==2.2.2.0, + any.authenticate-oauth ==1.7, + any.auto-update ==0.2.4, + any.base ==4.18.2.1, + any.base-compat ==0.14.1, + any.base-compat-batteries ==0.14.1, + any.base-orphans ==0.9.3, + any.base16 ==1.0, + any.base16-bytestring ==1.0.2.0, + any.base58-bytestring ==0.1.0, + any.base64-bytestring ==1.2.1.0, + any.basement ==0.0.16, + any.bifunctors ==5.6.2, + bifunctors +tagged, + any.bimap ==0.5.0, + any.binary ==0.8.9.1, + any.binary-orphans ==1.0.5, + any.bitvec ==1.1.5.0, + bitvec +simd, + 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.6, + brick -demos, + any.bsb-http-chunked ==0.0.0.4, + any.byteorder ==1.0.4, + any.bytes ==0.17.4, + any.bytestring ==0.11.5.3, + any.bytestring-to-vector ==0.3.0.1, + any.c2hs ==0.28.8, + c2hs +base3 -regression, + any.cabal-doctest ==1.0.11, + any.call-stack ==0.4.0, + any.case-insensitive ==1.2.1.0, + any.cborg ==0.2.10.0, + cborg +optimize-gmp, + any.cereal ==0.5.8.3, + cereal -bytestring-builder, + any.character-ps ==0.1, + any.clock ==0.8.4, + clock -llvm, + any.colour ==2.3.6, + any.comonad ==5.0.9, + comonad +containers +distributive +indexed-traversable, + any.concurrent-output ==1.10.21, + any.conduit ==1.3.6, + any.conduit-extra ==1.3.6, + any.config-ini ==0.2.7.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, + any.cookie ==0.5.0, + any.crypto-api ==0.13.3, + crypto-api -all_cpolys, + any.crypto-pubkey-types ==0.4.3, + any.cryptohash-md5 ==0.11.101.0, + any.cryptohash-sha1 ==0.11.101.0, + any.crypton ==1.0.1, + crypton -check_alignment +integer-gmp -old_toolchain_inliner +support_aesni +support_deepseq +support_pclmuldq +support_rdrand -support_sse +use_target_attributes, + any.crypton-connection ==0.4.3, + any.crypton-x509 ==1.7.7, + any.crypton-x509-store ==1.6.9, + any.crypton-x509-system ==1.6.7, + any.crypton-x509-validation ==1.6.13, + any.cryptonite ==0.30, + cryptonite -check_alignment +integer-gmp -old_toolchain_inliner +support_aesni +support_deepseq -support_pclmuldq +support_rdrand -support_sse +use_target_attributes, + any.data-clist ==0.2, + any.data-default ==0.8.0.0, + any.data-default-class ==0.2.0.0, + 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, + distributive +semigroups +tagged, + any.dlist ==1.0, + dlist -werror, + any.double-conversion ==2.0.5.0, + double-conversion -developer +embedded_double_conversion, + any.easy-file ==0.2.5, + any.entropy ==0.4.1.10, + entropy -donotgetentropy, + any.envy ==2.1.4.0, + any.esqueleto ==3.5.13.1, + any.exceptions ==0.10.7, + any.extra ==1.8, + any.fast-logger ==3.2.5, + any.file-embed ==0.0.16.0, + any.filepath ==1.4.300.1, + any.fixed ==0.3, + any.foreign-rust ==0.1.0, + any.foreign-store ==0.2.1, + any.formatting ==7.2.0, + formatting -no-double-conversion, + any.free ==5.2, + any.generically ==0.1.1, + any.generics-sop ==0.5.1.4, + any.ghc ==9.6.5, + any.ghc-bignum ==1.3, + any.ghc-boot ==9.6.5, + any.ghc-boot-th ==9.6.5, + any.ghc-heap ==9.6.5, + any.ghc-prim ==0.10.0, + any.ghci ==9.6.5, + any.half ==0.3.2, + any.happy ==2.1.3, + any.happy-lib ==2.1.3, + any.hashable ==1.4.7.0, + hashable -arch-native +integer-gmp -random-initial-seed, + any.haskell-lexer ==1.1.2, + any.haskoin-core ==1.1.0, + any.hexstring ==0.12.1.0, + any.hourglass ==0.2.12, + any.hpc ==0.6.2.0, + any.hsc2hs ==0.68.10, + hsc2hs -in-ghc-tree, + any.hspec ==2.11.10, + any.hspec-core ==2.11.10, + any.hspec-discover ==2.11.10, + any.hspec-expectations ==0.8.4, + any.http-api-data ==0.6.1, + http-api-data -use-text-show, + any.http-client ==0.7.17, + http-client +network-uri, + any.http-client-tls ==0.3.6.4, + any.http-conduit ==2.3.9.1, + http-conduit +aeson, + any.http-date ==0.0.11, + any.http-media ==0.8.1.1, + any.http-semantics ==0.3.0, + any.http-types ==0.12.4, + any.http2 ==5.3.9, + http2 -devel -h2spec, + any.indexed-traversable ==0.1.4, + any.indexed-traversable-instances ==0.1.2, + any.integer-conversion ==0.1.1, + any.integer-gmp ==1.1, + any.integer-logarithms ==1.0.3.1, + integer-logarithms -check-bounds +integer-gmp, + any.invariant ==0.6.4, + any.iproute ==1.7.15, + any.kan-extensions ==5.2.6, + any.language-c ==0.10.0, + language-c +iecfpextension +usebytestrings, + any.lens ==5.3.2, + lens -benchmark-uniplate -dump-splices +inlining -j +test-hunit +test-properties +test-templates +trustworthy, + any.lens-aeson ==1.2.3, + any.lift-type ==0.1.2.0, + any.lifted-base ==0.2.3.12, + any.linear ==1.22, + linear -herbie +template-haskell, + any.megaparsec ==9.7.0, + megaparsec -dev, + any.memory ==0.18.0, + memory +support_bytestring +support_deepseq, + any.microlens ==0.4.13.1, + 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, + any.monad-loops ==0.4.3, + monad-loops +base4, + any.mono-traversable ==1.0.21.0, + any.monomer ==1.6.0.1, + monomer -examples, + any.mtl ==2.3.1, + any.murmur3 ==1.0.5, + any.nanovg ==0.8.1.0, + nanovg -examples -gl2 -gles3 -stb_truetype, + any.network ==3.2.7.0, + network -devel, + any.network-byte-order ==0.1.7, + any.network-control ==0.1.3, + any.network-info ==0.2.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.7, + any.parallel ==3.2.2.0, + any.parsec ==3.1.16.1, + any.parser-combinators ==1.3.0, + parser-combinators -dev, + any.path-pieces ==0.2.1, + any.pem ==0.2.4, + any.persistent ==2.14.6.3, + any.persistent-sqlite ==2.13.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, + any.psqueues ==0.2.8.0, + any.pureMD5 ==2.1.4, + pureMD5 -test, + any.qrcode-core ==0.9.10, + any.qrcode-juicypixels ==0.8.6, + 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.9, + reflection -slow +template-haskell, + any.regex-base ==0.94.0.2, + any.regex-compat ==0.95.2.1, + any.regex-posix ==0.96.0.1, + regex-posix -_regex-posix-clib, + any.resource-pool ==0.4.0.0, + any.resourcet ==1.3.0, + any.rts ==1.0.2, + any.safe ==0.3.21, + any.safe-exceptions ==0.1.7.4, + any.scientific ==0.3.8.0, + scientific -integer-simple, + any.sdl2 ==2.5.5.0, + sdl2 -examples -no-linear -opengl-example +pkgconfig +recent-ish, + any.secp256k1-haskell ==1.4.2, + any.semialign ==1.3.1, + semialign +semigroupoids, + any.semigroupoids ==6.0.1, + semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers, + any.semigroups ==0.20, + 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.2, + any.servant-server ==0.20.2, + any.silently ==1.2.5.4, + 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, + any.splitmix ==0.1.0.5, + splitmix -optimised-mixer, + any.stm ==2.5.1.0, + any.stm-chans ==3.0.0.9, + any.streaming-commons ==0.2.2.6, + streaming-commons -use-bytestring-builder, + any.strict ==0.5.1, + any.string-conversions ==0.4.0.1, + any.system-cxx-std-lib ==1.0, + any.tagged ==0.8.9, + tagged +deepseq +transformers, + any.tasty ==1.5.2, + tasty +unix, + any.template-haskell ==2.20.0.0, + any.terminal-size ==0.3.4, + any.terminfo ==0.4.1.6, + any.text ==2.0.2, + any.text-iso8601 ==0.1.1, + any.text-short ==0.1.6, + text-short -asserts, + any.text-show ==3.11, + text-show +integer-gmp, + any.text-zipper ==0.13, + any.tf-random ==0.5, + any.th-abstraction ==0.7.1.0, + any.th-compat ==0.1.6, + any.th-lift ==0.8.6, + any.th-lift-instances ==0.1.20, + any.these ==1.2.1, + any.time ==1.12.2, + any.time-compat ==1.9.7, + any.time-locale-compat ==0.1.1.5, + time-locale-compat -old-locale, + any.time-manager ==0.2.1, + any.tls ==2.1.5, + tls -devel, + any.transformers ==0.6.1.0, + any.transformers-base ==0.4.6, + transformers-base +orphaninstances, + any.transformers-compat ==0.7.2, + transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, + any.typed-process ==0.2.12.0, + any.unix ==2.8.4.0, + any.unix-compat ==0.7.3, + any.unix-time ==0.4.16, + any.unliftio ==0.2.25.0, + any.unliftio-core ==0.2.1.0, + any.unordered-containers ==0.2.20, + unordered-containers -debug, + any.utf8-string ==1.0.2, + any.uuid ==1.3.16, + any.uuid-types ==1.0.6, + any.vault ==0.3.1.5, + vault +useghc, + any.vector ==0.13.2.0, + vector +boundschecks -internalchecks -unsafechecks -wall, + any.vector-algorithms ==0.9.0.3, + vector-algorithms +bench +boundschecks -internalchecks -llvm +properties -unsafechecks, + any.vector-stream ==0.1.0.1, + any.void ==0.7.3, + void -safe, + any.vty ==6.2, + 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.17, + wai-extra -build-example, + any.wai-logger ==2.5.0, + any.warp ==3.4.7, + 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, + zlib -bundled-c-zlib +non-blocking-ffi +pkg-config +index-state: hackage.haskell.org 2024-12-14T09:52:48Z diff --git a/configure b/configure index df9fc8d..25686c1 100755 --- a/configure +++ b/configure @@ -1,6 +1,17 @@ #!/bin/bash - -echo "export PKG_CONFIG_PATH=$HOME/.local/share/zcash-haskell:\$PKG_CONFIG_PATH" | tee -a ~/.bashrc -echo "export LD_LIBRARY_PATH=$HOME/.local/share/zcash-haskell:\$LD_LIBRARY_PATH" | tee -a ~/.bashrc +echo "Configuring Zenith...." +if grep -q "local/share/zcash-haskell" "$HOME/.bashrc"; then + echo "... Paths already exist" +else + # Set Paths + echo "... Adding new zenith paths to local configuration" + echo "export PKG_CONFIG_PATH=$HOME/.local/share/zcash-haskell:\$PKG_CONFIG_PATH" | tee -a ~/.bashrc + echo "export LD_LIBRARY_PATH=$HOME/.local/share/zcash-haskell:\$LD_LIBRARY_PATH" | tee -a ~/.bashrc +fi +echo "... Reloading paths" source ~/.bashrc +echo "... building zcash-haskell" cd zcash-haskell && cabal build +echo +echo "Done" +echo diff --git a/install b/install new file mode 100755 index 0000000..2dc2023 --- /dev/null +++ b/install @@ -0,0 +1,5 @@ +#!/bin/bash + +echo "Deploying Zenith executable..." +ln -s ${PWD}/dist-newstyle/build/x86_64-linux/ghc-9.6.5/zenith-0.6.0.0/build/zenith/zenith ~/.local/bin/zenith +echo "Done." diff --git a/sapling-output.params b/sapling-output.params deleted file mode 100644 index 01760fa..0000000 Binary files a/sapling-output.params and /dev/null differ diff --git a/sapling-spend.params b/sapling-spend.params deleted file mode 100644 index b91cd77..0000000 Binary files a/sapling-spend.params and /dev/null differ diff --git a/src/Zenith/CLI.hs b/src/Zenith/CLI.hs index 73409e8..29157c1 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 @@ -18,6 +19,7 @@ import Brick.Forms , handleFormEvent , invalidFormInputAttr , newForm + , radioField , renderForm , setFieldValid , updateFormState @@ -25,7 +27,7 @@ import Brick.Forms import qualified Brick.Main as M import qualified Brick.Types as BT import Brick.Types (Widget) -import Brick.Util (bg, clamp, fg, on, style) +import Brick.Util (bg, fg, on, style) import qualified Brick.Widgets.Border as B import Brick.Widgets.Border.Style (unicode, unicodeBold) import qualified Brick.Widgets.Center as C @@ -40,6 +42,8 @@ import Brick.Widgets.Core , joinBorders , padAll , padBottom + , padTop + , setAvailableSize , str , strWrap , strWrapWith @@ -49,6 +53,7 @@ import Brick.Widgets.Core , updateAttrMap , vBox , vLimit + , viewport , withAttr , withBorderStyle ) @@ -57,16 +62,24 @@ 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 (toText) +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) +import qualified Data.UUID as U import qualified Data.Vector as Vec import Database.Persist import Database.Persist.Sqlite @@ -76,27 +89,46 @@ import Lens.Micro ((&), (.~), (^.), set) import Lens.Micro.Mtl import Lens.Micro.TH import System.Hclip -import Text.Wrap (FillScope(..), FillStrategy(..), WrapSettings(..), wrapText) -import ZcashHaskell.Keys (generateWalletSeedPhrase, getWalletSeed) -import ZcashHaskell.Orchard (getSaplingFromUA, isValidUnifiedAddress) -import ZcashHaskell.Sapling (decodeSaplingAddress, isValidShieldedAddress) +import Text.Printf +import Text.Wrap (FillScope(..), FillStrategy(..), WrapSettings(..)) +import ZcashHaskell.Keys (generateWalletSeedPhrase) +import ZcashHaskell.Orchard + ( getSaplingFromUA + , isValidUnifiedAddress + , parseAddress + ) import ZcashHaskell.Transparent - ( decodeExchangeAddress - , decodeTransparentAddress + ( decodeTransparentAddress , encodeTransparentReceiver ) import ZcashHaskell.Types import ZcashHaskell.Utils (getBlockTime, makeZebraCall) import Zenith.Core import Zenith.DB -import Zenith.Scanner (processTx) +import Zenith.Scanner (checkIntegrity, processTx, rescanZebra, updateConfs) import Zenith.Types ( Config(..) + , HexStringDB(..) , PhraseDB(..) + , PrivacyPolicy(..) + , ProposedNote(..) + , ShieldDeshieldOp(..) , UnifiedAddressDB(..) + , ValidAddressAPI(..) , ZcashNetDB(..) + , ZenithStatus(..) + , ZenithUuid(..) + ) +import Zenith.Utils + ( displayTaz + , displayZec + , getChainTip + , isRecipientValid + , isRecipientValidGUI + , jsonNumber + , showAddress + , validBarValue ) -import Zenith.Utils (displayTaz, displayZec, jsonNumber, showAddress) data Name = WList @@ -108,6 +140,18 @@ data Name | RecField | AmtField | MemoField + | ABViewport + | ABList + | DescripField + | AddressField + | PrivacyNoneField + | PrivacyLowField + | PrivacyMediumField + | PrivacyFullField + | ShieldField + | DeshieldField + | TotalTranspField + | TotalShieldedField deriving (Eq, Show, Ord) data DialogInput = DialogInput @@ -118,12 +162,26 @@ makeLenses ''DialogInput data SendInput = SendInput { _sendTo :: !T.Text - , _sendAmt :: !Float + , _sendAmt :: !Scientific , _sendMemo :: !T.Text + , _policyField :: !PrivacyPolicy } deriving (Show) makeLenses ''SendInput +data AdrBookEntry = AdrBookEntry + { _descrip :: !T.Text + , _address :: !T.Text + } deriving (Show) + +makeLenses ''AdrBookEntry + +newtype ShDshEntry = ShDshEntry + { _shAmt :: Scientific + } deriving (Show) + +makeLenses ''ShDshEntry + data DialogType = WName | AName @@ -132,19 +190,31 @@ data DialogType | ASelect | SendTx | Blank + | AdrBook + | AdrBookForm + | AdrBookUpdForm + | AdrBookDelForm + | DeshieldForm + | ShieldForm data DisplayType = AddrDisplay | MsgDisplay | PhraseDisplay | TxDisplay + | TxIdDisplay | SyncDisplay | SendDisplay + | AdrBookEntryDisplay | BlankDisplay data Tick = TickVal !Float | TickMsg !String + | TickTx !HexString + +data DropDownItem = + DropdownItem String data State = State { _network :: !ZcashNet @@ -169,6 +239,14 @@ data State = State , _eventDispatch :: !(BC.BChan Tick) , _timer :: !Int , _txForm :: !(Form SendInput () Name) + , _abAddresses :: !(L.List Name (Entity AddressBook)) + , _abForm :: !(Form AdrBookEntry () Name) + , _abCurAdrs :: !T.Text -- used for address book CRUD operations + , _sentTx :: !(Maybe HexString) + , _unconfBalance :: !Integer + , _deshieldForm :: !(Form ShDshEntry () Name) + , _tBalance :: !Integer + , _sBalance :: !Integer } makeLenses ''State @@ -182,14 +260,15 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] withBorderStyle unicode $ B.borderWithLabel (str - ("Zenith - " <> + (" Zenith - " <> show (st ^. network) <> " - " <> T.unpack (maybe "(None)" (\(_, w) -> zcashWalletName $ entityVal w) - (L.listSelectedElement (st ^. wallets))))) + (L.listSelectedElement (st ^. wallets))) ++ + " ")) (C.hCenter (str ("Account: " ++ @@ -204,18 +283,35 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] if st ^. network == MainNet then displayZec (st ^. balance) else displayTaz (st ^. balance))) <=> + C.hCenter + (str + ("Unconf: " ++ + if st ^. network == MainNet + then displayZec (st ^. unconfBalance) + else displayTaz (st ^. unconfBalance))) <=> listAddressBox "Addresses" (st ^. addresses) <+> B.vBorder <+> - (C.hCenter (str ("Last block seen: " ++ show (st ^. syncBlock))) <=> - listTxBox "Transactions" (st ^. network) (st ^. transactions))) <=> - C.hCenter - (hBox - [ capCommand "W" "allets" - , capCommand "A" "ccounts" - , capCommand "V" "iew address" - , capCommand "Q" "uit" - , str $ show (st ^. timer) - ]) + (C.hCenter + (str ("Last block seen: " ++ show (st ^. syncBlock) ++ "\n")) <=> + listTxBox " Transactions " (st ^. network) (st ^. transactions))) <=> + (vBox + [ C.hCenter + (hBox + [ capCommand "W" "allets" + , capCommand "A" "ccounts" + , capCommand "V" "iew address" + , capCommand3 "" "S" "end Tx" + ]) + , C.hCenter + (hBox + [ capCommand2 "Address " "B" "ook" + , capCommand2 "s" "H" "ield" + , capCommand "D" "e-shield" + , capCommand "Q" "uit" + , capCommand "?" " Help" + , str $ show (st ^. timer) + ]) + ]) listBox :: Show e => String -> L.List Name e -> Widget Name listBox titleLabel l = C.vCenter $ @@ -252,7 +348,7 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] (hBox [ capCommand "↑↓ " "move" , capCommand "↲ " "select" - , capCommand "Tab " "->" + , capCommand3 "" "Tab" " ->" ]) ] listTxBox :: @@ -268,19 +364,20 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] (hBox [ capCommand "↑↓ " "move" , capCommand "T" "x Display" - , capCommand "Tab " "<-" + , capCommand3 "" "Tab" " <-" ]) ] helpDialog :: State -> Widget Name helpDialog st = if st ^. helpBox then D.renderDialog - (D.dialog (Just (str "Commands")) Nothing 55) + (D.dialog (Just (str " Commands ")) Nothing 55) (vBox ([C.hCenter $ str "Key", B.hBorder] <> keyList) <+> vBox ([str "Actions", B.hBorder] <> actionList)) else emptyWidget where - keyList = map (C.hCenter . str) ["?", "Esc", "w", "a", "v", "q"] + keyList = + map (C.hCenter . str) ["?", "Esc", "w", "a", "v", "s", "b", "d", "q"] actionList = map (hLimit 40 . str) @@ -289,6 +386,9 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] , "Switch wallets" , "Switch accounts" , "View address" + , "Send Tx" + , "Address Book" + , "Shield/De-Shield" , "Quit" ] inputDialog :: State -> Widget Name @@ -296,20 +396,20 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] case st ^. dialogBox of WName -> D.renderDialog - (D.dialog (Just (str "Create Wallet")) Nothing 50) + (D.dialog (Just (str " Create Wallet ")) Nothing 50) (renderForm $ st ^. inputForm) AName -> D.renderDialog - (D.dialog (Just (str "Create Account")) Nothing 50) + (D.dialog (Just (str " Create Account ")) Nothing 50) (renderForm $ st ^. inputForm) AdName -> D.renderDialog - (D.dialog (Just (str "Create Address")) Nothing 50) + (D.dialog (Just (str " Create Address ")) Nothing 50) (renderForm $ st ^. inputForm) WSelect -> D.renderDialog - (D.dialog (Just (str "Select Wallet")) Nothing 50) - (selectListBox "Wallets" (st ^. wallets) listDrawWallet <=> + (D.dialog (Just (str " Select Wallet ")) Nothing 50) + (selectListBox " Wallets " (st ^. wallets) listDrawWallet <=> C.hCenter (hBox [ capCommand "↑↓ " "move" @@ -320,8 +420,8 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] ])) ASelect -> D.renderDialog - (D.dialog (Just (str "Select Account")) Nothing 50) - (selectListBox "Accounts" (st ^. accounts) listDrawAccount <=> + (D.dialog (Just (str " Select Account ")) Nothing 50) + (selectListBox " Accounts " (st ^. accounts) listDrawAccount <=> C.hCenter (hBox [ capCommand "↑↓ " "move" @@ -331,11 +431,94 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] ])) SendTx -> D.renderDialog - (D.dialog (Just (str "Send Transaction")) Nothing 50) + (D.dialog (Just (str " Send Transaction ")) Nothing 50) (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 -> + D.renderDialog + (D.dialog (Just $ str " Address Book ") Nothing 60) + (withAttr abDefAttr $ + setAvailableSize (50, 20) $ + viewport ABViewport BT.Vertical $ + vLimit 20 $ + hLimit 50 $ + vBox + [ vLimit 16 $ + hLimit 50 $ + vBox $ [L.renderList listDrawAB True (s ^. abAddresses)] + , padTop Max $ + vLimit 4 $ + hLimit 50 $ + withAttr abMBarAttr $ + vBox $ + [ C.hCenter $ + (capCommand "N" "ew Address" <+> + capCommand "E" "dit Address" <+> + capCommand3 "" "C" "opy Address") + , C.hCenter $ + (capCommand "D" "elete Address" <+> + capCommand "S" "end Zcash" <+> capCommand3 "E" "x" "it") + ] + ]) + -- Address Book new entry form + AdrBookForm -> + D.renderDialog + (D.dialog (Just $ str " New Address Book Entry ") Nothing 50) + (renderForm (st ^. abForm) <=> + C.hCenter + (hBox [capCommand "↲" " Save", capCommand3 "" "" " Cancel"])) + -- Address Book edit/update entry form + AdrBookUpdForm -> + D.renderDialog + (D.dialog (Just $ str " Edit Address Book Entry ") Nothing 50) + (renderForm (st ^. abForm) <=> + C.hCenter + (hBox [capCommand "↲" " Save", capCommand3 "" "" " Cancel"])) + -- Address Book edit/update entry form + AdrBookDelForm -> + D.renderDialog + (D.dialog (Just $ str " Delete Address Book Entry ") Nothing 50) + (renderForm (st ^. abForm) <=> + C.hCenter + (hBox + [ capCommand "C" "onfirm delete" + , capCommand3 "" "" " Cancel" + ])) + -- splashDialog :: State -> Widget Name splashDialog st = if st ^. splashBox @@ -347,9 +530,14 @@ 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.5.1.0-beta")) <=> + (withAttr titleAttr (str "Zcash Wallet v0.7.1.0-beta")) <=> C.hCenter (withAttr blinkAttr $ str "Press any key...")) else emptyWidget + capCommand3 :: String -> String -> String -> Widget Name + capCommand3 l h e = hBox [str l, withAttr titleAttr (str h), str e] + capCommand2 :: String -> String -> String -> Widget Name + capCommand2 l h e = + hBox [str l, withAttr titleAttr (str h), str e, str " | "] capCommand :: String -> String -> Widget Name capCommand k comm = hBox [withAttr titleAttr (str k), str comm, str " | "] xCommand :: Widget Name @@ -400,7 +588,7 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] Just (_, w) -> withBorderStyle unicodeBold $ D.renderDialog - (D.dialog (Just $ txt "Seed Phrase") Nothing 50) + (D.dialog (Just $ txt " Seed Phrase ") Nothing 50) (padAll 1 $ txtWrap $ E.decodeUtf8Lenient $ @@ -409,15 +597,25 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] MsgDisplay -> withBorderStyle unicodeBold $ D.renderDialog - (D.dialog (Just $ txt "Message") Nothing 50) + (D.dialog (Just $ txt " Message ") Nothing 50) (padAll 1 $ strWrap $ st ^. msg) + TxIdDisplay -> + withBorderStyle unicodeBold $ + D.renderDialog + (D.dialog (Just $ txt " Success ") Nothing 50) + (padAll 1 $ + (txt "Tx ID: " <+> + txtWrapWith + (WrapSettings False True NoFill FillAfterFirst) + (maybe "None" toText (st ^. sentTx))) <=> + C.hCenter (hBox [capCommand "C" "opy", xCommand])) TxDisplay -> case L.listSelectedElement $ st ^. transactions of Nothing -> emptyWidget Just (_, tx) -> withBorderStyle unicodeBold $ D.renderDialog - (D.dialog (Just $ txt "Transaction") Nothing 50) + (D.dialog (Just $ txt " Transaction ") Nothing 50) (padAll 1 (str @@ -443,7 +641,7 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] SyncDisplay -> withBorderStyle unicodeBold $ D.renderDialog - (D.dialog (Just $ txt "Sync") Nothing 50) + (D.dialog (Just $ txt " Sync ") Nothing 50) (padAll 1 (updateAttrMap @@ -452,13 +650,33 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] , (barToDoAttr, P.progressIncompleteAttr) ]) (P.progressBar - (Just $ show (st ^. barValue * 100)) + (Just $ printf "%.2f%%" (st ^. barValue * 100)) (_barValue st)))) SendDisplay -> withBorderStyle unicodeBold $ D.renderDialog - (D.dialog (Just $ txt "Sending Transaction") Nothing 50) - (padAll 1 (str $ st ^. msg)) + (D.dialog (Just $ txt " Sending Transaction ") Nothing 50) + (padAll + 1 + (strWrapWith + (WrapSettings False True NoFill FillAfterFirst) + (st ^. msg))) + AdrBookEntryDisplay -> do + case L.listSelectedElement $ st ^. abAddresses of + Just (_, a) -> do + let abentry = + T.pack $ + " Descr: " ++ + T.unpack (addressBookAbdescrip (entityVal a)) ++ + "\n Address: " ++ + T.unpack (addressBookAbaddress (entityVal a)) + withBorderStyle unicodeBold $ + D.renderDialog + (D.dialog (Just $ txt " Address Book Entry ") Nothing 60) + (padAll 1 $ + txtWrapWith (WrapSettings False True NoFill FillAfterFirst) $ + abentry) + _ -> emptyWidget BlankDisplay -> emptyWidget mkInputForm :: DialogInput -> Form DialogInput e Name @@ -472,29 +690,46 @@ 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 -isRecipientValid :: T.Text -> Bool -isRecipientValid a = - 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 a of - Just _a4 -> True - Nothing -> False) +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 + +mkNewABForm :: AdrBookEntry -> Form AdrBookEntry e Name +mkNewABForm = + newForm + [ label "Descrip: " @@= editTextField descrip DescripField (Just 1) + , label "Address: " @@= editTextField address AddressField (Just 1) + ] + where + label s w = + padBottom (Pad 1) $ vLimit 1 (hLimit 10 $ str s <+> fill ' ') <+> w listDrawElement :: (Show a) => Bool -> a -> Widget Name listDrawElement sel a = @@ -545,13 +780,21 @@ listDrawTx znet sel tx = else displayTaz amt fmtAmt = if amt > 0 - then "↘" <> dispAmount <> " " - else " " <> dispAmount <> "↗" + then "↘ " <> dispAmount <> " " + else " " <> dispAmount <> "↗ " selStr s = if sel then withAttr customAttr (txt $ "> " <> s) else txt $ " " <> s +listDrawAB :: Bool -> Entity AddressBook -> Widget Name +listDrawAB sel ab = + let selStr s = + if sel + then withAttr abSelAttr (txt $ " " <> s) + else txt $ " " <> s + in selStr $ addressBookAbdescrip (entityVal ab) + customAttr :: A.AttrName customAttr = L.listSelectedAttr <> A.attrName "custom" @@ -570,23 +813,74 @@ barDoneAttr = A.attrName "done" barToDoAttr :: A.AttrName barToDoAttr = A.attrName "remaining" -validBarValue :: Float -> Float -validBarValue = clamp 0 1 +abDefAttr :: A.AttrName +abDefAttr = A.attrName "abdefault" -scanZebra :: T.Text -> T.Text -> Int -> Int -> BC.BChan Tick -> IO () -scanZebra dbP zHost zPort b eChan = do - _ <- liftIO $ initDb dbP +abSelAttr :: A.AttrName +abSelAttr = A.attrName "abselected" + +abMBarAttr :: A.AttrName +abMBarAttr = A.attrName "menubar" + +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 - let sb = max dbBlock b - if sb > zgb_blocks bStatus || sb < 1 - then do - liftIO $ BC.writeBChan eChan $ TickMsg "Invalid starting block for scan" + 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 - let bList = [(sb + 1) .. (zgb_blocks bStatus)] - let step = (1.0 :: Float) / fromIntegral (zgb_blocks bStatus - (sb + 1)) - mapM_ (processBlock pool step) bList + logDebugN $ + "dbBlock: " <> + T.pack (show dbBlock) <> " chkBlock: " <> T.pack (show chkBlock) + let sb = + if chkBlock == dbBlock + then max dbBlock b + else max chkBlock b + when (chkBlock /= dbBlock && chkBlock /= 1) $ + rewindWalletData pool sb $ ZcashNetDB znet + if sb > zgb_blocks bStatus || sb < 1 + then do + liftIO $ + BC.writeBChan eChan $ TickMsg "Invalid starting block for scan" + else do + let bList = [(sb + 1) .. (zgb_blocks bStatus)] + if not (null bList) + then do + let step = + (1.0 :: Float) / + fromIntegral (zgb_blocks bStatus - (sb + 1)) + _ <- liftIO $ startSync pool + mapM_ (liftIO . processBlock pool step) bList + confUp <- + liftIO $ try $ updateConfs zHost zPort pool :: NoLoggingT + IO + (Either IOError ()) + case confUp of + Left _e0 -> do + _ <- liftIO $ completeSync pool Failed + liftIO $ + BC.writeBChan eChan $ + TickMsg "Failed to update unconfirmed transactions" + Right _ -> do + logDebugN "Updated confirmations" + logDebugN "Starting commitment tree update" + _ <- updateCommitmentTrees pool zHost zPort (ZcashNetDB znet) + logDebugN "Finished tree update" + _ <- liftIO $ completeSync pool Successful + liftIO $ BC.writeBChan eChan $ TickMsg "startSync" + return () + else do + liftIO $ BC.writeBChan eChan $ TickMsg "startSync" where processBlock :: ConnectionPool -> Float -> Int -> IO () processBlock pool step bl = do @@ -599,30 +893,19 @@ scanZebra dbP zHost zPort b eChan = do [Data.Aeson.String $ T.pack $ show bl, jsonNumber 1] case r of Left e1 -> do + _ <- liftIO $ completeSync pool Failed liftIO $ BC.writeBChan eChan $ TickMsg e1 Right blk -> do - r2 <- - liftIO $ - makeZebraCall - zHost - zPort - "getblock" - [Data.Aeson.String $ T.pack $ show bl, jsonNumber 0] - case r2 of - Left e2 -> do - 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 - 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) + bi <- + saveBlock pool $ + ZcashBlock + (fromIntegral $ bl_height blk) + (HexStringDB $ bl_hash blk) + (fromIntegral $ bl_confirmations blk) + (fromIntegral $ bl_time blk) + (ZcashNetDB znet) + mapM_ (processTx zHost zPort bi pool) $ bl_txs blk + liftIO $ BC.writeBChan eChan $ TickVal step appEvent :: BT.BrickEvent Name Tick -> BT.EventM Name State () appEvent (BT.AppEvent t) = do @@ -632,43 +915,60 @@ 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 () SyncDisplay -> return () - SendDisplay -> do - BT.modify $ set msg m + SendDisplay -> BT.modify $ set msg m + AdrBookEntryDisplay -> return () BlankDisplay -> return () + TickTx txid -> do + BT.modify $ set sentTx (Just txid) + BT.modify $ set displayBox TxIdDisplay TickVal v -> do case s ^. displayBox of AddrDisplay -> return () MsgDisplay -> return () PhraseDisplay -> return () TxDisplay -> return () + TxIdDisplay -> return () SendDisplay -> return () + AdrBookEntryDisplay -> return () SyncDisplay -> do if s ^. barValue == 1.0 then do - 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 @@ -678,25 +978,34 @@ appEvent (BT.AppEvent t) = do WSelect -> return () ASelect -> return () SendTx -> return () + AdrBook -> return () + 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 do - BT.modify $ set timer $ 1 + s ^. timer + else BT.modify $ set timer $ 1 + s ^. timer appEvent (BT.VtyEvent e) = do r <- F.focusGetCurrent <$> use focusRing s <- BT.get @@ -705,8 +1014,7 @@ appEvent (BT.VtyEvent e) = do else if s ^. helpBox then do case e of - V.EvKey V.KEsc [] -> do - BT.modify $ set helpBox False + V.EvKey V.KEsc [] -> BT.modify $ set helpBox False _ev -> return () else do case s ^. displayBox of @@ -765,8 +1073,19 @@ appEvent (BT.VtyEvent e) = do MsgDisplay -> BT.modify $ set displayBox BlankDisplay PhraseDisplay -> BT.modify $ set displayBox BlankDisplay TxDisplay -> BT.modify $ set displayBox BlankDisplay + TxIdDisplay -> do + case e of + V.EvKey (V.KChar 'x') [] -> + BT.modify $ set displayBox BlankDisplay + V.EvKey (V.KChar 'c') [] -> do + liftIO $ + setClipboard $ + T.unpack $ maybe "None" toText (s ^. sentTx) + BT.modify $ set msg "Copied transaction ID!" + _ev -> return () SendDisplay -> BT.modify $ set displayBox BlankDisplay SyncDisplay -> BT.modify $ set displayBox BlankDisplay + AdrBookEntryDisplay -> BT.modify $ set displayBox BlankDisplay BlankDisplay -> do case s ^. dialogBox of WName -> do @@ -829,7 +1148,7 @@ appEvent (BT.VtyEvent e) = do V.EvKey (V.KChar 'n') [] -> do BT.modify $ set inputForm $ - updateFormState (DialogInput "New Wallet") $ + updateFormState (DialogInput " New Wallet ") $ s ^. inputForm BT.modify $ set dialogBox WName V.EvKey (V.KChar 's') [] -> @@ -846,7 +1165,7 @@ appEvent (BT.VtyEvent e) = do V.EvKey (V.KChar 'n') [] -> do BT.modify $ set inputForm $ - updateFormState (DialogInput "New Account") $ + updateFormState (DialogInput " New Account ") $ s ^. inputForm BT.modify $ set dialogBox AName ev -> BT.zoom accounts $ L.handleListEvent ev @@ -885,7 +1204,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 $ @@ -900,6 +1220,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 @@ -907,14 +1228,318 @@ appEvent (BT.VtyEvent e) = do BT.modify $ set msg "Invalid inputs" BT.modify $ set displayBox MsgDisplay BT.modify $ set dialogBox Blank - ev -> do + ev -> BT.zoom txForm $ do handleFormEvent (BT.VtyEvent ev) 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 + bl <- + liftIO $ + getChainTip (s ^. zebraHost) (s ^. zebraPort) + _ <- + liftIO $ + forkIO $ + deshieldTransaction + pool + (s ^. eventDispatch) + (s ^. zebraHost) + (s ^. zebraPort) + (s ^. network) + (entityKey selAcc) + bl + (fs1 ^. shAmt) + 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') [] -> + BT.modify $ set dialogBox Blank + V.EvKey (V.KChar 'c') [] + -- Copy Address to Clipboard + -> do + case L.listSelectedElement $ s ^. abAddresses of + Just (_, a) -> do + liftIO $ + setClipboard $ + T.unpack $ addressBookAbaddress (entityVal a) + BT.modify $ + set msg $ + "Address copied to Clipboard from >>\n" ++ + T.unpack (addressBookAbdescrip (entityVal a)) + BT.modify $ set displayBox MsgDisplay + _any -> do + BT.modify $ + set msg "Error while copying the address!!" + BT.modify $ set displayBox MsgDisplay + -- Send Zcash transaction + V.EvKey (V.KChar 's') [] -> do + case L.listSelectedElement $ s ^. abAddresses of + Just (_, a) -> do + BT.modify $ + set txForm $ + mkSendForm + (s ^. balance) + (SendInput + (addressBookAbaddress (entityVal a)) + 0.0 + "" + Full) + BT.modify $ set dialogBox SendTx + _ -> do + BT.modify $ + set msg "No receiver address available!!" + BT.modify $ set displayBox MsgDisplay + -- Edit an entry in Address Book + V.EvKey (V.KChar 'e') [] -> do + case L.listSelectedElement $ s ^. abAddresses of + Just (_, a) -> do + BT.modify $ + set + abCurAdrs + (addressBookAbaddress (entityVal a)) + BT.modify $ + set abForm $ + mkNewABForm + (AdrBookEntry + (addressBookAbdescrip (entityVal a)) + (addressBookAbaddress (entityVal a))) + BT.modify $ set dialogBox AdrBookUpdForm + _ -> do + BT.modify $ set dialogBox Blank + -- Delete an entry from Address Book + V.EvKey (V.KChar 'd') [] -> do + case L.listSelectedElement $ s ^. abAddresses of + Just (_, a) -> do + BT.modify $ + set + abCurAdrs + (addressBookAbaddress (entityVal a)) + BT.modify $ + set abForm $ + mkNewABForm + (AdrBookEntry + (addressBookAbdescrip (entityVal a)) + (addressBookAbaddress (entityVal a))) + BT.modify $ set dialogBox AdrBookDelForm + _ -> do + BT.modify $ set dialogBox Blank + -- Create a new entry in Address Book + V.EvKey (V.KChar 'n') [] -> do + BT.modify $ + set abForm $ mkNewABForm (AdrBookEntry "" "") + BT.modify $ set dialogBox AdrBookForm + -- Show AddressBook entry data + V.EvKey V.KEnter [] -> do + BT.modify $ set displayBox AdrBookEntryDisplay + -- Process any other event + ev -> BT.zoom abAddresses $ L.handleListEvent ev + -- Process new address book entry + AdrBookForm -> do + case e of + V.EvKey V.KEsc [] -> BT.modify $ set dialogBox AdrBook + V.EvKey V.KEnter [] -> do + pool <- liftIO $ runNoLoggingT $ initPool $ s ^. dbPath + fs <- BT.zoom abForm $ BT.gets formState + let idescr = T.unpack $ T.strip (fs ^. descrip) + let iabadr = fs ^. address + if not (null idescr) && isRecipientValid iabadr + then do + res <- + liftIO $ + saveAdrsInAdrBook pool $ + AddressBook + (ZcashNetDB (s ^. network)) + (fs ^. descrip) + (fs ^. address) + case res of + Nothing -> do + BT.modify $ + set + msg + ("AddressBook Entry already exists: " ++ + T.unpack (fs ^. address)) + BT.modify $ set displayBox MsgDisplay + Just _ -> do + BT.modify $ + set + msg + ("New AddressBook entry created!!\n" ++ + T.unpack (fs ^. address)) + BT.modify $ set displayBox MsgDisplay + -- case end + s' <- liftIO $ refreshAddressBook s + BT.put s' + BT.modify $ set dialogBox AdrBook + else do + BT.modify $ set msg "Invalid or missing data!!: " + BT.modify $ set displayBox MsgDisplay + BT.modify $ set dialogBox AdrBookForm + ev -> + BT.zoom abForm $ do + handleFormEvent (BT.VtyEvent ev) + fs <- BT.gets formState + BT.modify $ + setFieldValid + (isRecipientValid (fs ^. address)) + AddressField + AdrBookUpdForm -> do + case e of + V.EvKey V.KEsc [] -> BT.modify $ set dialogBox AdrBook + V.EvKey V.KEnter [] -> do + pool <- liftIO $ runNoLoggingT $ initPool $ s ^. dbPath + fs <- BT.zoom abForm $ BT.gets formState + let idescr = T.unpack $ T.strip (fs ^. descrip) + let iabadr = fs ^. address + if not (null idescr) && isRecipientValid iabadr + then do + res <- + liftIO $ + updateAdrsInAdrBook + pool + (fs ^. descrip) + (fs ^. address) + (s ^. abCurAdrs) + BT.modify $ + set + msg + ("AddressBook entry modified!!\n" ++ + T.unpack (fs ^. address)) + BT.modify $ set displayBox MsgDisplay + -- case end + s' <- liftIO $ refreshAddressBook s + BT.put s' + BT.modify $ set dialogBox AdrBook + else do + BT.modify $ set msg "Invalid or missing data!!: " + BT.modify $ set displayBox MsgDisplay + BT.modify $ set dialogBox AdrBookForm + ev -> + BT.zoom abForm $ do + handleFormEvent (BT.VtyEvent ev) + fs <- BT.gets formState + BT.modify $ + setFieldValid + (isRecipientValid (fs ^. address)) + AddressField + -- Process delete AddresBook entry + AdrBookDelForm -> do + case e of + V.EvKey V.KEsc [] -> BT.modify $ set dialogBox AdrBook + V.EvKey (V.KChar 'c') [] -> do + pool <- liftIO $ runNoLoggingT $ initPool $ s ^. dbPath + fs <- BT.zoom abForm $ BT.gets formState + res <- liftIO $ deleteAdrsFromAB pool (fs ^. address) + s' <- liftIO $ refreshAddressBook s + 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 V.EvKey (V.KChar '\t') [] -> focusRing %= F.focusNext @@ -936,20 +1561,77 @@ 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 -> BT.zoom addresses $ L.handleListEvent ev Just TList -> BT.zoom transactions $ L.handleListEvent ev + Just ABList -> + BT.zoom abAddresses $ L.handleListEvent ev _anyName -> return () where printMsg :: String -> BT.EventM Name State () 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 @@ -963,11 +1645,14 @@ theMap = , (blinkAttr, style V.blink) , (focusedFormInputAttr, V.white `on` V.blue) , (invalidFormInputAttr, V.red `on` V.black) - , (E.editAttr, V.white `on` V.blue) - , (E.editFocusedAttr, V.blue `on` V.white) + , (E.editAttr, V.white `on` V.black) + , (E.editFocusedAttr, V.black `on` V.white) , (baseAttr, bg V.brightBlack) , (barDoneAttr, V.white `on` V.blue) , (barToDoAttr, V.white `on` V.black) + , (abDefAttr, V.white `on` V.blue) + , (abSelAttr, V.black `on` V.white) + , (abMBarAttr, V.white `on` V.black) ] theApp :: M.App State Tick Name @@ -980,8 +1665,8 @@ theApp = , M.appAttrMap = const theMap } -runZenithCLI :: Config -> IO () -runZenithCLI config = do +runZenithTUI :: Config -> IO () +runZenithTUI config = do let host = c_zebraHost config let port = c_zebraPort config let dbFilePath = c_dbPath config @@ -995,65 +1680,94 @@ runZenithCLI 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 - bal <- - if not (null accList) - then getBalance 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 "") - 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." @@ -1072,7 +1786,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 @@ -1081,6 +1795,10 @@ refreshWallet s = do if not (null aL) then getBalance pool $ entityKey $ head aL else return 0 + uBal <- + if not (null aL) + then getUnconfirmedBalance pool $ entityKey $ head aL + else return 0 txL <- if not (null addrL) then getUserTx pool $ entityKey $ head addrL @@ -1091,6 +1809,8 @@ refreshWallet s = do let txL' = L.listReplace (Vec.fromList txL) (Just 0) (s ^. transactions) return $ s & wallets .~ wL & accounts .~ aL' & syncBlock .~ bl & balance .~ bal & + unconfBalance .~ + uBal & addresses .~ addrL' & transactions .~ @@ -1107,14 +1827,13 @@ addNewWallet n s = do let netName = s ^. network r <- saveWallet pool $ ZcashWallet n (ZcashNetDB netName) (PhraseDB sP) bH 0 case r of - Nothing -> do - return $ s & msg .~ ("Wallet already exists: " ++ T.unpack n) + Nothing -> return $ s & msg .~ ("Wallet already exists: " ++ T.unpack n) Just _ -> do wL <- getWallets pool netName let aL = L.listFindBy (\x -> zcashWalletName (entityVal x) == n) $ L.listReplace (Vec.fromList wL) (Just 0) (s ^. wallets) - return $ (s & wallets .~ aL) & msg .~ "Created new wallet: " ++ T.unpack n + return $ s & wallets .~ aL & msg .~ "Created new wallet: " ++ T.unpack n addNewAccount :: T.Text -> State -> IO State addNewAccount n s = do @@ -1133,19 +1852,18 @@ addNewAccount n s = do try $ createZcashAccount n (aL' + 1) selWallet :: IO (Either IOError ZcashAccount) case zA of - Left e -> return $ s & msg .~ ("Error: " ++ show e) + Left e -> return $ s & msg .~ "Error: " ++ show e Right zA' -> do r <- saveAccount pool zA' case r of - Nothing -> - return $ s & msg .~ ("Account already exists: " ++ T.unpack n) + Nothing -> return $ s & msg .~ "Account already exists: " ++ T.unpack n Just x -> do aL <- runNoLoggingT $ getAccounts pool (entityKey selWallet) let nL = L.listMoveToElement x $ L.listReplace (Vec.fromList aL) (Just 0) (s ^. accounts) return $ - (s & accounts .~ nL) & msg .~ "Created new account: " ++ T.unpack n + s & accounts .~ nL & msg .~ "Created new account: " ++ T.unpack n refreshAccount :: State -> IO State refreshAccount s = do @@ -1161,6 +1879,7 @@ refreshAccount s = do Just (_k, w) -> return w aL <- runNoLoggingT $ getAddresses pool $ entityKey selAccount bal <- getBalance pool $ entityKey selAccount + uBal <- getUnconfirmedBalance pool $ entityKey selAccount let aL' = L.listReplace (Vec.fromList aL) (Just 0) (s ^. addresses) selAddress <- do case L.listSelectedElement aL' of @@ -1171,13 +1890,17 @@ refreshAccount s = do case selAddress of Nothing -> return $ - s & balance .~ bal & addresses .~ aL' & msg .~ "Switched to account: " ++ + s & balance .~ bal & unconfBalance .~ uBal & addresses .~ aL' & msg .~ + "Switched to account: " ++ T.unpack (zcashAccountName $ entityVal selAccount) Just (_i, a) -> do tList <- getUserTx pool $ entityKey a let tL' = L.listReplace (Vec.fromList tList) (Just 0) (s ^. transactions) return $ - s & balance .~ bal & addresses .~ aL' & transactions .~ tL' & msg .~ + s & balance .~ bal & unconfBalance .~ uBal & addresses .~ aL' & + transactions .~ + tL' & + msg .~ "Switched to account: " ++ T.unpack (zcashAccountName $ entityVal selAccount) @@ -1198,6 +1921,21 @@ refreshTxs s = do let tL' = L.listReplace (Vec.fromList tList) (Just 0) (s ^. transactions) return $ s & transactions .~ tL' +refreshAddressBook :: State -> IO State +refreshAddressBook s = do + pool <- runNoLoggingT $ initPool $ s ^. dbPath + selAddress <- + do case L.listSelectedElement $ s ^. abAddresses of + Nothing -> do + let fAdd = + L.listSelectedElement $ + L.listMoveToBeginning $ s ^. abAddresses + return fAdd + Just a2 -> return $ Just a2 + abookList <- getAdrBook pool (s ^. network) + let tL' = L.listReplace (Vec.fromList abookList) (Just 0) (s ^. abAddresses) + return $ s & abAddresses .~ tL' + addNewAddress :: T.Text -> Scope -> State -> IO State addNewAddress n scope s = do pool <- runNoLoggingT $ initPool $ s ^. dbPath @@ -1215,19 +1953,18 @@ addNewAddress n scope s = do try $ createWalletAddress n (maxAddr + 1) (s ^. network) scope selAccount :: IO (Either IOError WalletAddress) case uA of - Left e -> return $ s & msg .~ ("Error: " ++ show e) + Left e -> return $ s & msg .~ "Error: " ++ show e Right uA' -> do nAddr <- saveAddress pool uA' case nAddr of - Nothing -> - return $ s & msg .~ ("Address already exists: " ++ T.unpack n) + Nothing -> return $ s & msg .~ "Address already exists: " ++ T.unpack n Just x -> do addrL <- runNoLoggingT $ getAddresses pool (entityKey selAccount) let nL = L.listMoveToElement x $ L.listReplace (Vec.fromList addrL) (Just 0) (s ^. addresses) return $ - (s & addresses .~ nL) & msg .~ "Created new address: " ++ + s & addresses .~ nL & msg .~ "Created new address: " ++ T.unpack n ++ "(" ++ T.unpack (showAddress $ walletAddressUAddress $ entityVal x) ++ ")" @@ -1240,20 +1977,91 @@ 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..." - outUA <- parseAddress ua - res <- - runFileLoggingT "zenith.log" $ - prepareTx pool zHost zPort znet accId bl amt outUA memo - BC.writeBChan chan $ TickMsg "Transaction ready, sending to Zebra..." + case parseAddress (E.encodeUtf8 ua) of + Nothing -> BC.writeBChan chan $ TickMsg "Incorrect address" + Just outUA -> do + res <- + 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 + 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 + +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 + ops <- + mapM + (\case + Left e -> return $ T.pack $ show e + Right x -> do + thisOp <- getOperation pool x + case thisOp of + Nothing -> return "" + Just o -> + return $ + (U.toText . getUuid . operationUuid $ entityVal o) <> + ": " <> (T.pack . show . operationStatus $ entityVal o)) + res + BC.writeBChan chan $ TickMsg $ T.unpack $ T.intercalate "\n" ops + +deshieldTransaction :: + ConnectionPool + -> BC.BChan Tick + -> T.Text + -> Int + -> ZcashNet + -> ZcashAccountId + -> Int + -> Scientific + -> 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 @@ -1262,20 +2070,4 @@ sendTransaction pool chan zHost zPort znet accId bl amt ua memo = do [Data.Aeson.String $ toText rawTx] case resp of Left e1 -> BC.writeBChan chan $ TickMsg $ "Zebra error: " ++ show e1 - Right txId -> BC.writeBChan chan $ TickMsg $ "Tx ID: " ++ txId - where - parseAddress :: T.Text -> IO UnifiedAddress - parseAddress a = - case isValidUnifiedAddress (E.encodeUtf8 a) of - Just a1 -> return a1 - Nothing -> - case decodeSaplingAddress (E.encodeUtf8 a) of - Just a2 -> - return $ - UnifiedAddress znet Nothing (Just $ sa_receiver a2) Nothing - Nothing -> - case decodeTransparentAddress (E.encodeUtf8 a) of - Just a3 -> - return $ - UnifiedAddress znet Nothing Nothing (Just $ ta_receiver a3) - Nothing -> throwIO $ userError "Incorrect address" + Right txId -> BC.writeBChan chan $ TickTx txId diff --git a/src/Zenith/Core.hs b/src/Zenith/Core.hs index a8dc6f2..5d26696 100644 --- a/src/Zenith/Core.hs +++ b/src/Zenith/Core.hs @@ -3,50 +3,48 @@ -- | Core wallet functionality for Zenith module Zenith.Core where +import Control.Concurrent (forkIO) 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) +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 Data.UUID as U +import Data.UUID.V4 (nextRandom) 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 + , parseAddress , updateOrchardCommitmentTree , updateOrchardWitness ) @@ -55,7 +53,9 @@ import ZcashHaskell.Sapling , genSaplingInternalAddress , genSaplingPaymentAddress , genSaplingSpendingKey + , getSaplingFrontier , getSaplingNotePosition + , getSaplingTreeParts , getSaplingWitness , updateSaplingCommitmentTree , updateSaplingWitness @@ -68,19 +68,26 @@ 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(..) + , ZenithStatus(..) + , ZenithUuid(..) ) +import Zenith.Utils (getTransparentFromUA) -- * Zebra Node interaction -- | Checks the status of the `zebrad` node @@ -107,20 +114,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 +245,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 +293,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 +368,7 @@ findSaplingOutputs config b znet za = do (getHex $ shieldOutputProof $ entityVal s)) n scope - pos + (fromIntegral pos) -- | Get Orchard actions findOrchardActions :: @@ -328,65 +383,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 +452,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 +470,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,176 +481,416 @@ 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 + -> Scientific + -> NoLoggingT IO (Either TxError HexString) +deshieldNotes pool zebraHost zebraPort znet za bh pnote = do + bal <- liftIO $ getShieldedBalance pool za + addrs <- getAddresses pool za + let defAddr = + parseAddress $ + E.encodeUtf8 $ getUA $ walletAddressUAddress $ entityVal $ head addrs + case defAddr of + Nothing -> return $ Left ZHError + Just (Unified x) -> do + case getTransparentFromUA x of + Nothing -> return $ Left ZHError + Just ta -> do + let zats = pnote * scientific 1 8 + if fromInteger bal > (scientific 2 4 + zats) + then prepareTxV2 + pool + zebraHost + zebraPort + znet + za + bh + [ ProposedNote + (ValidAddressAPI $ Transparent ta) + pnote + Nothing + ] + Low + else return $ Left InsufficientFunds + _anyOther -> return $ Left ZHError + +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 U.UUID] +shieldTransparentNotes pool zHost zPort 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 - return tx + trNotes' <- liftIO $ getWalletUnspentTrNotes pool za + if null trNotes' + then return [Left InsufficientFunds] + else do + 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 + opid <- liftIO nextRandom + startTime <- liftIO getCurrentTime + opkey <- + liftIO $ + saveOperation pool $ + Operation (ZenithUuid opid) startTime Nothing Processing Nothing + case opkey of + Nothing -> return $ Left ZHError + Just opkey' -> 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 + _ <- + liftIO $ + forkIO $ do + tx <- + liftIO $ + createTransaction + (maybe (hexString "00") (getHash . value . fst) sTree) + (maybe (hexString "00") (getHash . value . fst) oTree) + tSpends + [] + [] + [snote] + znet + (bh + 3) + True + case tx of + Left e -> + finalizeOperation pool opkey' Failed $ T.pack $ show e + Right rawTx -> do + zebraRes <- + makeZebraCall + zHost + zPort + "sendrawtransaction" + [Data.Aeson.String $ toText rawTx] + case zebraRes of + Left e1 -> + finalizeOperation pool opkey' Failed $ + T.pack $ show e1 + Right txId -> + finalizeOperation pool opkey' Successful $ + "Tx ID: " <> toText txId + logDebugN $ T.pack $ show opid + return $ Right opid 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) - "" - 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] @@ -644,12 +927,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) @@ -660,11 +1323,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) @@ -675,100 +1345,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 a48151d..7de2015 100644 --- a/src/Zenith/DB.hs +++ b/src/Zenith/DB.hs @@ -18,21 +18,30 @@ 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 as P import qualified Database.Persist.Sqlite as PS import Database.Persist.TH import Haskoin.Transaction.Common @@ -41,18 +50,24 @@ import Haskoin.Transaction.Common , TxOut(..) , txHashToHex ) -import qualified Lens.Micro as ML ((&), (.~), (^.)) -import ZcashHaskell.Orchard (isValidUnifiedAddress) -import ZcashHaskell.Sapling (decodeSaplingOutputEsk) +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(..) @@ -62,21 +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 @@ -129,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 @@ -162,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 @@ -185,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 @@ -212,7 +243,7 @@ share UniqueTSPos tx position deriving Show Eq OrchAction - tx ZcashTransactionId + tx ZcashTransactionId OnDeleteCascade OnUpdateCascade nf HexStringDB rk HexStringDB cmx HexStringDB @@ -225,7 +256,7 @@ share UniqueOAPos tx position deriving Show Eq ShieldOutput - tx ZcashTransactionId + tx ZcashTransactionId OnDeleteCascade OnUpdateCascade cv HexStringDB cmu HexStringDB ephKey HexStringDB @@ -236,7 +267,7 @@ share UniqueSOPos tx position deriving Show Eq ShieldSpend - tx ZcashTransactionId + tx ZcashTransactionId OnDeleteCascade OnUpdateCascade cv HexStringDB anchor HexStringDB nullifier HexStringDB @@ -246,15 +277,203 @@ share position Int UniqueSSPos tx position deriving Show Eq + QrCode + address WalletAddressId OnDeleteCascade OnUpdateCascade + version ZcashPool + bytes BS.ByteString + height Int + width Int + name T.Text + UniqueQr address version + deriving Show Eq + AddressBook + network ZcashNetDB + abdescrip T.Text + 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 @@ -279,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 @@ -353,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 :: @@ -379,6 +630,7 @@ getAddresses pool a = addrs <- from $ table @WalletAddress where_ (addrs ^. WalletAddressAccId ==. val a) where_ (addrs ^. WalletAddressScope ==. val (ScopeDB External)) + orderBy [asc $ addrs ^. WalletAddressId] pure addrs getAddressById :: @@ -416,6 +668,16 @@ getWalletAddresses pool w = do addrs <- mapM (getAddresses pool . entityKey) accs return $ concat addrs +getExternalAddresses :: ConnectionPool -> IO [Entity WalletAddress] +getExternalAddresses pool = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + addrs <- from $ table @WalletAddress + where_ $ addrs ^. WalletAddressScope ==. val (ScopeDB External) + return addrs + -- | Returns the largest address index for the given account getMaxAddress :: ConnectionPool -- ^ The database path @@ -446,19 +708,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_ $ @@ -537,17 +833,83 @@ 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 +-- | Functions to manage the QR codes stored in the database +saveQrCode :: + ConnectionPool -- ^ the connection pool + -> QrCode + -> NoLoggingT IO (Maybe (Entity QrCode)) +saveQrCode pool qr = + PS.retryOnBusy $ flip PS.runSqlPool pool $ insertUniqueEntity qr + +getQrCodes :: + ConnectionPool -- ^ the connection pool + -> WalletAddressId + -> IO [Entity QrCode] +getQrCodes pool wId = + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + qrs <- from $ table @QrCode + where_ $ qrs ^. QrCodeAddress ==. val wId + return qrs + +getQrCode :: ConnectionPool -> ZcashPool -> WalletAddressId -> IO (Maybe QrCode) +getQrCode pool zp wId = do + r <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + qrs <- from $ table @QrCode + where_ $ qrs ^. QrCodeAddress ==. val wId + where_ $ qrs ^. QrCodeVersion ==. val zp + 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 :: @@ -567,15 +929,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 @@ -607,29 +971,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 @@ -644,7 +1016,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)) @@ -655,14 +1027,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 @@ -677,7 +1048,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) @@ -689,9 +1060,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 @@ -706,13 +1078,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 @@ -728,10 +1104,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 @@ -740,9 +1117,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 @@ -764,17 +1141,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 @@ -785,21 +1167,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 @@ -817,96 +1447,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 @@ -916,6 +1517,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 @@ -1028,6 +1639,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 $ @@ -1087,7 +1711,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 () @@ -1182,12 +1806,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 @@ -1195,15 +1823,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 @@ -1231,12 +1874,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 @@ -1244,15 +1888,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 @@ -1314,15 +1973,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 @@ -1337,6 +2032,106 @@ getBalance pool za = do let oBal = sum oAmts return . fromIntegral $ tBal + sBal + oBal +getTransparentBalance :: ConnectionPool -> ZcashAccountId -> IO Integer +getTransparentBalance pool za = do + trNotes <- getWalletUnspentTrNotes pool za + let tAmts = map (walletTrNoteValue . entityVal) trNotes + return . fromIntegral $ sum tAmts + +getShieldedBalance :: ConnectionPool -> ZcashAccountId -> IO Integer +getShieldedBalance pool za = do + 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 . fromIntegral $ sBal + oBal + +getUnconfirmedBalance :: ConnectionPool -> ZcashAccountId -> IO Integer +getUnconfirmedBalance 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 . 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 $ @@ -1366,6 +2161,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] @@ -1374,10 +2201,42 @@ getWalletUnspentTrNotes pool za = do PS.retryOnBusy $ flip PS.runSqlPool pool $ do select $ do - n <- from $ table @WalletTrNote - where_ (n ^. WalletTrNoteAccId ==. val za) - where_ (n ^. WalletTrNoteSpent ==. val False) - pure n + (txs :& tNotes) <- + from $ table @WalletTransaction `innerJoin` table @WalletTrNote `on` + (\(txs :& tNotes) -> + txs ^. WalletTransactionId ==. tNotes ^. WalletTrNoteTx) + where_ (tNotes ^. WalletTrNoteAccId ==. val za) + where_ (tNotes ^. WalletTrNoteSpent ==. val False) + where_ + ((tNotes ^. WalletTrNoteChange ==. val True &&. txs ^. + WalletTransactionConf >=. + val 3) ||. + (tNotes ^. WalletTrNoteChange ==. val False &&. txs ^. + WalletTransactionConf >=. + val 10)) + pure tNotes + +getWalletUnspentUnconfirmedTrNotes :: + ConnectionPool -> ZcashAccountId -> IO [Entity WalletTrNote] +getWalletUnspentUnconfirmedTrNotes pool za = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + (txs :& tNotes) <- + from $ table @WalletTransaction `innerJoin` table @WalletTrNote `on` + (\(txs :& tNotes) -> + txs ^. WalletTransactionId ==. tNotes ^. WalletTrNoteTx) + where_ (tNotes ^. WalletTrNoteAccId ==. val za) + where_ (tNotes ^. WalletTrNoteSpent ==. val False) + where_ + ((tNotes ^. WalletTrNoteChange ==. val True &&. txs ^. + WalletTransactionConf <. + val 3) ||. + (tNotes ^. WalletTrNoteChange ==. val False &&. txs ^. + WalletTransactionConf <. + val 10)) + pure tNotes getWalletUnspentSapNotes :: ConnectionPool -> ZcashAccountId -> IO [Entity WalletSapNote] @@ -1386,10 +2245,42 @@ getWalletUnspentSapNotes pool za = do PS.retryOnBusy $ flip PS.runSqlPool pool $ do select $ do - n1 <- from $ table @WalletSapNote - where_ (n1 ^. WalletSapNoteAccId ==. val za) - where_ (n1 ^. WalletSapNoteSpent ==. val False) - pure n1 + (txs :& sNotes) <- + from $ table @WalletTransaction `innerJoin` table @WalletSapNote `on` + (\(txs :& sNotes) -> + txs ^. WalletTransactionId ==. sNotes ^. WalletSapNoteTx) + where_ (sNotes ^. WalletSapNoteAccId ==. val za) + where_ (sNotes ^. WalletSapNoteSpent ==. val False) + where_ + ((sNotes ^. WalletSapNoteChange ==. val True &&. txs ^. + WalletTransactionConf >=. + val 3) ||. + (sNotes ^. WalletSapNoteChange ==. val False &&. txs ^. + WalletTransactionConf >=. + val 10)) + pure sNotes + +getWalletUnspentUnconfirmedSapNotes :: + ConnectionPool -> ZcashAccountId -> IO [Entity WalletSapNote] +getWalletUnspentUnconfirmedSapNotes pool za = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + (txs :& sNotes) <- + from $ table @WalletTransaction `innerJoin` table @WalletSapNote `on` + (\(txs :& sNotes) -> + txs ^. WalletTransactionId ==. sNotes ^. WalletSapNoteTx) + where_ (sNotes ^. WalletSapNoteAccId ==. val za) + where_ (sNotes ^. WalletSapNoteSpent ==. val False) + where_ + ((sNotes ^. WalletSapNoteChange ==. val True &&. txs ^. + WalletTransactionConf <. + val 3) ||. + (sNotes ^. WalletSapNoteChange ==. val False &&. txs ^. + WalletTransactionConf <. + val 10)) + pure sNotes getWalletUnspentOrchNotes :: ConnectionPool -> ZcashAccountId -> IO [Entity WalletOrchNote] @@ -1398,10 +2289,42 @@ getWalletUnspentOrchNotes pool za = do PS.retryOnBusy $ flip PS.runSqlPool pool $ do select $ do - n2 <- from $ table @WalletOrchNote - where_ (n2 ^. WalletOrchNoteAccId ==. val za) - where_ (n2 ^. WalletOrchNoteSpent ==. val False) - pure n2 + (txs :& oNotes) <- + from $ table @WalletTransaction `innerJoin` table @WalletOrchNote `on` + (\(txs :& oNotes) -> + txs ^. WalletTransactionId ==. oNotes ^. WalletOrchNoteTx) + where_ (oNotes ^. WalletOrchNoteAccId ==. val za) + where_ (oNotes ^. WalletOrchNoteSpent ==. val False) + where_ + ((oNotes ^. WalletOrchNoteChange ==. val True &&. txs ^. + WalletTransactionConf >=. + val 3) ||. + (oNotes ^. WalletOrchNoteChange ==. val False &&. txs ^. + WalletTransactionConf >=. + val 10)) + pure oNotes + +getWalletUnspentUnconfirmedOrchNotes :: + ConnectionPool -> ZcashAccountId -> IO [Entity WalletOrchNote] +getWalletUnspentUnconfirmedOrchNotes pool za = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + (txs :& oNotes) <- + from $ table @WalletTransaction `innerJoin` table @WalletOrchNote `on` + (\(txs :& oNotes) -> + txs ^. WalletTransactionId ==. oNotes ^. WalletOrchNoteTx) + where_ (oNotes ^. WalletOrchNoteAccId ==. val za) + where_ (oNotes ^. WalletOrchNoteSpent ==. val False) + where_ + ((oNotes ^. WalletOrchNoteChange ==. val True &&. txs ^. + WalletTransactionConf <. + val 3) ||. + (oNotes ^. WalletOrchNoteChange ==. val False &&. txs ^. + WalletTransactionConf <. + val 10)) + pure oNotes selectUnspentNotes :: ConnectionPool @@ -1426,7 +2349,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 @@ -1435,7 +2358,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 @@ -1443,7 +2366,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 @@ -1462,10 +2511,493 @@ getWalletTxId pool wId = do where_ (wtx ^. WalletTransactionId ==. val wId) pure $ wtx ^. WalletTransactionTxId +getUnconfirmedBlocks :: ConnectionPool -> IO [Int] +getUnconfirmedBlocks pool = do + r <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + wtx <- from $ table @WalletTransaction + where_ (wtx ^. WalletTransactionConf <=. val 10) + pure $ wtx ^. WalletTransactionBlock + return $ map (\(Value i) -> i) r + +saveConfs :: ConnectionPool -> Int -> Int -> IO () +saveConfs pool b c = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ 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 readUnifiedAddressDB = isValidUnifiedAddress . TE.encodeUtf8 . getUA . walletAddressUAddress +-- | Get list of external zcash addresses from database +getAdrBook :: ConnectionPool -> ZcashNet -> IO [Entity AddressBook] +getAdrBook pool n = + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + adrbook <- from $ table @AddressBook + where_ (adrbook ^. AddressBookNetwork ==. val (ZcashNetDB n)) + pure adrbook + +-- | Save a new address into AddressBook +saveAdrsInAdrBook :: + ConnectionPool -- ^ The database path to use + -> AddressBook -- ^ The address to add to the database + -> IO (Maybe (Entity AddressBook)) +saveAdrsInAdrBook pool a = + runNoLoggingT $ + PS.retryOnBusy $ flip PS.runSqlPool pool $ insertUniqueEntity a + +-- | Update an existing address into AddressBook +updateAdrsInAdrBook :: ConnectionPool -> T.Text -> T.Text -> T.Text -> IO () +updateAdrsInAdrBook pool d a ia = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + update $ \ab -> do + set ab [AddressBookAbdescrip =. val d, AddressBookAbaddress =. val a] + where_ $ ab ^. AddressBookAbaddress ==. val ia + +-- | Get one AddrssBook record using the Address as a key +-- getABookRec :: ConnectionPool -> T.Tex t -> IO (Maybe (Entity AddressBook)) +-- getABookRec pool a = do +-- runNoLoggingT $ +-- PS.retryOnBusy $ +-- flip PS.runSqlPool pool $ +-- select $ do +-- adrbook <- from $ table @AddressBook +-- where_ ((adrbook ^. AddressBookAbaddress) ==. val a) +-- return adrbook +-- | delete an existing address from AddressBook +deleteAdrsFromAB :: ConnectionPool -> T.Text -> IO () +deleteAdrsFromAB pool ia = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + delete $ do + ab <- from $ table @AddressBook + where_ (ab ^. AddressBookAbaddress ==. val ia) + 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 new file mode 100644 index 0000000..a059b89 --- /dev/null +++ b/src/Zenith/GUI.hs @@ -0,0 +1,2014 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} + +module Zenith.GUI where + +import Codec.Picture +import Codec.Picture.Types (pixelFold, promoteImage) +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 + ( LoggingT + , NoLoggingT + , logDebugN + , runNoLoggingT + , runStderrLoggingT + ) +import Data.Aeson +import qualified Data.ByteString as BS +import Data.HexString (toText) +import Data.Maybe (fromMaybe, isJust, isNothing) +import Data.Scientific (Scientific, fromFloatDigits) +import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import qualified Data.UUID as U +import Database.Esqueleto.Experimental (ConnectionPool, fromSqlKey) +import Database.Persist +import Lens.Micro ((&), (+~), (.~), (?~), (^.), set) +import Lens.Micro.TH +import Monomer +import qualified Monomer.Lens as L +import System.Directory (getHomeDirectory) +import System.FilePath (()) +import Text.Printf +import Text.Wrap (FillScope(..), FillStrategy(..), WrapSettings(..), wrapText) +import TextShow hiding (toText) +import ZcashHaskell.Keys (generateWalletSeedPhrase) +import ZcashHaskell.Orchard + ( getSaplingFromUA + , isValidUnifiedAddress + , parseAddress + ) +import ZcashHaskell.Transparent + ( decodeTransparentAddress + , encodeTransparentReceiver + ) +import ZcashHaskell.Types + ( BlockResponse(..) + , Scope(..) + , ToBytes(..) + , UnifiedAddress(..) + , ValidAddress(..) + , ZcashNet(..) + , ZebraGetBlockChainInfo(..) + , ZebraGetInfo(..) + ) +import ZcashHaskell.Utils (getBlockTime, makeZebraCall) +import Zenith.Core +import Zenith.DB +import Zenith.GUI.Theme +import Zenith.Scanner (checkIntegrity, processTx, rescanZebra, updateConfs) +import Zenith.Types hiding (ZcashAddress(..)) +import Zenith.Utils + ( displayAmount + , getChainTip + , isRecipientValidGUI + , isValidString + , isZecAddressValid + , jsonNumber + , padWithZero + , showAddress + , validBarValue + ) + +data AppEvent + = AppInit + | ShowMsg !T.Text + | ShowError !T.Text + | ShowModal !T.Text + | CloseMsg + | WalletClicked + | AccountClicked + | MenuClicked + | NewClicked + | NewAddress !(Maybe (Entity ZcashAccount)) + | NewAccount !(Maybe (Entity ZcashWallet)) + | NewWallet + | SetPool !ZcashPool + | SwitchQr !(Maybe QrCode) + | SwitchAddr !Int + | SwitchAcc !Int + | SwitchWal !Int + | UpdateBalance !(Integer, Integer, Integer, Integer) + | CopyAddr !(Maybe (Entity WalletAddress)) + | LoadTxs ![Entity UserTx] + | LoadAddrs ![Entity WalletAddress] + | LoadAccs ![Entity ZcashAccount] + | LoadWallets ![Entity ZcashWallet] + | ConfirmCancel + | SaveAddress !(Maybe (Entity ZcashAccount)) + | SaveAccount !(Maybe (Entity ZcashWallet)) + | SaveWallet + | CloseSeed + | CloseTxId + | ShowSeed + | CopySeed !T.Text + | CopyTx !T.Text + | CloseTx + | ShowTx !Int + | TickUp + | SyncVal !Float + | SendTx + | ShowSend + | CancelSend + | 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 + { _configuration :: !Config + , _network :: !ZcashNet + , _wallets :: ![Entity ZcashWallet] + , _selWallet :: !Int + , _accounts :: ![Entity ZcashAccount] + , _selAcc :: !Int + , _addresses :: ![Entity WalletAddress] + , _selAddr :: !Int + , _transactions :: ![Entity UserTx] + , _setTx :: !Int + , _msg :: !(Maybe T.Text) + , _zebraOn :: !Bool + , _balance :: !Integer + , _unconfBalance :: !(Maybe Integer) + , _selPool :: !ZcashPool + , _qrCodeWidget :: !(Maybe QrCode) + , _accPopup :: !Bool + , _walPopup :: !Bool + , _menuPopup :: !Bool + , _newPopup :: !Bool + , _mainInput :: !T.Text + , _confirmTitle :: !(Maybe T.Text) + , _confirmAccept :: !T.Text + , _confirmCancel :: !T.Text + , _confirmEvent :: !AppEvent + , _inError :: !Bool + , _showSeed :: !Bool + , _modalMsg :: !(Maybe T.Text) + , _showTx :: !(Maybe Int) + , _timer :: !Int + , _barValue :: !Float + , _openSend :: !Bool + , _sendRecipient :: !T.Text + , _sendAmount :: !Float + , _sendMemo :: !T.Text + , _recipientValid :: !Bool + , _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 + +remixArrowRightWideLine :: T.Text +remixArrowRightWideLine = toGlyph 0xF496 + +remixHourglassFill :: T.Text +remixHourglassFill = toGlyph 0xF338 + +remixIcon :: T.Text -> WidgetNode s e +remixIcon i = label i `styleBasic` [textFont "Remix", textMiddle] + +buildUI :: + WidgetEnv AppModel AppEvent -> AppModel -> WidgetNode AppModel AppEvent +buildUI wenv model = widgetTree + where + btnColor = rgbHex "#ff5722" --rgbHex "#1818B2" + btnHiLite = rgbHex "#207DE8" + currentWallet = + if null (model ^. wallets) + then Nothing + else Just ((model ^. wallets) !! (model ^. selWallet)) + currentAccount = + if null (model ^. accounts) + then Nothing + else Just ((model ^. accounts) !! (model ^. selAcc)) + currentAddress = + if null (model ^. addresses) + then Nothing + else Just ((model ^. addresses) !! (model ^. selAddr)) + widgetTree = + zstack + [ mainWindow + , confirmOverlay `nodeVisible` isJust (model ^. confirmTitle) + , seedOverlay `nodeVisible` model ^. showSeed + , txOverlay `nodeVisible` isJust (model ^. showTx) + , sendTxOverlay `nodeVisible` model ^. openSend + , 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 + [ windowHeader + , spacer + , balanceBox + , filler + , mainPane + , filler + , windowFooter + ] + windowHeader = + hstack + [ vstack + [ box_ + [onClick MenuClicked, alignMiddle] + (remixIcon remixMenuFill `styleBasic` + [textSize 16, textColor white]) `styleBasic` + [cursorHand, height 25, padding 3] `styleHover` + [bgColor btnHiLite] + , popup menuPopup menuBox + ] + , vstack + [ box_ [onClick WalletClicked, alignMiddle] walletButton `styleBasic` + [cursorHand, height 25, padding 3] `styleHover` + [bgColor btnHiLite] + , popup walPopup walListPopup + ] + , vstack + [ box_ [onClick AccountClicked, alignMiddle] accountButton `styleBasic` + [cursorHand, height 25, padding 3] `styleHover` + [bgColor btnHiLite] + , popup accPopup accListPopup + ] + , filler + , remixIcon remixErrorWarningFill `styleBasic` [textColor white] + , label "Testnet" `styleBasic` [textColor white] `nodeVisible` + (model ^. network == TestNet) + ] `styleBasic` + [bgColor btnColor] + menuBox = + box_ + [alignMiddle] + (vstack + [ box_ + [alignLeft] + (vstack + [ box_ + [alignLeft, onClick NewClicked] + (hstack + [ label "New" + , filler + , widgetIf (not $ model ^. newPopup) $ + remixIcon remixMenuUnfoldFill + , widgetIf (model ^. newPopup) $ + remixIcon remixMenuFoldFill + ]) + , widgetIf (model ^. newPopup) $ animSlideIn newBox + ]) `styleBasic` + [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 = + box_ + [alignMiddle] + (vstack + [ box_ + [alignLeft, onClick $ NewAddress currentAccount] + (hstack [label "Address", filler]) `styleBasic` + [bgColor white, borderB 1 gray, padding 3] + , box_ + [alignLeft, onClick $ NewAccount currentWallet] + (hstack [label "Account", filler]) `styleBasic` + [bgColor white, borderB 1 gray, padding 3] + , box_ + [alignLeft, onClick NewWallet] + (hstack [label "Wallet", filler]) `styleBasic` + [bgColor white, borderB 1 gray, padding 3] + ]) + walletButton = + hstack + [ label "Wallet: " `styleBasic` [textFont "Bold", textColor white] + , label (maybe "None" (zcashWalletName . entityVal) currentWallet) `styleBasic` + [textFont "Regular", textColor white] + , remixIcon remixArrowRightWideLine `styleBasic` [textColor white] + ] + walListPopup = + box_ [alignMiddle] dispWalList `styleBasic` [bgColor btnColor, padding 3] + dispWalList = vstack (zipWith walRow [0 ..] (model ^. wallets)) + walRow :: Int -> Entity ZcashWallet -> WidgetNode AppModel AppEvent + walRow idx wal = + box_ + [onClick $ SwitchWal idx, alignCenter] + (label (zcashWalletName (entityVal wal))) `styleBasic` + [ padding 1 + , borderB 1 gray + , bgColor white + , width 80 + , styleIf (model ^. selWallet == idx) (borderL 2 btnHiLite) + , styleIf (model ^. selWallet == idx) (borderR 2 btnHiLite) + ] + accountButton = + hstack + [ label "Account: " `styleBasic` [textFont "Bold", textColor white] + , label (maybe "None" (zcashAccountName . entityVal) currentAccount) `styleBasic` + [textFont "Regular", textColor white] + , remixIcon remixArrowRightWideLine `styleBasic` [textColor white] + ] + accListPopup = + box_ [alignMiddle] dispAccList `styleBasic` [bgColor btnColor, padding 3] + dispAccList = vstack (zipWith accRow [0 ..] (model ^. accounts)) + accRow :: Int -> Entity ZcashAccount -> WidgetNode AppModel AppEvent + accRow idx wAcc = + box_ + [onClick $ SwitchAcc idx, alignLeft] + (label (zcashAccountName (entityVal wAcc))) `styleBasic` + [ padding 1 + , borderB 1 gray + , bgColor white + , width 80 + , styleIf (model ^. selAcc == idx) (borderL 2 btnHiLite) + , styleIf (model ^. selAcc == idx) (borderR 2 btnHiLite) + ] + mainPane = + box_ [alignMiddle] $ + hstack + [ addressBox + , vstack + [ mainButton "Send" ShowSend `styleBasic` [textFont "Bold"] + , txBox `nodeVisible` not (null $ model ^. transactions) + ] + ] + balanceBox = + hstack + [ filler + , boxShadow $ + box_ + [alignMiddle] + (vstack + [ hstack + [ filler + , animFadeIn + (label + (displayAmount (model ^. network) $ model ^. balance) `styleBasic` + [textSize 20]) + , filler + ] + , hstack + [ filler + , remixIcon remixHourglassFill `styleBasic` [textSize 8] + , label + (maybe "0" (displayAmount (model ^. network)) $ + model ^. unconfBalance) `styleBasic` + [textSize 8] + , filler + ] `nodeVisible` + isJust (model ^. unconfBalance) + ]) `styleBasic` + [bgColor white, radius 5, border 1 btnColor] + , filler + ] + addressBox = + vstack + [ boxShadow $ + box_ + [alignMiddle] + (vstack + [ label "Addresses" `styleBasic` + [textFont "Bold", textColor white, bgColor btnColor] + , vscroll (vstack (zipWith addrRow [0 ..] (model ^. addresses))) `nodeKey` + "addrScroll" + ]) `styleBasic` + [padding 3, radius 2, bgColor white] + , addrQRCode + ] + addrQRCode :: WidgetNode AppModel AppEvent + addrQRCode = + box_ + [alignMiddle] + (hstack + [ filler + , boxShadow $ + hstack + [ vstack + [ tooltip "Unified" $ + box_ + [onClick (SetPool OrchardPool)] + (remixIcon remixShieldCheckFill `styleBasic` + [ textSize 14 + , padding 4 + , styleIf + (model ^. selPool == OrchardPool) + (bgColor btnColor) + , styleIf + (model ^. selPool == OrchardPool) + (textColor white) + ]) + , filler + , tooltip "Legacy Shielded" $ + box_ + [onClick (SetPool SaplingPool)] + (remixIcon remixShieldLine `styleBasic` + [ textSize 14 + , padding 4 + , styleIf + (model ^. selPool == SaplingPool) + (bgColor btnColor) + , styleIf + (model ^. selPool == SaplingPool) + (textColor white) + ]) + , filler + , tooltip "Transparent" $ + box_ + [onClick (SetPool TransparentPool)] + (remixIcon remixEyeLine `styleBasic` + [ textSize 14 + , padding 4 + , styleIf + (model ^. selPool == TransparentPool) + (bgColor btnColor) + , styleIf + (model ^. selPool == TransparentPool) + (textColor white) + ]) + ] `styleBasic` + [bgColor white] + , vstack + [ filler + , tooltip "Copy" $ + box_ + [onClick $ CopyAddr currentAddress] + (hstack + [ label + (case model ^. selPool of + OrchardPool -> "Unified" + SaplingPool -> "Legacy Shielded" + TransparentPool -> "Transparent" + SproutPool -> "Unknown") `styleBasic` + [textColor white] + , remixIcon remixFileCopyFill `styleBasic` + [textSize 14, padding 4, textColor white] + ]) `styleBasic` + [cursorHand] + , box_ + [alignMiddle] + (case model ^. qrCodeWidget of + Just qr -> + imageMem_ + (qrCodeName qr) + (qrCodeBytes qr) + (Size + (fromIntegral $ qrCodeHeight qr) + (fromIntegral $ qrCodeWidth qr)) + [fitWidth] + Nothing -> + image_ + (T.pack $ + (model ^. home) + "Zenith/assets/1F928_color.png") + [fitEither]) `styleBasic` + [bgColor white, height 100, width 100] + , filler + ] `styleBasic` + [bgColor btnColor, border 2 btnColor] + ] `styleBasic` + [radius 3, border 1 btnColor] + , filler + ]) + addrRow :: Int -> Entity WalletAddress -> WidgetNode AppModel AppEvent + addrRow idx wAddr = + box_ + [onClick $ SwitchAddr idx, alignLeft] + (label + (walletAddressName (entityVal wAddr) <> + ": " <> showAddress (walletAddressUAddress $ entityVal wAddr))) `styleBasic` + [ padding 1 + , borderB 1 gray + , styleIf (model ^. selAddr == idx) (borderL 2 btnHiLite) + , styleIf (model ^. selAddr == idx) (borderR 2 btnHiLite) + ] + txBox = + boxShadow $ + box_ + [alignMiddle] + (vstack + [ label "Transactions" `styleBasic` + [textFont "Bold", bgColor btnColor, textColor white] + , vscroll (vstack (zipWith txRow [0 ..] (model ^. transactions))) `nodeKey` + "txScroll" + ]) `styleBasic` + [radius 2, padding 3, bgColor white] + txRow :: Int -> Entity UserTx -> WidgetNode AppModel AppEvent + txRow idx tx = + box_ + [onClick $ ShowTx idx] + (hstack + [ label + (T.pack $ + show + (posixSecondsToUTCTime + (fromIntegral (userTxTime $ entityVal tx)))) + , filler + , widgetIf + (T.length (userTxMemo $ entityVal tx) > 1) + (remixIcon remixDiscussFill) + , if 0 >= userTxAmount (entityVal tx) + then remixIcon remixArrowRightUpFill `styleBasic` [textColor red] + else remixIcon remixArrowRightDownFill `styleBasic` + [textColor green] + , label $ + displayAmount (model ^. network) $ + fromIntegral $ userTxAmount (entityVal tx) + ]) `styleBasic` + [padding 2, borderB 1 gray] + windowFooter = + hstack + [ label + ("Last block sync: " <> + maybe "N/A" (showt . zcashWalletLastSync . entityVal) currentWallet) `styleBasic` + [padding 3, textSize 8] + , spacer + , label (showt $ model ^. timer) `styleBasic` [padding 3, textSize 8] + , filler + , image_ + (T.pack $ (model ^. home) "Zenith/assets/1F993.png") + [fitHeight] `styleBasic` + [height 24, width 24] `nodeVisible` + (model ^. zebraOn) + , label + ("Connected on " <> + c_zebraHost (model ^. configuration) <> + ":" <> showt (c_zebraPort $ model ^. configuration)) `styleBasic` + [padding 3, textSize 8] `nodeVisible` + (model ^. zebraOn) + , label "Disconnected" `styleBasic` [padding 3, textSize 8] `nodeVisible` + not (model ^. zebraOn) + ] + msgOverlay = + alert CloseMsg $ + hstack + [ filler + , remixIcon remixErrorWarningFill `styleBasic` + [textSize 32, textColor btnColor] `nodeVisible` + (model ^. inError) + , spacer + , label $ fromMaybe "" (model ^. msg) + , filler + ] + confirmOverlay = + confirm_ + (model ^. confirmEvent) + ConfirmCancel + [ titleCaption $ fromMaybe "" $ model ^. confirmTitle + , acceptCaption $ model ^. confirmAccept + , cancelCaption $ model ^. confirmCancel + ] + (hstack [label "Name:", filler, textField_ mainInput [maxLength 25]]) + sendTxOverlay = + box + (vstack + [ filler + , hstack + [ filler + , box_ + [] + (vstack + [ box_ + [alignMiddle] + (label "Send Zcash" `styleBasic` + [textFont "Bold", textSize 12]) + , separatorLine `styleBasic` [fgColor btnColor] + , spacer + , hstack + [ 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 + , styleIf + (not $ model ^. recipientValid) + (textColor red) + ] + ] + , hstack + [ label "Amount:" `styleBasic` + [width 50, textFont "Bold"] + , spacer + , numericField_ + sendAmount + [ decimals 8 + , minValue 0.0 + , maxValue + (fromIntegral (model ^. balance) / 100000000.0) + , validInput amountValid + , onChange CheckAmount + ] `styleBasic` + [ width 150 + , styleIf + (not $ model ^. amountValid) + (textColor red) + ] + ] + , hstack + [ label "Memo:" `styleBasic` + [width 50, textFont "Bold"] + , spacer + , textArea sendMemo `styleBasic` + [width 150, height 40] + ] + , spacer + -- Radio button group for privacy level + , box_ + [alignMiddle] + (hstack + [ spacer + , button "Cancel" CancelSend + , spacer + , mainButton "Send" SendTx `nodeEnabled` + (model ^. amountValid && model ^. recipientValid) + , spacer + ]) + ]) `styleBasic` + [radius 4, border 2 btnColor, bgColor white, padding 4] + , filler + ] + , filler + ]) `styleBasic` + [bgColor (white & L.a .~ 0.5)] + seedOverlay = + alert CloseSeed $ + vstack + [ box_ + [] + (label "Seed Phrase" `styleBasic` + [textFont "Bold", textSize 12, textColor white]) `styleBasic` + [bgColor btnColor, radius 2, padding 3] + , spacer + , textAreaV_ + (maybe + "None" + (E.decodeUtf8Lenient . + getBytes . getPhrase . zcashWalletSeedPhrase . entityVal) + currentWallet) + (const CloseSeed) + [readOnly, maxLines 2] `styleBasic` + [textSize 8] + , spacer + , hstack + [ filler + , box_ + [ onClick $ + CopySeed $ + maybe + "None" + (E.decodeUtf8Lenient . + getBytes . getPhrase . zcashWalletSeedPhrase . entityVal) + currentWallet + ] + (hstack + [ label "Copy" `styleBasic` [textColor white] + , remixIcon remixFileCopyLine `styleBasic` [textColor white] + ]) `styleBasic` + [cursorHand, bgColor btnColor, radius 2, padding 3] + , filler + ] + ] + modalOverlay = + box + (label (fromMaybe "?" $ model ^. modalMsg) `styleBasic` + [textSize 12, textFont "Bold"]) `styleBasic` + [bgColor (white & L.a .~ 0.7)] + txOverlay = + case model ^. showTx of + Nothing -> alert CloseTx $ label "N/A" + Just i -> + alert CloseTx $ + vstack + [ box_ + [alignLeft] + (hstack + [ label "Date " `styleBasic` [width 60, textFont "Bold"] + , separatorLine `styleBasic` [fgColor btnColor] + , spacer + , label + (T.pack $ + show $ + posixSecondsToUTCTime $ + fromIntegral $ + userTxTime $ entityVal $ (model ^. transactions) !! i) + ]) `styleBasic` + [padding 2, bgColor white, width 280, borderB 1 gray] + , box_ + [alignLeft] + (hstack + [ label "Tx ID " `styleBasic` [width 60, textFont "Bold"] + , separatorLine `styleBasic` [fgColor btnColor] + , spacer + , label_ + (txtWrap $ + toText $ + getHex $ + userTxHex $ entityVal $ (model ^. transactions) !! i) + [multiline] + , spacer + , box_ + [ onClick $ + CopyTx $ + toText $ + getHex $ + userTxHex $ entityVal $ (model ^. transactions) !! i + ] + (remixIcon remixFileCopyFill `styleBasic` + [textColor white]) `styleBasic` + [cursorHand, bgColor btnColor, radius 2, padding 2] + ]) `styleBasic` + [padding 2, bgColor white, width 280, borderB 1 gray] + , box_ + [alignLeft] + (hstack + [ label "Amount" `styleBasic` [width 60, textFont "Bold"] + , separatorLine `styleBasic` [fgColor btnColor] + , spacer + , label $ + displayAmount (model ^. network) $ + fromIntegral $ + userTxAmount $ entityVal $ (model ^. transactions) !! i + ]) `styleBasic` + [padding 2, bgColor white, width 280, borderB 1 gray] + , box_ + [alignLeft] + (hstack + [ label "Memo " `styleBasic` [width 60, textFont "Bold"] + , separatorLine `styleBasic` [fgColor btnColor] + , spacer + , label_ + (txtWrap $ + userTxMemo $ entityVal $ (model ^. transactions) !! i) + [multiline] + ]) `styleBasic` + [padding 2, bgColor white, width 280, borderB 1 gray] + ] + txIdOverlay = + case model ^. showId of + Nothing -> alert CloseTxId $ label "N/A" + Just t -> + alert CloseTxId $ + box_ + [alignLeft] + (vstack + [ box_ [alignMiddle] $ + label "Transaction Sent!" `styleBasic` [textFont "Bold"] + , spacer + , hstack + [ label "Tx ID " `styleBasic` [width 60, textFont "Bold"] + , separatorLine `styleBasic` [fgColor btnColor] + , spacer + , label_ (txtWrap t) [multiline] + , spacer + , box_ + [onClick $ CopyTx t] + (remixIcon remixFileCopyFill `styleBasic` + [textColor white]) `styleBasic` + [cursorHand, bgColor btnColor, radius 2, padding 2] + ] + ]) `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 + let dbFilePath = c_dbPath config + pool <- runNoLoggingT $ initPool dbFilePath + addrs <- getExternalAddresses pool + mapM_ (checkExistingQrs pool) addrs + where + checkExistingQrs :: ConnectionPool -> Entity WalletAddress -> IO () + checkExistingQrs pool wAddr = do + s <- getQrCodes pool (entityKey wAddr) + if not (null s) + then return () + else do + generateOneQr pool OrchardPool wAddr + generateOneQr pool SaplingPool wAddr + generateOneQr pool TransparentPool wAddr + generateOneQr :: + ConnectionPool -> ZcashPool -> Entity WalletAddress -> IO () + generateOneQr p zp wAddr = + case encodeText (defaultQRCodeOptions L) Utf8WithoutECI =<< + dispAddr zp (entityVal wAddr) of + Just qr -> do + _ <- + runNoLoggingT $ + saveQrCode p $ + QrCode + (entityKey wAddr) + zp + (qrCodeData qr) + (qrCodeH qr) + (qrCodeW qr) + (walletAddressName (entityVal wAddr) <> T.pack (show zp)) + return () + Nothing -> return () + qrCodeImg :: QRImage -> Image PixelRGBA8 + qrCodeImg qr = promoteImage (toImage 4 2 qr) + qrCodeH :: QRImage -> Int + qrCodeH qr = fromIntegral $ imageHeight $ qrCodeImg qr + qrCodeW :: QRImage -> Int + qrCodeW qr = fromIntegral $ imageWidth $ qrCodeImg qr + qrCodeData :: QRImage -> BS.ByteString + qrCodeData qr = + BS.pack $ + pixelFold + (\bs _ _ (PixelRGBA8 i j k l) -> bs <> [i, j, k, l]) + [] + (qrCodeImg qr) + dispAddr :: ZcashPool -> WalletAddress -> Maybe T.Text + dispAddr zp w = + case zp of + TransparentPool -> + T.append "zcash:" . + encodeTransparentReceiver + (maybe + TestNet + ua_net + ((isValidUnifiedAddress . + E.encodeUtf8 . getUA . walletAddressUAddress) + w)) <$> + (t_rec =<< + (isValidUnifiedAddress . E.encodeUtf8 . getUA . walletAddressUAddress) + w) + SaplingPool -> + T.append "zcash:" <$> + (getSaplingFromUA . E.encodeUtf8 . getUA . walletAddressUAddress) w + OrchardPool -> + Just $ (T.append "zcash:" . getUA . walletAddressUAddress) w + SproutPool -> Nothing + +handleEvent :: + WidgetEnv AppModel AppEvent + -> WidgetNode AppModel AppEvent + -> AppModel + -> AppEvent + -> [AppEventResponse AppModel AppEvent] +handleEvent wenv node model evt = + case evt of + AppInit -> + [Event NewWallet | isNothing currentWallet] <> [Producer timeTicker] + ShowMsg t -> [Model $ model & msg ?~ t & menuPopup .~ False] + ShowError t -> + [ Model $ + model & msg ?~ t & menuPopup .~ False & inError .~ True & modalMsg .~ + Nothing + ] + ShowModal t -> [Model $ model & modalMsg ?~ t] + WalletClicked -> [Model $ model & walPopup .~ True] + AccountClicked -> [Model $ model & accPopup .~ True] + MenuClicked -> [Model $ model & menuPopup .~ True] + NewClicked -> [Model $ model & newPopup .~ not (model ^. newPopup)] + NewAddress acc -> + [ Model $ + model & confirmTitle ?~ "New Address" & confirmAccept .~ "Create" & + confirmCancel .~ + "Cancel" & + confirmEvent .~ + SaveAddress acc & + menuPopup .~ + False + ] + NewAccount wal -> + [ Model $ + model & confirmTitle ?~ "New Account" & confirmAccept .~ "Create" & + confirmCancel .~ + "Cancel" & + confirmEvent .~ + SaveAccount wal & + menuPopup .~ + False + ] + NewWallet -> + [ Model $ + model & confirmTitle ?~ "New Wallet" & confirmAccept .~ "Create" & + confirmCancel .~ + "Cancel" & + confirmEvent .~ + SaveWallet & + menuPopup .~ + False + ] + ConfirmCancel -> [Model $ model & confirmTitle .~ Nothing & mainInput .~ ""] + ShowSeed -> [Model $ model & showSeed .~ True & menuPopup .~ False] + ShowSend -> + [ Model $ + model & openSend .~ True & privacyChoice .~ Full & recipientValid .~ + False + ] + SendTx -> + case currentAccount of + Nothing -> [Event $ ShowError "No account available", Event CancelSend] + Just acc -> + case currentWallet of + Nothing -> + [Event $ ShowError "No wallet available", Event CancelSend] + Just wal -> + [ Producer $ + sendTransaction + (model ^. configuration) + (model ^. network) + (entityKey acc) + (zcashWalletLastSync $ entityVal wal) + (fromFloatDigits $ model ^. sendAmount) + (model ^. sendRecipient) + (model ^. sendMemo) + (model ^. privacyChoice) + , Event CancelSend + ] + CancelSend -> + [ Model $ + model & openSend .~ False & sendRecipient .~ "" & sendAmount .~ 0.0 & + sendMemo .~ + "" + ] + SaveAddress acc -> + if T.length (model ^. mainInput) > 1 + then [ Task $ addNewAddress (model ^. mainInput) External acc + , Event $ ShowModal "Generating QR codes..." + , Event ConfirmCancel + ] + else [Event $ ShowError "Invalid input", Event ConfirmCancel] + SaveAccount wal -> + if T.length (model ^. mainInput) > 1 + then [ Task $ addNewAccount (model ^. mainInput) wal + , Event ConfirmCancel + ] + else [Event $ ShowError "Invalid input", Event ConfirmCancel] + SaveWallet -> + if T.length (model ^. mainInput) > 1 + then [Task addNewWallet, Event ConfirmCancel] + else [Event $ ShowError "Invalid input"] + SetPool p -> + [ Model $ model & selPool .~ p & modalMsg .~ Nothing + , Task $ + SwitchQr <$> do + dbPool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration + case currentAddress of + Nothing -> return Nothing + Just wAddr -> getQrCode dbPool p $ entityKey wAddr + , Task $ + LoadTxs <$> do + dbPool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration + case currentAddress of + Nothing -> return [] + Just wAddr -> getUserTx dbPool $ entityKey wAddr + ] + SwitchQr q -> [Model $ model & qrCodeWidget .~ q] + SwitchAddr i -> [Model $ model & selAddr .~ i, Event $ SetPool OrchardPool] + SwitchAcc i -> + [ Model $ model & selAcc .~ i + , Task $ + LoadAddrs <$> do + dbPool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration + case selectAccount i of + Nothing -> return [] + Just acc -> runNoLoggingT $ getAddresses dbPool $ entityKey acc + , Task $ + UpdateBalance <$> do + dbPool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration + case selectAccount i of + Nothing -> return (0, 0, 0, 0) + Just acc -> do + b <- getBalance dbPool $ entityKey acc + u <- getUnconfirmedBalance dbPool $ entityKey acc + 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 + , Task $ + LoadAccs <$> do + dbPool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration + case selectWallet i of + Nothing -> return [] + Just wal -> runNoLoggingT $ getAccounts dbPool $ entityKey wal + ] + UpdateBalance (b, u, s, t) -> + [ Model $ + model & balance .~ b & sBalance .~ s & tBalance .~ t & unconfBalance .~ + (if u == 0 + then Nothing + else Just u) + ] + CopyAddr a -> + [ setClipboardData ClipboardEmpty + , setClipboardData $ + ClipboardText $ + case model ^. selPool of + OrchardPool -> + maybe "None" (getUA . walletAddressUAddress . entityVal) a + SaplingPool -> + fromMaybe "None" $ + (getSaplingFromUA . + E.encodeUtf8 . getUA . walletAddressUAddress . entityVal) =<< + a + SproutPool -> "None" + TransparentPool -> + maybe "None" (encodeTransparentReceiver (model ^. network)) $ + t_rec =<< + (isValidUnifiedAddress . + E.encodeUtf8 . getUA . walletAddressUAddress . entityVal) =<< + a + , Event $ ShowMsg "Copied address!" + ] + CopySeed s -> + [ setClipboardData ClipboardEmpty + , setClipboardData $ ClipboardText s + , Event $ ShowMsg "Copied seed phrase!" + ] + CopyTx t -> + [ setClipboardData ClipboardEmpty + , setClipboardData $ ClipboardText t + , Event $ ShowMsg "Copied transaction ID!" + ] + LoadTxs t -> [Model $ model & transactions .~ t] + LoadAddrs a -> + if not (null a) + then [ Model $ model & addresses .~ a + , Event $ SwitchAddr $ model ^. selAddr + , Event $ SetPool OrchardPool + ] + else [Event $ NewAddress currentAccount] + LoadAccs a -> + if not (null a) + then [Model $ model & accounts .~ a, Event $ SwitchAcc 0] + else [Event $ NewAccount currentWallet] + LoadWallets a -> + if not (null a) + then [ Model $ model & wallets .~ a & modalMsg .~ Nothing + , Event $ SwitchWal $ model ^. selWallet + ] + else [Event NewWallet] + CloseMsg -> [Model $ model & msg .~ Nothing & inError .~ False] + CloseSeed -> [Model $ model & showSeed .~ False] + CloseTx -> [Model $ model & showTx .~ Nothing] + CloseTxId -> [Model $ model & showId .~ Nothing] + ShowTx i -> [Model $ model & showTx ?~ i] + TickUp -> + 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] + else [ Model $ + model & barValue .~ validBarValue (i + model ^. barValue) & + modalMsg ?~ + ("Wallet Sync: " <> + T.pack (printf "%.2f%%" (model ^. barValue * 100))) + ] + 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) + then Nothing + else Just ((model ^. wallets) !! (model ^. selWallet)) + selectWallet i = + if null (model ^. wallets) + then Nothing + else Just ((model ^. wallets) !! i) + currentAccount = + if null (model ^. accounts) + then Nothing + else Just ((model ^. accounts) !! (model ^. selAcc)) + selectAccount i = + if null (model ^. accounts) + then Nothing + else Just ((model ^. accounts) !! i) + currentAddress = + if null (model ^. addresses) + then Nothing + else Just ((model ^. addresses) !! (model ^. selAddr)) + addNewAddress :: + T.Text -> Scope -> Maybe (Entity ZcashAccount) -> IO AppEvent + addNewAddress n scope acc = do + case acc of + Nothing -> return $ ShowError "No account available" + Just a -> do + pool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration + maxAddr <- getMaxAddress pool (entityKey a) scope + uA <- + try $ createWalletAddress n (maxAddr + 1) (model ^. network) scope a :: IO + (Either IOError WalletAddress) + case uA of + Left e -> return $ ShowError $ "Error: " <> T.pack (show e) + Right uA' -> do + nAddr <- saveAddress pool uA' + case nAddr of + Nothing -> return $ ShowError $ "Address already exists: " <> n + Just _x -> do + generateQRCodes $ model ^. configuration + addrL <- runNoLoggingT $ getAddresses pool $ entityKey a + return $ LoadAddrs addrL + addNewAccount :: T.Text -> Maybe (Entity ZcashWallet) -> IO AppEvent + addNewAccount n w = do + case w of + Nothing -> return $ ShowError "No wallet available" + Just w' -> do + pool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration + accIx <- getMaxAccount pool $ entityKey w' + newAcc <- + try $ createZcashAccount n (accIx + 1) w' :: IO + (Either IOError ZcashAccount) + case newAcc of + Left e -> return $ ShowError "Failed to create account" + Right newAcc' -> do + r <- saveAccount pool newAcc' + case r of + Nothing -> return $ ShowError "Account already exists" + Just _x -> do + aList <- runNoLoggingT $ getAccounts pool (entityKey w') + return $ LoadAccs aList + addNewWallet :: IO AppEvent + addNewWallet = do + sP <- generateWalletSeedPhrase + pool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration + bc <- + try $ + checkBlockChain + (c_zebraHost $ model ^. configuration) + (c_zebraPort $ model ^. configuration) :: IO + (Either IOError ZebraGetBlockChainInfo) + case bc of + Left e1 -> return $ ShowError $ T.pack $ show e1 + Right chainInfo -> do + r <- + saveWallet pool $ + ZcashWallet + (model ^. mainInput) + (ZcashNetDB (model ^. network)) + (PhraseDB sP) + (zgb_blocks chainInfo) + 0 + case r of + Nothing -> return $ ShowError "Wallet already exists" + 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 + -> ZcashNet + -> (AppEvent -> IO ()) + -> NoLoggingT IO () +scanZebra dbPath zHost zPort net sendMsg = do + bStatus <- liftIO $ checkBlockChain zHost zPort + 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 liftIO $ sendMsg (ShowError "Invalid starting block for scan") + else do + let bList = [(sb + 1) .. (zgb_blocks bStatus)] + if not (null bList) + then do + let step = (1.0 :: Float) / fromIntegral (length bList) + _ <- liftIO $ startSync pool + mapM_ (liftIO . processBlock pool step) bList + confUp <- + liftIO $ try $ updateConfs zHost zPort pool :: NoLoggingT + IO + (Either IOError ()) + case confUp of + Left _e0 -> do + _ <- liftIO $ completeSync pool Failed + liftIO $ + sendMsg + (ShowError "Failed to update unconfirmed transactions") + Right _ -> do + liftIO $ sendMsg TreeSync + _ <- updateCommitmentTrees pool zHost zPort $ ZcashNetDB net + _ <- liftIO $ completeSync pool Successful + logDebugN "Starting wallet sync" + liftIO $ sendMsg StartSync + else liftIO $ sendMsg (SyncVal 1.0) + where + processBlock :: ConnectionPool -> Float -> Int -> IO () + processBlock pool step bl = do + r <- + liftIO $ + makeZebraCall + zHost + zPort + "getblock" + [Data.Aeson.String $ showt bl, jsonNumber 1] + case r of + Left e1 -> do + _ <- completeSync pool Failed + sendMsg (ShowError $ showt e1) + Right blk -> do + bi <- + saveBlock pool $ + ZcashBlock + (fromIntegral $ bl_height blk) + (HexStringDB $ bl_hash blk) + (fromIntegral $ bl_confirmations blk) + (fromIntegral $ bl_time blk) + (ZcashNetDB net) + mapM_ (processTx zHost zPort bi pool) $ bl_txs blk + sendMsg (SyncVal step) + +shieldTransaction :: + Config -> ZcashNet -> ZcashAccountId -> (AppEvent -> IO ()) -> IO () +shieldTransaction config znet accId sendMsg = do + sendMsg $ ShowModal "Shielding funds..." + let dbPath = c_dbPath config + let zHost = c_zebraHost config + let zPort = c_zebraPort config + pool <- runNoLoggingT $ initPool dbPath + bl <- getChainTip zHost zPort + res <- runNoLoggingT $ shieldTransparentNotes pool zHost zPort znet accId bl + ops <- + mapM + (\case + Left e -> return $ T.pack $ show e + Right x -> do + thisOp <- getOperation pool x + case thisOp of + Nothing -> return "" + Just o -> + return $ + (U.toText . getUuid . operationUuid $ entityVal o) <> + ": " <> (T.pack . show . operationStatus $ entityVal o)) + res + sendMsg $ ShowMsg $ T.intercalate "\n" ops + +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 + res <- runNoLoggingT $ deshieldNotes pool zHost zPort znet accId bl pnote + 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 + -> Scientific + -> T.Text + -> T.Text + -> PrivacyPolicy + -> (AppEvent -> IO ()) + -> IO () +sendTransaction config znet accId bl amt ua memo policy sendMsg = do + sendMsg $ ShowModal "Preparing transaction..." + case parseAddress (E.encodeUtf8 ua) of + Nothing -> sendMsg $ ShowError "Incorrect address" + Just addr -> do + let dbPath = c_dbPath config + let zHost = c_zebraHost config + let zPort = c_zebraPort config + pool <- runNoLoggingT $ initPool dbPath + res <- + 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 + 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 + +timeTicker :: (AppEvent -> IO ()) -> IO () +timeTicker sendMsg = do + sendMsg TickUp + 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 + +runZenithGUI :: Config -> IO () +runZenithGUI config = do + homeDir <- try getHomeDirectory :: IO (Either IOError FilePath) + case homeDir of + Left e -> print e + Right hD -> do + let host = c_zebraHost config + let port = c_zebraPort config + let dbFilePath = c_dbPath config + pool <- runNoLoggingT $ initPool dbFilePath + w <- try $ checkZebra host port :: IO (Either IOError ZebraGetInfo) + case w of + Right zebra -> do + bc <- + try $ checkBlockChain host port :: IO + (Either IOError ZebraGetBlockChainInfo) + case bc of + Left e1 -> throwIO e1 + Right chainInfo -> do + 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 - 0.7.1.0-beta" + , appWindowState $ MainWindowNormal (1000, 700) + , appTheme zenithTheme + , appFontDef + "Regular" + (T.pack $ + hd + "Zenith/assets/Atkinson-Hyperlegible-Regular-102.ttf" --"./assets/DejaVuSansMono.ttf" + ) + , appFontDef + "Bold" + (T.pack $ hd "Zenith/assets/Atkinson-Hyperlegible-Bold-102.ttf") + , appFontDef + "Italic" + (T.pack $ hd "Zenith/assets/Atkinson-Hyperlegible-Italic-102.ttf") + , appFontDef "Remix" (T.pack $ hd "Zenith/assets/remixicon.ttf") + , appDisableAutoScale True + , appScaleFactor 2.0 + , appInitEvent AppInit + ] diff --git a/src/Zenith/GUI/Theme.hs b/src/Zenith/GUI/Theme.hs new file mode 100644 index 0000000..2e2cd4b --- /dev/null +++ b/src/Zenith/GUI/Theme.hs @@ -0,0 +1,343 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Zenith.GUI.Theme + ( zenithTheme + ) where + +import Data.Default +import Lens.Micro ((&), (+~), (.~), (?~), (^.), at, set) +import Monomer +import Monomer.Core.Themes.BaseTheme +import Monomer.Core.Themes.SampleThemes +import Monomer.Graphics (rgbHex, transparent) +import Monomer.Graphics.ColorTable +import qualified Monomer.Lens as L + +baseTextStyle :: TextStyle +baseTextStyle = def & L.fontSize ?~ FontSize 10 & L.fontColor ?~ black + +hiliteTextStyle :: TextStyle +hiliteTextStyle = def & L.fontSize ?~ FontSize 10 & L.fontColor ?~ white + +zenithTheme :: Theme +zenithTheme = + baseTheme zgoThemeColors & L.basic . L.labelStyle . L.text ?~ baseTextStyle & + L.hover . + L.tooltipStyle . L.text ?~ + baseTextStyle & + L.hover . + L.labelStyle . L.text ?~ + baseTextStyle & + L.basic . + L.dialogTitleStyle . L.text ?~ + (baseTextStyle & L.fontSize ?~ FontSize 12 & L.font ?~ "Bold") & + L.hover . + L.dialogTitleStyle . L.text ?~ + (baseTextStyle & L.fontSize ?~ FontSize 12 & L.font ?~ "Bold") & + L.basic . + L.btnStyle . L.text ?~ + baseTextStyle & + L.hover . + L.btnStyle . L.text ?~ + baseTextStyle & + L.focus . + L.btnStyle . L.text ?~ + baseTextStyle & + L.focusHover . + L.btnStyle . L.text ?~ + baseTextStyle & + L.active . + L.btnStyle . L.text ?~ + baseTextStyle & + L.disabled . + L.btnStyle . L.text ?~ + baseTextStyle & + L.basic . + L.btnMainStyle . L.text ?~ + hiliteTextStyle & + L.hover . + L.btnMainStyle . L.text ?~ + hiliteTextStyle & + L.focus . + L.btnMainStyle . L.text ?~ + hiliteTextStyle & + L.focusHover . + L.btnMainStyle . L.text ?~ + hiliteTextStyle & + L.active . + L.btnMainStyle . L.text ?~ + hiliteTextStyle & + L.disabled . + L.btnMainStyle . L.text ?~ + hiliteTextStyle & + L.disabled . + L.btnMainStyle . L.bgColor ?~ + gray07c & + L.basic . + L.textFieldStyle . L.text ?~ + baseTextStyle & + L.hover . + L.textFieldStyle . L.text ?~ + baseTextStyle & + L.focus . + L.textFieldStyle . L.text ?~ + baseTextStyle & + L.active . + L.textFieldStyle . L.text ?~ + baseTextStyle & + L.focusHover . + L.textFieldStyle . L.text ?~ + baseTextStyle & + L.basic . + L.numericFieldStyle . L.text ?~ + baseTextStyle & + L.hover . + L.numericFieldStyle . L.text ?~ + baseTextStyle & + L.focus . + L.numericFieldStyle . L.text ?~ + baseTextStyle & + L.active . + L.numericFieldStyle . L.text ?~ + baseTextStyle & + L.focusHover . + L.numericFieldStyle . L.text ?~ + baseTextStyle & + L.basic . + L.textAreaStyle . L.text ?~ + baseTextStyle & + L.hover . + L.textAreaStyle . L.text ?~ + baseTextStyle & + L.focus . + L.textAreaStyle . L.text ?~ + baseTextStyle & + L.active . + L.textAreaStyle . L.text ?~ + baseTextStyle & + L.focusHover . + L.textAreaStyle . L.text ?~ + baseTextStyle + +zenithThemeColors :: BaseThemeColors +zenithThemeColors = + BaseThemeColors + { clearColor = gray01 + , sectionColor = gray01 + , btnFocusBorder = blue09 + , btnBgBasic = gray07b + , btnBgHover = gray08 + , btnBgFocus = gray07c + , btnBgActive = gray06 + , btnBgDisabled = gray05 + , btnText = gray02 + , btnTextDisabled = gray01 + , btnMainFocusBorder = blue08 + , btnMainBgBasic = btnColor + , btnMainBgHover = btnHiLite + , btnMainBgFocus = btnColor + , btnMainBgActive = btnHiLite + , btnMainBgDisabled = blue04 + , btnMainText = white + , btnMainTextDisabled = gray08 + , dialogBg = gray01 + , dialogBorder = gray01 + , dialogText = white + , dialogTitleText = white + , emptyOverlay = gray05 & L.a .~ 0.8 + , shadow = gray00 & L.a .~ 0.33 + , externalLinkBasic = blue07 + , externalLinkHover = blue08 + , externalLinkFocus = blue07 + , externalLinkActive = blue06 + , externalLinkDisabled = gray06 + , iconBg = gray08 + , iconFg = gray01 + , inputIconFg = black + , inputBorder = gray02 + , inputFocusBorder = blue08 + , inputBgBasic = gray04 + , inputBgHover = gray06 + , inputBgFocus = gray05 + , inputBgActive = gray03 + , inputBgDisabled = gray07 + , inputFgBasic = gray06 + , inputFgHover = blue08 + , inputFgFocus = blue08 + , inputFgActive = blue07 + , inputFgDisabled = gray07 + , inputSndBasic = gray05 + , inputSndHover = gray06 + , inputSndFocus = gray05 + , inputSndActive = gray05 + , inputSndDisabled = gray03 + , inputHlBasic = gray07 + , inputHlHover = blue08 + , inputHlFocus = blue08 + , inputHlActive = blue08 + , inputHlDisabled = gray08 + , inputSelBasic = gray06 + , inputSelFocus = blue06 + , inputText = white + , inputTextDisabled = gray02 + , labelText = white + , scrollBarBasic = gray01 & L.a .~ 0.2 + , scrollThumbBasic = gray07 & L.a .~ 0.6 + , scrollBarHover = gray01 & L.a .~ 0.4 + , scrollThumbHover = gray07 & L.a .~ 0.8 + , slMainBg = gray00 + , slNormalBgBasic = transparent + , slNormalBgHover = gray05 + , slNormalText = white + , slNormalFocusBorder = blue08 + , slSelectedBgBasic = gray04 + , slSelectedBgHover = gray05 + , slSelectedText = white + , slSelectedFocusBorder = blue08 + , tooltipBorder = gray05 + , tooltipBg = rgbHex "#1D212B" + , tooltipText = white + } + +zgoThemeColors = + BaseThemeColors + { clearColor = gray10 -- gray12, + , sectionColor = gray09 -- gray11, + , btnFocusBorder = blue08 + , btnBgBasic = gray07 + , btnBgHover = gray07c + , btnBgFocus = gray07b + , btnBgActive = gray06 + , btnBgDisabled = gray05 + , btnText = gray02 + , btnTextDisabled = gray02 + , btnMainFocusBorder = blue09 + , btnMainBgBasic = btnColor + , btnMainBgHover = btnHiLite + , btnMainBgFocus = btnColor + , btnMainBgActive = btnHiLite + , btnMainBgDisabled = blue04 + , btnMainText = white + , btnMainTextDisabled = white + , dialogBg = white + , dialogBorder = white + , dialogText = black + , dialogTitleText = black + , emptyOverlay = gray07 & L.a .~ 0.8 + , shadow = gray00 & L.a .~ 0.2 + , externalLinkBasic = blue07 + , externalLinkHover = blue08 + , externalLinkFocus = blue07 + , externalLinkActive = blue06 + , externalLinkDisabled = gray06 + , iconBg = gray07 + , iconFg = gray01 + , inputIconFg = black + , inputBorder = gray06 + , inputFocusBorder = blue07 + , inputBgBasic = gray10 + , inputBgHover = white + , inputBgFocus = white + , inputBgActive = gray09 + , inputBgDisabled = gray05 + , inputFgBasic = gray05 + , inputFgHover = blue07 + , inputFgFocus = blue07 + , inputFgActive = blue06 + , inputFgDisabled = gray04 + , inputSndBasic = gray04 + , inputSndHover = gray05 + , inputSndFocus = gray05 + , inputSndActive = gray04 + , inputSndDisabled = gray03 + , inputHlBasic = gray06 + , inputHlHover = blue07 + , inputHlFocus = blue07 + , inputHlActive = blue06 + , inputHlDisabled = gray05 + , inputSelBasic = gray07 + , inputSelFocus = blue08 + , inputText = black + , inputTextDisabled = gray02 + , labelText = black + , scrollBarBasic = gray03 & L.a .~ 0.2 + , scrollThumbBasic = gray01 & L.a .~ 0.2 + , scrollBarHover = gray07 & L.a .~ 0.8 + , scrollThumbHover = gray05 & L.a .~ 0.8 + , slMainBg = white + , slNormalBgBasic = transparent + , slNormalBgHover = gray09 + , slNormalText = black + , slNormalFocusBorder = blue07 + , slSelectedBgBasic = gray08 + , slSelectedBgHover = gray09 + , slSelectedText = black + , slSelectedFocusBorder = blue07 + , tooltipBorder = gray08 + , tooltipBg = gray07 + , tooltipText = black + } + +--black = rgbHex "#000000" +{-white = rgbHex "#FFFFFF"-} +btnColor = rgbHex "#ff5722" --rgbHex "#1818B2" + +btnHiLite = rgbHex "#207DE8" + +blue01 = rgbHex "#002159" + +blue02 = rgbHex "#01337D" + +blue03 = rgbHex "#03449E" + +blue04 = rgbHex "#0552B5" + +blue05 = rgbHex "#0967D2" + +blue05b = rgbHex "#0F6BD7" + +blue05c = rgbHex "#1673DE" + +blue06 = rgbHex "#2186EB" + +blue06b = rgbHex "#2489EE" + +blue06c = rgbHex "#2B8FF6" + +blue07 = rgbHex "#47A3F3" + +blue07b = rgbHex "#50A6F6" + +blue07c = rgbHex "#57ACFC" + +blue08 = rgbHex "#7CC4FA" + +blue09 = rgbHex "#BAE3FF" + +blue10 = rgbHex "#E6F6FF" + +gray00 = rgbHex "#111111" + +gray01 = rgbHex "#2E2E2E" + +gray02 = rgbHex "#393939" + +gray03 = rgbHex "#515151" + +gray04 = rgbHex "#626262" + +gray05 = rgbHex "#7E7E7E" + +gray06 = rgbHex "#9E9E9E" + +gray07 = rgbHex "#B1B1B1" + +gray07b = rgbHex "#B4B4B4" + +gray07c = rgbHex "#BBBBBB" + +gray08 = rgbHex "#CFCFCF" + +gray09 = rgbHex "#E1E1E1" + +gray10 = rgbHex "#F7F7F7" diff --git a/src/Zenith/RPC.hs b/src/Zenith/RPC.hs new file mode 100644 index 0000000..82f62c1 --- /dev/null +++ b/src/Zenith/RPC.hs @@ -0,0 +1,1113 @@ +{-# 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 (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 + , deshieldNotes + , prepareTxV2 + , shieldTransparentNotes + , 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 + | ShieldNotes + | DeshieldFunds + | 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 ShieldNotes = Data.Aeson.String "shieldnotes" + toJSON DeshieldFunds = Data.Aeson.String "deshieldfunds" + 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 + "shieldnotes" -> pure ShieldNotes + "deshieldfunds" -> pure DeshieldFunds + _ -> 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 + | ShieldNotesParams !Int + | DeshieldParams !Int !Scientific + 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] + toJSON (ShieldNotesParams i) = Data.Aeson.Array $ V.fromList [jsonNumber i] + toJSON (DeshieldParams i s) = + Data.Aeson.Array $ V.fromList [jsonNumber i, Data.Aeson.Number s] + +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 + | MultiOpResponse !T.Text ![T.Text] + | 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 + toJSON (MultiOpResponse 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" + String s -> do + k7 <- parseJSON r1 + pure $ MultiOpResponse i k7 + _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 + ShieldNotes -> do + p <- obj .: "params" + case p of + Array a -> + if V.length a == 1 + then do + x <- parseJSON $ a V.! 0 + pure $ RpcCall v i ShieldNotes (ShieldNotesParams x) + else pure $ RpcCall v i ShieldNotes BadParams + _anyOther -> pure $ RpcCall v i ShieldNotes BadParams + DeshieldFunds -> 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 DeshieldFunds (DeshieldParams x y) + else pure $ RpcCall v i DeshieldFunds BadParams + _anyOther -> pure $ RpcCall v i DeshieldFunds 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.8.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.8.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" + ShieldNotes -> do + case parameters req of + ShieldNotesParams i -> do + let dbPath = w_dbPath state + let net = w_network state + let zHost = w_host state + let zPort = w_port 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 + bl <- + liftIO $ + getLastSyncBlock + pool + (zcashAccountWalletId $ entityVal acc') + opids <- + liftIO $ + runNoLoggingT $ + shieldTransparentNotes + pool + zHost + zPort + net + (entityKey acc') + bl + let ops = + map + (\case + Left e -> T.pack $ show e + Right op -> U.toText op) + opids + return $ MultiOpResponse (callId req) ops + Nothing -> + return $ + ErrorResponse + (callId req) + (-32006) + "Account does not exist." + _anyOtherParams -> + return $ ErrorResponse (callId req) (-32602) "Invalid params" + DeshieldFunds -> do + case parameters req of + DeshieldParams i k -> do + let dbPath = w_dbPath state + let net = w_network state + let zHost = w_host state + let zPort = w_port 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 i + case acc of + Just acc' -> do + bl <- + liftIO $ + getLastSyncBlock + pool + (zcashAccountWalletId $ entityVal acc') + _ <- + liftIO $ + forkIO $ do + res <- + runNoLoggingT $ + deshieldNotes + pool + zHost + zPort + net + (entityKey acc') + bl + k + 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 + bi <- + saveBlock pool $ + ZcashBlock + (fromIntegral $ bl_height blk) + (HexStringDB $ bl_hash blk) + (fromIntegral $ bl_confirmations blk) + (fromIntegral $ bl_time blk) + (ZcashNetDB net) + mapM_ (processTx zHost zPort bi pool) $ bl_txs blk diff --git a/src/Zenith/Scanner.hs b/src/Zenith/Scanner.hs index df47ed1..8bef9f6 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,53 +31,85 @@ import ZcashHaskell.Types , fromRawTBundle ) import ZcashHaskell.Utils (getBlockTime, makeZebraCall, readZebraTransaction) -import Zenith.Core (checkBlockChain) -import Zenith.DB (getMaxBlock, initDb, saveTransaction) +import Zenith.Core (checkBlockChain, syncWallet, updateCommitmentTrees) +import Zenith.DB + ( 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 :: @@ -86,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 @@ -97,39 +129,29 @@ 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 $ - makeZebraCall - host - port - "getblock" - [Data.Aeson.String $ T.pack $ show b, jsonNumber 0] - case r2 of - Left e2 -> liftIO $ throwIO $ userError e2 - Right hb -> do - let blockTime = getBlockTime hb - mapM_ (processTx host port blockTime pool) $ - bl_txs $ addTime blk blockTime - liftIO $ tick pg - where - addTime :: BlockResponse -> Int -> BlockResponse - addTime bl t = - BlockResponse - (bl_confirmations bl) - (bl_height bl) - (fromIntegral t) - (bl_txs bl) + bi <- + saveBlock pool $ + ZcashBlock + (fromIntegral $ bl_height blk) + (HexStringDB $ bl_hash blk) + (fromIntegral $ bl_confirmations blk) + (fromIntegral $ bl_time blk) + net + mapM_ (processTx host port bi pool) $ bl_txs blk + liftIO $ tick pg -- | 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 $ @@ -139,12 +161,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 @@ -155,3 +180,82 @@ processTx host port bt pool t = do (fromRawSBundle $ zt_sBundle rzt) (fromRawOBundle $ zt_oBundle rzt) return () + +-- | Function to update unconfirmed transactions +updateConfs :: + T.Text -- ^ Host name for `zebrad` + -> Int -- ^ Port for `zebrad` + -> ConnectionPool + -> IO () +updateConfs host port pool = do + targetBlocks <- getUnconfirmedBlocks pool + mapM_ updateTx targetBlocks + where + updateTx :: Int -> IO () + updateTx b = do + r <- + makeZebraCall + host + port + "getblock" + [Data.Aeson.String $ T.pack $ show b, jsonNumber 1] + case r of + 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 5526aa6..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,22 +312,6 @@ instance FromJSON AddressSource where "mnemonic_seed" -> return MnemonicSeed _ -> fail "Not a known address source" -data ZcashPool - = Transparent - | Sprout - | Sapling - | Orchard - deriving (Show, Eq, Generic, ToJSON) - -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] @@ -201,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 [] @@ -209,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 96ca8dd..53fc8bb 100644 --- a/src/Zenith/Utils.hs +++ b/src/Zenith/Utils.hs @@ -3,17 +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.Sapling (isValidShieldedAddress) +import ZcashHaskell.Orchard + ( encodeUnifiedAddress + , isValidUnifiedAddress + , parseAddress + ) +import ZcashHaskell.Sapling (decodeSaplingAddress, isValidShieldedAddress) +import ZcashHaskell.Transparent + ( decodeExchangeAddress + , decodeTransparentAddress + ) +import ZcashHaskell.Types + ( ExchangeAddress(..) + , SaplingAddress(..) + , TransparentAddress(..) + , UnifiedAddress(..) + , ValidAddress(..) + , ZcashNet(..) + ) +import ZcashHaskell.Utils (makeZebraCall) import Zenith.Types ( AddressGroup(..) + , PrivacyPolicy(..) , UnifiedAddressDB(..) , ZcashAddress(..) , ZcashPool(..) @@ -26,18 +47,24 @@ jsonNumber i = Number $ scientific (fromIntegral i) 0 -- | Helper function to display small amounts of ZEC displayZec :: Integer -> String displayZec s - | abs s < 100 = show s ++ " zats " - | abs s < 100000 = show (fromIntegral s / 100) ++ " μZEC " - | abs s < 100000000 = show (fromIntegral s / 100000) ++ " mZEC " + | abs s < 100 = show s ++ " zats" + | abs s < 100000 = show (fromIntegral s / 100) ++ " μZEC" + | abs s < 100000000 = show (fromIntegral s / 100000) ++ " mZEC" | otherwise = show (fromIntegral s / 100000000) ++ " ZEC " -- | Helper function to display small amounts of ZEC displayTaz :: Integer -> String displayTaz s - | abs s < 100 = show s ++ " tazs " - | abs s < 100000 = show (fromIntegral s / 100) ++ " μTAZ " - | abs s < 100000000 = show (fromIntegral s / 100000) ++ " mTAZ " - | otherwise = show (fromIntegral s / 100000000) ++ " TAZ " + | abs s < 100 = show s ++ " tazs" + | abs s < 100000 = show (fromIntegral s / 100) ++ " μTAZ" + | abs s < 100000000 = show (fromIntegral s / 100000) ++ " mTAZ" + | otherwise = show (fromIntegral s / 100000000) ++ " TAZ" + +displayAmount :: ZcashNet -> Integer -> T.Text +displayAmount n a = + if n == MainNet + then T.pack $ displayZec a + else T.pack $ displayTaz a -- | Helper function to display abbreviated Unified Address showAddress :: UnifiedAddressDB -> T.Text @@ -52,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 @@ -66,9 +93,161 @@ 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 = void $ 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 = 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) + +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 -> + case decodeSaplingAddress (E.encodeUtf8 a) of + Just a2 -> + Just $ UnifiedAddress znet Nothing (Just $ sa_receiver a2) Nothing + Nothing -> + case decodeTransparentAddress (E.encodeUtf8 a) of + 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 + +getTransparentFromUA :: UnifiedAddress -> Maybe TransparentAddress +getTransparentFromUA ua = TransparentAddress (ua_net ua) <$> t_rec ua 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..f41668e --- /dev/null +++ b/test/ServerSpec.hs @@ -0,0 +1,802 @@ +{-# 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.8.0.0-beta" TestNet "v2.1.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 + describe "Shield notes" $ do + it "bad credentials" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + "baduser" + "idontknow" + ShieldNotes + BlankParams + res `shouldBe` Left "Invalid credentials" + describe "correct credentials" $ do + it "no parameters" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + ShieldNotes + BlankParams + case res of + Left e -> assertFailure e + Right (ErrorResponse i c m) -> c `shouldBe` (-32602) + it "invalid account" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + ShieldNotes + (ShieldNotesParams 27) + case res of + Left e -> assertFailure e + Right (ErrorResponse i c m) -> c `shouldBe` (-32006) + it "valid account" $ do + res <- + makeZenithCall + "127.0.0.1" + nodePort + nodeUser + nodePwd + ShieldNotes + (ShieldNotesParams 1) + case res of + Left e -> assertFailure e + Right (MultiOpResponse i c) -> c `shouldNotBe` [] + +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..fb4b13e 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,892 @@ 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 <- runNoLoggingT $ truncateTree oTree i + let finalAnchor = + getOrchardTreeAnchor $ + OrchardCommitmentTree $ ztiOrchard zebraTreesIn + getHash (value updatedTree) `shouldBe` finalAnchor + it "Counting leaves in tree" $ do + let tree = + OrchardCommitmentTree $ + hexString + "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" + case getOrchardTreeParts tree of + Nothing -> assertFailure "Failed to get tree parts" + Just t1 -> do + let newTree = mkOrchardTree t1 + countLeaves newTree `shouldBe` + fromIntegral (1 + getPosition (value newTree)) + it "Validate large load" $ do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + 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 <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 3) + 3026170 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + (Just "Sending memo to orchard") + ] + Full + case tx of + Left e -> assertFailure $ show e + Right h -> h `shouldNotBe` hexString "deadbeef" + it "To Sapling" $ do + let uaRead = + parseAddress + "ztestsapling136jp8z89v2jh6kqd5rs4dtvlxym90m43svzdwzxaplyvc5ttzppytpvx80ncllcsqzpmukxjl3y" + case uaRead of + Nothing -> assertFailure "wrong address" + Just ua -> do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + tx <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 4) + 3001331 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + (Just "Sending memo to sapling") + ] + Full + case tx of + Left e -> assertFailure $ show e + Right h -> h `shouldNotBe` hexString "deadbeef" + it "To Transparent" $ do + let uaRead = parseAddress "tmAmSa4AauSFuJieeanRBjkfnah45ysGtgZ" + case uaRead of + Nothing -> assertFailure "wrong address" + Just ua -> do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + tx <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 4) + 3001331 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + Nothing + ] + Full + tx `shouldBe` + Left (PrivacyPolicyError "Receiver not capable of Full privacy") + it "To mixed shielded receivers" $ do + let uaRead = + parseAddress + "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" + let uaRead2 = + parseAddress + "ztestsapling136jp8z89v2jh6kqd5rs4dtvlxym90m43svzdwzxaplyvc5ttzppytpvx80ncllcsqzpmukxjl3y" + case uaRead of + Nothing -> assertFailure "wrong address" + Just ua -> do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + tx <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 1) + 3001331 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + (Just "Sending memo to orchard") + , ProposedNote + (ValidAddressAPI $ fromJust uaRead2) + 0.004 + Nothing + ] + Full + tx `shouldBe` + Left + (PrivacyPolicyError + "Combination of receivers not allowed for Full privacy") + describe "Medium" $ do + it "To Orchard" $ do + let uaRead = + parseAddress + "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" + case uaRead of + Nothing -> assertFailure "wrong address" + Just ua -> do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + tx <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 1) + 3001372 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + (Just "Sending memo to orchard") + ] + Medium + case tx of + Left e -> assertFailure $ show e + Right h -> h `shouldNotBe` hexString "deadbeef" + it "To Sapling" $ do + let uaRead = + parseAddress + "ztestsapling136jp8z89v2jh6kqd5rs4dtvlxym90m43svzdwzxaplyvc5ttzppytpvx80ncllcsqzpmukxjl3y" + case uaRead of + Nothing -> assertFailure "wrong address" + Just ua -> do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + tx <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 1) + 3001372 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + (Just "Sending memo to sapling") + ] + Medium + case tx of + Left e -> assertFailure $ show e + Right h -> h `shouldNotBe` (hexString "00") + it "To Transparent" $ do + let uaRead = parseAddress "tmAmSa4AauSFuJieeanRBjkfnah45ysGtgZ" + case uaRead of + Nothing -> assertFailure "wrong address" + Just ua -> do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + tx <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 4) + 3001331 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + Nothing + ] + Medium + tx `shouldBe` + Left + (PrivacyPolicyError "Receiver not capable of Medium privacy") + it "To mixed shielded receivers" $ do + let uaRead = + parseAddress + "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" + let uaRead2 = + parseAddress + "ztestsapling136jp8z89v2jh6kqd5rs4dtvlxym90m43svzdwzxaplyvc5ttzppytpvx80ncllcsqzpmukxjl3y" + case uaRead of + Nothing -> assertFailure "wrong address" + Just ua -> do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + tx <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 1) + 3001331 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + (Just "Sending memo to orchard") + , ProposedNote + (ValidAddressAPI $ fromJust uaRead2) + 0.004 + Nothing + ] + Medium + case tx of + Left e -> assertFailure $ show e + Right h -> h `shouldNotBe` (hexString "deadbeef") + describe "Low" $ do + it "To Orchard" $ do + let uaRead = + parseAddress + "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" + case uaRead of + Nothing -> assertFailure "wrong address" + Just ua -> do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + tx <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 1) + 3001372 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + Nothing + ] + Low + case tx of + Left e -> assertFailure $ show e + Right h -> h `shouldNotBe` (hexString "deadbeef") + it "To Sapling" $ do + let uaRead = + parseAddress + "ztestsapling136jp8z89v2jh6kqd5rs4dtvlxym90m43svzdwzxaplyvc5ttzppytpvx80ncllcsqzpmukxjl3y" + case uaRead of + Nothing -> assertFailure "wrong address" + Just ua -> do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + tx <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 1) + 3001372 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + Nothing + ] + Low + case tx of + Left e -> assertFailure $ show e + Right h -> h `shouldNotBe` (hexString "deadbeef") + it "To Transparent" $ do + let uaRead = parseAddress "tmAmSa4AauSFuJieeanRBjkfnah45ysGtgZ" + case uaRead of + Nothing -> assertFailure "wrong address" + Just ua -> do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + tx <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 1) + 3001372 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + Nothing + ] + Low + case tx of + Left e -> assertFailure $ show e + Right h -> h `shouldNotBe` (hexString "deadbeef") + describe "None" $ do + it "To Orchard" $ do + let uaRead = + parseAddress + "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" + case uaRead of + Nothing -> assertFailure "wrong address" + Just ua -> do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + tx <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 1) + 3001372 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + Nothing + ] + None + tx `shouldBe` + Left + (PrivacyPolicyError + "Shielded recipients not compatible with privacy policy.") + it "To Sapling" $ do + let uaRead = + parseAddress + "ztestsapling136jp8z89v2jh6kqd5rs4dtvlxym90m43svzdwzxaplyvc5ttzppytpvx80ncllcsqzpmukxjl3y" + case uaRead of + Nothing -> assertFailure "wrong address" + Just ua -> do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + tx <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 1) + 3001372 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + Nothing + ] + None + tx `shouldBe` + Left + (PrivacyPolicyError + "Shielded recipients not compatible with privacy policy.") + it "To Transparent" $ do + let uaRead = parseAddress "tmAmSa4AauSFuJieeanRBjkfnah45ysGtgZ" + case uaRead of + Nothing -> assertFailure "wrong address" + Just ua -> do + pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + tx <- + runNoLoggingT $ + prepareTxV2 + pool + "localhost" + 18232 + TestNet + (toSqlKey 1) + 3001372 + [ ProposedNote + (ValidAddressAPI $ fromJust uaRead) + 0.005 + Nothing + ] + None + case tx of + Left e -> assertFailure $ show e + Right h -> h `shouldNotBe` hexString "deadbeef" diff --git a/zcash-haskell b/zcash-haskell index 9dddb42..7d3ae36 160000 --- a/zcash-haskell +++ b/zcash-haskell @@ -1 +1 @@ -Subproject commit 9dddb42bb3ab78ed0c4d44efb00960ac112c2ce6 +Subproject commit 7d3ae36d2b48b8ed91a70e40a77fb7efe57765a0 diff --git a/zenith-openrpc.json b/zenith-openrpc.json new file mode 100644 index 0000000..ce0dfa5 --- /dev/null +++ b/zenith-openrpc.json @@ -0,0 +1,1031 @@ +{ + "openrpc": "1.0.0-rc1", + "info": { + "version": "0.8.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", + "schema": { + "$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" } + ] + }, + { + "name": "shieldnotes", + "summary": "Shield all transparent notes into the Orchard pool for the given account", + "description": "Creates one or more transactions, grouping all the unspent transparent notes for the given account by their transparent address to avoid associating different transparent addresses. These notes are sent to the given account's internal change address as shielded Orchard notes.", + "tags": [], + "params": [ + { "$ref": "#/components/contentDescriptors/AccountId"} + ], + "paramStructure": "by-position", + "result": { + "name": "Operation ID(s)", + "schema": { + "type": "array", + "items": { "$ref": "#/components/contentDescriptors/OperationId"} + } + }, + "examples": [ + { + "name": "Shield transparent notes", + "summary": "Shield transparent notes", + "description": "Shield the transparent notes in a given account", + "params": [ + { + "name": "Account index", + "summary": "The index for the account to use", + "value": "3" + } + ], + "result": { + "name": "ShieldNotes result", + "value": [ + "ab350df0-9f57-44c0-9e0d-f7b8af1f4231", + "8c6f2656-22ef-4f9d-b465-80ddd13fc485" + ] + } + }, + { + "name": "No transparent funds", + "summary": "Shield transparent notes with no transparent funds", + "description": "Attempt to shield the transparent notes in a given account, when account has none", + "params": [ + { + "name": "Account index", + "summary": "The index for the account to use", + "value": "3" + } + ], + "result": { + "name": "ShieldNotes result", + "value": [ + "InsufficientFunds" + ] + } + } + ], + "errors": [ + { "$ref": "#/components/errors/ZebraNotAvailable" }, + { "$ref": "#/components/errors/ZenithBusy" }, + { "$ref": "#/components/errors/InvalidAccount" } + ] + }, + { + "name": "deshieldfunds", + "summary": "De-shield the given amount of ZEC from the given account", + "description": "Creates a new internal transaction with the requested amount of ZEC to the transparent pool. The fee is not included in the given amount.", + "tags": [], + "params": [ + { "$ref": "#/components/contentDescriptors/AccountId"}, + { "$ref": "#/components/contentDescriptors/Amount"} + ], + "paramStructure": "by-position", + "result": { + "name": "Operation ID", + "schema": { + "$ref": "#/components/contentDescriptors/OperationId" + } + }, + "examples": [ + { + "name": "De-Shield funds", + "summary": "De-shield funds", + "description": "Move the given amount of ZEC for the given acount from the shielded pool to the transparent pool", + "params": [ + { + "name": "Account index", + "summary": "The index for the account to use", + "value": "3" + }, + { + "name": "Amount", + "summary": "The amount of ZEC to use", + "value": 1.23 + } + ], + "result": { + "name": "Deshield funds result", + "value": "ab350df0-9f57-44c0-9e0d-f7b8af1f4231" + } + }, + { + "name": "No transparent funds", + "summary": "Shield transparent notes with no transparent funds", + "description": "Attempt to shield the transparent notes in a given account, when account has none", + "params": [ + { + "name": "Account index", + "summary": "The index for the account to use", + "value": "3" + } + ], + "result": { + "name": "ShieldNotes result", + "value": [ + "InsufficientFunds" + ] + } + } + ], + "errors": [ + { "$ref": "#/components/errors/ZebraNotAvailable" }, + { "$ref": "#/components/errors/ZenithBusy" }, + { "$ref": "#/components/errors/InvalidAccount" } + ] + } + ], + "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" + } + }, + "Amount": { + "name": "A numeric amount", + "summary": "A numeric amount", + "description": "A number that represents an amount to be used by a function as an input", + "required": true, + "schema": { + "type": "number" + } + }, + "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 3101182..8691137 100644 --- a/zenith.cabal +++ b/zenith.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: zenith -version: 0.5.1.0-beta +version: 0.7.1.0-beta license: MIT license-file: LICENSE author: Rene Vergara @@ -27,32 +27,40 @@ library ghc-options: -Wall -Wunused-imports exposed-modules: Zenith.CLI + Zenith.GUI + Zenith.GUI.Theme Zenith.Core Zenith.DB Zenith.Types 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 , esqueleto - , resource-pool - , binary , exceptions - , monad-logger - , vty-crossplatform - , secp256k1-haskell - , pureMD5 + , filepath , ghc + , generics-sop , haskoin-core , hexstring , http-client @@ -61,20 +69,31 @@ library , 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 @@ -92,7 +111,7 @@ executable zenith , configurator , data-default , sort - , structured-cli + --, structured-cli , text , time , zenith @@ -100,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 @@ -122,8 +147,11 @@ test-suite zenith-tests build-depends: base >=4.12 && <5 , bytestring + , aeson , configurator , monad-logger + , borsh + , aeson , data-default , sort , text @@ -138,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