diff --git a/.gitmodules b/.gitmodules index 601b93a..8a74eac 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 = master + branch = milestone2 diff --git a/CHANGELOG.md b/CHANGELOG.md index 30d4a3d..20fa1a2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,43 +5,6 @@ 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 diff --git a/app/Main.hs b/app/Main.hs index f3d4b4c..0b6a6f0 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -19,8 +19,8 @@ import System.IO import Text.Read (readMaybe) import ZcashHaskell.Types import Zenith.CLI +import Zenith.Core (clearSync, testSync) import Zenith.GUI (runZenithGUI) -import Zenith.Scanner (clearSync, rescanZebra) import Zenith.Types (Config(..), ZcashAddress(..), ZcashPool(..), ZcashTx(..)) import Zenith.Utils import Zenith.Zcashd @@ -204,15 +204,12 @@ main :: IO () main = do config <- load ["$(HOME)/Zenith/zenith.cfg"] args <- getArgs - dbFileName <- require config "dbFileName" - nodeUser <- require config "nodeUser" - nodePwd <- require config "nodePwd" + dbFilePath <- require config "dbFilePath" + {-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 myConfig = Config dbFilePath zebraHost zebraPort if not (null args) then do case head args @@ -229,8 +226,7 @@ main = do of "gui" -> runZenithGUI myConfig "tui" -> runZenithTUI myConfig - "rescan" -> rescanZebra zebraHost zebraPort dbFilePath - "resync" -> clearSync myConfig + "rescan" -> clearSync myConfig _ -> printUsage else printUsage @@ -240,5 +236,4 @@ printUsage = do putStrLn "Available commands:" {-putStrLn "legacy\tLegacy CLI for zcashd"-} putStrLn "tui\tTUI for zebrad" - putStrLn "gui\tGUI for zebrad" putStrLn "rescan\tRescan the existing wallet(s)" diff --git a/app/Server.hs b/app/Server.hs deleted file mode 100644 index 7944fe3..0000000 --- a/app/Server.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Server where - -import Control.Concurrent (forkIO, threadDelay) -import Control.Exception (throwIO, throwTo, try) -import Control.Monad (forever, when) -import Control.Monad.Logger (runNoLoggingT) -import Data.Configurator -import qualified Data.Text as T -import Network.Wai.Handler.Warp (run) -import Servant -import System.Exit -import System.Posix.Signals -import ZcashHaskell.Types (ZebraGetBlockChainInfo(..), ZebraGetInfo(..)) -import Zenith.Core (checkBlockChain, checkZebra) -import Zenith.DB (getWallets, initDb, initPool) -import Zenith.RPC - ( State(..) - , ZenithRPC(..) - , authenticate - , scanZebra - , zenithServer - ) -import Zenith.Scanner (rescanZebra) -import Zenith.Types (Config(..)) -import Zenith.Utils (getZenithPath) - -main :: IO () -main = do - config <- load ["$(HOME)/Zenith/zenith.cfg"] - dbFileName <- require config "dbFileName" - nodeUser <- require config "nodeUser" - nodePwd <- require config "nodePwd" - zebraPort <- require config "zebraPort" - zebraHost <- require config "zebraHost" - nodePort <- require config "nodePort" - dbFP <- getZenithPath - let dbFilePath = T.pack $ dbFP ++ dbFileName - let myConfig = Config dbFilePath zebraHost zebraPort nodeUser nodePwd nodePort - let ctx = authenticate myConfig :. EmptyContext - w <- try $ checkZebra zebraHost zebraPort :: IO (Either IOError ZebraGetInfo) - case w of - Right zebra -> do - bc <- - try $ checkBlockChain zebraHost zebraPort :: IO - (Either IOError ZebraGetBlockChainInfo) - case bc of - Left e1 -> throwIO e1 - Right chainInfo -> do - x <- initDb dbFilePath - case x of - Left e2 -> throwIO $ userError e2 - Right x' -> do - when x' $ rescanZebra zebraHost zebraPort dbFilePath - pool <- runNoLoggingT $ initPool dbFilePath - walList <- getWallets pool $ zgb_net chainInfo - if not (null walList) - then do - scanThread <- - forkIO $ - forever $ do - _ <- - scanZebra - dbFilePath - zebraHost - zebraPort - (zgb_net chainInfo) - threadDelay 90000000 - putStrLn "Zenith RPC Server 0.7.0.0-beta" - putStrLn "------------------------------" - putStrLn $ - "Connected to " ++ - show (zgb_net chainInfo) ++ - " Zebra " ++ - T.unpack (zgi_build zebra) ++ " on port " ++ show zebraPort - let myState = - State - (zgb_net chainInfo) - zebraHost - zebraPort - dbFilePath - (zgi_build zebra) - (zgb_blocks chainInfo) - run nodePort $ - serveWithContext - (Proxy :: Proxy ZenithRPC) - ctx - (zenithServer myState) - else putStrLn - "No wallets available. Please start Zenith interactively to create a wallet" diff --git a/app/ZenScan.hs b/app/ZenScan.hs index 24b09fe..05059ca 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 (rescanZebra) +import Zenith.Scanner (scanZebra) main :: IO () main = do diff --git a/cabal.project.freeze b/cabal.project.freeze index 34022e4..175cc2c 100644 --- a/cabal.project.freeze +++ b/cabal.project.freeze @@ -9,18 +9,19 @@ constraints: any.Cabal ==3.10.3.0, any.OneTuple ==0.4.2, any.OpenGLRaw ==3.3.4.1, OpenGLRaw -osandroid +usegles2 +useglxgetprocaddress +usenativewindowslibraries, - any.QuickCheck ==2.15.0.1, + any.QuickCheck ==2.14.3, 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.X11 ==1.10.3, + X11 -pedantic, 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, + any.ansi-terminal ==1.1.1, ansi-terminal -example, any.ansi-terminal-types ==1.1, any.appar ==0.1.8, @@ -38,11 +39,11 @@ constraints: any.Cabal ==3.10.3.0, attoparsec -developer, any.attoparsec-aeson ==2.2.2.0, any.authenticate-oauth ==1.7, - any.auto-update ==0.2.4, + any.auto-update ==0.2.1, 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.base-compat ==0.14.0, + any.base-compat-batteries ==0.14.0, + any.base-orphans ==0.9.2, any.base16 ==1.0, any.base16-bytestring ==1.0.2.0, any.base58-bytestring ==0.1.0, @@ -58,19 +59,18 @@ constraints: any.Cabal ==3.10.3.0, any.blaze-builder ==0.4.2.3, any.blaze-html ==0.9.2.0, any.blaze-markup ==0.8.3.0, - any.boring ==0.2.2, - boring +tagged, any.borsh ==0.3.0, - any.brick ==2.6, + any.brick ==2.4, brick -demos, - any.bsb-http-chunked ==0.0.0.4, any.byteorder ==1.0.4, - any.bytes ==0.17.4, + any.bytes ==0.17.3, any.bytestring ==0.11.5.3, + any.bytestring-builder ==0.10.8.2.0, + bytestring-builder +bytestring_has_builder, any.bytestring-to-vector ==0.3.0.1, any.c2hs ==0.28.8, c2hs +base3 -regression, - any.cabal-doctest ==1.0.11, + any.cabal-doctest ==1.0.10, any.call-stack ==0.4.0, any.case-insensitive ==1.2.1.0, any.cborg ==0.2.10.0, @@ -81,16 +81,15 @@ constraints: any.Cabal ==3.10.3.0, any.clock ==0.8.4, clock -llvm, any.colour ==2.3.6, - any.comonad ==5.0.9, + any.comonad ==5.0.8, comonad +containers +distributive +indexed-traversable, any.concurrent-output ==1.10.21, - any.conduit ==1.3.6, + any.conduit ==1.3.5, 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, @@ -98,22 +97,22 @@ constraints: any.Cabal ==3.10.3.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, + any.crypton ==1.0.0, 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-connection ==0.4.1, 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.crypton-x509-validation ==1.6.12, 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-default ==0.7.1.1, + any.data-default-class ==0.1.2.0, + any.data-default-instances-containers ==0.0.1, + any.data-default-instances-dlist ==0.0.1, + any.data-default-instances-old-locale ==0.0.1, any.data-fix ==0.3.4, - any.dec ==0.0.6, any.deepseq ==1.4.8.1, any.directory ==1.3.8.4, any.distributive ==0.6.2.1, @@ -125,12 +124,11 @@ constraints: any.Cabal ==3.10.3.0, 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.envy ==2.1.3.0, + any.esqueleto ==3.5.11.2, any.exceptions ==0.10.7, - any.extra ==1.8, - any.fast-logger ==3.2.5, - any.file-embed ==0.0.16.0, + any.extra ==1.7.16, + any.fast-logger ==3.2.3, any.filepath ==1.4.300.1, any.fixed ==0.3, any.foreign-rust ==0.1.0, @@ -138,6 +136,8 @@ constraints: any.Cabal ==3.10.3.0, any.formatting ==7.2.0, formatting -no-double-conversion, any.free ==5.2, + any.generic-deriving ==1.14.5, + generic-deriving +base-4-9, any.generically ==0.1.1, any.generics-sop ==0.5.1.4, any.ghc ==9.6.5, @@ -147,54 +147,48 @@ constraints: any.Cabal ==3.10.3.0, 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.half ==0.3.1, + any.happy ==1.20.1.1, any.hashable ==1.4.7.0, hashable -arch-native +integer-gmp -random-initial-seed, - any.haskell-lexer ==1.1.2, + any.haskell-lexer ==1.1.1, 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 ==2.11.9, + any.hspec-core ==2.11.9, + any.hspec-discover ==2.11.9, 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, + any.http-client-tls ==0.3.6.3, + any.http-conduit ==2.3.8.3, http-conduit +aeson, - any.http-date ==0.0.11, - any.http-media ==0.8.1.1, - any.http-semantics ==0.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.invariant ==0.6.3, + any.iproute ==1.7.12, any.kan-extensions ==5.2.6, - any.language-c ==0.10.0, - language-c +iecfpextension +usebytestrings, + any.language-c ==0.9.3, + language-c -allwarnings +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.lift-type ==0.1.1.1, any.lifted-base ==0.2.3.12, any.linear ==1.22, linear -herbie +template-haskell, - any.megaparsec ==9.7.0, + any.megaparsec ==9.6.1, megaparsec -dev, any.memory ==0.18.0, memory +support_bytestring +support_deepseq, @@ -202,57 +196,47 @@ constraints: any.Cabal ==3.10.3.0, any.microlens-mtl ==0.2.0.3, any.microlens-th ==0.4.3.15, any.mime-types ==0.1.2.0, - any.mmorph ==1.2.0, any.monad-control ==1.0.3.1, any.monad-logger ==0.3.40, monad-logger +template_haskell, any.monad-loops ==0.4.3, monad-loops +base4, - any.mono-traversable ==1.0.21.0, + any.mono-traversable ==1.0.17.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, + any.network ==3.2.1.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.os-string ==2.0.6, 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 ==2.14.6.1, 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.qrcode-core ==0.9.9, + any.qrcode-juicypixels ==0.8.5, 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, + any.reflection ==2.1.8, reflection -slow +template-haskell, any.regex-base ==0.94.0.2, any.regex-compat ==0.95.2.1, @@ -267,7 +251,7 @@ constraints: any.Cabal ==3.10.3.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.secp256k1-haskell ==1.2.0, any.semialign ==1.3.1, semialign +semigroupoids, any.semigroupoids ==6.0.1, @@ -276,15 +260,8 @@ constraints: any.Cabal ==3.10.3.0, semigroups +binary +bytestring -bytestring-builder +containers +deepseq +hashable +tagged +template-haskell +text +transformers +unordered-containers, any.serialise ==0.2.6.1, serialise +newtime15, - any.servant ==0.20.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.silently ==1.2.5.3, 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, @@ -297,10 +274,8 @@ constraints: any.Cabal ==3.10.3.0, any.strict ==0.5.1, any.string-conversions ==0.4.0.1, any.system-cxx-std-lib ==1.0, - any.tagged ==0.8.9, + any.tagged ==0.8.8, 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, @@ -308,43 +283,41 @@ constraints: any.Cabal ==3.10.3.0, 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-show ==3.10.5, + text-show +base-4-9 +integer-gmp +new-functor-classes +template-haskell-2-11, 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-abstraction ==0.7.0.0, + any.th-compat ==0.1.5, + any.th-lift ==0.8.4, 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, + any.tls ==2.1.0, 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.typed-process ==0.2.11.1, any.unix ==2.8.4.0, - any.unix-compat ==0.7.3, - any.unix-time ==0.4.16, + any.unix-compat ==0.7.2, + any.unix-time ==0.4.15, 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, + any.vector ==0.13.1.0, vector +boundschecks -internalchecks -unsafechecks -wall, - any.vector-algorithms ==0.9.0.3, + any.vector-algorithms ==0.9.0.2, vector-algorithms +bench +boundschecks -internalchecks -llvm +properties -unsafechecks, any.vector-stream ==0.1.0.1, any.void ==0.7.3, @@ -353,20 +326,11 @@ constraints: any.Cabal ==3.10.3.0, any.vty-crossplatform ==0.4.0.0, vty-crossplatform -demos, any.vty-unix ==0.2.0.0, - any.wai ==3.2.4, - any.wai-app-static ==3.1.9, - wai-app-static +crypton -print, - any.wai-extra ==3.1.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 +index-state: hackage.haskell.org 2024-07-10T18:40:26Z diff --git a/src/Zenith/CLI.hs b/src/Zenith/CLI.hs index 41642d0..b10b7e0 100644 --- a/src/Zenith/CLI.hs +++ b/src/Zenith/CLI.hs @@ -2,7 +2,6 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE LambdaCase #-} module Zenith.CLI where @@ -11,15 +10,16 @@ import qualified Brick.BChan as BC import qualified Brick.Focus as F import Brick.Forms ( Form(..) + , FormFieldState , (@@=) , allFieldsValid + , editShowableField , editShowableFieldWithValidate , editTextField , focusedFormInputAttr , handleFormEvent , invalidFormInputAttr , newForm - , radioField , renderForm , setFieldValid , updateFormState @@ -42,6 +42,7 @@ import Brick.Widgets.Core , joinBorders , padAll , padBottom + , padLeft , padTop , setAvailableSize , str @@ -62,20 +63,13 @@ 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 (throw, throwIO, try) -import Control.Monad (forM_, forever, unless, void, when) +import Control.Exception (catch, throw, throwIO, try) +import Control.Monad (forever, void) import Control.Monad.IO.Class (liftIO) -import Control.Monad.Logger - ( LoggingT - , NoLoggingT - , logDebugN - , runNoLoggingT - , runStderrLoggingT - ) +import Control.Monad.Logger (LoggingT, runFileLoggingT, runNoLoggingT) import Data.Aeson import Data.HexString (HexString(..), toText) import Data.Maybe -import Data.Scientific (Scientific, scientific) import qualified Data.Text as T import qualified Data.Text.Encoding as E import Data.Time.Clock.POSIX (posixSecondsToUTCTime) @@ -89,13 +83,10 @@ import Lens.Micro.Mtl import Lens.Micro.TH import System.Hclip import Text.Printf -import Text.Wrap (FillScope(..), FillStrategy(..), WrapSettings(..)) -import ZcashHaskell.Keys (generateWalletSeedPhrase) -import ZcashHaskell.Orchard - ( getSaplingFromUA - , isValidUnifiedAddress - , parseAddress - ) +import Text.Wrap (FillScope(..), FillStrategy(..), WrapSettings(..), wrapText) +import ZcashHaskell.Keys (generateWalletSeedPhrase, getWalletSeed) +import ZcashHaskell.Orchard (getSaplingFromUA, isValidUnifiedAddress) +import ZcashHaskell.Sapling (decodeSaplingAddress, isValidShieldedAddress) import ZcashHaskell.Transparent ( decodeTransparentAddress , encodeTransparentReceiver @@ -104,26 +95,19 @@ import ZcashHaskell.Types import ZcashHaskell.Utils (getBlockTime, makeZebraCall) import Zenith.Core import Zenith.DB -import Zenith.Scanner (checkIntegrity, processTx, rescanZebra, updateConfs) +import Zenith.Scanner (processTx, updateConfs) import Zenith.Types ( Config(..) - , HexStringDB(..) , PhraseDB(..) - , PrivacyPolicy(..) - , ProposedNote(..) - , ShieldDeshieldOp(..) , UnifiedAddressDB(..) - , ValidAddressAPI(..) , ZcashNetDB(..) - , ZenithStatus(..) ) import Zenith.Utils ( displayTaz , displayZec - , getChainTip , isRecipientValid - , isRecipientValidGUI , jsonNumber + , parseAddress , showAddress , validBarValue ) @@ -142,14 +126,6 @@ data Name | ABList | DescripField | AddressField - | PrivacyNoneField - | PrivacyLowField - | PrivacyMediumField - | PrivacyFullField - | ShieldField - | DeshieldField - | TotalTranspField - | TotalShieldedField deriving (Eq, Show, Ord) data DialogInput = DialogInput @@ -160,9 +136,8 @@ makeLenses ''DialogInput data SendInput = SendInput { _sendTo :: !T.Text - , _sendAmt :: !Scientific + , _sendAmt :: !Float , _sendMemo :: !T.Text - , _policyField :: !PrivacyPolicy } deriving (Show) makeLenses ''SendInput @@ -174,12 +149,6 @@ data AdrBookEntry = AdrBookEntry makeLenses ''AdrBookEntry -newtype ShDshEntry = ShDshEntry - { _shAmt :: Scientific - } deriving (Show) - -makeLenses ''ShDshEntry - data DialogType = WName | AName @@ -192,8 +161,6 @@ data DialogType | AdrBookForm | AdrBookUpdForm | AdrBookDelForm - | DeshieldForm - | ShieldForm data DisplayType = AddrDisplay @@ -211,9 +178,6 @@ data Tick | TickMsg !String | TickTx !HexString -data DropDownItem = - DropdownItem String - data State = State { _network :: !ZcashNet , _wallets :: !(L.List Name (Entity ZcashWallet)) @@ -242,9 +206,6 @@ data State = State , _abCurAdrs :: !T.Text -- used for address book CRUD operations , _sentTx :: !(Maybe HexString) , _unconfBalance :: !Integer - , _deshieldForm :: !(Form ShDshEntry () Name) - , _tBalance :: !Integer - , _sBalance :: !Integer } makeLenses ''State @@ -261,11 +222,11 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] (" Zenith - " <> show (st ^. network) <> " - " <> - T.unpack - (maybe - "(None)" - (\(_, w) -> zcashWalletName $ entityVal w) - (L.listSelectedElement (st ^. wallets))) ++ + (T.unpack + (maybe + "(None)" + (\(_, w) -> zcashWalletName $ entityVal w) + (L.listSelectedElement (st ^. wallets)))) ++ " ")) (C.hCenter (str @@ -292,24 +253,17 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] (C.hCenter (str ("Last block seen: " ++ show (st ^. syncBlock) ++ "\n")) <=> listTxBox " Transactions " (st ^. network) (st ^. transactions))) <=> - (vBox - [ C.hCenter - (hBox - [ capCommand "W" "allets" - , capCommand "A" "ccounts" - , capCommand "V" "iew address" - , capCommand3 "" "S" "end Tx" - ]) - , C.hCenter - (hBox - [ capCommand2 "Address " "B" "ook" - , capCommand2 "s" "H" "ield" - , capCommand "D" "e-shield" - , capCommand "Q" "uit" - , capCommand "?" " Help" - , str $ show (st ^. timer) - ]) - ]) + C.hCenter + (hBox + [ capCommand "W" "allets" + , capCommand "A" "ccounts" + , capCommand "V" "iew address" + , capCommand "S" "end Tx" + , capCommand2 "Address " "B" "ook" + , capCommand "Q" "uit" + , capCommand "?" " Help" + , str $ show (st ^. timer) + ]) listBox :: Show e => String -> L.List Name e -> Widget Name listBox titleLabel l = C.vCenter $ @@ -375,7 +329,7 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] else emptyWidget where keyList = - map (C.hCenter . str) ["?", "Esc", "w", "a", "v", "s", "b", "d", "q"] + map (C.hCenter . str) ["?", "Esc", "w", "a", "v", "s", "b", "q"] actionList = map (hLimit 40 . str) @@ -386,7 +340,6 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] , "View address" , "Send Tx" , "Address Book" - , "Shield/De-Shield" , "Quit" ] inputDialog :: State -> Widget Name @@ -433,37 +386,6 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] (renderForm (st ^. txForm) <=> C.hCenter (hBox [capCommand "↲ " "Send", capCommand " " "Cancel"])) - DeshieldForm -> - D.renderDialog - (D.dialog (Just (str " De-Shield ZEC ")) Nothing 50) - (C.hCenter - (padAll 1 $ - vBox - [ str $ - "Transparent Bal.: " ++ - if st ^. network == MainNet - then displayZec (st ^. tBalance) - else displayTaz (st ^. tBalance) - , str $ - "Shielded Bal.: " ++ - if st ^. network == MainNet - then displayZec (st ^. sBalance) - else displayTaz (st ^. sBalance) - ]) <=> - renderForm (st ^. deshieldForm) <=> - C.hCenter - (hBox [capCommand "P" "roceed", capCommand " " "Cancel"])) - ShieldForm -> - D.renderDialog - (D.dialog (Just (str " Shield ZEC ")) Nothing 50) - (C.hCenter - (str $ - "Shield " ++ - if st ^. network == MainNet - then displayZec (st ^. tBalance) - else displayTaz (st ^. tBalance) ++ "?") <=> - C.hCenter - (hBox [capCommand "P" "roceed", capCommand " " "Cancel"])) Blank -> emptyWidget -- Address Book List AdrBook -> @@ -528,7 +450,7 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] (str " _____ _ _ _ \n|__ /___ _ __ (_) |_| |__\n / // _ \\ '_ \\| | __| '_ \\\n / /| __/ | | | | |_| | | |\n/____\\___|_| |_|_|\\__|_| |_|") <=> C.hCenter - (withAttr titleAttr (str "Zcash Wallet v0.7.1.0-beta")) <=> + (withAttr titleAttr (str "Zcash Wallet v0.6.0.0-beta")) <=> C.hCenter (withAttr blinkAttr $ str "Press any key...")) else emptyWidget capCommand3 :: String -> String -> String -> Widget Name @@ -688,34 +610,14 @@ mkInputForm = mkSendForm :: Integer -> SendInput -> Form SendInput e Name mkSendForm bal = newForm - [ 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 "To: " @@= editTextField sendTo RecField (Just 1) , label "Amount: " @@= editShowableFieldWithValidate sendAmt AmtField (isAmountValid bal) , label "Memo: " @@= editTextField sendMemo MemoField (Just 1) ] where - isAmountValid :: Integer -> Scientific -> Bool - isAmountValid b i = fromIntegral b >= (i * scientific 1 8) - label s w = - padBottom (Pad 1) $ vLimit 1 (hLimit 15 $ str s <+> fill ' ') <+> w - -mkDeshieldForm :: Integer -> ShDshEntry -> Form ShDshEntry e Name -mkDeshieldForm tbal = - newForm - [ label "Amount: " @@= - editShowableFieldWithValidate shAmt AmtField (isAmountValid tbal) - ] - where - isAmountValid :: Integer -> Scientific -> Bool - isAmountValid b i = fromIntegral b >= (i * scientific 1 8) + isAmountValid :: Integer -> Float -> Bool + isAmountValid b i = (fromIntegral b / 100000000.0) >= i label s w = padBottom (Pad 1) $ vLimit 1 (hLimit 15 $ str s <+> fill ' ') <+> w @@ -820,32 +722,19 @@ 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 +scanZebra :: T.Text -> T.Text -> Int -> Int -> BC.BChan Tick -> IO () +scanZebra dbP zHost zPort b eChan = do + _ <- liftIO $ initDb dbP bStatus <- liftIO $ checkBlockChain zHost zPort - pool <- liftIO $ runNoLoggingT $ initPool dbP - dbBlock <- liftIO $ getMaxBlock pool $ ZcashNetDB znet - chkBlock <- liftIO $ checkIntegrity dbP zHost zPort znet dbBlock 1 - syncChk <- liftIO $ isSyncing pool - if syncChk - then liftIO $ BC.writeBChan eChan $ TickMsg "Sync alread in progress" - else do - logDebugN $ - "dbBlock: " <> - T.pack (show dbBlock) <> " chkBlock: " <> T.pack (show chkBlock) - let sb = - if chkBlock == dbBlock - then max dbBlock b - else max chkBlock b - when (chkBlock /= dbBlock && chkBlock /= 1) $ - rewindWalletData pool sb $ ZcashNetDB znet + pool <- runNoLoggingT $ initPool dbP + dbBlock <- runNoLoggingT $ getMaxBlock pool + confUp <- try $ updateConfs zHost zPort pool :: IO (Either IOError ()) + case confUp of + Left _e0 -> + liftIO $ + BC.writeBChan eChan $ TickMsg "Failed to update unconfirmed transactions" + Right _ -> do + let sb = max dbBlock b if sb > zgb_blocks bStatus || sb < 1 then do liftIO $ @@ -857,28 +746,8 @@ scanZebra dbP zHost zPort b eChan znet = 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" + mapM_ (processBlock pool step) bList + else liftIO $ BC.writeBChan eChan $ TickVal 1.0 where processBlock :: ConnectionPool -> Float -> Int -> IO () processBlock pool step bl = do @@ -890,20 +759,29 @@ scanZebra dbP zHost zPort b eChan znet = do "getblock" [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 + Left e1 -> liftIO $ BC.writeBChan eChan $ TickMsg 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 znet) - mapM_ (processTx zHost zPort bi pool) $ bl_txs blk - liftIO $ BC.writeBChan eChan $ TickVal step + r2 <- + liftIO $ + makeZebraCall + zHost + zPort + "getblock" + [Data.Aeson.String $ T.pack $ show bl, jsonNumber 0] + case r2 of + Left e2 -> 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) appEvent :: BT.BrickEvent Name Tick -> BT.EventM Name State () appEvent (BT.AppEvent t) = do @@ -913,35 +791,7 @@ appEvent (BT.AppEvent t) = do TickMsg m -> do case s ^. displayBox of AddrDisplay -> 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 + MsgDisplay -> return () PhraseDisplay -> return () TxDisplay -> return () TxIdDisplay -> return () @@ -964,9 +814,26 @@ appEvent (BT.AppEvent t) = do SyncDisplay -> do if s ^. barValue == 1.0 then do - BT.modify $ set msg "Decoding, please wait..." + 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 barValue 0.0 - BT.modify $ set displayBox MsgDisplay + updatedState <- BT.get + ns <- liftIO $ refreshWallet updatedState + BT.put ns else BT.modify $ set barValue $ validBarValue (v + s ^. barValue) BlankDisplay -> do case s ^. dialogBox of @@ -980,27 +847,21 @@ appEvent (BT.AppEvent t) = do AdrBookForm -> return () AdrBookUpdForm -> return () AdrBookDelForm -> return () - DeshieldForm -> return () - ShieldForm -> return () Blank -> do if s ^. timer == 90 then do BT.modify $ set barValue 0.0 BT.modify $ set displayBox SyncDisplay - sBlock <- - liftIO $ - getMinBirthdayHeight pool (ZcashNetDB $ s ^. network) + sBlock <- liftIO $ getMinBirthdayHeight pool _ <- liftIO $ forkIO $ - runNoLoggingT $ scanZebra (s ^. dbPath) (s ^. zebraHost) (s ^. zebraPort) sBlock (s ^. eventDispatch) - (s ^. network) BT.modify $ set timer 0 return () else BT.modify $ set timer $ 1 + s ^. timer @@ -1202,8 +1063,7 @@ appEvent (BT.VtyEvent e) = do Just (_k, w) -> return w fs1 <- BT.zoom txForm $ BT.gets formState bl <- - liftIO $ - getChainTip (s ^. zebraHost) (s ^. zebraPort) + liftIO $ getLastSyncBlock pool $ entityKey selWal _ <- liftIO $ forkIO $ @@ -1218,7 +1078,6 @@ 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 @@ -1232,103 +1091,8 @@ appEvent (BT.VtyEvent e) = do fs <- BT.gets formState BT.modify $ setFieldValid - (isRecipientValidGUI - (fs ^. policyField) - (fs ^. sendTo)) + (isRecipientValid (fs ^. sendTo)) RecField - DeshieldForm -> do - case e of - V.EvKey V.KEsc [] -> BT.modify $ set dialogBox Blank - V.EvKey (V.KChar 'p') [] -> do - if allFieldsValid (s ^. deshieldForm) - then do - pool <- - liftIO $ runNoLoggingT $ initPool $ s ^. dbPath - selWal <- - do case L.listSelectedElement $ s ^. wallets of - Nothing -> do - let fWall = - L.listSelectedElement $ - L.listMoveToBeginning $ s ^. wallets - case fWall of - Nothing -> - throw $ - userError "Failed to select wallet" - Just (_j, w1) -> return w1 - Just (_k, w) -> return w - selAcc <- - do case L.listSelectedElement $ s ^. accounts of - Nothing -> do - let fAcc = - L.listSelectedElement $ - L.listMoveToBeginning $ - s ^. accounts - case fAcc of - Nothing -> - throw $ - userError "Failed to select wallet" - Just (_j, w1) -> return w1 - Just (_k, w) -> return w - selAddr <- - do case L.listSelectedElement $ s ^. addresses of - Nothing -> do - let fAddr = - L.listSelectedElement $ - L.listMoveToBeginning $ - s ^. addresses - case fAddr of - Nothing -> - throw $ - userError "Failed to select address" - Just (_j, w1) -> return w1 - Just (_k, w) -> return w - fs1 <- BT.zoom deshieldForm $ BT.gets formState - let tAddrMaybe = - Transparent <$> - ((decodeTransparentAddress . - E.encodeUtf8 . - encodeTransparentReceiver (s ^. network)) =<< - (t_rec =<< - (isValidUnifiedAddress . - E.encodeUtf8 . - getUA . walletAddressUAddress) - (entityVal selAddr))) - bl <- - liftIO $ - getChainTip (s ^. zebraHost) (s ^. zebraPort) - case tAddrMaybe of - Nothing -> do - BT.modify $ - set - msg - "Failed to obtain transparent address" - BT.modify $ set displayBox MsgDisplay - BT.modify $ set dialogBox Blank - Just tAddr -> do - _ <- - liftIO $ - forkIO $ - deshieldTransaction - pool - (s ^. eventDispatch) - (s ^. zebraHost) - (s ^. zebraPort) - (s ^. network) - (entityKey selAcc) - bl - (ProposedNote - (ValidAddressAPI tAddr) - (fs1 ^. shAmt) - Nothing) - BT.modify $ set displayBox SendDisplay - BT.modify $ set dialogBox Blank - else do - BT.modify $ set msg "Invalid inputs" - BT.modify $ set displayBox MsgDisplay - BT.modify $ set dialogBox Blank - ev -> - BT.zoom deshieldForm $ do - handleFormEvent (BT.VtyEvent ev) AdrBook -> do case e of V.EvKey (V.KChar 'x') [] -> @@ -1346,7 +1110,7 @@ appEvent (BT.VtyEvent e) = do "Address copied to Clipboard from >>\n" ++ T.unpack (addressBookAbdescrip (entityVal a)) BT.modify $ set displayBox MsgDisplay - _any -> do + _ -> do BT.modify $ set msg "Error while copying the address!!" BT.modify $ set displayBox MsgDisplay @@ -1361,8 +1125,7 @@ appEvent (BT.VtyEvent e) = do (SendInput (addressBookAbaddress (entityVal a)) 0.0 - "" - Full) + "") BT.modify $ set dialogBox SendTx _ -> do BT.modify $ @@ -1512,53 +1275,6 @@ appEvent (BT.VtyEvent e) = do BT.put s' BT.modify $ set dialogBox AdrBook ev -> BT.modify $ set dialogBox AdrBookDelForm - ShieldForm -> do - case e of - V.EvKey V.KEsc [] -> BT.modify $ set dialogBox Blank - V.EvKey (V.KChar 'p') [] -> do - pool <- liftIO $ runNoLoggingT $ initPool $ s ^. dbPath - selWal <- - do case L.listSelectedElement $ s ^. wallets of - Nothing -> do - let fWall = - L.listSelectedElement $ - L.listMoveToBeginning $ s ^. wallets - case fWall of - Nothing -> - throw $ - userError "Failed to select wallet" - Just (_j, w1) -> return w1 - Just (_k, w) -> return w - selAcc <- - do case L.listSelectedElement $ s ^. accounts of - Nothing -> do - let fAcc = - L.listSelectedElement $ - L.listMoveToBeginning $ s ^. accounts - case fAcc of - Nothing -> - throw $ - userError "Failed to select account" - Just (_j, w1) -> return w1 - Just (_k, w) -> return w - bl <- liftIO $ getLastSyncBlock pool $ entityKey selWal - _ <- - liftIO $ - forkIO $ - shieldTransaction - pool - (s ^. eventDispatch) - (s ^. zebraHost) - (s ^. zebraPort) - (s ^. network) - (entityKey selAcc) - bl - BT.modify $ set msg "Preparing transaction..." - BT.modify $ set displayBox SendDisplay - BT.modify $ set dialogBox Blank - ev -> - BT.zoom deshieldForm $ do - handleFormEvent (BT.VtyEvent ev) -- Process any other event Blank -> do case e of @@ -1581,61 +1297,10 @@ appEvent (BT.VtyEvent e) = do V.EvKey (V.KChar 's') [] -> do BT.modify $ set txForm $ - mkSendForm (s ^. balance) (SendInput "" 0.0 "" Full) + mkSendForm (s ^. balance) (SendInput "" 0.0 "") 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 -> @@ -1650,8 +1315,6 @@ appEvent (BT.VtyEvent e) = do printMsg s = BT.modify $ updateMsg s updateMsg :: String -> State -> State updateMsg = set msg --- fs <- BT.gets formState --- ev -> BT.zoom shdshForm $ L.handleListEvent ev appEvent _ = return () theMap :: A.AttrMap @@ -1700,94 +1363,75 @@ runZenithTUI config = do 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 - walList <- getWallets pool $ zgb_net chainInfo - accList <- + 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 = 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 = - 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 + then zcashWalletLastSync $ entityVal $ head walList + else 0 + abookList <- getAdrBook pool $ zgb_net chainInfo + bal <- + if not (null accList) + then getBalance pool $ entityKey $ head accList + else return 0 + uBal <- + if not (null accList) + then getUnconfirmedBalance pool $ entityKey $ head accList + else return 0 + eventChan <- BC.newBChan 10 + _ <- + forkIO $ + forever $ do + BC.writeBChan eventChan (TickVal 0.0) + threadDelay 1000000 + let buildVty = VC.mkVty V.defaultConfig + initialVty <- buildVty + void $ + M.customMain initialVty buildVty (Just eventChan) theApp $ + State + (zgb_net chainInfo) + (L.list WList (Vec.fromList walList) 1) + (L.list AcList (Vec.fromList accList) 0) + (L.list AList (Vec.fromList addrList) 1) + (L.list TList (Vec.fromList txList) 1) + ("Start up Ok! Connected to Zebra " ++ + (T.unpack . zgi_build) zebra ++ " on port " ++ show port ++ ".") + False + (if null walList + then WName + else Blank) + True + (mkInputForm $ DialogInput "Main") + (F.focusRing [AList, TList]) + (zgb_blocks chainInfo) + dbFilePath + host + port + MsgDisplay + block + bal + 1.0 + eventChan + 0 + (mkSendForm 0 $ SendInput "" 0.0 "") + (L.list ABList (Vec.fromList abookList) 1) + (mkNewABForm (AdrBookEntry "" "")) + "" + Nothing + uBal + Left e -> do print $ "No Zebra node available on port " <> show port <> ". Check your configuration." @@ -1806,7 +1450,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 $ walList !! ix + let bl = zcashWalletLastSync $ entityVal selWallet addrL <- if not (null aL) then runNoLoggingT $ getAddresses pool $ entityKey $ head aL @@ -1997,37 +1641,22 @@ sendTransaction :: -> ZcashNet -> ZcashAccountId -> Int - -> Scientific + -> Float -> T.Text -> T.Text - -> PrivacyPolicy -> IO () -sendTransaction pool chan zHost zPort znet accId bl amt ua memo policy = do +sendTransaction pool chan zHost zPort znet accId bl amt ua memo = do BC.writeBChan chan $ TickMsg "Preparing transaction..." - case parseAddress (E.encodeUtf8 ua) of + case parseAddress ua znet 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 + runFileLoggingT "zenith.log" $ + prepareTx pool zHost zPort znet accId bl amt outUA memo + BC.writeBChan chan $ TickMsg "Transaction ready, sending to Zebra..." 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 @@ -2037,56 +1666,3 @@ sendTransaction pool chan zHost zPort znet accId bl amt ua memo policy = do case resp of Left e1 -> BC.writeBChan chan $ TickMsg $ "Zebra error: " ++ show e1 Right txId -> BC.writeBChan chan $ TickTx txId - -shieldTransaction :: - ConnectionPool - -> BC.BChan Tick - -> T.Text - -> Int - -> ZcashNet - -> ZcashAccountId - -> Int - -> IO () -shieldTransaction pool chan zHost zPort znet accId bl = do - BC.writeBChan chan $ TickMsg "Preparing shielding transaction..." - res <- runNoLoggingT $ shieldTransparentNotes pool zHost zPort znet accId bl - forM_ res $ \case - Left e -> BC.writeBChan chan $ TickMsg $ show e - Right rawTx -> do - BC.writeBChan chan $ TickMsg "Transaction ready, sending to Zebra..." - resp <- - makeZebraCall - zHost - zPort - "sendrawtransaction" - [Data.Aeson.String $ toText rawTx] - case resp of - Left e1 -> BC.writeBChan chan $ TickMsg $ "Zebra error: " ++ show e1 - Right txId -> BC.writeBChan chan $ TickTx txId - -deshieldTransaction :: - ConnectionPool - -> BC.BChan Tick - -> T.Text - -> Int - -> ZcashNet - -> ZcashAccountId - -> Int - -> ProposedNote - -> IO () -deshieldTransaction pool chan zHost zPort znet accId bl pnote = do - BC.writeBChan chan $ TickMsg "Deshielding funds..." - res <- runNoLoggingT $ deshieldNotes pool zHost zPort znet accId bl pnote - case res of - Left e -> BC.writeBChan chan $ TickMsg $ show e - Right rawTx -> do - BC.writeBChan chan $ TickMsg "Transaction ready, sending to Zebra..." - resp <- - makeZebraCall - zHost - zPort - "sendrawtransaction" - [Data.Aeson.String $ toText rawTx] - case resp of - Left e1 -> BC.writeBChan chan $ TickMsg $ "Zebra error: " ++ show e1 - Right txId -> BC.writeBChan chan $ TickTx txId diff --git a/src/Zenith/Core.hs b/src/Zenith/Core.hs index 835a00d..abfb476 100644 --- a/src/Zenith/Core.hs +++ b/src/Zenith/Core.hs @@ -4,41 +4,47 @@ module Zenith.Core where import Control.Exception (throwIO, try) -import Control.Monad (forM, unless, when) +import Control.Monad (forM, 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 Data.HexString (HexString, hexBytes, hexString, toBytes, toText) -import Data.Int (Int32, Int64) +import qualified Data.ByteString.Lazy as LBS +import Data.Digest.Pure.MD5 +import Data.HexString (HexString, hexString, toBytes, toText) import Data.List -import Data.Maybe (fromJust, fromMaybe) -import Data.Scientific (Scientific, scientific, toBoundedInteger) +import Data.Maybe (fromJust) +import Data.Pool (Pool) import qualified Data.Text as T import qualified Data.Text.Encoding as E import Data.Time import qualified Database.Esqueleto.Experimental as ESQ import Database.Persist import Database.Persist.Sqlite +import GHC.Float.RealFracMethods (floorFloatInteger) import Haskoin.Crypto.Keys (XPrvKey(..)) import Lens.Micro ((&), (.~), (^.), set) +import Network.HTTP.Client import ZcashHaskell.Keys import ZcashHaskell.Orchard ( decryptOrchardActionSK , encodeUnifiedAddress , genOrchardReceiver , genOrchardSpendingKey - , getOrchardFrontier , getOrchardNotePosition - , getOrchardTreeParts , getOrchardWitness , isValidUnifiedAddress , updateOrchardCommitmentTree @@ -49,9 +55,7 @@ import ZcashHaskell.Sapling , genSaplingInternalAddress , genSaplingPaymentAddress , genSaplingSpendingKey - , getSaplingFrontier , getSaplingNotePosition - , getSaplingTreeParts , getSaplingWitness , updateSaplingCommitmentTree , updateSaplingWitness @@ -64,20 +68,16 @@ import ZcashHaskell.Transparent import ZcashHaskell.Types import ZcashHaskell.Utils import Zenith.DB -import Zenith.Tree import Zenith.Types ( Config(..) , HexStringDB(..) , OrchardSpendingKeyDB(..) , PhraseDB(..) - , PrivacyPolicy(..) - , ProposedNote(..) , RseedDB(..) , SaplingSpendingKeyDB(..) , ScopeDB(..) , TransparentSpendingKeyDB(..) , UnifiedAddressDB(..) - , ValidAddressAPI(..) , ZcashNetDB(..) , ZebraTreeInfo(..) ) @@ -107,35 +107,20 @@ checkBlockChain nodeHost nodePort = do -- | Get commitment trees from Zebra getCommitmentTrees :: - ConnectionPool - -> T.Text -- ^ Host where `zebrad` is avaiable + T.Text -- ^ Host where `zebrad` is avaiable -> Int -- ^ Port where `zebrad` is available - -> ZcashNetDB -> Int -- ^ Block height -> IO ZebraTreeInfo -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 +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 -- * Spending Keys -- | Create an Orchard Spending Key for the given wallet and account index @@ -238,47 +223,6 @@ 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 :: @@ -286,69 +230,77 @@ findSaplingOutputs :: -> Int -- ^ the starting block -> ZcashNetDB -- ^ The network -> Entity ZcashAccount -- ^ The account to use - -> NoLoggingT IO () + -> 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 <- 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 + 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 where sk :: SaplingSpendingKeyDB sk = zcashAccountSapSpendKey $ entityVal za decryptNotes :: - Tree SaplingNode + SaplingCommitmentTree -> ZcashNet -> ConnectionPool - -> (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 + -> [(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 Nothing -> do - 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 + 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 decodeShOut :: - Scope -> ZcashNet -> Int32 -> Entity ShieldOutput -> Maybe DecodedNote + Scope + -> ZcashNet + -> Integer + -> Entity ShieldOutput + -> Maybe DecodedNote decodeShOut scope n pos s = do decodeSaplingOutputEsk (getSapSK sk) @@ -361,7 +313,7 @@ findSaplingOutputs config b znet za = do (getHex $ shieldOutputProof $ entityVal s)) n scope - (fromIntegral pos) + pos -- | Get Orchard actions findOrchardActions :: @@ -376,53 +328,65 @@ findOrchardActions config b znet za = do let zebraPort = c_zebraPort config let zn = getNet znet pool <- runNoLoggingT $ initPool dbPath - 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 + 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 where decryptNotes :: - Tree OrchardNode + OrchardCommitmentTree -> ZcashNet -> ConnectionPool - -> (Entity ZcashTransaction, Entity OrchAction) + -> [(Entity ZcashTransaction, Entity OrchAction)] -> IO () - 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 + 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 wId <- saveWalletTransaction pool (entityKey za) zt saveWalletOrchNote pool wId nP - True + (fromJust noteWitness) + False (entityKey za) (entityKey o) - dn1 - Just dn -> do - wId <- saveWalletTransaction pool (entityKey za) zt - saveWalletOrchNote - pool - wId - nP - False - (entityKey za) - (entityKey o) - dn + dn + decryptNotes uT n pool txs sk :: OrchardSpendingKeyDB sk = zcashAccountOrchSpendKey $ entityVal za - decodeOrchAction :: Scope -> Int32 -> Entity OrchAction -> Maybe DecodedNote + decodeOrchAction :: + Scope -> Integer -> Entity OrchAction -> Maybe DecodedNote decodeOrchAction scope pos o = decryptOrchardActionSK (getOrchSK sk) scope $ OrchardAction @@ -445,7 +409,7 @@ updateSaplingWitnesses pool = do updateOneNote maxId n = do let noteSync = walletSapNoteWitPos $ entityVal n when (noteSync < maxId) $ do - cmus <- liftIO $ getSaplingCmus pool noteSync maxId + cmus <- liftIO $ getSaplingCmus pool $ walletSapNoteWitPos $ entityVal n let cmuList = map (\(ESQ.Value x) -> getHex x) cmus let newWitness = updateSaplingWitness @@ -463,7 +427,7 @@ updateOrchardWitnesses pool = do updateOneNote maxId n = do let noteSync = walletOrchNoteWitPos $ entityVal n when (noteSync < maxId) $ do - cmxs <- liftIO $ getOrchardCmxs pool noteSync maxId + cmxs <- liftIO $ getOrchardCmxs pool noteSync let cmxList = map (\(ESQ.Value x) -> getHex x) cmxs let newWitness = updateOrchardWitness @@ -474,357 +438,177 @@ updateOrchardWitnesses pool = do -- | Calculate fee per ZIP-317 calculateTxFee :: ([Entity WalletTrNote], [Entity WalletSapNote], [Entity WalletOrchNote]) - -> [OutgoingNote] - -> Int64 -calculateTxFee (t, s, o) nout = - fromIntegral $ 5000 * (tcount + saction + oaction) + -> Int + -> Integer +calculateTxFee (t, s, o) i = + fromIntegral + (5000 * (max (length t) tout + max (length s) sout + length o + oout)) where tout = - 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 + 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 -- | Prepare a transaction for sending -{- - -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 :: +prepareTx :: ConnectionPool -> T.Text -> Int -> ZcashNet -> ZcashAccountId -> Int - -> ProposedNote - -> NoLoggingT IO (Either TxError HexString) -deshieldNotes pool zebraHost zebraPort znet za bh pnote = do - bal <- liftIO $ getShieldedBalance pool za - let zats = pn_amt pnote * scientific 1 8 - if fromInteger bal > (scientific 2 4 + zats) - then prepareTxV2 pool zebraHost zebraPort znet za bh [pnote] Low - else return $ Left InsufficientFunds - -shieldTransparentNotes :: - ConnectionPool + -> Float + -> UnifiedAddress -> T.Text - -> Int - -> ZcashNet - -> ZcashAccountId - -> Int - -> NoLoggingT IO [Either TxError HexString] -shieldTransparentNotes pool zebraHost zebraPort znet za bh = do + -> 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 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 - trNotes' <- liftIO $ getWalletUnspentTrNotes pool za - dRecvs <- liftIO $ getReceivers pool trNotes' - let fNotes = - map - (\x -> - filter (\y -> walletTrNoteAddress (entityVal y) == x) trNotes') - dRecvs - sTree <- liftIO $ getSaplingTree pool - oTree <- liftIO $ getOrchardTree pool - forM fNotes $ \trNotes -> do - let noteTotal = getTotalAmount (trNotes, [], []) - tSpends <- - liftIO $ - prepTSpends - (getTranSK $ zcashAccountTPrivateKey $ entityVal acc) - trNotes - chgAddr <- getInternalAddresses pool $ entityKey acc - let internalUA = - getUA $ walletAddressUAddress $ entityVal $ head chgAddr - let oRcvr = - fromJust $ - o_rec =<< isValidUnifiedAddress (E.encodeUtf8 internalUA) - let dummy = - OutgoingNote - 4 - (getBytes $ getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc) - (getBytes oRcvr) - (fromIntegral $ noteTotal - 500) - "" - True - let feeAmt = calculateTxFee (trNotes, [], []) [dummy] - let snote = - OutgoingNote - 4 - (getBytes $ getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc) - (getBytes oRcvr) - (fromIntegral $ noteTotal - fromIntegral feeAmt) - "" - True - tx <- - liftIO $ - createTransaction - (maybe (hexString "00") (getHash . value . fst) sTree) - (maybe (hexString "00") (getHash . value . fst) oTree) - tSpends - [] - [] - [snote] - znet - (bh + 3) - True - logDebugN $ T.pack $ show tx - return tx + logDebugN $ T.pack $ show acc + spParams <- liftIO $ BS.readFile "sapling-spend.params" + outParams <- liftIO $ BS.readFile "sapling-output.params" + if show (md5 $ LBS.fromStrict spParams) /= + "0f44c12ef115ae019decf18ade583b20" + then logErrorN "Can't validate sapling parameters" + else logInfoN "Valid Sapling spend params" + if show (md5 $ LBS.fromStrict outParams) /= + "924daf81b87a81bbbb9c7d18562046c8" + then logErrorN "Can't validate sapling parameters" + else logInfoN "Valid Sapling output params" + --print $ BS.length spParams + --print $ BS.length outParams + logDebugN "Read Sapling params" + let zats = fromIntegral $ floorFloatInteger $ amt * (10 ^ 8) + logDebugN $ T.pack $ show zats + {-firstPass <- liftIO $ selectUnspentNotes pool za zats-} + --let fee = calculateTxFee firstPass $ fst recipient + --logDebugN $ T.pack $ "calculated fee " ++ show fee + (tList, sList, oList) <- liftIO $ selectUnspentNotes pool za (zats + 5000) + logDebugN "selected notes" + logDebugN $ T.pack $ show tList + logDebugN $ T.pack $ show sList + logDebugN $ T.pack $ show oList + let noteTotal = getTotalAmount (tList, sList, oList) + tSpends <- + liftIO $ + prepTSpends (getTranSK $ zcashAccountTPrivateKey $ entityVal acc) tList + --print tSpends + sSpends <- + liftIO $ + prepSSpends (getSapSK $ zcashAccountSapSpendKey $ entityVal acc) sList + --print sSpends + oSpends <- + liftIO $ + prepOSpends (getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc) oList + --print oSpends + dummy <- + liftIO $ makeOutgoing acc recipient zats (noteTotal - 5000 - zats) + logDebugN "Calculating fee" + let feeResponse = + createTransaction + (Just sT) + (Just oT) + tSpends + sSpends + oSpends + dummy + (SaplingSpendParams spParams) + (SaplingOutputParams outParams) + zn + (bh + 3) + False + case feeResponse of + Left e1 -> return $ Left Fee + Right fee -> do + let feeAmt = + fromIntegral (runGet getInt64le $ LBS.fromStrict $ toBytes fee) + (tList1, sList1, oList1) <- + liftIO $ selectUnspentNotes pool za (zats + feeAmt) + logDebugN $ T.pack $ "selected notes with fee" ++ show feeAmt + logDebugN $ T.pack $ show tList + logDebugN $ T.pack $ show sList + logDebugN $ T.pack $ show oList + outgoing <- + liftIO $ makeOutgoing acc recipient zats (noteTotal - feeAmt - zats) + logDebugN $ T.pack $ show outgoing + let tx = + createTransaction + (Just sT) + (Just oT) + tSpends + sSpends + oSpends + outgoing + (SaplingSpendParams spParams) + (SaplingOutputParams outParams) + zn + (bh + 3) + True + logDebugN $ T.pack $ show tx + return tx where + makeOutgoing :: + Entity ZcashAccount + -> (Int, BS.ByteString) + -> Integer + -> Integer + -> IO [OutgoingNote] + makeOutgoing acc (k, recvr) zats chg = do + chgAddr <- runNoLoggingT $ getInternalAddresses pool $ entityKey acc + let internalUA = getUA $ walletAddressUAddress $ entityVal $ head chgAddr + let chgRcvr = + fromJust $ o_rec =<< isValidUnifiedAddress (E.encodeUtf8 internalUA) + return + [ OutgoingNote + 4 + (getBytes $ getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc) + (getBytes chgRcvr) + (fromIntegral chg) + "" + 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] @@ -861,392 +645,12 @@ shieldTransparentNotes pool zebraHost zebraPort znet za bh = do flipTxId (fromIntegral $ walletTrNotePosition $ entityVal n)) (RawTxOut - (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) + (walletTrNoteValue $ entityVal n) (walletTrNoteScript $ entityVal n)) prepSSpends :: - SaplingSpendingKey - -> Tree SaplingNode - -> [Entity WalletSapNote] - -> IO [SaplingTxSpend] - prepSSpends sk tree notes = do + SaplingSpendingKey -> [Entity WalletSapNote] -> IO [SaplingTxSpend] + prepSSpends sk notes = do forM notes $ \n -> do - let notePath = - Zenith.Tree.path - (fromIntegral $ walletSapNotePosition $ entityVal n) - tree return $ SaplingTxSpend (getBytes sk) @@ -1257,18 +661,11 @@ prepareTxV2 pool zebraHost zebraPort zn za bh pnotes policy = do (getHex $ walletSapNoteNullifier $ entityVal n) "" (getRseed $ walletSapNoteRseed $ entityVal n)) - (fromMaybe nullPath notePath) + (toBytes $ getHex $ walletSapNoteWitness $ entityVal n) prepOSpends :: - OrchardSpendingKey - -> Tree OrchardNode - -> [Entity WalletOrchNote] - -> IO [OrchardTxSpend] - prepOSpends sk tree notes = do + OrchardSpendingKey -> [Entity WalletOrchNote] -> IO [OrchardTxSpend] + prepOSpends sk notes = do forM notes $ \n -> do - let notePath = - Zenith.Tree.path - (fromIntegral $ walletOrchNotePosition $ entityVal n) - tree return $ OrchardTxSpend (getBytes sk) @@ -1279,149 +676,100 @@ prepareTxV2 pool zebraHost zebraPort zn za bh pnotes policy = do (getHex $ walletOrchNoteNullifier $ entityVal n) (walletOrchNoteRho $ entityVal n) (getRseed $ walletOrchNoteRseed $ entityVal n)) - (fromMaybe nullPath notePath) + (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 -- | Sync the wallet with the data store syncWallet :: Config -- ^ configuration parameters -> Entity ZcashWallet - -> NoLoggingT IO () + -> IO () syncWallet config w = do startTime <- liftIO getCurrentTime - logDebugN $ T.pack $ show startTime let walletDb = c_dbPath config - let znet = zcashWalletNetwork $ entityVal w - pool <- liftIO $ runNoLoggingT $ initPool walletDb - accs <- liftIO $ runNoLoggingT $ getAccounts pool $ entityKey w - addrs <- - concat <$> - mapM (liftIO . runNoLoggingT . getAddresses pool . entityKey) accs - logDebugN $ "addrs: " <> T.pack (show addrs) + pool <- runNoLoggingT $ initPool walletDb + accs <- runNoLoggingT $ getAccounts pool $ entityKey w + addrs <- concat <$> mapM (runNoLoggingT . getAddresses pool . entityKey) accs intAddrs <- - 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) + concat <$> mapM (runNoLoggingT . getInternalAddresses pool . entityKey) accs + chainTip <- runNoLoggingT $ getMaxBlock pool + let lastBlock = zcashWalletLastSync $ entityVal w let startBlock = if lastBlock > 0 then lastBlock - 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" + else zcashWalletBirthdayHeight $ entityVal w + mapM_ (liftIO . findTransparentNotes pool startBlock) addrs + mapM_ (liftIO . findTransparentNotes pool startBlock) intAddrs mapM_ (liftIO . findTransparentSpends pool . entityKey) accs - logDebugN "processed transparent spends" - liftIO $ - runNoLoggingT $ - mapM_ + sapNotes <- + liftIO $ + mapM (findSaplingOutputs config startBlock (zcashWalletNetwork $ entityVal w)) accs - logDebugN "processed sapling outputs" - liftIO $ - mapM_ + orchNotes <- + liftIO $ + mapM (findOrchardActions config startBlock (zcashWalletNetwork $ entityVal w)) accs - logDebugN "processed orchard actions" + _ <- updateSaplingWitnesses pool + _ <- updateOrchardWitnesses pool _ <- liftIO $ updateWalletSync pool chainTip (entityKey w) - logDebugN "updated wallet lastSync" - mapM_ (liftIO . runNoLoggingT . getWalletTransactions pool) addrs + mapM_ (runNoLoggingT . getWalletTransactions pool) addrs --- | Update commitment trees -updateCommitmentTrees :: - ConnectionPool -> T.Text -> Int -> ZcashNetDB -> NoLoggingT IO () -updateCommitmentTrees pool zHost zPort zNet = do - sTdb <- liftIO $ getSaplingTree pool - oTdb <- liftIO $ getOrchardTree pool - maxBlock <- liftIO $ getMaxBlock pool zNet - newSapTree <- - case sTdb of - Nothing -> do - logDebugN ">no Sapling tree in DB" - bh <- liftIO $ getMinBirthdayHeight pool zNet - logDebugN $ ">min birthday: " <> T.pack (show bh) - saplingNotes <- liftIO $ getShieldedOutputs pool (bh + 1) zNet - let saplingComm = - map - (\(_, y) -> - ( getHex $ shieldOutputCmu (entityVal y) - , fromSqlKey (entityKey y))) - saplingNotes - logDebugN ">got shielded outputs" - treeInfo <- liftIO $ getCommitmentTrees pool zHost zPort zNet bh - case getSaplingTreeParts (SaplingCommitmentTree $ ztiSapling treeInfo) of - Nothing -> do - logDebugN ">failed to load tree from Zebra" - return InvalidTree - Just t1 -> do - let newTree = mkSaplingTree t1 - let zippedSapComms = - zip [(getPosition (value newTree) + 1) ..] saplingComm - return $ batchAppend newTree zippedSapComms - Just (sTree, sSync) -> do - logDebugN $ ">Sapling tree found, synced to " <> T.pack (show sSync) - saplingNotes <- liftIO $ getShieldedOutputs pool (sSync + 1) zNet - let saplingComm = - map - (\(_, y) -> - ( getHex $ shieldOutputCmu (entityVal y) - , fromSqlKey (entityKey y))) - saplingNotes - logDebugN ">got shielded outputs" - let zippedSapComms = - zip [(getPosition (value sTree) + 1) ..] saplingComm - return $ batchAppend sTree zippedSapComms - newOrchTree <- - case oTdb of - Nothing -> do - logDebugN ">no Orchard tree in DB" - bh <- liftIO $ getMinBirthdayHeight pool zNet - logDebugN $ ">min birthday: " <> T.pack (show bh) - orchardNotes <- liftIO $ getOrchardActions pool (bh + 1) zNet - let orchardComm = - map - (\(_, y) -> - ( getHex $ orchActionCmx (entityVal y) - , fromSqlKey (entityKey y))) - orchardNotes - logDebugN ">got orchard actions" - treeInfo <- liftIO $ getCommitmentTrees pool zHost zPort zNet bh - case getOrchardTreeParts (OrchardCommitmentTree $ ztiOrchard treeInfo) of - Nothing -> do - logDebugN ">failed to load tree from Zebra" - return InvalidTree - Just t1 -> do - let newTree = mkOrchardTree t1 - let zippedOrchComms = - zip [(getPosition (value newTree) + 1) ..] orchardComm - return $ batchAppend newTree zippedOrchComms - Just (oTree, oSync) -> do - logDebugN $ ">Orchard tree found, synced to " <> T.pack (show oSync) - orchardNotes <- liftIO $ getOrchardActions pool (oSync + 1) zNet - let orchardComm = - map - (\(_, y) -> - ( getHex $ orchActionCmx (entityVal y) - , fromSqlKey (entityKey y))) - orchardNotes - logDebugN ">got orchard actions" - let zippedOrchComms = - zip [(getPosition (value oTree) + 1) ..] orchardComm - return $ batchAppend oTree zippedOrchComms - case newSapTree of - Branch {} -> do - logInfoN ">Saving updated Sapling tree to db" - _ <- liftIO $ upsertSaplingTree pool maxBlock newSapTree - case newOrchTree of - Branch {} -> do - logInfoN ">Saving updated Orchard tree to db" - _ <- liftIO $ upsertOrchardTree pool maxBlock newOrchTree - return () - _anyOther -> do - logErrorN ">Failed to update the Orchard tree" - return () - _anyOther -> do - logErrorN ">Failed to update the Sapling tree" - return () +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 diff --git a/src/Zenith/DB.hs b/src/Zenith/DB.hs index dfbedf9..aea3c5a 100644 --- a/src/Zenith/DB.hs +++ b/src/Zenith/DB.hs @@ -18,28 +18,18 @@ module Zenith.DB where -import Codec.Borsh -import Control.Exception (SomeException(..), throw, throwIO, try) -import Control.Monad (unless, when) +import Control.Exception (throwIO) +import Control.Monad (forM_, when) import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Logger - ( LoggingT - , NoLoggingT - , logDebugN - , logErrorN - , runNoLoggingT - , runStderrLoggingT - ) +import Control.Monad.Logger (NoLoggingT, runNoLoggingT) +import Data.Bifunctor (bimap) import qualified Data.ByteString as BS import Data.HexString -import Data.Int import Data.List (group, sort) import Data.Maybe (catMaybes, fromJust, isJust) import Data.Pool (Pool) import qualified Data.Text as T import qualified Data.Text.Encoding as TE -import Data.Time.Clock (UTCTime, getCurrentTime) -import qualified Data.UUID as U import Data.Word import Database.Esqueleto.Experimental import qualified Database.Persist.Sqlite as PS @@ -50,24 +40,17 @@ import Haskoin.Transaction.Common , TxOut(..) , txHashToHex ) -import System.Directory (doesFileExist, getHomeDirectory, removeFile) -import System.FilePath (()) -import ZcashHaskell.Orchard - ( compareAddress - , getSaplingFromUA - , isValidUnifiedAddress - ) -import ZcashHaskell.Transparent (encodeTransparentReceiver) +import qualified Lens.Micro as ML ((&), (.~), (^.)) +import ZcashHaskell.Orchard (isValidUnifiedAddress) import ZcashHaskell.Types ( DecodedNote(..) - , ExchangeAddress(..) , OrchardAction(..) , OrchardBundle(..) - , OrchardReceiver(..) + , OrchardSpendingKey(..) , OrchardWitness(..) - , SaplingAddress(..) , SaplingBundle(..) - , SaplingReceiver(..) + , SaplingCommitmentTree(..) + , SaplingSpendingKey(..) , SaplingWitness(..) , Scope(..) , ShieldedOutput(..) @@ -77,31 +60,22 @@ import ZcashHaskell.Types , TransparentAddress(..) , TransparentBundle(..) , TransparentReceiver(..) - , TxError(..) , UnifiedAddress(..) - , ValidAddress(..) - , ZcashNet(..) + , ZcashNet + , decodeHexText ) -import Zenith.Tree (OrchardNode(..), SaplingNode(..), Tree(..), truncateTree) import Zenith.Types - ( AccountBalance(..) + ( Config(..) , HexStringDB(..) , OrchardSpendingKeyDB(..) , PhraseDB(..) - , PrivacyPolicy(..) , RseedDB(..) , SaplingSpendingKeyDB(..) , ScopeDB(..) , TransparentSpendingKeyDB , UnifiedAddressDB(..) - , ZcashAccountAPI(..) - , ZcashAddressAPI(..) , ZcashNetDB(..) - , ZcashNoteAPI(..) , ZcashPool(..) - , ZcashWalletAPI(..) - , ZenithStatus(..) - , ZenithUuid(..) ) share @@ -154,24 +128,24 @@ share tx WalletTransactionId OnDeleteCascade OnUpdateCascade accId ZcashAccountId OnDeleteCascade OnUpdateCascade address WalletAddressId OnDeleteCascade OnUpdateCascade - value Int64 + value Word64 spent Bool script BS.ByteString change Bool - position Int - UniqueTNote tx accId script + position Word64 + UniqueTNote tx script deriving Show Eq WalletTrSpend tx WalletTransactionId OnDeleteCascade OnUpdateCascade note WalletTrNoteId OnDeleteCascade OnUpdateCascade accId ZcashAccountId OnDeleteCascade OnUpdateCascade - value Int64 + value Word64 UniqueTrSpend tx accId deriving Show Eq WalletSapNote tx WalletTransactionId OnDeleteCascade OnUpdateCascade accId ZcashAccountId OnDeleteCascade OnUpdateCascade - value Int64 + value Word64 recipient BS.ByteString memo T.Text spent Bool @@ -187,18 +161,18 @@ share tx WalletTransactionId OnDeleteCascade OnUpdateCascade note WalletSapNoteId OnDeleteCascade OnUpdateCascade accId ZcashAccountId OnDeleteCascade OnUpdateCascade - value Int64 + value Word64 UniqueSapSepnd tx accId deriving Show Eq WalletOrchNote tx WalletTransactionId OnDeleteCascade OnUpdateCascade accId ZcashAccountId OnDeleteCascade OnUpdateCascade - value Int64 + value Word64 recipient BS.ByteString memo T.Text spent Bool nullifier HexStringDB - position Int64 + position Word64 witness HexStringDB change Bool witPos OrchActionId OnDeleteIgnore OnUpdateIgnore @@ -210,31 +184,25 @@ share tx WalletTransactionId OnDeleteCascade OnUpdateCascade note WalletOrchNoteId OnDeleteCascade OnUpdateCascade accId ZcashAccountId OnDeleteCascade OnUpdateCascade - value Int64 + value Word64 UniqueOrchSpend tx accId deriving Show Eq - ZcashBlock - height Int - hash HexStringDB + ZcashTransaction + block Int + txId HexStringDB conf Int time Int - network ZcashNetDB - UniqueBlock height network - deriving Show Eq - ZcashTransaction - blockId ZcashBlockId OnDeleteCascade OnUpdateCascade - txId HexStringDB - UniqueTx blockId txId + UniqueTx block txId deriving Show Eq TransparentNote - tx ZcashTransactionId OnDeleteCascade OnUpdateCascade - value Int64 + tx ZcashTransactionId + value Word64 script BS.ByteString position Int UniqueTNPos tx position deriving Show Eq TransparentSpend - tx ZcashTransactionId OnDeleteCascade OnUpdateCascade + tx ZcashTransactionId outPointHash HexStringDB outPointIndex Word64 script BS.ByteString @@ -243,7 +211,7 @@ share UniqueTSPos tx position deriving Show Eq OrchAction - tx ZcashTransactionId OnDeleteCascade OnUpdateCascade + tx ZcashTransactionId nf HexStringDB rk HexStringDB cmx HexStringDB @@ -256,7 +224,7 @@ share UniqueOAPos tx position deriving Show Eq ShieldOutput - tx ZcashTransactionId OnDeleteCascade OnUpdateCascade + tx ZcashTransactionId cv HexStringDB cmu HexStringDB ephKey HexStringDB @@ -267,7 +235,7 @@ share UniqueSOPos tx position deriving Show Eq ShieldSpend - tx ZcashTransactionId OnDeleteCascade OnUpdateCascade + tx ZcashTransactionId cv HexStringDB anchor HexStringDB nullifier HexStringDB @@ -292,188 +260,15 @@ share abaddress T.Text UniqueABA abaddress deriving Show Eq - Operation json - uuid ZenithUuid - start UTCTime - end UTCTime Maybe - status ZenithStatus - result T.Text Maybe - UniqueOp uuid - deriving Show Eq - ChainSync - name T.Text - start UTCTime - end UTCTime Maybe - status ZenithStatus - UniqueSync name - deriving Show Eq - TreeStore - pool ZcashPool - bytes BS.ByteString - lastSync Int - UniquePool pool - deriving Show Eq |] --- ** Type conversions --- | @ZcashWallet@ -toZcashWalletAPI :: Entity ZcashWallet -> ZcashWalletAPI -toZcashWalletAPI w = - ZcashWalletAPI - (fromIntegral $ fromSqlKey $ entityKey w) - (zcashWalletName $ entityVal w) - (getNet $ zcashWalletNetwork $ entityVal w) - (zcashWalletBirthdayHeight $ entityVal w) - (zcashWalletLastSync $ entityVal w) - --- | @ZcashAccount@ -toZcashAccountAPI :: Entity ZcashAccount -> ZcashAccountAPI -toZcashAccountAPI a = - ZcashAccountAPI - (fromIntegral $ fromSqlKey $ entityKey a) - (fromIntegral $ fromSqlKey $ zcashAccountWalletId $ entityVal a) - (zcashAccountName $ entityVal a) - --- | @WalletAddress@ -toZcashAddressAPI :: Entity WalletAddress -> ZcashAddressAPI -toZcashAddressAPI a = - ZcashAddressAPI - (fromIntegral $ fromSqlKey $ entityKey a) - (fromIntegral $ fromSqlKey $ walletAddressAccId $ entityVal a) - (walletAddressName $ entityVal a) - (getUA $ walletAddressUAddress $ entityVal a) - (getSaplingFromUA $ - TE.encodeUtf8 $ getUA $ walletAddressUAddress $ entityVal a) - (case t_rec =<< - (isValidUnifiedAddress . TE.encodeUtf8 . getUA . walletAddressUAddress) - (entityVal a) of - Nothing -> Nothing - Just tRec -> - Just $ - encodeTransparentReceiver - (maybe - TestNet - ua_net - ((isValidUnifiedAddress . - TE.encodeUtf8 . getUA . walletAddressUAddress) $ - entityVal a)) - tRec) - --- | @WalletTrNote@ -trToZcashNoteAPI :: ConnectionPool -> Entity WalletTrNote -> IO ZcashNoteAPI -trToZcashNoteAPI pool n = do - t <- getWalletTransaction pool $ walletTrNoteTx $ entityVal n - case t of - Nothing -> throwIO $ userError "Unable to find transaction" - Just t' -> do - return $ - ZcashNoteAPI - (getHex $ walletTransactionTxId $ entityVal t') -- tx ID - Zenith.Types.TransparentPool -- pool - (fromIntegral (walletTrNoteValue (entityVal n)) / 100000000.0) -- zec - (walletTrNoteValue $ entityVal n) -- zats - "" -- memo - (walletTransactionConf (entityVal t') >= 10) -- confirmed - (walletTransactionBlock $ entityVal t') -- blockheight - (walletTransactionTime $ entityVal t') -- blocktime - (walletTrNotePosition $ entityVal n) -- outindex - (walletTrNoteChange $ entityVal n) -- change - --- | @WalletSapNote@ -sapToZcashNoteAPI :: ConnectionPool -> Entity WalletSapNote -> IO ZcashNoteAPI -sapToZcashNoteAPI pool n = do - t <- getWalletTransaction pool $ walletSapNoteTx $ entityVal n - oi <- getSaplingOutIndex pool $ walletSapNoteWitPos $ entityVal n - case t of - Nothing -> throwIO $ userError "Unable to find transaction" - Just t' -> do - return $ - ZcashNoteAPI - (getHex $ walletTransactionTxId $ entityVal t') -- tx ID - Zenith.Types.SaplingPool -- pool - (fromIntegral (walletSapNoteValue (entityVal n)) / 100000000.0) -- zec - (walletSapNoteValue $ entityVal n) -- zats - (walletSapNoteMemo $ entityVal n) -- memo - (walletTransactionConf (entityVal t') >= 10) -- confirmed - (walletTransactionBlock $ entityVal t') -- blockheight - (walletTransactionTime $ entityVal t') -- blocktime - oi -- outindex - (walletSapNoteChange $ entityVal n) -- change - --- | @WalletOrchNote@ -orchToZcashNoteAPI :: ConnectionPool -> Entity WalletOrchNote -> IO ZcashNoteAPI -orchToZcashNoteAPI pool n = do - t <- getWalletTransaction pool $ walletOrchNoteTx $ entityVal n - oi <- getOrchardOutIndex pool $ walletOrchNoteWitPos $ entityVal n - case t of - Nothing -> throwIO $ userError "Unable to find transaction" - Just t' -> do - return $ - ZcashNoteAPI - (getHex $ walletTransactionTxId $ entityVal t') -- tx ID - OrchardPool - (fromIntegral (walletOrchNoteValue (entityVal n)) / 100000000.0) -- zec - (walletOrchNoteValue $ entityVal n) -- zats - (walletOrchNoteMemo $ entityVal n) -- memo - (walletTransactionConf (entityVal t') >= 10) -- confirmed - (walletTransactionBlock $ entityVal t') -- blockheight - (walletTransactionTime $ entityVal t') -- blocktime - oi -- outindex - (walletOrchNoteChange $ entityVal n) -- change - -- * Database functions -- | Initializes the database initDb :: T.Text -- ^ The database path to check - -> IO (Either String Bool) + -> IO () initDb dbName = do - 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 + PS.runSqlite dbName $ do runMigration migrateAll initPool :: T.Text -> NoLoggingT IO ConnectionPool initPool dbPath = do @@ -498,36 +293,6 @@ 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 @@ -602,21 +367,19 @@ saveAccount pool a = -- | Returns the largest block in storage getMaxBlock :: Pool SqlBackend -- ^ The database pool - -> ZcashNetDB - -> IO Int -getMaxBlock pool net = do + -> NoLoggingT IO Int +getMaxBlock pool = do b <- - runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do selectOne $ do - bls <- from $ table @ZcashBlock - where_ (bls ^. ZcashBlockNetwork ==. val net) - orderBy [desc $ bls ^. ZcashBlockHeight] - pure bls + txs <- from $ table @ZcashTransaction + where_ (txs ^. ZcashTransactionBlock >. val 0) + orderBy [desc $ txs ^. ZcashTransactionBlock] + pure txs case b of Nothing -> return $ -1 - Just x -> return $ zcashBlockHeight $ entityVal x + Just x -> return $ zcashTransactionBlock $ entityVal x -- | Returns a list of addresses associated with the given account getAddresses :: @@ -707,53 +470,19 @@ 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 - -> ZcashBlockId -- ^ The block the transaction is in + -> Int -- ^ block time -> Transaction -- ^ The transaction to save -> NoLoggingT IO (Key ZcashTransaction) -saveTransaction pool bi wt = +saveTransaction pool t wt = PS.retryOnBusy $ flip PS.runSqlPool pool $ do let ix = [0 ..] - w <- insert $ ZcashTransaction bi (HexStringDB $ tx_id wt) + w <- + insert $ + ZcashTransaction (tx_height wt) (HexStringDB $ tx_id wt) (tx_conf wt) t when (isJust $ tx_transpBundle wt) $ do _ <- insertMany_ $ @@ -832,20 +561,15 @@ saveTransaction pool bi wt = getZcashTransactions :: ConnectionPool -- ^ The database path -> Int -- ^ Block - -> ZcashNet -- ^ Network -> IO [Entity ZcashTransaction] -getZcashTransactions pool b net = +getZcashTransactions pool b = runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do select $ do - (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] + txs <- from $ table @ZcashTransaction + where_ $ txs ^. ZcashTransactionBlock >. val b + orderBy [asc $ txs ^. ZcashTransactionBlock] return txs -- ** QR codes @@ -883,32 +607,6 @@ getQrCode pool zp wId = do return qrs return $ entityVal <$> r -upgradeQrTable :: ConnectionPool -> IO () -upgradeQrTable pool = do - r <- - runNoLoggingT $ - PS.retryOnBusy $ - flip PS.runSqlPool pool $ - selectOne $ do - qrs <- from $ table @QrCode - where_ $ qrs ^. QrCodeVersion ==. val OrchardPool - return countRows - unless (maybe 0 (\(Value x) -> x) r > (0 :: Int)) $ do - _ <- - runNoLoggingT $ - PS.retryOnBusy $ - flip PS.runSqlPool pool $ do - rawExecute - "update qr_code set version = ? where version = ?" - [PersistText "OrchardPool", PersistText "Orchard"] - rawExecute - "update qr_code set version = ? where version = ?" - [PersistText "SaplingPool", PersistText "Sapling"] - rawExecute - "update qr_code set version = ? where version = ?" - [PersistText "TransparentPool", PersistText "Transparent"] - return () - -- * Wallet -- | Get the block of the last transaction known to the wallet getMaxWalletBlock :: @@ -928,17 +626,15 @@ getMaxWalletBlock pool = do Nothing -> return $ -1 Just x -> return $ walletTransactionBlock $ entityVal x -getMinBirthdayHeight :: ConnectionPool -> ZcashNetDB -> IO Int -getMinBirthdayHeight pool znet = do +getMinBirthdayHeight :: ConnectionPool -> IO Int +getMinBirthdayHeight pool = do b <- runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do selectOne $ do w <- from $ table @ZcashWallet - where_ - (w ^. ZcashWalletBirthdayHeight >. val 0 &&. w ^. ZcashWalletNetwork ==. - val znet) + where_ (w ^. ZcashWalletBirthdayHeight >. val 0) orderBy [asc $ w ^. ZcashWalletBirthdayHeight] pure w case b of @@ -970,37 +666,29 @@ saveWalletTransaction pool za zt = do runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do - 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 + t <- + upsert + (WalletTransaction + (zcashTransactionTxId zT') + za + (zcashTransactionBlock zT') + (zcashTransactionConf zT') + (zcashTransactionTime zT')) + [] + return $ entityKey t -- | Save a @WalletSapNote@ saveWalletSapNote :: ConnectionPool -- ^ The database path -> WalletTransactionId -- ^ The index for the transaction that contains the note - -> Int32 -- ^ note position + -> Integer -- ^ note position + -> SaplingWitness -- ^ the Sapling incremental witness -> Bool -- ^ change flag -> ZcashAccountId -> ShieldOutputId -> DecodedNote -- The decoded Sapling note -> IO () -saveWalletSapNote pool wId pos ch za zt dn = do +saveWalletSapNote pool wId pos wit ch za zt dn = do runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do @@ -1015,7 +703,7 @@ saveWalletSapNote pool wId pos ch za zt dn = do False (HexStringDB $ a_nullifier dn) (fromIntegral pos) - (HexStringDB $ hexString "00") + (HexStringDB $ sapWit wit) ch zt (RseedDB $ a_rseed dn)) @@ -1026,13 +714,14 @@ saveWalletSapNote pool wId pos ch za zt dn = do saveWalletOrchNote :: ConnectionPool -> WalletTransactionId - -> Int32 + -> Integer + -> OrchardWitness -> Bool -> ZcashAccountId -> OrchActionId -> DecodedNote -> IO () -saveWalletOrchNote pool wId pos ch za zt dn = do +saveWalletOrchNote pool wId pos wit ch za zt dn = do runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do @@ -1047,7 +736,7 @@ saveWalletOrchNote pool wId pos ch za zt dn = do False (HexStringDB $ a_nullifier dn) (fromIntegral pos) - (HexStringDB $ hexString "00") + (HexStringDB $ orchWit wit) ch zt (a_rho dn) @@ -1059,10 +748,9 @@ saveWalletOrchNote pool wId pos ch za zt dn = do findTransparentNotes :: ConnectionPool -- ^ The database path -> Int -- ^ Starting block - -> ZcashNetDB -- ^ Network to use -> Entity WalletAddress -> IO () -findTransparentNotes pool b net t = do +findTransparentNotes pool b t = do let tReceiver = t_rec =<< readUnifiedAddressDB (entityVal t) case tReceiver of Just tR -> do @@ -1077,17 +765,13 @@ findTransparentNotes pool b net t = do PS.retryOnBusy $ flip PS.runSqlPool pool $ do select $ do - (blks :& txs :& tNotes) <- - from $ table @ZcashBlock `innerJoin` table @ZcashTransaction `on` - (\(blks :& txs) -> - blks ^. ZcashBlockId ==. txs ^. ZcashTransactionBlockId) `innerJoin` - table @TransparentNote `on` - (\(_ :& txs :& tNotes) -> + (txs :& tNotes) <- + from $ table @ZcashTransaction `innerJoin` table @TransparentNote `on` + (\(txs :& tNotes) -> txs ^. ZcashTransactionId ==. tNotes ^. TransparentNoteTx) - where_ (blks ^. ZcashBlockHeight >. val b) - where_ (blks ^. ZcashBlockNetwork ==. val net) + where_ (txs ^. ZcashTransactionBlock >. val b) where_ (tNotes ^. TransparentNoteScript ==. val s) - pure (blks, txs, tNotes) + pure (txs, tNotes) mapM_ (saveWalletTrNote pool @@ -1103,11 +787,10 @@ saveWalletTrNote :: -> Scope -> ZcashAccountId -> WalletAddressId - -> (Entity ZcashBlock, Entity ZcashTransaction, Entity TransparentNote) + -> (Entity ZcashTransaction, Entity TransparentNote) -> IO () -saveWalletTrNote pool ch za wa (blk, zt, tn) = do +saveWalletTrNote pool ch za wa (zt, tn) = do let zT' = entityVal zt - let b = entityVal blk runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do @@ -1116,9 +799,9 @@ saveWalletTrNote pool ch za wa (blk, zt, tn) = do (WalletTransaction (zcashTransactionTxId zT') za - (zcashBlockHeight b) - (zcashBlockConf b) - (zcashBlockTime b)) + (zcashTransactionBlock zT') + (zcashTransactionConf zT') + (zcashTransactionTime zT')) [] insert_ $ WalletTrNote @@ -1140,22 +823,17 @@ saveSapNote pool wsn = getShieldedOutputs :: ConnectionPool -- ^ database path -> Int -- ^ block - -> ZcashNetDB -- ^ network to use -> IO [(Entity ZcashTransaction, Entity ShieldOutput)] -getShieldedOutputs pool b net = +getShieldedOutputs pool b = runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do select $ do - (blks :& txs :& sOutputs) <- - from $ table @ZcashBlock `innerJoin` table @ZcashTransaction `on` - (\(blks :& txs) -> - blks ^. ZcashBlockId ==. txs ^. ZcashTransactionBlockId) `innerJoin` - table @ShieldOutput `on` - (\(_ :& txs :& sOutputs) -> + (txs :& sOutputs) <- + from $ table @ZcashTransaction `innerJoin` table @ShieldOutput `on` + (\(txs :& sOutputs) -> txs ^. ZcashTransactionId ==. sOutputs ^. ShieldOutputTx) - where_ (blks ^. ZcashBlockHeight >=. val b) - where_ (blks ^. ZcashBlockNetwork ==. val net) + where_ (txs ^. ZcashTransactionBlock >=. val b) orderBy [ asc $ txs ^. ZcashTransactionId , asc $ sOutputs ^. ShieldOutputPosition @@ -1166,269 +844,21 @@ getShieldedOutputs pool b net = getOrchardActions :: ConnectionPool -- ^ database path -> Int -- ^ block - -> ZcashNetDB -- ^ network to use -> IO [(Entity ZcashTransaction, Entity OrchAction)] -getOrchardActions pool b net = +getOrchardActions pool b = runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do select $ do - (blks :& txs :& oActions) <- - from $ table @ZcashBlock `innerJoin` table @ZcashTransaction `on` - (\(blks :& txs) -> - blks ^. ZcashBlockId ==. txs ^. ZcashTransactionBlockId) `innerJoin` - table @OrchAction `on` - (\(_ :& txs :& oActions) -> + (txs :& oActions) <- + from $ table @ZcashTransaction `innerJoin` table @OrchAction `on` + (\(txs :& oActions) -> txs ^. ZcashTransactionId ==. oActions ^. OrchActionTx) - where_ (blks ^. ZcashBlockHeight >=. val b) - where_ (blks ^. ZcashBlockNetwork ==. val net) + where_ (txs ^. ZcashTransactionBlock >=. val b) 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 @@ -1446,67 +876,96 @@ getWalletTransactions pool w = do trNotes <- case tReceiver of Nothing -> return [] - Just tR -> liftIO $ getTrNotes pool tR - sapNotes <- - case sReceiver of + 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 Nothing -> return [] - 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 + 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 trSpends <- PS.retryOnBusy $ flip PS.runSqlPool pool $ do select $ do trSpends <- from $ table @WalletTrSpend where_ - (trSpends ^. WalletTrSpendNote `in_` valList (map entityKey trNotes)) + (trSpends ^. WalletTrSpendNote `in_` + valList (map entityKey (trNotes <> trChgNotes))) pure trSpends - 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 + sapNotes <- + case sReceiver 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 + 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 -> liftIO $ getSapFilteredNotes pool foundTxs sR - sapChgNotes' <- liftIO $ mapM (traceSapDag pool) sapChgNotes - sapChgSpends <- - mapM (getSapSpends . entityKey) (sapChgNotes <> concat sapChgNotes') + 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 -> 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 + 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 + mapM_ subTSpend trSpends + mapM_ subSSpend $ catMaybes sapSpends + mapM_ subOSpend $ catMaybes orchSpends where clearUserTx :: WalletAddressId -> NoLoggingT IO () clearUserTx waId = do @@ -1516,16 +975,6 @@ 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 @@ -1638,19 +1087,6 @@ 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 $ @@ -1710,7 +1146,7 @@ findTransparentSpends pool za = do (trSpends ^. TransparentSpendOutPointHash ==. val flipTxId) where_ (trSpends ^. TransparentSpendOutPointIndex ==. - val (fromIntegral $ walletTrNotePosition $ entityVal n)) + val (walletTrNotePosition $ entityVal n)) pure (tx, trSpends) if null s then return () @@ -1805,16 +1241,12 @@ getUnspentSapNotes pool = do where_ (n ^. WalletSapNoteSpent ==. val False) pure n -getSaplingCmus :: - ConnectionPool - -> ShieldOutputId - -> ShieldOutputId - -> IO [Value HexStringDB] -getSaplingCmus pool zt m = do +getSaplingCmus :: Pool SqlBackend -> ShieldOutputId -> IO [Value HexStringDB] +getSaplingCmus pool zt = do PS.runSqlPool (select $ do n <- from $ table @ShieldOutput - where_ (n ^. ShieldOutputId >. val zt &&. n ^. ShieldOutputId <=. val m) + where_ (n ^. ShieldOutputId >. val zt) orderBy [asc $ n ^. ShieldOutputId] pure $ n ^. ShieldOutputCmu) pool @@ -1822,30 +1254,15 @@ getSaplingCmus pool zt m = do getMaxSaplingNote :: Pool SqlBackend -> IO ShieldOutputId getMaxSaplingNote pool = do flip PS.runSqlPool pool $ do - maxBlock <- + x <- selectOne $ do - blks <- from $ table @ZcashBlock - where_ $ blks ^. ZcashBlockHeight >. val 0 - orderBy [desc $ blks ^. ZcashBlockHeight] - pure $ blks ^. ZcashBlockHeight - case maxBlock of + n <- from $ table @ShieldOutput + where_ (n ^. ShieldOutputId >. val (toSqlKey 0)) + orderBy [desc $ n ^. ShieldOutputId] + pure (n ^. ShieldOutputId) + case x of Nothing -> return $ toSqlKey 0 - 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 + Just (Value y) -> return y updateSapNoteRecord :: Pool SqlBackend @@ -1873,13 +1290,12 @@ getUnspentOrchNotes pool = do where_ (n ^. WalletOrchNoteSpent ==. val False) pure n -getOrchardCmxs :: - ConnectionPool -> OrchActionId -> OrchActionId -> IO [Value HexStringDB] -getOrchardCmxs pool zt m = do +getOrchardCmxs :: Pool SqlBackend -> OrchActionId -> IO [Value HexStringDB] +getOrchardCmxs pool zt = do PS.runSqlPool (select $ do n <- from $ table @OrchAction - where_ (n ^. OrchActionId >. val zt &&. n ^. OrchActionId <=. val m) + where_ (n ^. OrchActionId >. val zt) orderBy [asc $ n ^. OrchActionId] pure $ n ^. OrchActionCmx) pool @@ -1887,30 +1303,15 @@ getOrchardCmxs pool zt m = do getMaxOrchardNote :: Pool SqlBackend -> IO OrchActionId getMaxOrchardNote pool = do flip PS.runSqlPool pool $ do - maxBlock <- + x <- selectOne $ do - blks <- from $ table @ZcashBlock - where_ $ blks ^. ZcashBlockHeight >. val 0 - orderBy [desc $ blks ^. ZcashBlockHeight] - pure $ blks ^. ZcashBlockHeight - case maxBlock of + n <- from $ table @OrchAction + where_ (n ^. OrchActionId >. val (toSqlKey 0)) + orderBy [desc $ n ^. OrchActionId] + pure (n ^. OrchActionId) + case x of Nothing -> return $ toSqlKey 0 - 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 + Just (Value y) -> return y updateOrchNoteRecord :: Pool SqlBackend @@ -1972,51 +1373,15 @@ upsertWalTx :: => ZcashTransaction -> ZcashAccountId -> SqlPersistT m (Entity WalletTransaction) -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' +upsertWalTx zt za = + upsert + (WalletTransaction + (zcashTransactionTxId zt) + za + (zcashTransactionBlock zt) + (zcashTransactionConf zt) + (zcashTransactionTime zt)) + [] getBalance :: ConnectionPool -> ZcashAccountId -> IO Integer getBalance pool za = do @@ -2060,77 +1425,6 @@ getUnconfirmedBalance pool za = do let oBal = sum oAmts return . fromIntegral $ tBal + sBal + oBal -getPoolBalance :: ConnectionPool -> ZcashAccountId -> IO AccountBalance -getPoolBalance pool za = do - trNotes <- getWalletUnspentTrNotes pool za - let tAmts = map (walletTrNoteValue . entityVal) trNotes - let tBal = sum tAmts - sapNotes <- getWalletUnspentSapNotes pool za - let sAmts = map (walletSapNoteValue . entityVal) sapNotes - let sBal = sum sAmts - orchNotes <- getWalletUnspentOrchNotes pool za - let oAmts = map (walletOrchNoteValue . entityVal) orchNotes - let oBal = sum oAmts - return $ AccountBalance tBal sBal oBal - -getUnconfPoolBalance :: ConnectionPool -> ZcashAccountId -> IO AccountBalance -getUnconfPoolBalance pool za = do - trNotes <- getWalletUnspentUnconfirmedTrNotes pool za - let tAmts = map (walletTrNoteValue . entityVal) trNotes - let tBal = sum tAmts - sapNotes <- getWalletUnspentUnconfirmedSapNotes pool za - let sAmts = map (walletSapNoteValue . entityVal) sapNotes - let sBal = sum sAmts - orchNotes <- getWalletUnspentUnconfirmedOrchNotes pool za - let oAmts = map (walletOrchNoteValue . entityVal) orchNotes - let oBal = sum oAmts - return $ AccountBalance tBal sBal oBal - -rewindWalletTransactions :: ConnectionPool -> Int -> IO () -rewindWalletTransactions pool b = do - runNoLoggingT $ - PS.retryOnBusy $ - flip PS.runSqlPool pool $ do - delete $ do - _ <- from $ table @UserTx - return () - oldTxs <- - select $ do - txs <- from $ table @WalletTransaction - where_ $ txs ^. WalletTransactionBlock >. val b - pure txs - let oldKeys = map entityKey oldTxs - delete $ do - x <- from $ table @WalletOrchSpend - where_ $ x ^. WalletOrchSpendTx `in_` valList oldKeys - return () - delete $ do - x <- from $ table @WalletOrchNote - where_ $ x ^. WalletOrchNoteTx `in_` valList oldKeys - return () - delete $ do - x <- from $ table @WalletSapSpend - where_ $ x ^. WalletSapSpendTx `in_` valList oldKeys - return () - delete $ do - x <- from $ table @WalletSapNote - where_ $ x ^. WalletSapNoteTx `in_` valList oldKeys - return () - delete $ do - x <- from $ table @WalletTrSpend - where_ $ x ^. WalletTrSpendTx `in_` valList oldKeys - return () - delete $ do - x <- from $ table @WalletTrNote - where_ $ x ^. WalletTrNoteTx `in_` valList oldKeys - return () - delete $ do - txs <- from $ table @WalletTransaction - where_ $ txs ^. WalletTransactionBlock >. val b - return () - update $ \w -> do - set w [ZcashWalletLastSync =. val b] - clearWalletTransactions :: ConnectionPool -> IO () clearWalletTransactions pool = do runNoLoggingT $ @@ -2160,38 +1454,6 @@ 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] @@ -2348,7 +1610,7 @@ selectUnspentNotes pool za amt = do else return (tList, [], []) where checkTransparent :: - Int64 -> [Entity WalletTrNote] -> (Int64, [Entity WalletTrNote]) + Word64 -> [Entity WalletTrNote] -> (Word64, [Entity WalletTrNote]) checkTransparent x [] = (x, []) checkTransparent x (n:ns) = if walletTrNoteValue (entityVal n) < x @@ -2357,7 +1619,7 @@ selectUnspentNotes pool za amt = do snd (checkTransparent (x - walletTrNoteValue (entityVal n)) ns)) else (0, [n]) checkSapling :: - Int64 -> [Entity WalletSapNote] -> (Int64, [Entity WalletSapNote]) + Word64 -> [Entity WalletSapNote] -> (Word64, [Entity WalletSapNote]) checkSapling x [] = (x, []) checkSapling x (n:ns) = if walletSapNoteValue (entityVal n) < x @@ -2365,133 +1627,7 @@ selectUnspentNotes pool za amt = do , 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 - 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]) + Word64 -> [Entity WalletOrchNote] -> (Word64, [Entity WalletOrchNote]) checkOrchard x [] = (x, []) checkOrchard x (n:ns) = if walletOrchNoteValue (entityVal n) < x @@ -2530,22 +1666,6 @@ saveConfs pool b c = do update $ \t -> do set t [WalletTransactionConf =. val c] where_ $ t ^. WalletTransactionBlock ==. val b - update $ \bl -> do - set bl [ZcashBlockConf =. val c] - where_ $ bl ^. ZcashBlockHeight ==. val b - -getReceivers :: ConnectionPool -> [Entity WalletTrNote] -> IO [WalletAddressId] -getReceivers pool ns = do - r <- - runNoLoggingT $ - PS.retryOnBusy $ - flip PS.runSqlPool pool $ do - select $ - distinct $ do - t <- from $ table @WalletTrNote - where_ (t ^. WalletTrNoteId `in_` valList (map entityKey ns)) - return (t ^. WalletTrNoteAddress) - return $ map (\(Value x) -> x) r -- | Helper function to extract a Unified Address from the database readUnifiedAddressDB :: WalletAddress -> Maybe UnifiedAddress @@ -2604,399 +1724,3 @@ deleteAdrsFromAB pool ia = do rmdups :: Ord a => [a] -> [a] rmdups = map head . group . sort - --- * Zenith Operations --- | Get an operation by UUID -getOperation :: ConnectionPool -> U.UUID -> IO (Maybe (Entity Operation)) -getOperation pool uid = do - runNoLoggingT $ - PS.retryOnBusy $ - flip PS.runSqlPool pool $ do - selectOne $ do - ops <- from $ table @Operation - where_ (ops ^. OperationUuid ==. val (ZenithUuid uid)) - pure ops - --- | Save an operation -saveOperation :: ConnectionPool -> Operation -> IO (Maybe (Key Operation)) -saveOperation pool op = do - runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ insertUnique op - --- | Finalize an operation with either a successful result or an error -finalizeOperation :: - ConnectionPool -> Key Operation -> ZenithStatus -> T.Text -> IO () -finalizeOperation pool op status result = do - tstamp <- getCurrentTime - runNoLoggingT $ - PS.retryOnBusy $ - flip PS.runSqlPool pool $ - update $ \ops -> do - set - ops - [ OperationEnd =. val (Just tstamp) - , OperationStatus =. val status - , OperationResult =. val (Just result) - ] - where_ (ops ^. OperationId ==. val op) - --- * Chain sync --- | Check if the wallet is currently running a sync -isSyncing :: ConnectionPool -> IO Bool -isSyncing pool = do - s <- - runNoLoggingT $ - PS.retryOnBusy $ - flip PS.runSqlPool pool $ - selectOne $ do - r <- from $ table @ChainSync - where_ $ r ^. ChainSyncStatus ==. val Processing - pure r - case s of - Nothing -> return False - Just _ -> return True - --- | Record the start of a sync -startSync :: ConnectionPool -> IO () -startSync pool = do - start <- getCurrentTime - _ <- - runNoLoggingT $ - PS.retryOnBusy $ - flip PS.runSqlPool pool $ - upsert (ChainSync "Internal" start Nothing Processing) [] - return () - --- | Complete a sync -completeSync :: ConnectionPool -> ZenithStatus -> IO () -completeSync pool st = do - end <- getCurrentTime - _ <- - runNoLoggingT $ - PS.retryOnBusy $ - flip PS.runSqlPool pool $ - update $ \s -> do - set s [ChainSyncEnd =. val (Just end), ChainSyncStatus =. val st] - where_ (s ^. ChainSyncName ==. val "Internal") - return () - --- | Rewind the data store to a given block height -rewindWalletData :: ConnectionPool -> Int -> ZcashNetDB -> NoLoggingT IO () -rewindWalletData pool b net = do - logDebugN "Starting transaction rewind" - liftIO $ rewindWalletTransactions pool b - logDebugN "Completed transaction rewind" - logDebugN "Starting data store rewind" - _ <- - runStderrLoggingT $ - PS.retryOnBusy $ - flip PS.runSqlPool pool $ do - oldBlocks <- - select $ do - blk <- from $ table @ZcashBlock - where_ - (blk ^. ZcashBlockHeight >. val b &&. blk ^. ZcashBlockNetwork ==. - val net) - pure blk - let oldBlkKeys = map entityKey oldBlocks - oldTxs <- - select $ do - txs <- from $ table @ZcashTransaction - where_ $ txs ^. ZcashTransactionBlockId `in_` valList oldBlkKeys - pure txs - let oldTxKeys = map entityKey oldTxs - delete $ do - x <- from $ table @TransparentNote - where_ $ x ^. TransparentNoteTx `in_` valList oldTxKeys - logDebugN "Completed TransparentNote delete" - _ <- - runStderrLoggingT $ - PS.retryOnBusy $ - flip PS.runSqlPool pool $ do - oldBlocks <- - select $ do - blk <- from $ table @ZcashBlock - where_ - (blk ^. ZcashBlockHeight >. val b &&. blk ^. ZcashBlockNetwork ==. - val net) - pure blk - let oldBlkKeys = map entityKey oldBlocks - oldTxs <- - select $ do - txs <- from $ table @ZcashTransaction - where_ $ txs ^. ZcashTransactionBlockId `in_` valList oldBlkKeys - pure txs - let oldTxKeys = map entityKey oldTxs - delete $ do - x <- from $ table @TransparentSpend - where_ $ x ^. TransparentSpendTx `in_` valList oldTxKeys - logDebugN "Completed TransparentSpend delete" - _ <- - runStderrLoggingT $ - PS.retryOnBusy $ - flip PS.runSqlPool pool $ do - oldBlocks <- - select $ do - blk <- from $ table @ZcashBlock - where_ - (blk ^. ZcashBlockHeight >. val b &&. blk ^. ZcashBlockNetwork ==. - val net) - pure blk - let oldBlkKeys = map entityKey oldBlocks - oldTxs <- - select $ do - txs <- from $ table @ZcashTransaction - where_ $ txs ^. ZcashTransactionBlockId `in_` valList oldBlkKeys - pure txs - let oldTxKeys = map entityKey oldTxs - delete $ do - x <- from $ table @ShieldOutput - where_ $ x ^. ShieldOutputTx `in_` valList oldTxKeys - logDebugN "Completed ShieldOutput delete" - _ <- - runStderrLoggingT $ - PS.retryOnBusy $ - flip PS.runSqlPool pool $ do - oldBlocks <- - select $ do - blk <- from $ table @ZcashBlock - where_ - (blk ^. ZcashBlockHeight >. val b &&. blk ^. ZcashBlockNetwork ==. - val net) - pure blk - let oldBlkKeys = map entityKey oldBlocks - oldTxs <- - select $ do - txs <- from $ table @ZcashTransaction - where_ $ txs ^. ZcashTransactionBlockId `in_` valList oldBlkKeys - pure txs - let oldTxKeys = map entityKey oldTxs - delete $ do - x <- from $ table @ShieldSpend - where_ $ x ^. ShieldSpendTx `in_` valList oldTxKeys - logDebugN "Completed ShieldSpend delete" - _ <- - runStderrLoggingT $ - PS.retryOnBusy $ - flip PS.runSqlPool pool $ do - oldBlocks <- - select $ do - blk <- from $ table @ZcashBlock - where_ - (blk ^. ZcashBlockHeight >. val b &&. blk ^. ZcashBlockNetwork ==. - val net) - pure blk - let oldBlkKeys = map entityKey oldBlocks - oldTxs <- - select $ do - txs <- from $ table @ZcashTransaction - where_ $ txs ^. ZcashTransactionBlockId `in_` valList oldBlkKeys - pure txs - let oldTxKeys = map entityKey oldTxs - delete $ do - x <- from $ table @OrchAction - where_ $ x ^. OrchActionTx `in_` valList oldTxKeys - logDebugN "Completed OrchAction delete" - _ <- - runStderrLoggingT $ - PS.retryOnBusy $ - flip PS.runSqlPool pool $ do - oldBlocks <- - select $ do - blk <- from $ table @ZcashBlock - where_ - (blk ^. ZcashBlockHeight >. val b &&. blk ^. ZcashBlockNetwork ==. - val net) - pure blk - let oldBlkKeys = map entityKey oldBlocks - oldTxs <- - select $ do - txs <- from $ table @ZcashTransaction - where_ $ txs ^. ZcashTransactionBlockId `in_` valList oldBlkKeys - pure txs - let oldTxKeys = map entityKey oldTxs - delete $ do - x <- from $ table @ZcashTransaction - where_ $ x ^. ZcashTransactionId `in_` valList oldTxKeys - logDebugN "Completed ZcashTransaction delete" - _ <- - runStderrLoggingT $ - PS.retryOnBusy $ - flip PS.runSqlPool pool $ do - delete $ do - blk <- from $ table @ZcashBlock - where_ $ - (blk ^. ZcashBlockHeight >. val b) &&. - (blk ^. ZcashBlockNetwork ==. val net) - logDebugN "Completed data store rewind" - {- - -_ <- liftIO $ clearTrees pool - -logDebugN "Cleared commitment trees" - -} - saplingOutputIx <- liftIO $ getSaplingOutputAtBlock pool net b - orchardActionIx <- liftIO $ getOrchardActionAtBlock pool net b - case saplingOutputIx of - Nothing -> logErrorN "Couldn't get Sapling output index for tree rewind" - Just soIx -> do - saplingTree <- liftIO $ getSaplingTree pool - truncSapTree <- truncateTree (maybe InvalidTree fst saplingTree) soIx - _ <- liftIO $ upsertSaplingTree pool b truncSapTree - logDebugN $ "Truncated Sapling tree at index " <> T.pack (show soIx) - case orchardActionIx of - Nothing -> logErrorN "Couldn't get Orchard action index for tree rewind" - Just oaIx -> do - orchardTree <- liftIO $ getOrchardTree pool - truncOrchTree <- truncateTree (maybe InvalidTree fst orchardTree) oaIx - _ <- liftIO $ upsertOrchardTree pool b truncOrchTree - logDebugN $ "Truncated Orchard tree at index " <> T.pack (show oaIx) - -clearTrees :: ConnectionPool -> IO () -clearTrees pool = - runNoLoggingT $ - PS.retryOnBusy $ - flip PS.runSqlPool pool $ do - delete $ do - tr <- from $ table @TreeStore - return () - -getSaplingOutputAtBlock :: - ConnectionPool -> ZcashNetDB -> Int -> IO (Maybe Int64) -getSaplingOutputAtBlock pool znet b = do - r <- - runNoLoggingT $ - PS.retryOnBusy $ - flip PS.runSqlPool pool $ do - selectOne $ do - (blks :& txs :& sOutputs) <- - from $ table @ZcashBlock `innerJoin` table @ZcashTransaction `on` - (\(blks :& txs) -> - blks ^. ZcashBlockId ==. txs ^. ZcashTransactionBlockId) `innerJoin` - table @ShieldOutput `on` - (\(_ :& txs :& sOutputs) -> - txs ^. ZcashTransactionId ==. sOutputs ^. ShieldOutputTx) - where_ (blks ^. ZcashBlockHeight <=. val b) - where_ (blks ^. ZcashBlockNetwork ==. val znet) - orderBy [desc $ sOutputs ^. ShieldOutputId] - return sOutputs - case r of - Nothing -> return Nothing - Just so -> return $ Just $ fromSqlKey $ entityKey so - -getOrchardActionAtBlock :: - ConnectionPool -> ZcashNetDB -> Int -> IO (Maybe Int64) -getOrchardActionAtBlock pool znet b = do - r <- - runNoLoggingT $ - PS.retryOnBusy $ - flip PS.runSqlPool pool $ do - selectOne $ do - (blks :& txs :& oActions) <- - from $ table @ZcashBlock `innerJoin` table @ZcashTransaction `on` - (\(blks :& txs) -> - blks ^. ZcashBlockId ==. txs ^. ZcashTransactionBlockId) `innerJoin` - table @OrchAction `on` - (\(_ :& txs :& oActions) -> - txs ^. ZcashTransactionId ==. oActions ^. OrchActionTx) - where_ (blks ^. ZcashBlockHeight <=. val b) - where_ (blks ^. ZcashBlockNetwork ==. val znet) - orderBy [desc $ oActions ^. OrchActionId] - return oActions - case r of - Nothing -> return Nothing - Just so -> return $ Just $ fromSqlKey $ entityKey so - --- * Tree storage --- | Read the Orchard commitment tree -getOrchardTree :: ConnectionPool -> IO (Maybe (Tree OrchardNode, Int)) -getOrchardTree pool = do - treeRecord <- - runNoLoggingT $ - PS.retryOnBusy $ - flip PS.runSqlPool pool $ do - selectOne $ do - tr <- from $ table @TreeStore - where_ (tr ^. TreeStorePool ==. val OrchardPool) - pure tr - case treeRecord of - Nothing -> return Nothing - Just tR -> - case deserialiseBorsh $ BS.fromStrict $ treeStoreBytes $ entityVal tR of - Left _ -> return Nothing - Right t -> return $ Just (t, treeStoreLastSync $ entityVal tR) - --- | Save the Orchard commitment tree -upsertOrchardTree :: ConnectionPool -> Int -> Tree OrchardNode -> IO () -upsertOrchardTree pool ls tree = do - let treeBytes = BS.toStrict $ serialiseBorsh tree - chk <- - runNoLoggingT $ - PS.retryOnBusy $ - flip PS.runSqlPool pool $ do - select $ do - tr <- from $ table @TreeStore - where_ (tr ^. TreeStorePool ==. val OrchardPool) - pure tr - if not (null chk) - then do - _ <- - runNoLoggingT $ - PS.retryOnBusy $ - flip PS.runSqlPool pool $ do - update $ \p -> do - set p [TreeStoreBytes =. val treeBytes, TreeStoreLastSync =. val ls] - where_ $ p ^. TreeStorePool ==. val OrchardPool - return () - else do - _ <- - runNoLoggingT $ - PS.retryOnBusy $ - flip PS.runSqlPool pool $ - insertUnique_ $ TreeStore OrchardPool treeBytes ls - return () - --- | Read the Sapling commitment tree -getSaplingTree :: ConnectionPool -> IO (Maybe (Tree SaplingNode, Int)) -getSaplingTree pool = do - treeRecord <- - runStderrLoggingT $ - PS.retryOnBusy $ - flip PS.runSqlPool pool $ do - selectOne $ do - tr <- from $ table @TreeStore - where_ (tr ^. TreeStorePool ==. val SaplingPool) - pure tr - case treeRecord of - Nothing -> return Nothing - Just tR -> - case deserialiseBorsh $ BS.fromStrict $ treeStoreBytes $ entityVal tR of - Left _ -> return Nothing - Right t -> return $ Just (t, treeStoreLastSync $ entityVal tR) - --- | Save the Sapling commitment tree -upsertSaplingTree :: ConnectionPool -> Int -> Tree SaplingNode -> IO () -upsertSaplingTree pool ls tree = do - let treeBytes = BS.toStrict $ serialiseBorsh tree - chk <- - runNoLoggingT $ - PS.retryOnBusy $ - flip PS.runSqlPool pool $ do - select $ do - tr <- from $ table @TreeStore - where_ (tr ^. TreeStorePool ==. val SaplingPool) - pure tr - if not (null chk) - then do - _ <- - runNoLoggingT $ - PS.retryOnBusy $ - flip PS.runSqlPool pool $ do - update $ \p -> do - set p [TreeStoreBytes =. val treeBytes, TreeStoreLastSync =. val ls] - where_ $ p ^. TreeStorePool ==. val SaplingPool - return () - else do - _ <- - runNoLoggingT $ - PS.retryOnBusy $ - flip PS.runSqlPool pool $ - insertUnique_ $ TreeStore SaplingPool treeBytes ls - return () diff --git a/src/Zenith/GUI.hs b/src/Zenith/GUI.hs index 0c9dfdf..c0b4623 100644 --- a/src/Zenith/GUI.hs +++ b/src/Zenith/GUI.hs @@ -1,7 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE LambdaCase #-} module Zenith.GUI where @@ -11,24 +9,17 @@ 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 Control.Monad.Logger (runFileLoggingT, runNoLoggingT) import Data.Aeson import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS import Data.HexString (toText) -import Data.Maybe (fromMaybe, isJust, isNothing) -import Data.Scientific (Scientific, fromFloatDigits) +import Data.Maybe (fromJust, fromMaybe, isJust, isNothing) import qualified Data.Text as T import qualified Data.Text.Encoding as E import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Database.Esqueleto.Experimental (ConnectionPool, fromSqlKey) +import Database.Esqueleto.Experimental (ConnectionPool) import Database.Persist import Lens.Micro ((&), (+~), (.~), (?~), (^.), set) import Lens.Micro.TH @@ -36,25 +27,19 @@ import Monomer import qualified Monomer.Lens as L import System.Directory (getHomeDirectory) import System.FilePath (()) +import System.Hclip import Text.Printf import Text.Wrap (FillScope(..), FillStrategy(..), WrapSettings(..), wrapText) import TextShow hiding (toText) import ZcashHaskell.Keys (generateWalletSeedPhrase) -import ZcashHaskell.Orchard - ( getSaplingFromUA - , isValidUnifiedAddress - , parseAddress - ) -import ZcashHaskell.Transparent - ( decodeTransparentAddress - , encodeTransparentReceiver - ) +import ZcashHaskell.Orchard (getSaplingFromUA, isValidUnifiedAddress) +import ZcashHaskell.Transparent (encodeTransparentReceiver) import ZcashHaskell.Types ( BlockResponse(..) + , Phrase(..) , Scope(..) , ToBytes(..) , UnifiedAddress(..) - , ValidAddress(..) , ZcashNet(..) , ZebraGetBlockChainInfo(..) , ZebraGetInfo(..) @@ -63,16 +48,13 @@ import ZcashHaskell.Utils (getBlockTime, makeZebraCall) import Zenith.Core import Zenith.DB import Zenith.GUI.Theme -import Zenith.Scanner (checkIntegrity, processTx, rescanZebra, updateConfs) +import Zenith.Scanner (processTx, updateConfs) import Zenith.Types hiding (ZcashAddress(..)) import Zenith.Utils ( displayAmount - , getChainTip - , isRecipientValidGUI - , isValidString - , isZecAddressValid + , isRecipientValid , jsonNumber - , padWithZero + , parseAddress , showAddress , validBarValue ) @@ -95,7 +77,7 @@ data AppEvent | SwitchAddr !Int | SwitchAcc !Int | SwitchWal !Int - | UpdateBalance !(Integer, Integer, Integer, Integer) + | UpdateBalance !(Integer, Integer) | CopyAddr !(Maybe (Entity WalletAddress)) | LoadTxs ![Entity UserTx] | LoadAddrs ![Entity WalletAddress] @@ -120,33 +102,6 @@ data AppEvent | CheckRecipient !T.Text | CheckAmount !Float | ShowTxId !T.Text - | LoadAbList ![Entity AddressBook] - | ShowAdrBook - | CloseAdrBook - | NewAdrBkEntry - | CloseNewAdrBook - | NotImplemented - | CloseMsgAB - | CheckValidAddress !T.Text - | CheckValidDescrip !T.Text - | SaveNewABEntry - | UpdateABEntry !T.Text !T.Text - | CloseUpdABEntry - | ShowMessage !T.Text - | ShowABAddress !T.Text !T.Text - | CloseShowABAddress - | CopyABAdress !T.Text - | DeleteABEntry !T.Text - | UpdateABDescrip !T.Text !T.Text - | ResetRecipientValid - | ShowShield - | CloseShield - | ShowDeShield - | CloseDeShield - | SendDeShield - | SendShield - | StartSync - | TreeSync deriving (Eq, Show) data AppModel = AppModel @@ -189,23 +144,6 @@ data AppModel = AppModel , _amountValid :: !Bool , _showId :: !(Maybe T.Text) , _home :: !FilePath - , _showAdrBook :: !Bool - , _newAdrBkEntry :: !Bool - , _abdescrip :: !T.Text - , _abaddress :: !T.Text - , _abAddressValid :: !Bool - , _abDescripValid :: !Bool - , _abaddressList :: ![Entity AddressBook] - , _msgAB :: !(Maybe T.Text) - , _showABAddress :: !Bool - , _updateABAddress :: !Bool - , _privacyChoice :: !PrivacyPolicy - , _shieldZec :: !Bool - , _deShieldZec :: !Bool - , _tBalance :: !Integer - , _tBalanceValid :: !Bool - , _sBalance :: !Integer - , _sBalanceValid :: !Bool } deriving (Eq, Show) makeLenses ''AppModel @@ -247,17 +185,6 @@ buildUI wenv model = widgetTree , txIdOverlay `nodeVisible` isJust (model ^. showId) , msgOverlay `nodeVisible` isJust (model ^. msg) , modalOverlay `nodeVisible` isJust (model ^. modalMsg) - , adrbookOverlay `nodeVisible` model ^. showAdrBook - , newAdrBkOverlay `nodeVisible` model ^. newAdrBkEntry - , showABAddressOverlay (model ^. abdescrip) (model ^. abaddress) `nodeVisible` - model ^. - showABAddress - , updateABAddressOverlay (model ^. abdescrip) (model ^. abaddress) `nodeVisible` - model ^. - updateABAddress - , shieldOverlay `nodeVisible` model ^. shieldZec - , deShieldOverlay `nodeVisible` model ^. deShieldZec - , msgAdrBookOverlay `nodeVisible` isJust (model ^. msgAB) ] mainWindow = vstack @@ -320,12 +247,6 @@ buildUI wenv model = widgetTree [bgColor white, borderB 1 gray, padding 3] , box_ [alignLeft, onClick ShowSeed] (label "Backup Wallet") `styleBasic` [bgColor white, borderB 1 gray, padding 3] - , box_ [alignLeft, onClick ShowAdrBook] (label "Address Book") `styleBasic` - [bgColor white, borderB 1 gray, padding 3] - , box_ [alignLeft, onClick ShowShield] (label "Shield ZEC") `styleBasic` - [bgColor white, borderB 1 gray, padding 3] - , box_ [alignLeft, onClick ShowDeShield] (label "De-Shield ZEC") `styleBasic` - [bgColor white, borderB 1 gray, padding 3] ]) `styleBasic` [bgColor btnColor, padding 3] newBox = @@ -452,43 +373,43 @@ buildUI wenv model = widgetTree [ vstack [ tooltip "Unified" $ box_ - [onClick (SetPool OrchardPool)] + [onClick (SetPool Orchard)] (remixIcon remixShieldCheckFill `styleBasic` [ textSize 14 , padding 4 , styleIf - (model ^. selPool == OrchardPool) + (model ^. selPool == Orchard) (bgColor btnColor) , styleIf - (model ^. selPool == OrchardPool) + (model ^. selPool == Orchard) (textColor white) ]) , filler , tooltip "Legacy Shielded" $ box_ - [onClick (SetPool SaplingPool)] + [onClick (SetPool Sapling)] (remixIcon remixShieldLine `styleBasic` [ textSize 14 , padding 4 , styleIf - (model ^. selPool == SaplingPool) + (model ^. selPool == Sapling) (bgColor btnColor) , styleIf - (model ^. selPool == SaplingPool) + (model ^. selPool == Sapling) (textColor white) ]) , filler , tooltip "Transparent" $ box_ - [onClick (SetPool TransparentPool)] + [onClick (SetPool Transparent)] (remixIcon remixEyeLine `styleBasic` [ textSize 14 , padding 4 , styleIf - (model ^. selPool == TransparentPool) + (model ^. selPool == Transparent) (bgColor btnColor) , styleIf - (model ^. selPool == TransparentPool) + (model ^. selPool == Transparent) (textColor white) ]) ] `styleBasic` @@ -501,10 +422,10 @@ buildUI wenv model = widgetTree (hstack [ label (case model ^. selPool of - OrchardPool -> "Unified" - SaplingPool -> "Legacy Shielded" - TransparentPool -> "Transparent" - SproutPool -> "Unknown") `styleBasic` + Orchard -> "Unified" + Sapling -> "Legacy Shielded" + Transparent -> "Transparent" + Sprout -> "Unknown") `styleBasic` [textColor white] , remixIcon remixFileCopyFill `styleBasic` [textSize 14, padding 4, textColor white] @@ -640,28 +561,7 @@ buildUI wenv model = widgetTree , 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"] + [ label "To:" `styleBasic` [width 50] , spacer , textField_ sendRecipient [onChange CheckRecipient] `styleBasic` [ width 150 @@ -671,8 +571,7 @@ buildUI wenv model = widgetTree ] ] , hstack - [ label "Amount:" `styleBasic` - [width 50, textFont "Bold"] + [ label "Amount:" `styleBasic` [width 50] , spacer , numericField_ sendAmount @@ -690,14 +589,12 @@ buildUI wenv model = widgetTree ] ] , hstack - [ label "Memo:" `styleBasic` - [width 50, textFont "Bold"] + [ label "Memo:" `styleBasic` [width 50] , spacer , textArea sendMemo `styleBasic` [width 150, height 40] ] , spacer - -- Radio button group for privacy level , box_ [alignMiddle] (hstack @@ -757,7 +654,7 @@ buildUI wenv model = widgetTree box (label (fromMaybe "?" $ model ^. modalMsg) `styleBasic` [textSize 12, textFont "Bold"]) `styleBasic` - [bgColor (white & L.a .~ 0.7)] + [bgColor (white & L.a .~ 0.5)] txOverlay = case model ^. showTx of Nothing -> alert CloseTx $ label "N/A" @@ -853,261 +750,6 @@ buildUI wenv model = widgetTree ] ]) `styleBasic` [padding 2, bgColor white, width 280, borderB 1 gray, borderT 1 gray] - -- | - -- | Address Book overlays - -- | - adrbookOverlay = - alert CloseAdrBook $ - vstack - [ box_ - [] - (label "Address Book" `styleBasic` - [textFont "Bold", textSize 12, textColor white]) `styleBasic` - [bgColor btnColor, radius 2, padding 3] - , boxShadow $ - box_ - [alignMiddle] - (vstack - [ vscroll - (vstack (zipWith abookRow [0 ..] (model ^. abaddressList))) `nodeKey` - "txScroll" - ]) `styleBasic` - [radius 2, padding 3, bgColor white] - , spacer - , hstack [button "New" NewAdrBkEntry] - ] - abookRow :: Int -> Entity AddressBook -> WidgetNode AppModel AppEvent - abookRow idx ab = - box_ - [ onClick $ - ShowABAddress - (addressBookAbdescrip $ entityVal ab) - (addressBookAbaddress $ entityVal ab) - , alignLeft - ] - (hstack - [ label (T.pack $ padWithZero 3 $ show (fromSqlKey (entityKey ab))) `styleBasic` - [textFont "Bold"] - , spacer - , label (addressBookAbdescrip $ entityVal ab) - ]) `styleBasic` - [padding 2, borderB 1 gray] - newAdrBkOverlay = - alert CloseNewAdrBook $ - vstack - [ box_ - [] - (label "New Address Book Entry" `styleBasic` - [textFont "Bold", textSize 10, textColor white]) `styleBasic` - [bgColor btnColor, radius 2, padding 3] - , spacer - , hstack - [ label "Description: " `styleBasic` [width 80] - , spacer - , textField_ abdescrip [onChange CheckValidDescrip] `styleBasic` - [ width 320 - , styleIf (not $ model ^. abDescripValid) (textColor red) - ] - ] - , spacer - , hstack - [ label "Address:" `styleBasic` [width 50] - , spacer - , textField_ abaddress [onChange CheckValidAddress] `styleBasic` - [ width 350 - , styleIf (not $ model ^. abAddressValid) (textColor red) - ] - ] - , spacer - , hstack - [ button "Save" SaveNewABEntry `nodeEnabled` - ((model ^. abAddressValid) && (model ^. abDescripValid)) - , spacer - , button "Cancel" CloseNewAdrBook `nodeEnabled` True - ] - ] - updateABAddressOverlay abd aba = - alert CloseUpdABEntry $ - vstack - [ box_ - [] - (label "Edit Address Description" `styleBasic` - [textFont "Bold", textSize 10, textColor white]) `styleBasic` - [bgColor btnColor, radius 2, padding 3] - , spacer - , hstack - [ label "Description:" `styleBasic` [width 80] - , spacer - , textField_ abdescrip [onChange CheckValidDescrip] `styleBasic` - [ width 320 - , styleIf (not $ model ^. abDescripValid) (textColor red) - ] - ] - , spacer - , hstack - [ filler - , button "Save" (UpdateABDescrip abd aba) `nodeEnabled` - (model ^. abDescripValid) - , spacer - , button "Cancel" CloseUpdABEntry `nodeEnabled` True - , filler - ] - ] - showABAddressOverlay abd aba = - alert CloseShowABAddress $ - vstack - [ box_ - [] - (label "Address Book Entry" `styleBasic` - [textFont "Bold", textColor white, textSize 12, padding 3]) `styleBasic` - [bgColor btnColor, radius 2, padding 3] - , spacer - , hstack - [ filler - , label (txtWrapN abd 64) `styleBasic` [textFont "Bold"] - , filler - ] - , spacer - , hstack [filler, label_ (txtWrapN aba 64) [multiline], filler] - , spacer - , hstack - [ filler - , button "Edit Description" $ UpdateABEntry abd aba - , spacer - , button "Copy Address" $ CopyABAdress aba - , spacer - , button "Delete Entry" $ DeleteABEntry aba - , filler - ] - ] - msgAdrBookOverlay = - alert CloseMsgAB $ - hstack - [ filler - , remixIcon remixErrorWarningFill `styleBasic` - [textSize 32, textColor btnColor] `nodeVisible` - (model ^. inError) - , spacer - , label_ (txtWrapN (fromMaybe "" (model ^. msgAB)) 64) [multiline] - , filler - ] - shieldOverlay = - box - (vstack - [ filler - , hstack - [ filler - , box_ - [] - (vstack - [ box_ - [alignMiddle] - (label "Shield Zcash" `styleBasic` - [textFont "Bold", textSize 12]) - , separatorLine `styleBasic` [fgColor btnColor] - , spacer - , label - ("Shield " <> - displayAmount (model ^. network) (model ^. tBalance) <> - "?") `styleBasic` - [width 50, textFont "Regular"] - , spacer - , box_ - [alignMiddle] - (hstack - [ filler - , mainButton "Proceed" SendShield `nodeEnabled` - True - , spacer - , mainButton "Cancel" CloseShield `nodeEnabled` - True - , filler - ]) - ]) `styleBasic` - [radius 4, border 2 btnColor, bgColor white, padding 4] - , filler - ] - , filler - ]) `styleBasic` - [bgColor (white & L.a .~ 0.5)] - deShieldOverlay = - box - (vstack - [ filler - , hstack - [ filler - , box_ - [] - (vstack - [ box_ - [alignMiddle] - (label "De-Shield Zcash" `styleBasic` - [textFont "Bold", textSize 12]) - , separatorLine `styleBasic` [fgColor btnColor] - , spacer - , box_ - [] - (vstack - [ hstack - [ label "Total Transparent : " `styleBasic` - [textFont "Bold"] - , label - (displayAmount - (model ^. network) - (model ^. tBalance)) - ] - , spacer - , hstack - [ label "Total Shielded : " `styleBasic` - [textFont "Bold"] - , label - (displayAmount - (model ^. network) - (model ^. sBalance)) - ] - , spacer - , hstack - [ label "Amount:" `styleBasic` - [width 50, textFont "Bold"] - , spacer - , numericField_ - sendAmount - [ decimals 8 - , minValue 0.0 - , maxValue - (fromIntegral (model ^. sBalance) / - 100000000.0) - , validInput sBalanceValid - , onChange CheckAmount - ] `styleBasic` - [ width 150 - , styleIf - (not $ model ^. sBalanceValid) - (textColor red) - ] - ] - ]) - , spacer - , box_ - [alignMiddle] - (hstack - [ filler - , mainButton "Proceed" SendDeShield `nodeEnabled` - True - , spacer - , mainButton "Cancel" CloseDeShield `nodeEnabled` - True - , filler - ]) - ]) `styleBasic` - [radius 4, border 2 btnColor, bgColor white, padding 4] - , filler - ] - , filler - ]) `styleBasic` - [bgColor (white & L.a .~ 0.5)] - -notImplemented = NotImplemented generateQRCodes :: Config -> IO () generateQRCodes config = do @@ -1122,9 +764,9 @@ generateQRCodes config = do if not (null s) then return () else do - generateOneQr pool OrchardPool wAddr - generateOneQr pool SaplingPool wAddr - generateOneQr pool TransparentPool wAddr + generateOneQr pool Orchard wAddr + generateOneQr pool Sapling wAddr + generateOneQr pool Transparent wAddr generateOneQr :: ConnectionPool -> ZcashPool -> Entity WalletAddress -> IO () generateOneQr p zp wAddr = @@ -1159,7 +801,7 @@ generateQRCodes config = do dispAddr :: ZcashPool -> WalletAddress -> Maybe T.Text dispAddr zp w = case zp of - TransparentPool -> + Transparent -> T.append "zcash:" . encodeTransparentReceiver (maybe @@ -1171,12 +813,11 @@ generateQRCodes config = do (t_rec =<< (isValidUnifiedAddress . E.encodeUtf8 . getUA . walletAddressUAddress) w) - SaplingPool -> + Sapling -> T.append "zcash:" <$> (getSaplingFromUA . E.encodeUtf8 . getUA . walletAddressUAddress) w - OrchardPool -> - Just $ (T.append "zcash:" . getUA . walletAddressUAddress) w - SproutPool -> Nothing + Orchard -> Just $ (T.append "zcash:" . getUA . walletAddressUAddress) w + Sprout -> Nothing handleEvent :: WidgetEnv AppModel AppEvent @@ -1231,11 +872,7 @@ handleEvent wenv node model evt = ] ConfirmCancel -> [Model $ model & confirmTitle .~ Nothing & mainInput .~ ""] ShowSeed -> [Model $ model & showSeed .~ True & menuPopup .~ False] - ShowSend -> - [ Model $ - model & openSend .~ True & privacyChoice .~ Full & recipientValid .~ - False - ] + ShowSend -> [Model $ model & openSend .~ True] SendTx -> case currentAccount of Nothing -> [Event $ ShowError "No account available", Event CancelSend] @@ -1250,10 +887,9 @@ handleEvent wenv node model evt = (model ^. network) (entityKey acc) (zcashWalletLastSync $ entityVal wal) - (fromFloatDigits $ model ^. sendAmount) + (model ^. sendAmount) (model ^. sendRecipient) (model ^. sendMemo) - (model ^. privacyChoice) , Event CancelSend ] CancelSend -> @@ -1295,7 +931,7 @@ handleEvent wenv node model evt = Just wAddr -> getUserTx dbPool $ entityKey wAddr ] SwitchQr q -> [Model $ model & qrCodeWidget .~ q] - SwitchAddr i -> [Model $ model & selAddr .~ i, Event $ SetPool OrchardPool] + SwitchAddr i -> [Model $ model & selAddr .~ i, Event $ SetPool Orchard] SwitchAcc i -> [ Model $ model & selAcc .~ i , Task $ @@ -1308,14 +944,12 @@ handleEvent wenv node model evt = UpdateBalance <$> do dbPool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration case selectAccount i of - Nothing -> return (0, 0, 0, 0) + Nothing -> return (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 + return (b, u) + , Event $ SetPool Orchard ] SwitchWal i -> [ Model $ model & selWallet .~ i & selAcc .~ 0 & selAddr .~ 0 @@ -1326,9 +960,9 @@ handleEvent wenv node model evt = Nothing -> return [] Just wal -> runNoLoggingT $ getAccounts dbPool $ entityKey wal ] - UpdateBalance (b, u, s, t) -> + UpdateBalance (b, u) -> [ Model $ - model & balance .~ b & sBalance .~ s & tBalance .~ t & unconfBalance .~ + model & balance .~ b & unconfBalance .~ (if u == 0 then Nothing else Just u) @@ -1338,15 +972,14 @@ handleEvent wenv node model evt = , setClipboardData $ ClipboardText $ case model ^. selPool of - OrchardPool -> - maybe "None" (getUA . walletAddressUAddress . entityVal) a - SaplingPool -> + Orchard -> maybe "None" (getUA . walletAddressUAddress . entityVal) a + Sapling -> fromMaybe "None" $ (getSaplingFromUA . E.encodeUtf8 . getUA . walletAddressUAddress . entityVal) =<< a - SproutPool -> "None" - TransparentPool -> + Sprout -> "None" + Transparent -> maybe "None" (encodeTransparentReceiver (model ^. network)) $ t_rec =<< (isValidUnifiedAddress . @@ -1369,7 +1002,7 @@ handleEvent wenv node model evt = if not (null a) then [ Model $ model & addresses .~ a , Event $ SwitchAddr $ model ^. selAddr - , Event $ SetPool OrchardPool + , Event $ SetPool Orchard ] else [Event $ NewAddress currentAccount] LoadAccs a -> @@ -1378,7 +1011,7 @@ handleEvent wenv node model evt = else [Event $ NewAccount currentWallet] LoadWallets a -> if not (null a) - then [ Model $ model & wallets .~ a & modalMsg .~ Nothing + then [ Model $ model & wallets .~ a , Event $ SwitchWal $ model ^. selWallet ] else [Event NewWallet] @@ -1388,167 +1021,45 @@ handleEvent wenv node model evt = 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 - ] + if (model ^. timer) < 90 + then [Model $ model & timer .~ (1 + model ^. timer)] + else if (model ^. barValue) == 1.0 + then [ Model $ model & timer .~ 0 & barValue .~ 0.0 + , Producer $ + scanZebra + (c_dbPath $ model ^. configuration) + (c_zebraHost $ model ^. configuration) + (c_zebraPort $ model ^. configuration) + ] + else [Model $ model & timer .~ 0] SyncVal i -> if (i + model ^. barValue) >= 0.999 - then [Model $ model & barValue .~ 1.0 & modalMsg .~ Nothing] + then [ Model $ model & barValue .~ 1.0 & modalMsg .~ Nothing + , Task $ do + case currentWallet of + Nothing -> return $ ShowError "No wallet available" + Just cW -> do + syncWallet (model ^. configuration) cW + return $ SwitchAddr (model ^. selAddr) + , Task $ do + pool <- + runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration + wL <- getWallets pool (model ^. network) + return $ LoadWallets wL + ] 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 - ] + CheckRecipient a -> [Model $ model & recipientValid .~ isRecipientValid 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) @@ -1636,84 +1147,28 @@ handleEvent wenv node model evt = Just _ -> do wL <- getWallets pool (model ^. network) return $ LoadWallets wL - -- | - -- | Address Book -> save new entry into database - -- | - saveAddrBook :: Config -> ZcashNetDB -> T.Text -> T.Text -> IO AppEvent - saveAddrBook config n d a = do - pool <- runNoLoggingT $ initPool $ c_dbPath config - res <- liftIO $ saveAdrsInAdrBook pool $ AddressBook n d a - case res of - Nothing -> return $ ShowMessage "Error saving AddressBook entry..." - Just _ -> return $ ShowMessage "New Address Book entry added!!" - -- | - -- | Address Book -> save new entry into database - -- | - deleteAdrBook :: Config -> T.Text -> IO AppEvent - deleteAdrBook config a = do - pool <- runNoLoggingT $ initPool $ c_dbPath config - res <- liftIO $ deleteAdrsFromAB pool a - return $ ShowMessage "Address Book entry deleted!!" - -- | - -- | Address Book -> save new entry into database - -- | - updAddrBookDescrip :: Config -> T.Text -> T.Text -> IO AppEvent - updAddrBookDescrip config d a = do - pool <- runNoLoggingT $ initPool $ c_dbPath config - res <- liftIO $ updateAdrsInAdrBook pool d a a - return $ ShowMessage "Address Book entry updated!!" -scanZebra :: - T.Text - -> T.Text - -> Int - -> ZcashNet - -> (AppEvent -> IO ()) - -> NoLoggingT IO () -scanZebra dbPath zHost zPort net sendMsg = do +scanZebra :: T.Text -> T.Text -> Int -> (AppEvent -> IO ()) -> IO () +scanZebra dbPath zHost zPort sendMsg = do + _ <- liftIO $ initDb dbPath 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 + pool <- runNoLoggingT $ initPool dbPath + b <- liftIO $ getMinBirthdayHeight pool + dbBlock <- runNoLoggingT $ getMaxBlock pool + let sb = max dbBlock b + confUp <- try $ updateConfs zHost zPort pool :: IO (Either IOError ()) + case confUp of + Left _e0 -> sendMsg (ShowError "Failed to update unconfirmed transactions") + Right _ -> do if sb > zgb_blocks bStatus || sb < 1 - then liftIO $ sendMsg (ShowError "Invalid starting block for scan") + then 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) + mapM_ (processBlock pool step) bList + else sendMsg (SyncVal 1.0) where processBlock :: ConnectionPool -> Float -> Int -> IO () processBlock pool step bl = do @@ -1725,135 +1180,52 @@ scanZebra dbPath zHost zPort net sendMsg = do "getblock" [Data.Aeson.String $ showt bl, jsonNumber 1] case r of - Left e1 -> do - _ <- completeSync pool Failed - sendMsg (ShowError $ showt e1) + Left e1 -> 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 - forM_ res $ \case - Left e -> sendMsg $ ShowError $ T.pack (show e) - Right rawTx -> do - sendMsg $ ShowMsg "Transaction ready, sending to Zebra..." - resp <- - makeZebraCall - zHost - zPort - "sendrawtransaction" - [Data.Aeson.String $ toText rawTx] - case resp of - Left e1 -> sendMsg $ ShowError $ "Zebra error: " <> T.pack (show e1) - Right txId -> sendMsg $ ShowTxId txId - -deshieldTransaction :: - Config - -> ZcashNet - -> ZcashAccountId - -> Maybe (Entity WalletAddress) - -> Scientific - -> (AppEvent -> IO ()) - -> IO () -deshieldTransaction config znet accId addR pnote sendMsg = do - case addR of - Nothing -> sendMsg $ ShowError "No address available" - Just addr -> do - sendMsg $ ShowModal "De-shielding funds..." - let dbPath = c_dbPath config - let zHost = c_zebraHost config - let zPort = c_zebraPort config - pool <- runNoLoggingT $ initPool dbPath - bl <- getChainTip zHost zPort - let tAddrMaybe = - Transparent <$> - ((decodeTransparentAddress . - E.encodeUtf8 . encodeTransparentReceiver znet) =<< - (t_rec =<< - (isValidUnifiedAddress . - E.encodeUtf8 . getUA . walletAddressUAddress) - (entityVal addr))) - case tAddrMaybe of - Nothing -> sendMsg $ ShowError "No transparent address available" - Just tAddr -> do - res <- - runNoLoggingT $ - deshieldNotes - pool + r2 <- + liftIO $ + makeZebraCall zHost zPort - znet - accId - bl - (ProposedNote (ValidAddressAPI tAddr) pnote Nothing) - case res of - Left e -> sendMsg $ ShowError $ T.pack (show e) - Right rawTx -> do - sendMsg $ ShowModal "Transaction ready, sending to Zebra..." - resp <- - makeZebraCall - zHost - zPort - "sendrawtransaction" - [Data.Aeson.String $ toText rawTx] - case resp of - Left e1 -> sendMsg $ ShowError $ "Zebra error: " <> showt e1 - Right txId -> sendMsg $ ShowTxId txId + "getblock" + [Data.Aeson.String $ showt bl, jsonNumber 0] + case r2 of + Left e2 -> sendMsg (ShowError $ showt e2) + Right hb -> do + let blockTime = getBlockTime hb + mapM_ (runNoLoggingT . processTx zHost zPort blockTime pool) $ + bl_txs $ addTime blk blockTime + sendMsg (SyncVal step) + addTime :: BlockResponse -> Int -> BlockResponse + addTime bl t = + BlockResponse + (bl_confirmations bl) + (bl_height bl) + (fromIntegral t) + (bl_txs bl) sendTransaction :: Config -> ZcashNet -> ZcashAccountId -> Int - -> Scientific + -> Float -> T.Text -> T.Text - -> PrivacyPolicy -> (AppEvent -> IO ()) -> IO () -sendTransaction config znet accId bl amt ua memo policy sendMsg = do +sendTransaction config znet accId bl amt ua memo sendMsg = do sendMsg $ ShowModal "Preparing transaction..." - case parseAddress (E.encodeUtf8 ua) of + case parseAddress ua znet of Nothing -> sendMsg $ ShowError "Incorrect address" - Just addr -> do + Just outUA -> 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 + runFileLoggingT "zenith.log" $ + prepareTx pool zHost zPort znet accId bl amt outUA memo case res of Left e -> sendMsg $ ShowError $ T.pack $ show e Right rawTx -> do @@ -1874,9 +1246,6 @@ timeTicker sendMsg = do threadDelay $ 1000 * 1000 timeTicker sendMsg -txtWrapN :: T.Text -> Int -> T.Text -txtWrapN t n = wrapText (WrapSettings False True NoFill FillAfterFirst) n t - txtWrap :: T.Text -> T.Text txtWrap = wrapText (WrapSettings False True NoFill FillAfterFirst) 32 @@ -1899,118 +1268,131 @@ runZenithGUI config = do 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" + initDb dbFilePath + generateQRCodes config + walList <- getWallets pool $ zgb_net chainInfo + accList <- + if not (null walList) + then runNoLoggingT $ + getAccounts pool $ entityKey $ head walList + else return [] + addrList <- + if not (null accList) + then runNoLoggingT $ + getAddresses pool $ entityKey $ head accList + else return [] + txList <- + if not (null addrList) + then getUserTx pool $ entityKey $ head addrList + else return [] + qr <- + if not (null addrList) + then getQrCode pool Orchard $ entityKey $ head addrList + else return Nothing + bal <- + if not (null accList) + then getBalance pool $ entityKey $ head accList + else return 0 + unconfBal <- + if not (null accList) + then getUnconfirmedBalance pool $ entityKey $ head accList + else return 0 + let model = + AppModel + config + (zgb_net chainInfo) + walList + 0 + accList + 0 + addrList + 0 + txList + 0 + Nothing + True + bal + (if unconfBal == 0 + then Nothing + else Just unconfBal) + Orchard + qr + False + False + False + False + "" + Nothing + "" + "" + (SaveAddress $ + if not (null accList) + then Just (head accList) + else Nothing) + False + False + Nothing + Nothing + 0 + 1.0 + False + "" + 0.0 + "" + False + False + Nothing + hD + startApp model handleEvent buildUI (params hD) + Left e -> do + initDb dbFilePath + let model = + AppModel + config + TestNet + [] + 0 + [] + 0 + [] + 0 + [] + 0 + (Just $ + "Couldn't connect to Zebra on " <> + host <> ":" <> showt port <> ". Check your configuration.") + False + 314259000 + (Just 30000) + Orchard + Nothing + False + False + False + False + "" + Nothing + "" + "" + (SaveAddress Nothing) + False + False + Nothing + Nothing + 0 + 1.0 + False + "" + 0.0 + "" + False + False + Nothing + hD + startApp model handleEvent buildUI (params hD) where params hd = - [ appWindowTitle "Zenith - Zcash Full Node Wallet - 0.7.1.0-beta" + [ appWindowTitle "Zenith - Zcash Full Node Wallet" , appWindowState $ MainWindowNormal (1000, 700) , appTheme zenithTheme , appFontDef diff --git a/src/Zenith/GUI/Theme.hs b/src/Zenith/GUI/Theme.hs index 2e2cd4b..6b59ef3 100644 --- a/src/Zenith/GUI/Theme.hs +++ b/src/Zenith/GUI/Theme.hs @@ -49,9 +49,6 @@ zenithTheme = L.active . L.btnStyle . L.text ?~ baseTextStyle & - L.disabled . - L.btnStyle . L.text ?~ - baseTextStyle & L.basic . L.btnMainStyle . L.text ?~ hiliteTextStyle & diff --git a/src/Zenith/RPC.hs b/src/Zenith/RPC.hs deleted file mode 100644 index 6dbf72f..0000000 --- a/src/Zenith/RPC.hs +++ /dev/null @@ -1,943 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE DerivingStrategies #-} - -module Zenith.RPC where - -import Control.Concurrent (forkIO) -import Control.Exception (try) -import Control.Monad (unless, when) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Logger (runFileLoggingT, runNoLoggingT, runStderrLoggingT) -import Data.Aeson -import qualified Data.HexString as H -import Data.Int -import Data.Scientific (floatingOrInteger) -import qualified Data.Text as T -import qualified Data.Text.Encoding as E -import Data.Time.Clock (getCurrentTime) -import qualified Data.UUID as U -import Data.UUID.V4 (nextRandom) -import qualified Data.Vector as V -import Database.Esqueleto.Experimental - ( ConnectionPool - , entityKey - , entityVal - , fromSqlKey - , toSqlKey - ) -import Servant -import Text.Read (readMaybe) -import ZcashHaskell.Keys (generateWalletSeedPhrase) -import ZcashHaskell.Orchard (parseAddress) -import ZcashHaskell.Types - ( BlockResponse(..) - , RpcError(..) - , Scope(..) - , ZcashNet(..) - , ZebraGetBlockChainInfo(..) - ) -import ZcashHaskell.Utils (getBlockTime, makeZebraCall) -import Zenith.Core - ( checkBlockChain - , createCustomWalletAddress - , createZcashAccount - , prepareTxV2 - , syncWallet - , updateCommitmentTrees - ) -import Zenith.DB - ( Operation(..) - , ZcashAccount(..) - , ZcashBlock(..) - , ZcashWallet(..) - , completeSync - , finalizeOperation - , findNotesByAddress - , getAccountById - , getAccounts - , getAddressById - , getAddresses - , getExternalAddresses - , getLastSyncBlock - , getMaxAccount - , getMaxAddress - , getMaxBlock - , getMinBirthdayHeight - , getOperation - , getPoolBalance - , getUnconfPoolBalance - , getWalletNotes - , getWallets - , initPool - , isSyncing - , rewindWalletData - , saveAccount - , saveAddress - , saveBlock - , saveOperation - , saveWallet - , startSync - , toZcashAccountAPI - , toZcashAddressAPI - , toZcashWalletAPI - , walletExists - ) -import Zenith.Scanner (checkIntegrity, processTx, updateConfs) -import Zenith.Types - ( AccountBalance(..) - , Config(..) - , HexStringDB(..) - , PhraseDB(..) - , PrivacyPolicy(..) - , ProposedNote(..) - , ZcashAccountAPI(..) - , ZcashAddressAPI(..) - , ZcashNetDB(..) - , ZcashNoteAPI(..) - , ZcashWalletAPI(..) - , ZenithStatus(..) - , ZenithUuid(..) - ) -import Zenith.Utils (jsonNumber) - -data ZenithMethod - = GetInfo - | ListWallets - | ListAccounts - | ListAddresses - | ListReceived - | GetBalance - | GetNewWallet - | GetNewAccount - | GetNewAddress - | GetOperationStatus - | SendMany - | UnknownMethod - deriving (Eq, Prelude.Show) - -instance ToJSON ZenithMethod where - toJSON GetInfo = Data.Aeson.String "getinfo" - toJSON ListWallets = Data.Aeson.String "listwallets" - toJSON ListAccounts = Data.Aeson.String "listaccounts" - toJSON ListAddresses = Data.Aeson.String "listaddresses" - toJSON ListReceived = Data.Aeson.String "listreceived" - toJSON GetBalance = Data.Aeson.String "getbalance" - toJSON GetNewWallet = Data.Aeson.String "getnewwallet" - toJSON GetNewAccount = Data.Aeson.String "getnewaccount" - toJSON GetNewAddress = Data.Aeson.String "getnewaddress" - toJSON GetOperationStatus = Data.Aeson.String "getoperationstatus" - toJSON SendMany = Data.Aeson.String "sendmany" - toJSON UnknownMethod = Data.Aeson.Null - -instance FromJSON ZenithMethod where - parseJSON = - withText "ZenithMethod" $ \case - "getinfo" -> pure GetInfo - "listwallets" -> pure ListWallets - "listaccounts" -> pure ListAccounts - "listaddresses" -> pure ListAddresses - "listreceived" -> pure ListReceived - "getbalance" -> pure GetBalance - "getnewwallet" -> pure GetNewWallet - "getnewaccount" -> pure GetNewAccount - "getnewaddress" -> pure GetNewAddress - "getoperationstatus" -> pure GetOperationStatus - "sendmany" -> pure SendMany - _ -> pure UnknownMethod - -data ZenithParams - = BlankParams - | BadParams - | AccountsParams !Int - | AddressesParams !Int - | NotesParams !T.Text - | BalanceParams !Int64 - | NameParams !T.Text - | NameIdParams !T.Text !Int - | NewAddrParams !Int !T.Text !Bool !Bool - | OpParams !ZenithUuid - | SendParams !Int ![ProposedNote] !PrivacyPolicy - | TestParams !T.Text - deriving (Eq, Prelude.Show) - -instance ToJSON ZenithParams where - toJSON BlankParams = Data.Aeson.Array V.empty - toJSON BadParams = Data.Aeson.Null - toJSON (AccountsParams n) = Data.Aeson.Array $ V.fromList [jsonNumber n] - toJSON (AddressesParams n) = Data.Aeson.Array $ V.fromList [jsonNumber n] - toJSON (TestParams t) = Data.Aeson.Array $ V.fromList [Data.Aeson.String t] - toJSON (NotesParams t) = Data.Aeson.Array $ V.fromList [Data.Aeson.String t] - toJSON (NameParams t) = Data.Aeson.Array $ V.fromList [Data.Aeson.String t] - toJSON (NameIdParams t i) = - Data.Aeson.Array $ V.fromList [Data.Aeson.String t, jsonNumber i] - toJSON (BalanceParams n) = - Data.Aeson.Array $ V.fromList [jsonNumber $ fromIntegral n] - toJSON (NewAddrParams a n s t) = - Data.Aeson.Array $ - V.fromList $ - [jsonNumber a, Data.Aeson.String n] <> - [Data.Aeson.String "ExcludeSapling" | s] <> - [Data.Aeson.String "ExcludeTransparent" | t] - toJSON (OpParams i) = - Data.Aeson.Array $ V.fromList [Data.Aeson.String $ U.toText $ getUuid i] - toJSON (SendParams i ns p) = - Data.Aeson.Array $ V.fromList [jsonNumber i, toJSON ns, toJSON p] - -data ZenithResponse - = InfoResponse !T.Text !ZenithInfo - | WalletListResponse !T.Text ![ZcashWalletAPI] - | AccountListResponse !T.Text ![ZcashAccountAPI] - | AddressListResponse !T.Text ![ZcashAddressAPI] - | NoteListResponse !T.Text ![ZcashNoteAPI] - | BalanceResponse !T.Text !AccountBalance !AccountBalance - | NewItemResponse !T.Text !Int64 - | NewAddrResponse !T.Text !ZcashAddressAPI - | OpResponse !T.Text !Operation - | SendResponse !T.Text !U.UUID - | ErrorResponse !T.Text !Double !T.Text - deriving (Eq, Prelude.Show) - -instance ToJSON ZenithResponse where - toJSON (InfoResponse t i) = packRpcResponse t i - toJSON (WalletListResponse i w) = packRpcResponse i w - toJSON (AccountListResponse i a) = packRpcResponse i a - toJSON (AddressListResponse i a) = packRpcResponse i a - toJSON (NoteListResponse i n) = packRpcResponse i n - toJSON (ErrorResponse i c m) = - object - [ "jsonrpc" .= ("2.0" :: String) - , "id" .= i - , "error" .= object ["code" .= c, "message" .= m] - ] - toJSON (BalanceResponse i c u) = - packRpcResponse i $ object ["confirmed" .= c, "unconfirmed" .= u] - toJSON (NewItemResponse i ix) = packRpcResponse i ix - toJSON (NewAddrResponse i a) = packRpcResponse i a - toJSON (OpResponse i u) = packRpcResponse i u - toJSON (SendResponse i o) = packRpcResponse i o - -instance FromJSON ZenithResponse where - parseJSON = - withObject "ZenithResponse" $ \obj -> do - jr <- obj .: "jsonrpc" - i <- obj .: "id" - e <- obj .:? "error" - r <- obj .:? "result" - if jr /= ("2.0" :: String) - then fail "Malformed JSON" - else do - case e of - Nothing -> do - case r of - Nothing -> fail "Malformed JSON" - Just r1 -> - case r1 of - Object k -> do - v <- k .:? "version" - v5 <- k .:? "unconfirmed" - v6 <- k .:? "ua" - v7 <- k .:? "uuid" - case (v :: Maybe String) of - Just _v' -> do - k1 <- parseJSON r1 - pure $ InfoResponse i k1 - Nothing -> - case (v5 :: Maybe AccountBalance) of - Just _v5' -> do - k6 <- parseJSON r1 - j1 <- k6 .: "confirmed" - j2 <- k6 .: "unconfirmed" - pure $ BalanceResponse i j1 j2 - Nothing -> - case (v6 :: Maybe String) of - Just _v6' -> do - k7 <- parseJSON r1 - pure $ NewAddrResponse i k7 - Nothing -> - case (v7 :: Maybe U.UUID) of - Just _v7' -> do - k8 <- parseJSON r1 - pure $ OpResponse i k8 - Nothing -> fail "Unknown object" - Array n -> do - if V.null n - then fail "Malformed JSON" - else do - case V.head n of - Object n' -> do - v1 <- n' .:? "lastSync" - v2 <- n' .:? "wallet" - v3 <- n' .:? "ua" - v4 <- n' .:? "amountZats" - case (v1 :: Maybe Int) of - Just _v1' -> do - k2 <- parseJSON r1 - pure $ WalletListResponse i k2 - Nothing -> - case (v2 :: Maybe Int) of - Just _v2' -> do - k3 <- parseJSON r1 - pure $ AccountListResponse i k3 - Nothing -> - case (v3 :: Maybe String) of - Just _v3' -> do - k4 <- parseJSON r1 - pure $ AddressListResponse i k4 - Nothing -> - case (v4 :: Maybe Int) of - Just _v4' -> do - k5 <- parseJSON r1 - pure $ NoteListResponse i k5 - Nothing -> fail "Unknown object" - _anyOther -> fail "Malformed JSON" - Number k -> do - case floatingOrInteger k of - Left _e -> fail "Unknown value" - Right k' -> pure $ NewItemResponse i k' - String s -> do - case U.fromText s of - Nothing -> fail "Unknown value" - Just u -> pure $ SendResponse i u - _anyOther -> fail "Malformed JSON" - Just e1 -> pure $ ErrorResponse i (ecode e1) (emessage e1) - -data ZenithInfo = ZenithInfo - { zi_version :: !T.Text - , zi_network :: !ZcashNet - , zi_zebra :: !T.Text - } deriving (Eq, Prelude.Show) - -instance ToJSON ZenithInfo where - toJSON (ZenithInfo v n z) = - object ["version" .= v, "network" .= n, "zebraVersion" .= z] - -instance FromJSON ZenithInfo where - parseJSON = - withObject "ZenithInfo" $ \obj -> do - v <- obj .: "version" - n <- obj .: "network" - z <- obj .: "zebraVersion" - pure $ ZenithInfo v n z - --- | A type to model Zenith RPC calls -data RpcCall = RpcCall - { jsonrpc :: !T.Text - , callId :: !T.Text - , method :: !ZenithMethod - , parameters :: !ZenithParams - } deriving (Eq, Prelude.Show) - -instance ToJSON RpcCall where - toJSON (RpcCall jr i m p) = - object ["jsonrpc" .= jr, "id" .= i, "method" .= m, "params" .= p] - -instance FromJSON RpcCall where - parseJSON = - withObject "RpcCall" $ \obj -> do - v <- obj .: "jsonrpc" - i <- obj .: "id" - m <- obj .: "method" - case m of - UnknownMethod -> pure $ RpcCall v i UnknownMethod BlankParams - ListWallets -> do - p <- obj .: "params" - if null (p :: [Value]) - then pure $ RpcCall v i ListWallets BlankParams - else pure $ RpcCall v i ListWallets BadParams - GetInfo -> do - p <- obj .: "params" - if null (p :: [Value]) - then pure $ RpcCall v i GetInfo BlankParams - else pure $ RpcCall v i GetInfo BadParams - ListAccounts -> do - p <- obj .: "params" - case p of - Array a -> - if V.length a == 1 - then do - w <- parseJSON $ V.head a - pure $ RpcCall v i ListAccounts (AccountsParams w) - else pure $ RpcCall v i ListAccounts BadParams - _anyOther -> pure $ RpcCall v i ListAccounts BadParams - ListAddresses -> do - p <- obj .: "params" - case p of - Array a -> - if V.length a == 1 - then do - x <- parseJSON $ V.head a - pure $ RpcCall v i ListAddresses (AddressesParams x) - else pure $ RpcCall v i ListAddresses BadParams - _anyOther -> pure $ RpcCall v i ListAddresses BadParams - ListReceived -> do - p <- obj .: "params" - case p of - Array a -> - if V.length a == 1 - then do - x <- parseJSON $ V.head a - pure $ RpcCall v i ListReceived (NotesParams x) - else pure $ RpcCall v i ListReceived BadParams - _anyOther -> pure $ RpcCall v i ListReceived BadParams - GetBalance -> do - p <- obj .: "params" - case p of - Array a -> - if V.length a == 1 - then do - x <- parseJSON $ V.head a - pure $ RpcCall v i GetBalance (BalanceParams x) - else pure $ RpcCall v i GetBalance BadParams - _anyOther -> pure $ RpcCall v i GetBalance BadParams - GetNewWallet -> do - p <- obj .: "params" - case p of - Array a -> - if V.length a == 1 - then do - x <- parseJSON $ V.head a - pure $ RpcCall v i GetNewWallet (NameParams x) - else pure $ RpcCall v i GetNewWallet BadParams - _anyOther -> pure $ RpcCall v i GetNewWallet BadParams - GetNewAccount -> do - p <- obj .: "params" - case p of - Array a -> - if V.length a == 2 - then do - x <- parseJSON $ a V.! 0 - y <- parseJSON $ a V.! 1 - pure $ RpcCall v i GetNewAccount (NameIdParams x y) - else pure $ RpcCall v i GetNewAccount BadParams - _anyOther -> pure $ RpcCall v i GetNewAccount BadParams - GetNewAddress -> do - p <- obj .: "params" - case p of - Array a -> - if V.length a >= 2 - then do - x <- parseJSON $ a V.! 0 - y <- parseJSON $ a V.! 1 - (sap, tr) <- - case a V.!? 2 of - Nothing -> return (False, False) - Just s -> do - s' <- parseJSON s - case s' of - ("ExcludeSapling" :: String) -> do - case a V.!? 3 of - Nothing -> return (True, False) - Just t -> do - t' <- parseJSON t - return - (True, t' == ("ExcludeTransparent" :: String)) - ("ExcludeTransparent" :: String) -> do - case a V.!? 3 of - Nothing -> return (False, True) - Just t -> do - t' <- parseJSON t - return - (t' == ("ExcludeSapling" :: String), True) - _anyOther -> return (False, False) - pure $ RpcCall v i GetNewAddress (NewAddrParams x y sap tr) - else pure $ RpcCall v i GetNewAddress BadParams - _anyOther -> pure $ RpcCall v i GetNewAddress BadParams - GetOperationStatus -> do - p <- obj .: "params" - case p of - Array a -> - if V.length a == 1 - then do - x <- parseJSON $ a V.! 0 - case U.fromText x of - Just u -> do - pure $ - RpcCall v i GetOperationStatus (OpParams $ ZenithUuid u) - Nothing -> pure $ RpcCall v i GetOperationStatus BadParams - else pure $ RpcCall v i GetOperationStatus BadParams - _anyOther -> pure $ RpcCall v i GetOperationStatus BadParams - SendMany -> do - p <- obj .: "params" - case p of - Array a -> - if V.length a >= 2 - then do - acc <- parseJSON $ a V.! 0 - x <- parseJSON $ a V.! 1 - case x of - String _ -> do - x' <- parseJSON $ a V.! 1 - y <- parseJSON $ a V.! 2 - if not (null y) - then pure $ RpcCall v i SendMany (SendParams acc y x') - else pure $ RpcCall v i SendMany BadParams - Array _ -> do - x' <- parseJSON $ a V.! 1 - if not (null x') - then pure $ - RpcCall v i SendMany (SendParams acc x' Full) - else pure $ RpcCall v i SendMany BadParams - _anyOther -> pure $ RpcCall v i SendMany BadParams - else pure $ RpcCall v i SendMany BadParams - _anyOther -> pure $ RpcCall v i SendMany BadParams - -type ZenithRPC - = "status" :> Get '[ JSON] Value :<|> BasicAuth "zenith-realm" Bool :> ReqBody - '[ JSON] - RpcCall :> Post '[ JSON] ZenithResponse - -data State = State - { w_network :: !ZcashNet - , w_host :: !T.Text - , w_port :: !Int - , w_dbPath :: !T.Text - , w_build :: !T.Text - , w_startBlock :: !Int - } - -zenithServer :: State -> Server ZenithRPC -zenithServer state = getinfo :<|> handleRPC - where - getinfo :: Handler Value - getinfo = - return $ - object - [ "version" .= ("0.7.0.0-beta" :: String) - , "network" .= ("testnet" :: String) - ] - handleRPC :: Bool -> RpcCall -> Handler ZenithResponse - handleRPC isAuth req = - case method req of - UnknownMethod -> - return $ ErrorResponse (callId req) (-32601) "Method not found" - ListWallets -> - case parameters req of - BlankParams -> do - pool <- liftIO $ runNoLoggingT $ initPool $ w_dbPath state - walList <- liftIO $ getWallets pool $ w_network state - if not (null walList) - then return $ - WalletListResponse - (callId req) - (map toZcashWalletAPI walList) - else return $ - ErrorResponse - (callId req) - (-32001) - "No wallets available. Please create one first" - _anyOther -> - return $ ErrorResponse (callId req) (-32602) "Invalid params" - ListAccounts -> - case parameters req of - AccountsParams w -> do - let dbPath = w_dbPath state - pool <- liftIO $ runNoLoggingT $ initPool dbPath - wl <- liftIO $ walletExists pool w - case wl of - Just wl' -> do - accList <- - liftIO $ runNoLoggingT $ getAccounts pool (entityKey wl') - if not (null accList) - then return $ - AccountListResponse - (callId req) - (map toZcashAccountAPI accList) - else return $ - ErrorResponse - (callId req) - (-32002) - "No accounts available for this wallet. Please create one first" - Nothing -> - return $ - ErrorResponse (callId req) (-32008) "Wallet does not exist." - _anyOther -> - return $ ErrorResponse (callId req) (-32602) "Invalid params" - ListAddresses -> - case parameters req of - AddressesParams a -> do - let dbPath = w_dbPath state - pool <- liftIO $ runNoLoggingT $ initPool dbPath - addrList <- - liftIO $ - runNoLoggingT $ getAddresses pool (toSqlKey $ fromIntegral a) - if not (null addrList) - then return $ - AddressListResponse - (callId req) - (map toZcashAddressAPI addrList) - else return $ - ErrorResponse - (callId req) - (-32003) - "No addresses available for this account. Please create one first" - _anyOther -> - return $ ErrorResponse (callId req) (-32602) "Invalid params" - GetInfo -> - case parameters req of - BlankParams -> - return $ - InfoResponse - (callId req) - (ZenithInfo "0.7.0.0-beta" (w_network state) (w_build state)) - _anyOtherParams -> - return $ ErrorResponse (callId req) (-32602) "Invalid params" - ListReceived -> - case parameters req of - NotesParams x -> do - case (readMaybe (T.unpack x) :: Maybe Int64) of - Just x' -> do - let dbPath = w_dbPath state - pool <- liftIO $ runNoLoggingT $ initPool dbPath - a <- liftIO $ getAddressById pool $ toSqlKey x' - case a of - Just a' -> do - nList <- liftIO $ getWalletNotes pool a' - return $ NoteListResponse (callId req) nList - Nothing -> - return $ - ErrorResponse - (callId req) - (-32004) - "Address does not belong to the wallet" - Nothing -> - case parseAddress (E.encodeUtf8 x) of - Nothing -> - return $ - ErrorResponse - (callId req) - (-32005) - "Unable to parse address" - Just x' -> do - let dbPath = w_dbPath state - pool <- liftIO $ runNoLoggingT $ initPool dbPath - addrs <- liftIO $ getExternalAddresses pool - nList <- - liftIO $ - concat <$> mapM (findNotesByAddress pool x') addrs - return $ NoteListResponse (callId req) nList - _anyOtherParams -> - return $ ErrorResponse (callId req) (-32602) "Invalid params" - GetBalance -> - case parameters req of - BalanceParams i -> do - let dbPath = w_dbPath state - pool <- liftIO $ runNoLoggingT $ initPool dbPath - acc <- liftIO $ getAccountById pool $ toSqlKey i - case acc of - Just acc' -> do - c <- liftIO $ getPoolBalance pool $ entityKey acc' - u <- liftIO $ getUnconfPoolBalance pool $ entityKey acc' - return $ BalanceResponse (callId req) c u - Nothing -> - return $ - ErrorResponse (callId req) (-32006) "Account does not exist." - _anyOtherParams -> - return $ ErrorResponse (callId req) (-32602) "Invalid params" - GetNewWallet -> - case parameters req of - NameParams t -> do - let dbPath = w_dbPath state - pool <- liftIO $ runNoLoggingT $ initPool dbPath - syncChk <- liftIO $ isSyncing pool - if syncChk - then return $ - ErrorResponse - (callId req) - (-32012) - "The Zenith server is syncing, please try again later." - else do - sP <- liftIO generateWalletSeedPhrase - r <- - liftIO $ - saveWallet pool $ - ZcashWallet - t - (ZcashNetDB $ w_network state) - (PhraseDB sP) - (w_startBlock state) - 0 - case r of - Nothing -> - return $ - ErrorResponse - (callId req) - (-32007) - "Entity with that name already exists." - Just r' -> - return $ - NewItemResponse (callId req) $ fromSqlKey $ entityKey r' - _anyOtherParams -> - return $ ErrorResponse (callId req) (-32602) "Invalid params" - GetNewAccount -> - case parameters req of - NameIdParams t i -> do - let dbPath = w_dbPath state - pool <- liftIO $ runNoLoggingT $ initPool dbPath - syncChk <- liftIO $ isSyncing pool - if syncChk - then return $ - ErrorResponse - (callId req) - (-32012) - "The Zenith server is syncing, please try again later." - else do - w <- liftIO $ walletExists pool i - case w of - Just w' -> do - aIdx <- liftIO $ getMaxAccount pool $ entityKey w' - nAcc <- - liftIO - (try $ createZcashAccount t (aIdx + 1) w' :: IO - (Either IOError ZcashAccount)) - case nAcc of - Left e -> - return $ - ErrorResponse (callId req) (-32010) $ T.pack $ show e - Right nAcc' -> do - r <- liftIO $ saveAccount pool nAcc' - case r of - Nothing -> - return $ - ErrorResponse - (callId req) - (-32007) - "Entity with that name already exists." - Just x -> - return $ - NewItemResponse (callId req) $ - fromSqlKey $ entityKey x - Nothing -> - return $ - ErrorResponse - (callId req) - (-32008) - "Wallet does not exist." - _anyOtherParams -> - return $ ErrorResponse (callId req) (-32602) "Invalid params" - GetNewAddress -> - case parameters req of - NewAddrParams i n s t -> do - let dbPath = w_dbPath state - let net = w_network state - pool <- liftIO $ runNoLoggingT $ initPool dbPath - syncChk <- liftIO $ isSyncing pool - if syncChk - then return $ - ErrorResponse - (callId req) - (-32012) - "The Zenith server is syncing, please try again later." - else do - acc <- - liftIO $ getAccountById pool $ toSqlKey $ fromIntegral i - case acc of - Just acc' -> do - maxAddr <- - liftIO $ getMaxAddress pool (entityKey acc') External - newAddr <- - liftIO $ - createCustomWalletAddress - n - (maxAddr + 1) - net - External - acc' - s - t - dbAddr <- liftIO $ saveAddress pool newAddr - case dbAddr of - Just nAddr -> do - return $ - NewAddrResponse - (callId req) - (toZcashAddressAPI nAddr) - Nothing -> - return $ - ErrorResponse - (callId req) - (-32007) - "Entity with that name already exists." - Nothing -> - return $ - ErrorResponse - (callId req) - (-32006) - "Account does not exist." - _anyOtherParams -> - return $ ErrorResponse (callId req) (-32602) "Invalid params" - GetOperationStatus -> - case parameters req of - OpParams u -> do - let dbPath = w_dbPath state - pool <- liftIO $ runNoLoggingT $ initPool dbPath - op <- liftIO $ getOperation pool $ getUuid u - case op of - Just o -> do - return $ OpResponse (callId req) $ entityVal o - Nothing -> - return $ - ErrorResponse (callId req) (-32009) "Operation ID not found" - _anyOtherParams -> - return $ ErrorResponse (callId req) (-32602) "Invalid params" - SendMany -> - case parameters req of - SendParams a ns p -> do - let dbPath = w_dbPath state - let zHost = w_host state - let zPort = w_port state - let znet = w_network state - pool <- liftIO $ runNoLoggingT $ initPool dbPath - syncChk <- liftIO $ isSyncing pool - if syncChk - then return $ - ErrorResponse - (callId req) - (-32012) - "The Zenith server is syncing, please try again later." - else do - opid <- liftIO nextRandom - startTime <- liftIO getCurrentTime - opkey <- - liftIO $ - saveOperation pool $ - Operation - (ZenithUuid opid) - startTime - Nothing - Processing - Nothing - case opkey of - Nothing -> - return $ - ErrorResponse (callId req) (-32010) "Internal Error" - Just opkey' -> do - acc <- - liftIO $ getAccountById pool $ toSqlKey $ fromIntegral a - case acc of - Just acc' -> do - bl <- - liftIO $ - getLastSyncBlock - pool - (zcashAccountWalletId $ entityVal acc') - _ <- - liftIO $ - forkIO $ do - res <- - liftIO $ - runNoLoggingT $ - prepareTxV2 - pool - zHost - zPort - znet - (entityKey acc') - bl - ns - p - case res of - Left e -> - finalizeOperation pool opkey' Failed $ - T.pack $ show e - Right rawTx -> do - zebraRes <- - makeZebraCall - zHost - zPort - "sendrawtransaction" - [Data.Aeson.String $ H.toText rawTx] - case zebraRes of - Left e1 -> - finalizeOperation pool opkey' Failed $ - T.pack $ show e1 - Right txId -> - finalizeOperation pool opkey' Successful $ - "Tx ID: " <> H.toText txId - return $ SendResponse (callId req) opid - Nothing -> - return $ - ErrorResponse - (callId req) - (-32006) - "Account does not exist." - _anyOtherParams -> - return $ ErrorResponse (callId req) (-32602) "Invalid params" - -authenticate :: Config -> BasicAuthCheck Bool -authenticate config = BasicAuthCheck check - where - check (BasicAuthData username password) = - if username == c_zenithUser config && password == c_zenithPwd config - then return $ Authorized True - else return Unauthorized - -packRpcResponse :: ToJSON a => T.Text -> a -> Value -packRpcResponse i x = - object ["jsonrpc" .= ("2.0" :: String), "id" .= i, "result" .= x] - -scanZebra :: T.Text -> T.Text -> Int -> ZcashNet -> IO () -scanZebra dbPath zHost zPort net = do - bStatus <- checkBlockChain zHost zPort - pool <- runNoLoggingT $ initPool dbPath - b <- getMinBirthdayHeight pool $ ZcashNetDB net - dbBlock <- getMaxBlock pool $ ZcashNetDB net - chkBlock <- checkIntegrity dbPath zHost zPort net dbBlock 1 - syncChk <- isSyncing pool - unless syncChk $ do - let sb = - if chkBlock == dbBlock - then max dbBlock b - else max chkBlock b - unless (chkBlock == dbBlock || chkBlock == 1) $ - runNoLoggingT $ rewindWalletData pool sb $ ZcashNetDB net - unless (sb > zgb_blocks bStatus || sb < 1) $ do - let bList = [(sb + 1) .. (zgb_blocks bStatus)] - unless (null bList) $ do - _ <- startSync pool - mapM_ (processBlock pool) bList - confUp <- try $ updateConfs zHost zPort pool :: IO (Either IOError ()) - case confUp of - Left _e0 -> do - _ <- completeSync pool Failed - return () - Right _ -> do - wals <- getWallets pool net - _ <- - runNoLoggingT $ - updateCommitmentTrees pool zHost zPort $ ZcashNetDB net - runNoLoggingT $ - mapM_ - (syncWallet (Config dbPath zHost zPort "user" "pwd" 8080)) - wals - _ <- completeSync pool Successful - return () - where - processBlock :: ConnectionPool -> Int -> IO () - processBlock pool bl = do - r <- - makeZebraCall - zHost - zPort - "getblock" - [Data.Aeson.String $ T.pack (show bl), jsonNumber 1] - case r of - Left _ -> completeSync pool Failed - Right blk -> do - 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 8bef9f6..09f7ccc 100644 --- a/src/Zenith/Scanner.hs +++ b/src/Zenith/Scanner.hs @@ -2,28 +2,29 @@ module Zenith.Scanner where -import Control.Concurrent.Async (concurrently_, withAsync) import Control.Exception (throwIO, try) -import Control.Monad (when) +import qualified Control.Monad.Catch as CM (try) import Control.Monad.IO.Class (liftIO) import Control.Monad.Logger - ( NoLoggingT + ( LoggingT + , 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 @@ -31,85 +32,59 @@ import ZcashHaskell.Types , fromRawTBundle ) import ZcashHaskell.Utils (getBlockTime, makeZebraCall, readZebraTransaction) -import Zenith.Core (checkBlockChain, syncWallet, updateCommitmentTrees) +import Zenith.Core (checkBlockChain) import Zenith.DB - ( ZcashBlock(..) - , ZcashBlockId - , clearWalletData - , clearWalletTransactions - , completeSync - , getBlock - , getMaxBlock - , getMinBirthdayHeight + ( getMaxBlock , 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 -rescanZebra :: - T.Text -- ^ Host +scanZebra :: + Int -- ^ Starting block + -> T.Text -- ^ Host -> Int -- ^ Port -> T.Text -- ^ Path to database file - -> IO () -rescanZebra host port dbFilePath = do + -> NoLoggingT IO () +scanZebra b host port dbFilePath = do + _ <- liftIO $ initDb dbFilePath + startTime <- liftIO getCurrentTime + logInfoN $ "Started sync: " <> T.pack (show startTime) bc <- - try $ checkBlockChain host port :: IO + liftIO $ try $ checkBlockChain host port :: NoLoggingT + IO (Either IOError ZebraGetBlockChainInfo) case bc of - Left e -> print e + Left e -> logErrorN $ T.pack (show e) Right bStatus -> do - 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 dbInfo = + mkSqliteConnectionInfo dbFilePath & extraPragmas .~ + ["read_uncommited = true"] + pool <- createSqlitePoolFromInfo dbInfo 5 + dbBlock <- getMaxBlock pool let sb = max dbBlock b if sb > zgb_blocks bStatus || sb < 1 then liftIO $ throwIO $ userError "Invalid starting block for scan" else do - 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" + 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" -- | Function to process a raw block and extract the transaction information processBlock :: @@ -117,10 +92,9 @@ processBlock :: -> Int -- ^ Port for `zebrad` -> ConnectionPool -- ^ DB file path -> ProgressBar -- ^ Progress bar - -> ZcashNetDB -- ^ the network -> Int -- ^ The block number to process - -> IO () -processBlock host port pool pg net b = do + -> NoLoggingT IO () +processBlock host port pool pg b = do r <- liftIO $ makeZebraCall @@ -129,29 +103,39 @@ processBlock host port pool pg net b = do "getblock" [Data.Aeson.String $ T.pack $ show b, jsonNumber 1] case r of - Left e -> do - _ <- completeSync pool Failed - liftIO $ throwIO $ userError e + Left e -> liftIO $ throwIO $ userError e Right blk -> do - 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 + 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) -- | Function to process a raw transaction processTx :: T.Text -- ^ Host name for `zebrad` -> Int -- ^ Port for `zebrad` - -> ZcashBlockId -- ^ Block ID + -> Int -- ^ Block time -> ConnectionPool -- ^ DB file path -> HexString -- ^ transaction id - -> IO () + -> NoLoggingT IO () processTx host port bt pool t = do r <- liftIO $ @@ -161,15 +145,12 @@ processTx host port bt pool t = do "getrawtransaction" [Data.Aeson.String $ toText t, jsonNumber 1] case r of - Left e -> do - _ <- completeSync pool Failed - liftIO $ throwIO $ userError e + Left e -> liftIO $ throwIO $ userError e Right rawTx -> do case readZebraTransaction (ztr_hex rawTx) of Nothing -> return () Just rzt -> do _ <- - runNoLoggingT $ saveTransaction pool bt $ Transaction t @@ -203,59 +184,3 @@ updateConfs host port pool = do Left e -> throwIO $ userError e Right blk -> do saveConfs pool b $ fromInteger $ bl_confirmations blk - -clearSync :: Config -> IO () -clearSync config = do - let zHost = c_zebraHost config - let zPort = c_zebraPort config - let dbPath = c_dbPath config - pool <- runNoLoggingT $ initPool dbPath - bc <- - try $ checkBlockChain zHost zPort :: IO - (Either IOError ZebraGetBlockChainInfo) - case bc of - Left e1 -> throwIO e1 - Right chainInfo -> do - x <- initDb dbPath - _ <- upgradeQrTable pool - case x of - Left e2 -> throwIO $ userError e2 - Right x' -> do - when x' $ rescanZebra zHost zPort dbPath - _ <- clearWalletTransactions pool - w <- getWallets pool $ zgb_net chainInfo - liftIO $ mapM_ (updateWalletSync pool 0 . entityKey) w - w' <- liftIO $ getWallets pool $ zgb_net chainInfo - r <- runNoLoggingT $ mapM (syncWallet config) w' - liftIO $ print r - --- | Detect chain re-orgs -checkIntegrity :: - T.Text -- ^ Database path - -> T.Text -- ^ Zebra host - -> Int -- ^ Zebra port - -> ZcashNet -- ^ the network to scan - -> Int -- ^ The block to start the check - -> Int -- ^ depth - -> IO Int -checkIntegrity dbP zHost zPort znet b d = - if b < 1 - then return 1 - else do - r <- - makeZebraCall - zHost - zPort - "getblock" - [Data.Aeson.String $ T.pack $ show b, jsonNumber 1] - case r of - Left e -> throwIO $ userError e - Right blk -> do - pool <- runNoLoggingT $ initPool dbP - dbBlk <- getBlock pool b $ ZcashNetDB znet - case dbBlk of - Nothing -> return 1 - Just dbBlk' -> - if bl_hash blk == getHex (zcashBlockHash $ entityVal dbBlk') - then return b - else checkIntegrity dbP zHost zPort znet (b - 5 * d) (d + 1) diff --git a/src/Zenith/Tree.hs b/src/Zenith/Tree.hs deleted file mode 100644 index 042421b..0000000 --- a/src/Zenith/Tree.hs +++ /dev/null @@ -1,400 +0,0 @@ -{-# 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 f71b6c3..6176c17 100644 --- a/src/Zenith/Types.hs +++ b/src/Zenith/Types.hs @@ -10,37 +10,23 @@ 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 - ( ExchangeAddress(..) - , OrchardSpendingKey(..) + ( OrchardSpendingKey(..) , Phrase(..) , Rseed(..) - , SaplingAddress(..) , SaplingSpendingKey(..) , Scope(..) - , TransparentAddress(..) , TransparentSpendingKey - , ValidAddress(..) , ZcashNet(..) ) @@ -56,9 +42,6 @@ newtype ZcashNetDB = ZcashNetDB { getNet :: ZcashNet } deriving newtype (Eq, Show, Read) -instance ToJSON ZcashNetDB where - toJSON (ZcashNetDB z) = toJSON z - derivePersistField "ZcashNetDB" newtype UnifiedAddressDB = UnifiedAddressDB @@ -109,165 +92,8 @@ 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 @@ -312,6 +138,24 @@ instance FromJSON AddressSource where "mnemonic_seed" -> return MnemonicSeed _ -> fail "Not a known address source" +data ZcashPool + = Transparent + | Sprout + | Sapling + | Orchard + deriving (Show, Read, Eq, Generic, ToJSON) + +derivePersistField "ZcashPool" + +instance FromJSON ZcashPool where + parseJSON = + withText "ZcashPool" $ \case + "p2pkh" -> return Transparent + "sprout" -> return Sprout + "sapling" -> return Sapling + "orchard" -> return Orchard + _ -> fail "Not a known Zcash pool" + data ZcashAddress = ZcashAddress { source :: AddressSource , pool :: [ZcashPool] @@ -359,8 +203,7 @@ instance FromJSON AddressGroup where Nothing -> return [] Just x -> do x' <- x .:? "addresses" - return $ - maybe [] (map (ZcashAddress s1 [TransparentPool] Nothing)) x' + return $ maybe [] (map (ZcashAddress s1 [Transparent] Nothing)) x' processSapling k s2 = case k of Nothing -> return [] @@ -368,7 +211,7 @@ instance FromJSON AddressGroup where where processOneSapling sx = withObject "Sapling" $ \oS -> do oS' <- oS .: "addresses" - return $ map (ZcashAddress sx [SaplingPool] Nothing) oS' + return $ map (ZcashAddress sx [Sapling] Nothing) oS' processUnified u = case u of Nothing -> return [] diff --git a/src/Zenith/Utils.hs b/src/Zenith/Utils.hs index c3b74ee..eedf02d 100644 --- a/src/Zenith/Utils.hs +++ b/src/Zenith/Utils.hs @@ -3,38 +3,28 @@ 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 - , parseAddress - ) +import ZcashHaskell.Orchard (encodeUnifiedAddress, isValidUnifiedAddress) import ZcashHaskell.Sapling (decodeSaplingAddress, isValidShieldedAddress) import ZcashHaskell.Transparent ( decodeExchangeAddress , decodeTransparentAddress ) import ZcashHaskell.Types - ( ExchangeAddress(..) - , SaplingAddress(..) + ( SaplingAddress(..) , TransparentAddress(..) , UnifiedAddress(..) - , ValidAddress(..) , ZcashNet(..) ) -import ZcashHaskell.Utils (makeZebraCall) import Zenith.Types ( AddressGroup(..) - , PrivacyPolicy(..) , UnifiedAddressDB(..) , ZcashAddress(..) , ZcashPool(..) @@ -79,9 +69,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 TransparentPool - | sReg && chkS = Just SaplingPool - | uReg && chk = Just OrchardPool + | tReg = Just Transparent + | sReg && chkS = Just Sapling + | uReg && chk = Just Orchard | otherwise = Nothing where transparentRegex = "^t1[a-zA-Z0-9]{33}$" :: String @@ -93,13 +83,6 @@ 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 = @@ -107,18 +90,12 @@ copyAddress a = createProcess_ "toClipboard" $ shell $ "echo " ++ T.unpack (addy a) ++ " | xclip -r -selection clipboard" --- | Get current user and build zenith path -getZenithPath :: IO String -getZenithPath = do - homeDirectory <- getHomeDirectory - return (homeDirectory ++ "/Zenith/") - -- | Bound a value to the 0..1 range, used for progress reporting on UIs validBarValue :: Float -> Float validBarValue = clamp (0, 1) isRecipientValid :: T.Text -> Bool -isRecipientValid a = do +isRecipientValid a = case isValidUnifiedAddress (E.encodeUtf8 a) of Just _a1 -> True Nothing -> @@ -126,84 +103,12 @@ isRecipientValid a = do (case decodeTransparentAddress (E.encodeUtf8 a) of Just _a3 -> True Nothing -> - case decodeExchangeAddress (E.encodeUtf8 a) of + case decodeExchangeAddress 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 = +parseAddress :: T.Text -> ZcashNet -> Maybe UnifiedAddress +parseAddress a znet = case isValidUnifiedAddress (E.encodeUtf8 a) of Just a1 -> Just a1 Nothing -> @@ -215,36 +120,3 @@ parseAddressUA a znet = Just a3 -> Just $ UnifiedAddress znet Nothing Nothing (Just $ ta_receiver a3) Nothing -> Nothing - -isValidContent :: String -> Bool -isValidContent [] = False -- an empty string is invalid -isValidContent (x:xs) - | not (isAlphaNum x) = False -- string must start with an alphanumeric character - | otherwise = allValidChars xs -- process the rest of the string - where - allValidChars :: String -> Bool - allValidChars [] = True -- if we got here, string is valid - allValidChars (y:ys) - | isAlphaNum y || isSpace y = allValidChars ys -- char is valid, continue - | otherwise = False -- found an invalid character, return false - -isValidString :: T.Text -> Bool -isValidString c = do - let a = T.unpack c - isValidContent a - -padWithZero :: Int -> String -> String -padWithZero n s - | (length s) >= n = s - | otherwise = padWithZero n ("0" ++ s) - -isEmpty :: [a] -> Bool -isEmpty [] = True -isEmpty _ = False - -getChainTip :: T.Text -> Int -> IO Int -getChainTip zHost zPort = do - r <- makeZebraCall zHost zPort "getblockcount" [] - case r of - Left e1 -> pure 0 - Right i -> pure i diff --git a/src/Zenith/Zcashd.hs b/src/Zenith/Zcashd.hs index 8d402b9..bc4c2d2 100644 --- a/src/Zenith/Zcashd.hs +++ b/src/Zenith/Zcashd.hs @@ -123,10 +123,9 @@ sendTx user pwd fromAddy toAddy amount memo = do if source fromAddy /= ImportedWatchOnly then do let privacyPolicy - | valAdd == Just TransparentPool = "AllowRevealedRecipients" + | valAdd == Just Transparent = "AllowRevealedRecipients" | isNothing (account fromAddy) && - elem TransparentPool (pool fromAddy) = - "AllowRevealedSenders" + elem Transparent (pool fromAddy) = "AllowRevealedSenders" | otherwise = "AllowRevealedAmounts" let pd = case memo of @@ -302,7 +301,7 @@ sendWithUri user pwd fromAddy uri repTo = do let addType = validateAddress $ T.pack parsedAddress case addType of Nothing -> putStrLn " Invalid address" - Just TransparentPool -> do + Just Transparent -> 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 deleted file mode 100644 index 882b5e0..0000000 --- a/test/ServerSpec.hs +++ /dev/null @@ -1,754 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -import Control.Concurrent (forkIO, threadDelay) -import Control.Exception (SomeException, throwIO, try) -import Control.Monad (when) -import Control.Monad.Logger (runNoLoggingT) -import Data.Aeson -import qualified Data.ByteString as BS -import Data.Configurator -import Data.Maybe (fromJust, fromMaybe) -import qualified Data.Text as T -import qualified Data.Text.Encoding as E -import Data.Time.Clock (getCurrentTime) -import qualified Data.UUID as U -import Network.HTTP.Simple -import Network.Wai.Handler.Warp (run) -import Servant -import System.Directory -import Test.HUnit hiding (State) -import Test.Hspec -import ZcashHaskell.Orchard (isValidUnifiedAddress, parseAddress) -import ZcashHaskell.Types - ( ZcashNet(..) - , ZebraGetBlockChainInfo(..) - , ZebraGetInfo(..) - ) -import Zenith.Core (checkBlockChain, checkZebra) -import Zenith.DB (Operation(..), initDb, initPool, saveOperation) -import Zenith.RPC - ( RpcCall(..) - , State(..) - , ZenithInfo(..) - , ZenithMethod(..) - , ZenithParams(..) - , ZenithRPC(..) - , ZenithResponse(..) - , authenticate - , zenithServer - ) -import Zenith.Types - ( Config(..) - , PrivacyPolicy(..) - , ProposedNote(..) - , ValidAddressAPI(..) - , ZcashAccountAPI(..) - , ZcashAddressAPI(..) - , ZcashWalletAPI(..) - , ZenithStatus(..) - , ZenithUuid(..) - ) - -main :: IO () -main = do - config <- load ["$(HOME)/Zenith/zenith.cfg"] - let dbFilePath = "test.db" - nodeUser <- require config "nodeUser" - nodePwd <- require config "nodePwd" - zebraPort <- require config "zebraPort" - zebraHost <- require config "zebraHost" - nodePort <- require config "nodePort" - let myConfig = Config dbFilePath zebraHost zebraPort nodeUser nodePwd nodePort - hspec $ do - describe "RPC methods" $ do - beforeAll_ (startAPI myConfig) $ do - describe "getinfo" $ do - it "bad credentials" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - "baduser" - "idontknow" - GetInfo - BlankParams - res `shouldBe` Left "Invalid credentials" - it "correct credentials" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - GetInfo - BlankParams - case res of - Left e -> assertFailure e - Right r -> - r `shouldBe` - InfoResponse "zh" (ZenithInfo "0.7.0.0-beta" TestNet "v1.9.0") - describe "Wallets" $ do - describe "listwallet" $ do - it "bad credentials" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - "baduser" - "idontknow" - ListWallets - BlankParams - res `shouldBe` Left "Invalid credentials" - it "correct credentials, no wallet" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - ListWallets - BlankParams - case res of - Left e -> assertFailure e - Right r -> - r `shouldBe` - ErrorResponse - "zh" - (-32001) - "No wallets available. Please create one first" - describe "getnewwallet" $ do - it "bad credentials" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - "baduser" - "idontknow" - GetNewWallet - BlankParams - res `shouldBe` Left "Invalid credentials" - describe "correct credentials" $ do - it "no params" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - GetNewWallet - BlankParams - case res of - Left e -> assertFailure e - Right r -> - r `shouldBe` ErrorResponse "zh" (-32602) "Invalid params" - it "Valid params" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - GetNewWallet - (NameParams "Main") - case res of - Left e -> assertFailure e - Right r -> r `shouldBe` NewItemResponse "zh" 1 - it "duplicate name" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - GetNewWallet - (NameParams "Main") - case res of - Left e -> assertFailure e - Right r -> - r `shouldBe` - ErrorResponse - "zh" - (-32007) - "Entity with that name already exists." - describe "listwallet" $ do - it "wallet exists" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - ListWallets - BlankParams - case res of - Left e -> assertFailure e - Right (WalletListResponse i k) -> - zw_name (head k) `shouldBe` "Main" - Right _ -> assertFailure "Unexpected response" - describe "Accounts" $ do - describe "listaccounts" $ do - it "bad credentials" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - "baduser" - "idontknow" - ListAccounts - BlankParams - res `shouldBe` Left "Invalid credentials" - describe "correct credentials" $ do - it "invalid wallet" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - ListAccounts - (AccountsParams 17) - case res of - Left e -> assertFailure e - Right r -> - r `shouldBe` - ErrorResponse "zh" (-32008) "Wallet does not exist." - it "valid wallet, no accounts" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - ListAccounts - (AccountsParams 1) - case res of - Left e -> assertFailure e - Right r -> - r `shouldBe` - ErrorResponse - "zh" - (-32002) - "No accounts available for this wallet. Please create one first" - describe "getnewaccount" $ do - it "invalid credentials" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - "baduser" - "idontknow" - GetNewAccount - BlankParams - res `shouldBe` Left "Invalid credentials" - describe "correct credentials" $ do - it "invalid wallet" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - GetNewAccount - (NameIdParams "Personal" 17) - case res of - Left e -> assertFailure e - Right r -> - r `shouldBe` - ErrorResponse "zh" (-32008) "Wallet does not exist." - it "valid wallet" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - GetNewAccount - (NameIdParams "Personal" 1) - case res of - Left e -> assertFailure e - Right r -> r `shouldBe` NewItemResponse "zh" 1 - it "valid wallet, duplicate name" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - GetNewAccount - (NameIdParams "Personal" 1) - case res of - Left e -> assertFailure e - Right r -> - r `shouldBe` - ErrorResponse - "zh" - (-32007) - "Entity with that name already exists." - describe "listaccounts" $ do - it "valid wallet" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - ListAccounts - (AccountsParams 1) - case res of - Left e -> assertFailure e - Right r -> - r `shouldBe` - AccountListResponse "zh" [ZcashAccountAPI 1 1 "Personal"] - describe "Addresses" $ do - describe "listaddresses" $ do - it "bad credentials" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - "baduser" - "idontknow" - ListAddresses - BlankParams - res `shouldBe` Left "Invalid credentials" - it "correct credentials, no addresses" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - ListAddresses - (AddressesParams 1) - case res of - Left e -> assertFailure e - Right r -> - r `shouldBe` - ErrorResponse - "zh" - (-32003) - "No addresses available for this account. Please create one first" - describe "getnewaddress" $ do - it "bad credentials" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - "baduser" - "idontknow" - GetNewAddress - BlankParams - res `shouldBe` Left "Invalid credentials" - describe "correct credentials" $ do - it "invalid account" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - GetNewAddress - (NewAddrParams 17 "Business" False False) - case res of - Left e -> assertFailure e - Right r -> - r `shouldBe` - ErrorResponse "zh" (-32006) "Account does not exist." - it "valid account" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - GetNewAddress - (NewAddrParams 1 "Business" False False) - case res of - Left e -> assertFailure e - Right (NewAddrResponse i a) -> zd_name a `shouldBe` "Business" - Right _ -> assertFailure "unexpected response" - it "valid account, duplicate name" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - GetNewAddress - (NewAddrParams 1 "Business" False False) - case res of - Left e -> assertFailure e - Right r -> - r `shouldBe` - ErrorResponse - "zh" - (-32007) - "Entity with that name already exists." - it "valid account, no sapling" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - GetNewAddress - (NewAddrParams 1 "NoSapling" True False) - case res of - Left e -> assertFailure e - Right (NewAddrResponse i a) -> zd_legacy a `shouldBe` Nothing - Right _ -> assertFailure "unexpected response" - it "valid account, no transparent" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - GetNewAddress - (NewAddrParams 1 "NoTransparent" False True) - case res of - Left e -> assertFailure e - Right (NewAddrResponse i a) -> - zd_transparent a `shouldBe` Nothing - Right _ -> assertFailure "unexpected response" - it "valid account, orchard only" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - GetNewAddress - (NewAddrParams 1 "OrchOnly" True True) - case res of - Left e -> assertFailure e - Right (NewAddrResponse i a) -> - a `shouldSatisfy` - (\b -> - (zd_transparent b == Nothing) && (zd_legacy b == Nothing)) - Right _ -> assertFailure "unexpected response" - describe "listaddresses" $ do - it "correct credentials, addresses exist" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - ListAddresses - (AddressesParams 1) - case res of - Left e -> assertFailure e - Right (AddressListResponse i a) -> length a `shouldBe` 4 - describe "Notes" $ do - describe "listreceived" $ do - it "bad credentials" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - "baduser" - "idontknow" - ListReceived - BlankParams - res `shouldBe` Left "Invalid credentials" - describe "correct credentials" $ do - it "no parameters" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - ListReceived - BlankParams - case res of - Left e -> assertFailure e - Right (ErrorResponse i c m) -> c `shouldBe` (-32602) - it "unknown index" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - ListReceived - (NotesParams "17") - case res of - Left e -> assertFailure e - Right (ErrorResponse i c m) -> c `shouldBe` (-32004) - describe "Balance" $ do - describe "getbalance" $ do - it "bad credentials" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - "baduser" - "idontknow" - GetBalance - BlankParams - res `shouldBe` Left "Invalid credentials" - describe "correct credentials" $ do - it "no parameters" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - GetBalance - BlankParams - case res of - Left e -> assertFailure e - Right (ErrorResponse i c m) -> c `shouldBe` (-32602) - it "unknown index" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - GetBalance - (BalanceParams 17) - case res of - Left e -> assertFailure e - Right (ErrorResponse i c m) -> c `shouldBe` (-32006) - describe "Operations" $ do - describe "getoperationstatus" $ do - it "bad credentials" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - "baduser" - "idontknow" - GetOperationStatus - BlankParams - res `shouldBe` Left "Invalid credentials" - describe "correct credentials" $ do - it "invalid ID" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - GetOperationStatus - (NameParams "badId") - case res of - Left e -> assertFailure e - Right (ErrorResponse i c m) -> c `shouldBe` (-32602) - it "valid ID" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - GetOperationStatus - (OpParams - (ZenithUuid $ - fromMaybe U.nil $ - U.fromText "bd2aa95a-db51-4cc4-9fea-0f9cf79003a4")) - case res of - Left e -> assertFailure e - Right (OpResponse i o) -> - operationUuid o `shouldBe` - (ZenithUuid $ - fromMaybe U.nil $ - U.fromText "bd2aa95a-db51-4cc4-9fea-0f9cf79003a4") - Right _ -> assertFailure "unexpected response" - it "valid ID not found" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - GetOperationStatus - (OpParams - (ZenithUuid $ - fromMaybe U.nil $ - U.fromText "bd2aa95a-db51-4cc4-9fea-0f9cf79003a5")) - case res of - Left e -> assertFailure e - Right (ErrorResponse i c m) -> c `shouldBe` (-32009) - Right _ -> assertFailure "unexpected response" - describe "Send tx" $ do - describe "sendmany" $ do - it "bad credentials" $ do - res <- - makeZenithCall - "127.0.0.1" - nodePort - "baduser" - "idontknow" - SendMany - BlankParams - res `shouldBe` Left "Invalid credentials" - describe "correct credentials" $ do - it "invalid account" $ do - let uaRead = - parseAddress - "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - SendMany - (SendParams - 17 - [ ProposedNote - (ValidAddressAPI $ fromJust uaRead) - 0.005 - (Just "A cool memo") - ] - Full) - case res of - Left e -> assertFailure e - Right (ErrorResponse i c m) -> c `shouldBe` (-32006) - it "valid account, empty notes" $ do - let uaRead = - parseAddress - "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - SendMany - (SendParams 1 [] Full) - case res of - Left e -> assertFailure e - Right (ErrorResponse i c m) -> c `shouldBe` (-32602) - it "valid account, single output" $ do - let uaRead = - parseAddress - "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - SendMany - (SendParams - 1 - [ ProposedNote - (ValidAddressAPI $ fromJust uaRead) - 5.0 - (Just "A cool memo") - ] - Full) - case res of - Left e -> assertFailure e - Right (SendResponse i o) -> o `shouldNotBe` U.nil - it "valid account, multiple outputs" $ do - let uaRead = - parseAddress - "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" - let uaRead2 = - parseAddress - "ztestsapling136jp8z89v2jh6kqd5rs4dtvlxym90m43svzdwzxaplyvc5ttzppytpvx80ncllcsqzpmukxjl3y" - res <- - makeZenithCall - "127.0.0.1" - nodePort - nodeUser - nodePwd - SendMany - (SendParams - 1 - [ ProposedNote - (ValidAddressAPI $ fromJust uaRead) - 5.0 - (Just "A cool memo") - , ProposedNote - (ValidAddressAPI $ fromJust uaRead2) - 1.0 - (Just "Not so cool memo") - ] - Full) - case res of - Left e -> assertFailure e - Right (SendResponse i o) -> o `shouldNotBe` U.nil - -startAPI :: Config -> IO () -startAPI config = do - putStrLn "Starting test RPC server" - checkDbFile <- doesFileExist "test.db" - when checkDbFile $ removeFile "test.db" - let ctx = authenticate config :. EmptyContext - w <- - try $ checkZebra (c_zebraHost config) (c_zebraPort config) :: IO - (Either IOError ZebraGetInfo) - case w of - Right zebra -> do - bc <- - try $ checkBlockChain (c_zebraHost config) (c_zebraPort config) :: IO - (Either IOError ZebraGetBlockChainInfo) - case bc of - Left e1 -> throwIO e1 - Right chainInfo -> do - x <- initDb "test.db" - case x of - Left e2 -> throwIO $ userError e2 - Right x' -> do - pool <- runNoLoggingT $ initPool "test.db" - ts <- getCurrentTime - y <- - saveOperation - pool - (Operation - (ZenithUuid $ - fromMaybe U.nil $ - U.fromText "bd2aa95a-db51-4cc4-9fea-0f9cf79003a4") - ts - Nothing - Processing - Nothing) - let myState = - State - (zgb_net chainInfo) - (c_zebraHost config) - (c_zebraPort config) - "test.db" - (zgi_build zebra) - (zgb_blocks chainInfo) - forkIO $ - run (c_zenithPort config) $ - serveWithContext - (Servant.Proxy :: Servant.Proxy ZenithRPC) - ctx - (zenithServer myState) - threadDelay 1000000 - putStrLn "Test server is up!" - --- | Make a Zebra RPC call -makeZenithCall :: - T.Text -- ^ Hostname for `zebrad` - -> Int -- ^ Port for `zebrad` - -> BS.ByteString - -> BS.ByteString - -> ZenithMethod -- ^ RPC method to call - -> ZenithParams -- ^ List of parameters - -> IO (Either String ZenithResponse) -makeZenithCall host port usr pwd m params = do - let payload = RpcCall "2.0" "zh" m params - let myRequest = - setRequestBodyJSON payload $ - setRequestPort port $ - setRequestHost (E.encodeUtf8 host) $ - setRequestBasicAuth usr pwd $ setRequestMethod "POST" defaultRequest - r <- httpJSONEither myRequest - case getResponseStatusCode r of - 403 -> return $ Left "Invalid credentials" - 200 -> - case getResponseBody r of - Left e -> return $ Left $ show e - Right r' -> return $ Right r' - e -> return $ Left $ show e ++ show (getResponseBody r) diff --git a/test/Spec.hs b/test/Spec.hs index ca66599..35fb3a1 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,40 +1,19 @@ {-# LANGUAGE OverloadedStrings #-} -import Codec.Borsh import Control.Monad (when) -import Control.Monad.Logger (runFileLoggingT, runNoLoggingT) -import Data.Aeson -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS +import Control.Monad.Logger (runNoLoggingT) 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 hiding (State(..)) +import Test.HUnit import Test.Hspec -import ZcashHaskell.Orchard - ( addOrchardNodeGetRoot - , getOrchardFrontier - , getOrchardNodeValue - , getOrchardPathAnchor - , getOrchardRootTest - , getOrchardTreeAnchor - , getOrchardTreeParts - , isValidUnifiedAddress - , parseAddress - ) +import ZcashHaskell.Orchard (isValidUnifiedAddress) import ZcashHaskell.Sapling ( decodeSaplingOutputEsk , encodeSaplingAddress - , getSaplingFrontier , getSaplingNotePosition - , getSaplingPathAnchor - , getSaplingRootTest - , getSaplingTreeAnchor - , getSaplingTreeParts , getSaplingWitness , isValidShieldedAddress , updateSaplingCommitmentTree @@ -42,32 +21,20 @@ 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 () @@ -154,15 +121,68 @@ main = do let ua = "utest1mvlny48qd4x94w8vz5u2lrxx0enuquajt72yekgq24p6pjaky3czk6m7x358h7g900ex6gzvdehaekl96qnakjzw8yaasp8y0u3j5jnlfd33trduznh6k3fcn5ek9qc857fgz8ehm37etx94sj58nrkc0k5hurxnuxpcpms3j8uy2t8kt2vy6vetvsfxxdhtjq0yqulqprvh7mf2u3x" isValidUnifiedAddress ua `shouldNotBe` Nothing + describe "Function tests" $ do + describe "Sapling Decoding" $ do + let sk = + SaplingSpendingKey + "\ETX}\195.\SUB\NUL\NUL\NUL\128\NUL\203\"\229IL\CANJ*\209\EM\145\228m\172\&4\SYNNl\DC3\161\147\SO\157\238H\192\147eQ\143L\201\216\163\180\147\145\156Zs+\146>8\176`ta\161\223\SO\140\177\b;\161\SO\236\151W\148<\STX\171|\DC2\172U\195(I\140\146\214\182\137\211\228\159\128~bV\STXy{m'\224\175\221\219\180!\ENQ_\161\132\240?\255\236\"6\133\181\170t\181\139\143\207\170\211\ENQ\167a\184\163\243\246\140\158t\155\133\138X\a\241\200\140\EMT\GS~\175\249&z\250\214\231\239mi\223\206\STX\t\EM<{V~J\253FB" + let tree = + SaplingCommitmentTree $ + hexString + "01818f2bd58b1e392334d0565181cc7843ae09e3533b2a50a8f1131af657340a5c001001161f962245812ba5e1804fd0a336bc78fa4ee4441a8e0f1525ca5da1b285d35101120f45afa700b8c1854aa8b9c8fe8ed92118ef790584bfcb926078812a10c83a00000000012f4f72c03f8c937a94919a01a07f21165cc8394295291cb888ca91ed003810390107114fe4bb4cd08b47f6ae47477c182d5da9fe5c189061808c1091e9bf3b4524000001447d6b9100cddd5f80c8cf4ddee2b87eba053bd987465aec2293bd0514e68b0d015f6c95e75f4601a0a31670a7deb970fc8988c611685161d2e1629d0a1a0ebd07015f8b9205e0514fa235d75c150b87e23866b882b39786852d1ab42aab11d31a4a0117ddeb3a5f8d2f6b2d0a07f28f01ab25e03a05a9319275bb86d72fcaef6fc01501f08f39275112dd8905b854170b7f247cf2df18454d4fa94e6e4f9320cca05f24011f8322ef806eb2430dc4a7a41c1b344bea5be946efc7b4349c1c9edb14ff9d39" + let nextTree = + SaplingCommitmentTree $ + hexString + "01bd8a3f3cfc964332a2ada8c09a0da9dfc24174befb938abb086b9be5ca049e4900100000019f0d7efb00169bb2202152d3266059d208ab17d14642c3339f9075e997160657000000012f4f72c03f8c937a94919a01a07f21165cc8394295291cb888ca91ed003810390107114fe4bb4cd08b47f6ae47477c182d5da9fe5c189061808c1091e9bf3b4524000001447d6b9100cddd5f80c8cf4ddee2b87eba053bd987465aec2293bd0514e68b0d015f6c95e75f4601a0a31670a7deb970fc8988c611685161d2e1629d0a1a0ebd07015f8b9205e0514fa235d75c150b87e23866b882b39786852d1ab42aab11d31a4a0117ddeb3a5f8d2f6b2d0a07f28f01ab25e03a05a9319275bb86d72fcaef6fc01501f08f39275112dd8905b854170b7f247cf2df18454d4fa94e6e4f9320cca05f24011f8322ef806eb2430dc4a7a41c1b344bea5be946efc7b4349c1c9edb14ff9d39" + it "Sapling is decoded correctly" $ do + so <- + runSqlite "zenith.db" $ + selectList [ShieldOutputTx ==. toSqlKey 38318] [] + let cmus = map (getHex . shieldOutputCmu . entityVal) so + let pos = + getSaplingNotePosition <$> + (getSaplingWitness =<< + updateSaplingCommitmentTree tree (head cmus)) + let pos1 = getSaplingNotePosition <$> getSaplingWitness tree + let pos2 = getSaplingNotePosition <$> getSaplingWitness nextTree + case pos of + Nothing -> assertFailure "couldn't get note position" + Just p -> do + print p + print pos1 + print pos2 + let dn = + decodeSaplingOutputEsk + sk + (ShieldedOutput + (getHex $ shieldOutputCv $ entityVal $ head so) + (getHex $ shieldOutputCmu $ entityVal $ head so) + (getHex $ shieldOutputEphKey $ entityVal $ head so) + (getHex $ shieldOutputEncCipher $ entityVal $ head so) + (getHex $ shieldOutputOutCipher $ entityVal $ head so) + (getHex $ shieldOutputProof $ entityVal $ head so)) + TestNet + External + p + case dn of + Nothing -> assertFailure "couldn't decode Sap output" + Just d -> + a_nullifier d `shouldBe` + hexString + "6c5d1413c63a9a88db71c3f41dc12cd60197ee742fc75b217215e7144db48bd3" describe "Note selection for Tx" $ do it "Value less than balance" $ do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + pool <- runNoLoggingT $ initPool "zenith.db" res <- selectUnspentNotes pool (toSqlKey 1) 14000000 res `shouldNotBe` ([], [], []) it "Value greater than balance" $ do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" + pool <- runNoLoggingT $ initPool "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 = @@ -175,7 +195,7 @@ main = do (case decodeTransparentAddress (E.encodeUtf8 a) of Just _a3 -> True Nothing -> - case decodeExchangeAddress (E.encodeUtf8 a) of + case decodeExchangeAddress a of Just _a4 -> True Nothing -> False)) it "Sapling" $ do @@ -189,7 +209,7 @@ main = do (case decodeTransparentAddress (E.encodeUtf8 a) of Just _a3 -> True Nothing -> - case decodeExchangeAddress (E.encodeUtf8 a) of + case decodeExchangeAddress a of Just _a4 -> True Nothing -> False)) it "Transparent" $ do @@ -202,7 +222,7 @@ main = do (case decodeTransparentAddress (E.encodeUtf8 a) of Just _a3 -> True Nothing -> - case decodeExchangeAddress (E.encodeUtf8 a) of + case decodeExchangeAddress a of Just _a4 -> True Nothing -> False)) it "Check Sapling Address" $ do @@ -213,893 +233,21 @@ main = do a `shouldBe` Just "ztestsapling1tgjr4zppwk4ne8xy6gdq4z2gwq7dmf5jq8z2ctpn8nlmtse0a74fa5z0m8z383gmpgqz6q6duu4" - describe "Tree loading" $ do - it "Sapling tree" $ do - let tree = - SaplingCommitmentTree $ - hexString - "01b4a6049100dd1aa53fd850c388e0ed3782b039448aa43de5fd41d9e2419b375b0114abe3b473ac2dcd9ec3c62ff5cffb683f2e584d70ce4c1c118d67a8c34f1d691f00000000014278a19b3777ee0ceb48c4d469ab0a95217de56f27a4eaf9f19a90244bcff05301692acd3dd617e7cb44a17026211a31899cf27ef5960d59b8323ba105c754965800016f641fd51f68efae0cb742182483d97054bca8fcfb8036b1c165acdb0b27fc1b0000015965da8d105e2d412c7e13f920e607461c8cbb67a38b3a667898d1eaa064ba5701be82b8379a88cce7629153e0b3d1bf826782d3e0c367d615d362b479ead41d6401e1dbd43a62ac601d82de803fc3b6485182854056c6577bae231882b19184b03e000000018f624406b4ebda9ee13c062063e16f65ab5d725b80645037be7760e4ca7887730000000000000000000000000000" - case getSaplingTreeParts tree of - Nothing -> assertFailure "Failed to get tree parts" - Just t1 -> do - pool <- runNoLoggingT $ initPool "test.db" - let newTree = mkSaplingTree t1 - _ <- upsertSaplingTree pool 2000 newTree - readTree <- getSaplingTree pool - case readTree of - Nothing -> assertFailure "Couldn't retrieve tree from db" - Just (t1, x) -> t1 `shouldBe` newTree - it "Sapling tree update" $ do - let tree = - SaplingCommitmentTree $ - hexString - "01b4a6049100dd1aa53fd850c388e0ed3782b039448aa43de5fd41d9e2419b375b0114abe3b473ac2dcd9ec3c62ff5cffb683f2e584d70ce4c1c118d67a8c34f1d691f00000000014278a19b3777ee0ceb48c4d469ab0a95217de56f27a4eaf9f19a90244bcff05301692acd3dd617e7cb44a17026211a31899cf27ef5960d59b8323ba105c754965800016f641fd51f68efae0cb742182483d97054bca8fcfb8036b1c165acdb0b27fc1b0000015965da8d105e2d412c7e13f920e607461c8cbb67a38b3a667898d1eaa064ba5701be82b8379a88cce7629153e0b3d1bf826782d3e0c367d615d362b479ead41d6401e1dbd43a62ac601d82de803fc3b6485182854056c6577bae231882b19184b03e000000018f624406b4ebda9ee13c062063e16f65ab5d725b80645037be7760e4ca7887730000000000000000000000000000" - let cmu1 = - hexString - "238a75ea513eb330cee527d3fa5000cd52620f116919a33afb9ac78ee1f91c17" :: SaplingCommitment - case getSaplingTreeParts tree of - Nothing -> assertFailure "Failed to get tree parts" - Just t1 -> do - pool <- runNoLoggingT $ initPool "test.db" - let newTree = mkSaplingTree t1 - _ <- upsertSaplingTree pool 2000 newTree - let updatedTree = append newTree (cmu1, 4) - _ <- upsertSaplingTree pool 2001 updatedTree - readTree <- getSaplingTree pool - case readTree of - Nothing -> assertFailure "Couldn't retrieve tree from db" - Just (t1, x) -> t1 `shouldBe` updatedTree - it "Orchard tree" $ do - let tree = - OrchardCommitmentTree $ - hexString - "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" - let cmx1 = - hexString - "1712ead46028d4349e234abf59e94e0640fe7a0829e2e2e17e1a931631810400" :: OrchardCommitment - case getOrchardTreeParts tree of - Nothing -> assertFailure "Failed to get tree parts" - Just t1 -> do - pool <- runNoLoggingT $ initPool "test.db" - let newTree = mkOrchardTree t1 - _ <- upsertOrchardTree pool 2000 newTree - readTree <- getOrchardTree pool - case readTree of - Nothing -> assertFailure "Couldn't retrieve tree from db" - Just (t1, x) -> t1 `shouldBe` newTree - it "Orchard tree update" $ do - let tree = - OrchardCommitmentTree $ - hexString - "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" - let cmx1 = - hexString - "1712ead46028d4349e234abf59e94e0640fe7a0829e2e2e17e1a931631810400" :: OrchardCommitment - case getOrchardTreeParts tree of - Nothing -> assertFailure "Failed to get tree parts" - Just t1 -> do - pool <- runNoLoggingT $ initPool "test.db" - let newTree = mkOrchardTree t1 - _ <- upsertOrchardTree pool 2000 newTree - let updatedTree = append newTree (cmx1, 4) - _ <- upsertOrchardTree pool 2001 updatedTree - readTree <- getOrchardTree pool - case readTree of - Nothing -> assertFailure "Couldn't retrieve tree from db" - Just (t1, x) -> t1 `shouldBe` updatedTree - describe "Tree tests" $ do - describe "Sapling" $ do - let cmx1 = - hexString - "238a75ea513eb330cee527d3fa5000cd52620f116919a33afb9ac78ee1f91c17" - let t0 = EmptyLeaf <> EmptyLeaf :: Tree SaplingNode - let t1 = t0 <> EmptyLeaf :: Tree SaplingNode - let t1a = t0 <> t0 - it "Create leaf" $ do - let n = leaf cmx1 0 0 :: Tree SaplingNode - getLevel (value n) `shouldBe` 0 - it "Create minimal tree" $ do - let t = leaf cmx1 0 0 <> EmptyLeaf :: Tree SaplingNode - getLevel (value t) `shouldBe` 1 - it "Create minimal empty tree" $ do - getHash (value t0) `shouldNotBe` hexString "00" - it "Expand empty tree" $ do t1 `shouldBe` t1a - it "Create empty tree non-rec" $ getEmptyRoot 2 `shouldBe` t1 - it "Validate empty tree" $ do - getHash (value (getEmptyRoot 32 :: Tree SaplingNode)) `shouldBe` - getSaplingRootTest 32 - it "Validate size of tree from Zebra" $ do - let tree = - SaplingCommitmentTree $ - hexString - "01b4a6049100dd1aa53fd850c388e0ed3782b039448aa43de5fd41d9e2419b375b0114abe3b473ac2dcd9ec3c62ff5cffb683f2e584d70ce4c1c118d67a8c34f1d691f00000000014278a19b3777ee0ceb48c4d469ab0a95217de56f27a4eaf9f19a90244bcff05301692acd3dd617e7cb44a17026211a31899cf27ef5960d59b8323ba105c754965800016f641fd51f68efae0cb742182483d97054bca8fcfb8036b1c165acdb0b27fc1b0000015965da8d105e2d412c7e13f920e607461c8cbb67a38b3a667898d1eaa064ba5701be82b8379a88cce7629153e0b3d1bf826782d3e0c367d615d362b479ead41d6401e1dbd43a62ac601d82de803fc3b6485182854056c6577bae231882b19184b03e000000018f624406b4ebda9ee13c062063e16f65ab5d725b80645037be7760e4ca7887730000000000000000000000000000" - case getSaplingTreeParts tree of - Nothing -> assertFailure "Failed to get parts" - Just t1 -> do - case getSaplingFrontier tree of - Nothing -> assertFailure "Failed to get frontier" - Just f1 -> do - saplingSize t1 `shouldBe` 1 + fromIntegral (sf_pos f1) - it "Deserialize commitment tree from Zebra" $ do - let tree = - SaplingCommitmentTree $ - hexString - "01b4a6049100dd1aa53fd850c388e0ed3782b039448aa43de5fd41d9e2419b375b0114abe3b473ac2dcd9ec3c62ff5cffb683f2e584d70ce4c1c118d67a8c34f1d691f00000000014278a19b3777ee0ceb48c4d469ab0a95217de56f27a4eaf9f19a90244bcff05301692acd3dd617e7cb44a17026211a31899cf27ef5960d59b8323ba105c754965800016f641fd51f68efae0cb742182483d97054bca8fcfb8036b1c165acdb0b27fc1b0000015965da8d105e2d412c7e13f920e607461c8cbb67a38b3a667898d1eaa064ba5701be82b8379a88cce7629153e0b3d1bf826782d3e0c367d615d362b479ead41d6401e1dbd43a62ac601d82de803fc3b6485182854056c6577bae231882b19184b03e000000018f624406b4ebda9ee13c062063e16f65ab5d725b80645037be7760e4ca7887730000000000000000000000000000" - case getSaplingTreeParts tree of - Nothing -> assertFailure "Failed to get frontier" - Just t1 -> do - length (st_parents t1) `shouldBe` 31 - it "Create commitment tree from Zebra" $ do - let tree = - SaplingCommitmentTree $ - hexString - "01b4a6049100dd1aa53fd850c388e0ed3782b039448aa43de5fd41d9e2419b375b0114abe3b473ac2dcd9ec3c62ff5cffb683f2e584d70ce4c1c118d67a8c34f1d691f00000000014278a19b3777ee0ceb48c4d469ab0a95217de56f27a4eaf9f19a90244bcff05301692acd3dd617e7cb44a17026211a31899cf27ef5960d59b8323ba105c754965800016f641fd51f68efae0cb742182483d97054bca8fcfb8036b1c165acdb0b27fc1b0000015965da8d105e2d412c7e13f920e607461c8cbb67a38b3a667898d1eaa064ba5701be82b8379a88cce7629153e0b3d1bf826782d3e0c367d615d362b479ead41d6401e1dbd43a62ac601d82de803fc3b6485182854056c6577bae231882b19184b03e000000018f624406b4ebda9ee13c062063e16f65ab5d725b80645037be7760e4ca7887730000000000000000000000000000" - case getSaplingTreeParts tree of - Nothing -> assertFailure "Failed to get tree parts" - Just t1 -> do - let newTree = mkSaplingTree t1 - getLevel (value newTree) `shouldBe` 32 - it "Validate commitment tree from Zebra" $ do - let tree = - SaplingCommitmentTree $ - hexString - "01b4a6049100dd1aa53fd850c388e0ed3782b039448aa43de5fd41d9e2419b375b0114abe3b473ac2dcd9ec3c62ff5cffb683f2e584d70ce4c1c118d67a8c34f1d691f00000000014278a19b3777ee0ceb48c4d469ab0a95217de56f27a4eaf9f19a90244bcff05301692acd3dd617e7cb44a17026211a31899cf27ef5960d59b8323ba105c754965800016f641fd51f68efae0cb742182483d97054bca8fcfb8036b1c165acdb0b27fc1b0000015965da8d105e2d412c7e13f920e607461c8cbb67a38b3a667898d1eaa064ba5701be82b8379a88cce7629153e0b3d1bf826782d3e0c367d615d362b479ead41d6401e1dbd43a62ac601d82de803fc3b6485182854056c6577bae231882b19184b03e000000018f624406b4ebda9ee13c062063e16f65ab5d725b80645037be7760e4ca7887730000000000000000000000000000" - case getSaplingTreeParts tree of - Nothing -> assertFailure "Failed to get tree parts" - Just t1 -> do - let newTree = mkSaplingTree t1 - let ctAnchor = getSaplingTreeAnchor tree - {- - -getHash (value newTree) `shouldBe` ctAnchor - -isFull (value newTree) `shouldBe` False - -} - getPosition (value newTree) `shouldBe` 145761 - it "Validate appending nodes to tree" $ do - let tree = - SaplingCommitmentTree $ - hexString - "01b4a6049100dd1aa53fd850c388e0ed3782b039448aa43de5fd41d9e2419b375b0114abe3b473ac2dcd9ec3c62ff5cffb683f2e584d70ce4c1c118d67a8c34f1d691f00000000014278a19b3777ee0ceb48c4d469ab0a95217de56f27a4eaf9f19a90244bcff05301692acd3dd617e7cb44a17026211a31899cf27ef5960d59b8323ba105c754965800016f641fd51f68efae0cb742182483d97054bca8fcfb8036b1c165acdb0b27fc1b0000015965da8d105e2d412c7e13f920e607461c8cbb67a38b3a667898d1eaa064ba5701be82b8379a88cce7629153e0b3d1bf826782d3e0c367d615d362b479ead41d6401e1dbd43a62ac601d82de803fc3b6485182854056c6577bae231882b19184b03e000000018f624406b4ebda9ee13c062063e16f65ab5d725b80645037be7760e4ca7887730000000000000000000000000000" - let cmu1 = - hexString - "238a75ea513eb330cee527d3fa5000cd52620f116919a33afb9ac78ee1f91c17" :: SaplingCommitment - let finalTree = - SaplingCommitmentTree $ - hexString - "01238a75ea513eb330cee527d3fa5000cd52620f116919a33afb9ac78ee1f91c17001f01fff1bcef0a4485a0beafb4813a3fd7fc7402c5efde08f56a8bb9ac99aa25ef4e000000014278a19b3777ee0ceb48c4d469ab0a95217de56f27a4eaf9f19a90244bcff05301692acd3dd617e7cb44a17026211a31899cf27ef5960d59b8323ba105c754965800016f641fd51f68efae0cb742182483d97054bca8fcfb8036b1c165acdb0b27fc1b0000015965da8d105e2d412c7e13f920e607461c8cbb67a38b3a667898d1eaa064ba5701be82b8379a88cce7629153e0b3d1bf826782d3e0c367d615d362b479ead41d6401e1dbd43a62ac601d82de803fc3b6485182854056c6577bae231882b19184b03e000000018f624406b4ebda9ee13c062063e16f65ab5d725b80645037be7760e4ca7887730000000000000000000000000000" - case getSaplingTreeParts tree of - Nothing -> assertFailure "Failed to get tree parts" - Just t1 -> do - let newTree = mkSaplingTree t1 - let updatedTree1 = append newTree (cmu1, 4) - let finalAnchor = getSaplingTreeAnchor finalTree - getHash (value updatedTree1) `shouldBe` finalAnchor - it "Validate serializing tree to bytes" $ do - let tree = - SaplingCommitmentTree $ - hexString - "01b4a6049100dd1aa53fd850c388e0ed3782b039448aa43de5fd41d9e2419b375b0114abe3b473ac2dcd9ec3c62ff5cffb683f2e584d70ce4c1c118d67a8c34f1d691f00000000014278a19b3777ee0ceb48c4d469ab0a95217de56f27a4eaf9f19a90244bcff05301692acd3dd617e7cb44a17026211a31899cf27ef5960d59b8323ba105c754965800016f641fd51f68efae0cb742182483d97054bca8fcfb8036b1c165acdb0b27fc1b0000015965da8d105e2d412c7e13f920e607461c8cbb67a38b3a667898d1eaa064ba5701be82b8379a88cce7629153e0b3d1bf826782d3e0c367d615d362b479ead41d6401e1dbd43a62ac601d82de803fc3b6485182854056c6577bae231882b19184b03e000000018f624406b4ebda9ee13c062063e16f65ab5d725b80645037be7760e4ca7887730000000000000000000000000000" - case mkSaplingTree <$> getSaplingTreeParts tree of - Nothing -> assertFailure "Failed to build tree" - Just t1 -> do - let treeBytes = serialiseBorsh t1 - LBS.length treeBytes `shouldNotBe` 0 - it "Validate deserializing tree from bytes" $ do - let tree = - SaplingCommitmentTree $ - hexString - "01b4a6049100dd1aa53fd850c388e0ed3782b039448aa43de5fd41d9e2419b375b0114abe3b473ac2dcd9ec3c62ff5cffb683f2e584d70ce4c1c118d67a8c34f1d691f00000000014278a19b3777ee0ceb48c4d469ab0a95217de56f27a4eaf9f19a90244bcff05301692acd3dd617e7cb44a17026211a31899cf27ef5960d59b8323ba105c754965800016f641fd51f68efae0cb742182483d97054bca8fcfb8036b1c165acdb0b27fc1b0000015965da8d105e2d412c7e13f920e607461c8cbb67a38b3a667898d1eaa064ba5701be82b8379a88cce7629153e0b3d1bf826782d3e0c367d615d362b479ead41d6401e1dbd43a62ac601d82de803fc3b6485182854056c6577bae231882b19184b03e000000018f624406b4ebda9ee13c062063e16f65ab5d725b80645037be7760e4ca7887730000000000000000000000000000" - case mkSaplingTree <$> getSaplingTreeParts tree of - Nothing -> assertFailure "Failed to build tree" - Just t1 -> do - let treeBytes = serialiseBorsh t1 - let rebuiltTree = deserialiseBorsh treeBytes - rebuiltTree `shouldBe` Right t1 - it "Create merkle path" $ do - let tree = - SaplingCommitmentTree $ - hexString - "01b4a6049100dd1aa53fd850c388e0ed3782b039448aa43de5fd41d9e2419b375b0114abe3b473ac2dcd9ec3c62ff5cffb683f2e584d70ce4c1c118d67a8c34f1d691f00000000014278a19b3777ee0ceb48c4d469ab0a95217de56f27a4eaf9f19a90244bcff05301692acd3dd617e7cb44a17026211a31899cf27ef5960d59b8323ba105c754965800016f641fd51f68efae0cb742182483d97054bca8fcfb8036b1c165acdb0b27fc1b0000015965da8d105e2d412c7e13f920e607461c8cbb67a38b3a667898d1eaa064ba5701be82b8379a88cce7629153e0b3d1bf826782d3e0c367d615d362b479ead41d6401e1dbd43a62ac601d82de803fc3b6485182854056c6577bae231882b19184b03e000000018f624406b4ebda9ee13c062063e16f65ab5d725b80645037be7760e4ca7887730000000000000000000000000000" - let cmu1 = - hexString - "238a75ea513eb330cee527d3fa5000cd52620f116919a33afb9ac78ee1f91c17" :: SaplingCommitment - case getSaplingTreeParts tree of - Nothing -> assertFailure "Failed to get tree parts" - Just t1 -> do - let newTree = mkSaplingTree t1 - let updatedTree = append newTree (cmu1, 4) - case path 145762 updatedTree of - Nothing -> assertFailure "Failed to get Merkle path" - Just p1 -> p1 `shouldNotBe` MerklePath 0 [] - it "Validate merkle path" $ do - let tree = - SaplingCommitmentTree $ - hexString - "01b4a6049100dd1aa53fd850c388e0ed3782b039448aa43de5fd41d9e2419b375b0114abe3b473ac2dcd9ec3c62ff5cffb683f2e584d70ce4c1c118d67a8c34f1d691f00000000014278a19b3777ee0ceb48c4d469ab0a95217de56f27a4eaf9f19a90244bcff05301692acd3dd617e7cb44a17026211a31899cf27ef5960d59b8323ba105c754965800016f641fd51f68efae0cb742182483d97054bca8fcfb8036b1c165acdb0b27fc1b0000015965da8d105e2d412c7e13f920e607461c8cbb67a38b3a667898d1eaa064ba5701be82b8379a88cce7629153e0b3d1bf826782d3e0c367d615d362b479ead41d6401e1dbd43a62ac601d82de803fc3b6485182854056c6577bae231882b19184b03e000000018f624406b4ebda9ee13c062063e16f65ab5d725b80645037be7760e4ca7887730000000000000000000000000000" - let cmu1 = - hexString - "238a75ea513eb330cee527d3fa5000cd52620f116919a33afb9ac78ee1f91c17" :: SaplingCommitment - case getSaplingTreeParts tree of - Nothing -> assertFailure "Failed to get tree parts" - Just t1 -> do - let newTree = mkSaplingTree t1 - let updatedTree = append newTree (cmu1, 4) - case path 145762 updatedTree of - Nothing -> assertFailure "Failed to get Merkle path" - Just p1 -> - getSaplingPathAnchor cmu1 p1 `shouldBe` - getHash (value updatedTree) - it "Find position by index" $ do - let tree = - SaplingCommitmentTree $ - hexString - "01b4a6049100dd1aa53fd850c388e0ed3782b039448aa43de5fd41d9e2419b375b0114abe3b473ac2dcd9ec3c62ff5cffb683f2e584d70ce4c1c118d67a8c34f1d691f00000000014278a19b3777ee0ceb48c4d469ab0a95217de56f27a4eaf9f19a90244bcff05301692acd3dd617e7cb44a17026211a31899cf27ef5960d59b8323ba105c754965800016f641fd51f68efae0cb742182483d97054bca8fcfb8036b1c165acdb0b27fc1b0000015965da8d105e2d412c7e13f920e607461c8cbb67a38b3a667898d1eaa064ba5701be82b8379a88cce7629153e0b3d1bf826782d3e0c367d615d362b479ead41d6401e1dbd43a62ac601d82de803fc3b6485182854056c6577bae231882b19184b03e000000018f624406b4ebda9ee13c062063e16f65ab5d725b80645037be7760e4ca7887730000000000000000000000000000" - let cmu1 = - hexString - "238a75ea513eb330cee527d3fa5000cd52620f116919a33afb9ac78ee1f91c17" :: SaplingCommitment - case getSaplingTreeParts tree of - Nothing -> assertFailure "Failed to get tree parts" - Just t1 -> do - let newTree = mkSaplingTree t1 - let updatedTree = append newTree (cmu1, 4) - getNotePosition updatedTree 4 `shouldBe` Just 145762 - describe "Orchard" $ do - let cmx1 = - hexString - "1712ead46028d4349e234abf59e94e0640fe7a0829e2e2e17e1a931631810400" - let cmx2 = - hexString - "39f5ad39817fb432fa07c5feb3a957189fbe7662a4b5555ca95093b6d853cf07" - let t0 = EmptyLeaf <> EmptyLeaf :: Tree OrchardNode - let t1 = t0 <> EmptyLeaf :: Tree OrchardNode - let t1a = t0 <> t0 - it "Create leaf" $ do - let n = leaf cmx1 0 0 :: Tree OrchardNode - getLevel (value n) `shouldBe` 0 - it "Create minimal tree" $ do - let t = leaf cmx1 0 0 <> EmptyLeaf :: Tree OrchardNode - getLevel (value t) `shouldBe` 1 - it "Create minimal empty tree" $ do - getHash (value t0) `shouldNotBe` hexString "00" - it "Expand empty tree" $ do t1 `shouldBe` t1a - it "Create empty tree non-rec" $ getEmptyRoot 2 `shouldBe` t1 - it "Validate empty tree" $ do - getHash (value (getEmptyRoot 32 :: Tree OrchardNode)) `shouldBe` - getOrchardRootTest 32 - it "Validate tree with one leaf" $ do - let n = leaf cmx1 0 1 :: Tree OrchardNode - let n1 = root n - getHash (value n1) `shouldBe` addOrchardNodeGetRoot 32 (hexBytes cmx1) - it "Validate size of tree from Zebra" $ do - let tree = - OrchardCommitmentTree $ - hexString - "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" - case getOrchardTreeParts tree of - Nothing -> assertFailure "Failed to get parts" - Just t1 -> do - case getOrchardFrontier tree of - Nothing -> assertFailure "Failed to get frontier" - Just f1 -> do - orchardSize t1 `shouldBe` 1 + fromIntegral (of_pos f1) - it "Deserialize commitment tree from Zebra" $ do - let tree = - OrchardCommitmentTree $ - hexString - "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" - case getOrchardTreeParts tree of - Nothing -> assertFailure "Failed to get frontier" - Just t1 -> do - length (ot_parents t1) `shouldBe` 31 - it "Create commitment tree from Zebra" $ do - let tree = - OrchardCommitmentTree $ - hexString - "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" - case getOrchardTreeParts tree of - Nothing -> assertFailure "Failed to get tree parts" - Just t1 -> do - let newTree = mkOrchardTree t1 - getLevel (value newTree) `shouldBe` 32 - it "Validate commitment tree from Zebra" $ do - let tree = - OrchardCommitmentTree $ - hexString - "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" - case getOrchardTreeParts tree of - Nothing -> assertFailure "Failed to get tree parts" - Just t1 -> do - let newTree = mkOrchardTree t1 - let ctAnchor = getOrchardTreeAnchor tree - {- - -getHash (value newTree) `shouldBe` ctAnchor - -isFull (value newTree) `shouldBe` False - -} - getPosition (value newTree) `shouldBe` 39733 - it "Validate appending nodes to tree" $ do - let tree = - OrchardCommitmentTree $ - hexString - "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" - let cmx1 = - hexString - "1712ead46028d4349e234abf59e94e0640fe7a0829e2e2e17e1a931631810400" :: OrchardCommitment - let cmx2 = - hexString - "39f5ad39817fb432fa07c5feb3a957189fbe7662a4b5555ca95093b6d853cf07" :: OrchardCommitment - let cmx3 = - hexString - "84f7fbc4b9f87215c653078d7fdd90756c3ba370c745065167da9eb73a65a83f" :: OrchardCommitment - let cmx4 = - hexString - "e55ad64e1ea2b261893fdea6ad0509b66e5f62d3142f351298c7135c4498d429" :: OrchardCommitment - let finalTree = - OrchardCommitmentTree $ - hexString - "0184f7fbc4b9f87215c653078d7fdd90756c3ba370c745065167da9eb73a65a83f01e55ad64e1ea2b261893fdea6ad0509b66e5f62d3142f351298c7135c4498d4291f0000014b1a76d3820087b26cd087ca84e17f3067a25ebed82ad23a93fa485affb5530b01ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" - case getOrchardTreeParts tree of - Nothing -> assertFailure "Failed to get tree parts" - Just t1 -> do - let newTree = mkOrchardTree t1 - let updatedTree1 = append newTree (cmx1, 4) - let updatedTree2 = append updatedTree1 (cmx2, 5) - let updatedTree3 = append updatedTree2 (cmx3, 6) - let updatedTree4 = append updatedTree3 (cmx4, 7) - let finalAnchor = getOrchardTreeAnchor finalTree - getHash (value updatedTree4) `shouldBe` finalAnchor - it "Validate serializing tree to bytes" $ do - let tree = - OrchardCommitmentTree $ - hexString - "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" - case mkOrchardTree <$> getOrchardTreeParts tree of - Nothing -> assertFailure "Failed to build tree" - Just t1 -> do - let treeBytes = serialiseBorsh t1 - LBS.length treeBytes `shouldNotBe` 0 - it "Validate deserializing tree from bytes" $ do - let tree = - OrchardCommitmentTree $ - hexString - "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" - case mkOrchardTree <$> getOrchardTreeParts tree of - Nothing -> assertFailure "Failed to build tree" - Just t1 -> do - let treeBytes = serialiseBorsh t1 - let rebuiltTree = deserialiseBorsh treeBytes - rebuiltTree `shouldBe` Right t1 - it "Create merkle path" $ do - let tree = - OrchardCommitmentTree $ - hexString - "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" - let cmx1 = - hexString - "1712ead46028d4349e234abf59e94e0640fe7a0829e2e2e17e1a931631810400" :: OrchardCommitment - let cmx2 = - hexString - "39f5ad39817fb432fa07c5feb3a957189fbe7662a4b5555ca95093b6d853cf07" :: OrchardCommitment - case getOrchardTreeParts tree of - Nothing -> assertFailure "Failed to get tree parts" - Just t1 -> do - let newTree = mkOrchardTree t1 - let updatedTree = foldl append newTree [(cmx1, 4), (cmx2, 5)] - case path 39735 updatedTree of - Nothing -> assertFailure "Failed to get Merkle path" - Just p1 -> p1 `shouldNotBe` MerklePath 0 [] - it "Validate merkle path" $ do - let tree = - OrchardCommitmentTree $ - hexString - "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" - let cmx1 = - hexString - "1712ead46028d4349e234abf59e94e0640fe7a0829e2e2e17e1a931631810400" :: OrchardCommitment - let cmx2 = - hexString - "39f5ad39817fb432fa07c5feb3a957189fbe7662a4b5555ca95093b6d853cf07" :: OrchardCommitment - case getOrchardTreeParts tree of - Nothing -> assertFailure "Failed to get tree parts" - Just t1 -> do - let newTree = mkOrchardTree t1 - let updatedTree = foldl append newTree [(cmx1, 4), (cmx2, 5)] - case path 39735 updatedTree of - Nothing -> assertFailure "Failed to get Merkle path" - Just p1 -> do - getOrchardPathAnchor cmx2 p1 `shouldBe` - getHash (value updatedTree) - it "Find position by index" $ do - let tree = - OrchardCommitmentTree $ - hexString - "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" - let cmx1 = - hexString - "1712ead46028d4349e234abf59e94e0640fe7a0829e2e2e17e1a931631810400" :: OrchardCommitment - let cmx2 = - hexString - "39f5ad39817fb432fa07c5feb3a957189fbe7662a4b5555ca95093b6d853cf07" :: OrchardCommitment - case getOrchardTreeParts tree of - Nothing -> assertFailure "Failed to get tree parts" - Just t1 -> do - let newTree = mkOrchardTree t1 - let updatedTree = foldl append newTree [(cmx1, 4), (cmx2, 5)] - getNotePosition updatedTree 4 `shouldBe` Just 39734 - it "Truncate tree" $ do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - maxBlock <- getMaxBlock pool $ ZcashNetDB TestNet - dbTree <- getOrchardTree pool - case dbTree of - Nothing -> assertFailure "failed to get tree from DB" - Just (oTree, oSync) -> do - let startBlock = oSync - 5 - zebraTreesIn <- - getCommitmentTrees - pool - "localhost" - 18232 - (ZcashNetDB TestNet) - startBlock - ix <- getOrchardActionAtBlock pool (ZcashNetDB TestNet) startBlock - case ix of - Nothing -> assertFailure "couldn't find index at block" - Just i -> do - updatedTree <- - runFileLoggingT "test.log" $ truncateTree oTree i - let finalAnchor = - getOrchardTreeAnchor $ - OrchardCommitmentTree $ ztiOrchard zebraTreesIn - getHash (value updatedTree) `shouldBe` finalAnchor - it "Counting leaves in tree" $ do - let tree = - OrchardCommitmentTree $ - hexString - "0136a7886d7d73bc1845223165fd9cb0cef02046c707e8f88a7f61564720bd0f3501dca1fbdd7b5ba92a0809af5e85874626ce0db14d0532a48e41dde6f0f81b46011f0001fb48c27bd07e68f27aba47cd6e93fa961e0ef8c63f993963a614e56855d2013c0001ea572db9c5c2d24c7ad9132ae32b27179466bf67a580d59901d13b281d3f530b01c160348f10b9ad893d9731317ebe36ac8665e01c52cbe15a56aa9b72e4e6c41e000001cd7695156de2debdc5b13ea84d32e4e3ac020fb0aa7cd372c57ce765103bd70401746e6bc066a10e7f80a9ff8993dcb25c819edd64f2ca10ac248ef7848d41450500011e6191f91b3fceb62dc881a156e1b9d2e88e09dca25093cf9c4936c8869fb41a013bf8b923e4187754e85175748d9cce4824a6787e4258977b5bfe1ba59012c032000001f3bbdc62260c4fca5c84bf3487246d4542da48eeeec8ec40c1029b6908eef83c00000000000000000000000000000000" - case getOrchardTreeParts tree of - Nothing -> assertFailure "Failed to get tree parts" - Just t1 -> do - let newTree = mkOrchardTree t1 - countLeaves newTree `shouldBe` - fromIntegral (1 + getPosition (value newTree)) - it "Validate large load" $ do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - maxBlock <- getMaxBlock pool $ ZcashNetDB TestNet - let startBlock = maxBlock - 310000 - zebraTreesIn <- - getCommitmentTrees - pool - "localhost" - 18232 - (ZcashNetDB TestNet) - startBlock - zebraTreesOut <- - getCommitmentTrees - pool - "localhost" - 18232 - (ZcashNetDB TestNet) - maxBlock - case getOrchardTreeParts $ - OrchardCommitmentTree $ ztiOrchard zebraTreesIn of - Nothing -> assertFailure "Failed to get tree parts" - Just t1 -> do - let newTree = mkOrchardTree t1 - oAct <- getOrchardActions pool startBlock $ ZcashNetDB TestNet - let cmxs = - map - (\(_, y) -> - ( getHex $ orchActionCmx $ entityVal y - , fromSqlKey $ entityKey y)) - oAct - let posCmx = zip [(getPosition (value newTree) + 1) ..] cmxs - let updatedTree = batchAppend newTree posCmx - let finalAnchor = - getOrchardTreeAnchor $ - OrchardCommitmentTree $ ztiOrchard zebraTreesOut - getHash (value updatedTree) `shouldBe` finalAnchor - it "Validate tree from DB" $ do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - dbTree <- getOrchardTree pool - case dbTree of - Nothing -> assertFailure "failed to get tree from DB" - Just (oTree, oSync) -> do - zebraTrees <- - getCommitmentTrees - pool - "localhost" - 18232 - (ZcashNetDB TestNet) - oSync - let finalAnchor = - getOrchardTreeAnchor $ - OrchardCommitmentTree $ ztiOrchard zebraTrees - getHash (value oTree) `shouldBe` finalAnchor - describe "TEX address" $ do - it "from UA" $ do - let addr = - parseAddress - "utest1fqtne08sdgmae0g0un7j3h6ss9gafguprv0yvkxv4trxxsdxx467pxkkc98cpsyk5r2enwwpn3p5c6aw537wyvlz20hs7vcqc4uhm22yfjnrsm8hy2hjjrscvhk2ac32rzndu94hh28gdl62wqgy3yev7w0gj9lmmz6yasghmle6tllx4yjv9sjt0xml66y9lyxc4rkk6q425nc5gxa" - case addr of - Nothing -> assertFailure "failed to parse address" - Just (Unified ua) -> - case (encodeExchangeAddress (ua_net ua) =<< (t_rec ua)) of - Nothing -> assertFailure "failed to encode TEX" - Just tex -> - tex `shouldBe` "textest1jze8c9jxxrpct34tpe4pvquz8nvxsxt6gawqqf" - Just _ -> assertFailure "no transparent receiver" - describe "Creating Tx" $ do - describe "Full" $ do - it "To Orchard" $ do - let uaRead = - parseAddress - "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" - case uaRead of - Nothing -> assertFailure "wrong address" - Just ua -> do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - tx <- - runFileLoggingT "zenith.log" $ - prepareTxV2 - pool - "localhost" - 18232 - TestNet - (toSqlKey 3) - 3026170 - [ ProposedNote - (ValidAddressAPI $ fromJust uaRead) - 0.005 - (Just "Sending memo to orchard") - ] - Full - case tx of - Left e -> assertFailure $ show e - Right h -> h `shouldNotBe` hexString "deadbeef" - it "To Sapling" $ do - let uaRead = - parseAddress - "ztestsapling136jp8z89v2jh6kqd5rs4dtvlxym90m43svzdwzxaplyvc5ttzppytpvx80ncllcsqzpmukxjl3y" - case uaRead of - Nothing -> assertFailure "wrong address" - Just ua -> do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - tx <- - runFileLoggingT "zenith.log" $ - prepareTxV2 - pool - "localhost" - 18232 - TestNet - (toSqlKey 4) - 3001331 - [ ProposedNote - (ValidAddressAPI $ fromJust uaRead) - 0.005 - (Just "Sending memo to sapling") - ] - Full - case tx of - Left e -> assertFailure $ show e - Right h -> h `shouldNotBe` hexString "deadbeef" - it "To Transparent" $ do - let uaRead = parseAddress "tmAmSa4AauSFuJieeanRBjkfnah45ysGtgZ" - case uaRead of - Nothing -> assertFailure "wrong address" - Just ua -> do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - tx <- - runFileLoggingT "zenith.log" $ - prepareTxV2 - pool - "localhost" - 18232 - TestNet - (toSqlKey 4) - 3001331 - [ ProposedNote - (ValidAddressAPI $ fromJust uaRead) - 0.005 - Nothing - ] - Full - tx `shouldBe` - Left (PrivacyPolicyError "Receiver not capable of Full privacy") - it "To mixed shielded receivers" $ do - let uaRead = - parseAddress - "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" - let uaRead2 = - parseAddress - "ztestsapling136jp8z89v2jh6kqd5rs4dtvlxym90m43svzdwzxaplyvc5ttzppytpvx80ncllcsqzpmukxjl3y" - case uaRead of - Nothing -> assertFailure "wrong address" - Just ua -> do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - tx <- - runFileLoggingT "zenith.log" $ - prepareTxV2 - pool - "localhost" - 18232 - TestNet - (toSqlKey 1) - 3001331 - [ ProposedNote - (ValidAddressAPI $ fromJust uaRead) - 0.005 - (Just "Sending memo to orchard") - , ProposedNote - (ValidAddressAPI $ fromJust uaRead2) - 0.004 - Nothing - ] - Full - tx `shouldBe` - Left - (PrivacyPolicyError - "Combination of receivers not allowed for Full privacy") - describe "Medium" $ do - it "To Orchard" $ do - let uaRead = - parseAddress - "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" - case uaRead of - Nothing -> assertFailure "wrong address" - Just ua -> do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - tx <- - runFileLoggingT "zenith.log" $ - prepareTxV2 - pool - "localhost" - 18232 - TestNet - (toSqlKey 1) - 3001372 - [ ProposedNote - (ValidAddressAPI $ fromJust uaRead) - 0.005 - (Just "Sending memo to orchard") - ] - Medium - case tx of - Left e -> assertFailure $ show e - Right h -> h `shouldNotBe` hexString "deadbeef" - it "To Sapling" $ do - let uaRead = - parseAddress - "ztestsapling136jp8z89v2jh6kqd5rs4dtvlxym90m43svzdwzxaplyvc5ttzppytpvx80ncllcsqzpmukxjl3y" - case uaRead of - Nothing -> assertFailure "wrong address" - Just ua -> do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - tx <- - runFileLoggingT "zenith.log" $ - prepareTxV2 - pool - "localhost" - 18232 - TestNet - (toSqlKey 1) - 3001372 - [ ProposedNote - (ValidAddressAPI $ fromJust uaRead) - 0.005 - (Just "Sending memo to sapling") - ] - Medium - case tx of - Left e -> assertFailure $ show e - Right h -> h `shouldNotBe` (hexString "00") - it "To Transparent" $ do - let uaRead = parseAddress "tmAmSa4AauSFuJieeanRBjkfnah45ysGtgZ" - case uaRead of - Nothing -> assertFailure "wrong address" - Just ua -> do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - tx <- - runFileLoggingT "zenith.log" $ - prepareTxV2 - pool - "localhost" - 18232 - TestNet - (toSqlKey 4) - 3001331 - [ ProposedNote - (ValidAddressAPI $ fromJust uaRead) - 0.005 - Nothing - ] - Medium - tx `shouldBe` - Left - (PrivacyPolicyError "Receiver not capable of Medium privacy") - it "To mixed shielded receivers" $ do - let uaRead = - parseAddress - "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" - let uaRead2 = - parseAddress - "ztestsapling136jp8z89v2jh6kqd5rs4dtvlxym90m43svzdwzxaplyvc5ttzppytpvx80ncllcsqzpmukxjl3y" - case uaRead of - Nothing -> assertFailure "wrong address" - Just ua -> do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - tx <- - runFileLoggingT "zenith.log" $ - prepareTxV2 - pool - "localhost" - 18232 - TestNet - (toSqlKey 1) - 3001331 - [ ProposedNote - (ValidAddressAPI $ fromJust uaRead) - 0.005 - (Just "Sending memo to orchard") - , ProposedNote - (ValidAddressAPI $ fromJust uaRead2) - 0.004 - Nothing - ] - Medium - case tx of - Left e -> assertFailure $ show e - Right h -> h `shouldNotBe` (hexString "deadbeef") - describe "Low" $ do - it "To Orchard" $ do - let uaRead = - parseAddress - "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" - case uaRead of - Nothing -> assertFailure "wrong address" - Just ua -> do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - tx <- - runFileLoggingT "zenith.log" $ - prepareTxV2 - pool - "localhost" - 18232 - TestNet - (toSqlKey 1) - 3001372 - [ ProposedNote - (ValidAddressAPI $ fromJust uaRead) - 0.005 - Nothing - ] - Low - case tx of - Left e -> assertFailure $ show e - Right h -> h `shouldNotBe` (hexString "deadbeef") - it "To Sapling" $ do - let uaRead = - parseAddress - "ztestsapling136jp8z89v2jh6kqd5rs4dtvlxym90m43svzdwzxaplyvc5ttzppytpvx80ncllcsqzpmukxjl3y" - case uaRead of - Nothing -> assertFailure "wrong address" - Just ua -> do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - tx <- - runFileLoggingT "zenith.log" $ - prepareTxV2 - pool - "localhost" - 18232 - TestNet - (toSqlKey 1) - 3001372 - [ ProposedNote - (ValidAddressAPI $ fromJust uaRead) - 0.005 - Nothing - ] - Low - case tx of - Left e -> assertFailure $ show e - Right h -> h `shouldNotBe` (hexString "deadbeef") - it "To Transparent" $ do - let uaRead = parseAddress "tmAmSa4AauSFuJieeanRBjkfnah45ysGtgZ" - case uaRead of - Nothing -> assertFailure "wrong address" - Just ua -> do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - tx <- - runFileLoggingT "zenith.log" $ - prepareTxV2 - pool - "localhost" - 18232 - TestNet - (toSqlKey 1) - 3001372 - [ ProposedNote - (ValidAddressAPI $ fromJust uaRead) - 0.005 - Nothing - ] - Low - case tx of - Left e -> assertFailure $ show e - Right h -> h `shouldNotBe` (hexString "deadbeef") - describe "None" $ do - it "To Orchard" $ do - let uaRead = - parseAddress - "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" - case uaRead of - Nothing -> assertFailure "wrong address" - Just ua -> do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - tx <- - runFileLoggingT "zenith.log" $ - prepareTxV2 - pool - "localhost" - 18232 - TestNet - (toSqlKey 1) - 3001372 - [ ProposedNote - (ValidAddressAPI $ fromJust uaRead) - 0.005 - Nothing - ] - None - tx `shouldBe` - Left - (PrivacyPolicyError - "Shielded recipients not compatible with privacy policy.") - it "To Sapling" $ do - let uaRead = - parseAddress - "ztestsapling136jp8z89v2jh6kqd5rs4dtvlxym90m43svzdwzxaplyvc5ttzppytpvx80ncllcsqzpmukxjl3y" - case uaRead of - Nothing -> assertFailure "wrong address" - Just ua -> do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - tx <- - runFileLoggingT "zenith.log" $ - prepareTxV2 - pool - "localhost" - 18232 - TestNet - (toSqlKey 1) - 3001372 - [ ProposedNote - (ValidAddressAPI $ fromJust uaRead) - 0.005 - Nothing - ] - None - tx `shouldBe` - Left - (PrivacyPolicyError - "Shielded recipients not compatible with privacy policy.") - it "To Transparent" $ do - let uaRead = parseAddress "tmAmSa4AauSFuJieeanRBjkfnah45ysGtgZ" - case uaRead of - Nothing -> assertFailure "wrong address" - Just ua -> do - pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db" - tx <- - runFileLoggingT "zenith.log" $ - prepareTxV2 - pool - "localhost" - 18232 - TestNet - (toSqlKey 1) - 3001372 - [ ProposedNote - (ValidAddressAPI $ fromJust uaRead) - 0.005 - Nothing - ] - None - case tx of - Left e -> assertFailure $ show e - Right h -> h `shouldNotBe` hexString "deadbeef" + {-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")-} diff --git a/zcash-haskell b/zcash-haskell index 4289a9d..e807441 160000 --- a/zcash-haskell +++ b/zcash-haskell @@ -1 +1 @@ -Subproject commit 4289a9ded67ef2ca432abc412934fb5b8b59a9cf +Subproject commit e8074419cfb54559a4c09731ad2448d5930869a2 diff --git a/zenith-openrpc.json b/zenith-openrpc.json deleted file mode 100644 index 53cb005..0000000 --- a/zenith-openrpc.json +++ /dev/null @@ -1,900 +0,0 @@ -{ - "openrpc": "1.0.0-rc1", - "info": { - "version": "0.7.0.0-beta", - "title": "Zenith RPC", - "description": "The RPC methods to interact with the Zenith Zcash wallet", - "license": { - "name": "MIT", - "url": "https://choosealicense.com/licenses/mit/" - } - }, - "servers": [ - { - "name": "Zenith RPC", - "summary": "The Zenith wallet RPC server", - "description": "This is the server that allows programmatic interaction with the Zenith Zcash wallet via RPC", - "url": "http://localhost:8234" - } - ], - "methods": [ - { - "name": "getinfo", - "summary": "Get basic Zenith information", - "description": "Get basic information about Zenith, such as the network it is running on and the version of Zebra it is connected to", - "tags": [], - "result" : { - "name": "Zenith information", - "schema": { "$ref": "#/components/schemas/ZenithInfo" } - }, - "params" : [], - "examples": [ - { - "name": "GetInfo example", - "summary": "Get information from Zenith", - "description": "Gets the status of the Zenith wallet server", - "params": [], - "result": { - "name": "GetInfo result", - "value": { - "version": "0.7.0.0-beta", - "network": "TestNet", - "zebraVersion": "v1.8.0" - } - } - - } - ], - "errors": [ - { "$ref": "#/components/errors/ZebraNotAvailable" } - ] - }, - { - "name": "listwallets", - "summary": "Get the list of available wallets", - "description": "Returns a list of available wallets per the network that the Zebra node is running on.", - "tags": [], - "result": { - "name": "Wallets", - "schema": { - "type": "array", - "items": { - "$ref": "#/components/schemas/ZcashWallet" - } - } - }, - "params": [], - "examples": [ - { - "name": "ListWallets example", - "summary": "Get list of wallets", - "description": "Get the list of wallets available in Zenith for the current network (Mainnet/Testnet)", - "params": [], - "result": { - "name": "ListWallets result", - "value": [ - { - "birthday": 2762066, - "index": 1, - "lastSync": 2919374, - "name": "Main", - "network": "TestNet" - }, - { - "birthday": 2798877, - "index": 2, - "lastSync": 2894652, - "name": "zcashd", - "network": "TestNet" - } - ] - } - - } - ], - "errors": [ - { "$ref": "#/components/errors/ZebraNotAvailable" }, - { "$ref": "#/components/errors/NoWallets" } - ] - }, - { - "name": "getnewwallet", - "summary": "Create a new wallet", - "description": "Create a new wallet for Zenith.", - "tags": [], - "params": [ - { "$ref": "#/components/contentDescriptors/Name"} - ], - "paramStructure": "by-position", - "result": { - "name": "Wallet", - "schema": { - "$ref": "#/components/contentDescriptors/WalletId" - } - }, - "examples": [ - { - "name": "GetNewWallet example", - "summary": "Create a wallet", - "description": "Creates a new wallet with the given name", - "params": [ - { - "name": "Wallet name", - "summary": "The user-friendly name for the wallet", - "value": "Main" - } - ], - "result": { - "name": "GetNewWallet result", - "value": 1 - } - } - ], - "errors": [ - { "$ref": "#/components/errors/ZebraNotAvailable" }, - { "$ref": "#/components/errors/ZenithBusy" }, - { "$ref": "#/components/errors/DuplicateName" } - ] - }, - { - "name": "listaccounts", - "summary": "List existing accounts for a wallet ID", - "description": "List existing accounts for the given wallet ID or provide an error if none", - "tags": [], - "result": { - "name": "Accounts", - "schema": { - "type": "array", - "items": { - "$ref": "#/components/schemas/ZcashAccount" - } - } - }, - "params": [{ "$ref": "#/components/contentDescriptors/WalletId"}], - "paramStructure": "by-position", - "examples": [ - { - "name": "ListAccounts example", - "summary": "Get list of accounts", - "description": "Get the list of accounts available in Zenith for the given wallet ID", - "params": [ - { - "name": "walletId", - "summary": "The integer ID of the wallet to use", - "value": 1 - } - ], - "result": { - "name": "ListAccounts result", - "value": [ - { - "index": 3, - "name": "Business", - "wallet": 1 - }, - { - "index": 1, - "name": "Savings", - "wallet": 1 - } - ] - } - - } - ], - "errors": [ - { "$ref": "#/components/errors/ZebraNotAvailable" }, - { "$ref": "#/components/errors/NoAccounts" } - ] - }, - { - "name": "getnewaccount", - "summary": "Create a new account", - "description": "Create a new account in the given wallet.", - "tags": [], - "params": [ - { "$ref": "#/components/contentDescriptors/Name"}, - { "$ref": "#/components/contentDescriptors/WalletId"} - ], - "paramStructure": "by-position", - "result": { - "name": "Account", - "schema": { - "$ref": "#/components/contentDescriptors/AccountId" - } - }, - "examples": [ - { - "name": "GetNewAccount example", - "summary": "Create an account", - "description": "Creates a new account with the given name", - "params": [ - { - "name": "Account name", - "summary": "The user-friendly name for the Account", - "value": "Personal" - }, - { - "name": "Wallet Id", - "summary": "The internal index of the Wallet to use", - "value": 1 - } - ], - "result": { - "name": "GetNewAccount result", - "value": 1 - } - } - ], - "errors": [ - { "$ref": "#/components/errors/ZebraNotAvailable" }, - { "$ref": "#/components/errors/DuplicateName" }, - { "$ref": "#/components/errors/ZenithBusy" }, - { "$ref": "#/components/errors/InvalidWallet" } - ] - }, - { - "name": "listaddresses", - "summary": "List existing addresses for an account ID", - "description": "List existing addresses for the given account ID or provide an error if none", - "tags": [], - "result": { - "name": "Addresses", - "schema": { - "type": "array", - "items": { - "$ref": "#/components/schemas/ZcashAddress" - } - } - }, - "params": [{ "$ref": "#/components/contentDescriptors/AccountId"}], - "paramStructure": "by-position", - "examples": [ - { - "name": "ListAddresses example", - "summary": "Get list of addresses", - "description": "Get the list of addresses available in Zenith for the given account ID", - "params": [ - { - "name": "accountId", - "summary": "The integer ID of the account to use", - "value": 1 - } - ], - "result": { - "name": "ListAddresses result", - "value": [ - { - "index": 3, - "account": 1, - "name": "Clothes", - "ua": "utest13dq4u4dnf3yddw8lq2n6zdclshra6xsp8zgkc5ydyu6k20zrsscmuex46qa4vh84rgd78sqnlleapznnz7mnzx9wv0unts8pv32paj8se5ca3kves2u4a89uy6e8cf4hnarxydxh7hq2e9uu39punfmm53k5h45xn9k3dx35la8j7munh9td7774m8gkqgc4mn40t69w20uu2gtks7a", - "legacy": "ztestsapling188csdsvhdny25am8ume03qr2026hdy03zpg5pq7jmmfxtxtct0e93p0rg80yfxvynqd4gwlwft5", - "transparent": "tmMouLwVfRYrF91fWjDJToivmsTWBhxfX4E" - }, - { - "index": 2, - "account": 1, - "name": "Vacation", - "ua": "utest1hhggl4nxfdx63evps6r7qz50cgacgtdpt9k7dl0734w63zn5qmrp6c2xdv9rkqyfkj6kgau4kz48xtm80e67l534qp02teqq86zuzetxql6z5v32yglg9n2un5zsu0hwcvaunzdfg5qnry6syh2dh9x8eu27de03j9pjfvrqda6acgtc6f0emdfh6r5jvfanmjml4ms5wwj9wfqmamq", - "legacy": "ztestsapling1mpup3xv2k9clxaf9wjcr0dt5gnmkprz9s9qsn298mqs356pf39wmh30q3pgsp0w5vyrmj6mrzw2", - "transparent": "tmX8qCB96Dq49YZkww3bSty7eZDA4Fq6F4R" - } - ] - } - - } - ], - "errors": [ - { "$ref": "#/components/errors/NoAddress" } - ] - }, - { - "name": "getnewaddress", - "summary": "Add a new address", - "description": "Derive a new address in the given account.", - "tags": [], - "params": [ - { "$ref": "#/components/contentDescriptors/AccountId"}, - { "$ref": "#/components/contentDescriptors/Name"}, - { "$ref": "#/components/contentDescriptors/ExcludeSapling"}, - { "$ref": "#/components/contentDescriptors/ExcludeTransparent"} - ], - "result": { - "name": "Address", - "schema": { - "$ref": "#/components/schemas/ZcashAddress" - } - }, - "examples": [ - { - "name": "GetNewAddress example", - "summary": "Get a new address for the given account", - "description": "Get a new address for the given account with an Orchard receiver, a Sapling receiver and a transparent receiver (default)", - "params": [ - { - "name": "Account Id", - "summary": "The account index", - "value": 1 - }, - { - "name": "Name", - "summary": "User-friendly name for the address", - "value": "AllRecvs" - } - ], - "result": - { - "name": "Default receivers", - "value": { - "index": 14, - "account": 1, - "name": "AllRecvs", - "ua": "utest1as2fhusjt5r7xl8963jnkkums6gue6qvu7fpw2cvrctwnwrku9r4av9zmmjt7mmet927cq9z4z0hq2w7tpm7qa8lzl5fyj6d83un6v3q78c76j7thpuzyzr260apm8xvjua5fvmrfzy59mpurec7tfamp6nd6eq95pe8vzm69hfsfea29u4v3a6lyuaah20c4k6rvf9skz35ct2r54z", - "legacy": "ztestsapling1esn0wamf8w3nz2juwryscc3l8e5xtll6aewx0r2h5xtmrpnzsw2k23lec65agn8v59r72v2krrh", - "transparent": "tmMteg5HxFnmn4mbm2UNEGzWgLX16bGLg16" - } - } - }, - { - "name": "GetNewAddress - no transparent", - "summary": "Get a new address for the given account with no transparent receiver", - "description": "Get a new address for the given account with an Orchard receiver, a Sapling receiver and *no* transparent receiver (default)", - "params": [ - { - "name": "Account Id", - "summary": "The account index", - "value": 1 - }, - { - "name": "Name", - "summary": "User-friendly name for the address", - "value": "NoTransparent" - }, - { - "name": "ExcludeTransparent", - "summary": "Option to exclude transparent receivers from the address", - "value": "ExcludeTransparent" - } - ], - "result": - { - "name": "NoTransparent", - "value": { - "index": 15, - "account": 1, - "name": "NoTransparent", - "ua": "utest1l0t3uzadaxa4jg7qatsfwqdvfp0qtedyyall65hm2nzwnwdmcvd7j4z6wdrftpsjxv8aw4qh0hka3wdqj0z48xrhg356dlapy36ug6tt20tkzavwccjfup8wy8sdkcc60rpf400mwek73n0ph9jyw9ae60rm5jt8rx75nzhyuymern2t", - "legacy": "ztestsapling1vp3kzw7rqldfvaw5edfgqq66qm0xnexmscwnys220403mqqh9uyl0sqsye37aelrese42y8ecnx", - "transparent": null - } - } - }, - { - "name": "GetNewAddress - no Sapling", - "summary": "Get a new address for the given account with no Sapling receiver", - "description": "Get a new address for the given account with an Orchard receiver and a transparent receiver, and *no* Sapling receiver.", - "params": [ - { - "name": "Account Id", - "summary": "The account index", - "value": 1 - }, - { - "name": "Name", - "summary": "User-friendly name for the address", - "value": "NoSapling" - }, - { - "name": "ExcludeSapling", - "summary": "Option to exclude Sapling receivers from the address", - "value": "ExcludeSapling" - } - ], - "result": - { - "name": "NoSapling", - "value": { - "index": 16, - "account": 3, - "name": "NoSapling", - "ua": "utest14yvw4msvn9r5nggv2s0yye8phqwrhsx8ddfvpg30zp4gtf928myaua8jwxssl7frr8eagvcrsa8tuu9dlh7cvksv3lkudvyrq2ysrtzate0dud7x0zhgz26wqccn8w7346v4kfagv3e", - "legacy": null, - "transparent": "tmQ7z6q46NLQXpeNkfeRL6wJwJWA4picf6b" - } - } - }, - { - "name": "GetNewAddress - Orchard only", - "summary": "Get a new address for the given account with only an Orchard receiver", - "description": "Get a new address for the given account with an Orchard receiver and *no* transparent receiver, and *no* Sapling receiver.", - "params": [ - { - "name": "Account Id", - "summary": "The account index", - "value": 1 - }, - { - "name": "Name", - "summary": "User-friendly name for the address", - "value": "OrchardOnly" - }, - { - "name": "ExcludeSapling", - "summary": "Option to exclude Sapling receivers from the address", - "value": "ExcludeSapling" - }, - { - "name": "ExcludeTransparent", - "summary": "Option to exclude transparent receivers from the address", - "value": "ExcludeTransparent" - } - ], - "result": - { - "name": "OrchardOnly", - "value": { - "index": 17, - "account": 3, - "name": "OrchardOnly", - "ua": "utest1890l0xjxcsapk0u7jnqdglzwp04rt4r8zfvh7qx6a76fq96fyxg9xysvklwjymm9xuxzk0578pvv3yzv0w8l5x4run96mahky5defw0m", - "legacy": null, - "transparent": null - } - } - } - ], - "errors": [ - { "$ref": "#/components/errors/InvalidAccount" }, - { "$ref": "#/components/errors/ZenithBusy" }, - { "$ref": "#/components/errors/DuplicateName" } - ] - }, - { - "name": "getbalance", - "summary": "Get the balance of the given account", - "description": "Get the balance of the given account, including any unconfirmed balance.", - "tags": [], - "params": [{ "$ref": "#/components/contentDescriptors/AccountId"}], - "result": { - "name": "Balance", - "schema": { - "type": "object", - "properties": { - "confirmed": {"$ref": "#/components/schemas/Balance" }, - "unconfirmed": {"$ref": "#/components/schemas/Balance" } - } - } - }, - "examples": [ - { - "name": "GetBalance example", - "summary": "Get account balance", - "description": "Provides the balance for the current account, showing the balance for the transparent, Sapling and Orchard pools, both for confirmed notes and unconfirmed notes", - "params": [ - { - "name": "accountId", - "summary": "The integer ID of the account to use", - "value": 1 - } - ], - "result": { - "name": "GetBalance result", - "value":{ - "confirmed": { - "orchard": 22210259, - "sapling": 0, - "transparent": 0 - }, - "unconfirmed": { - "orchard": 0, - "sapling": 0, - "transparent": 0 - } - } - } - } - ], - "errors": [ - { "$ref": "#/components/errors/InvalidAccount" } - ] - }, - { - "name": "listreceived", - "summary": "List received transactions", - "description": "List transactions received by the given address.", - "tags": [], - "params": [{ "$ref": "#/components/contentDescriptors/Address"}], - "paramStructure": "by-position", - "result": { - "name": "Transactions", - "schema": { - "type": "array", - "items": { - "$ref": "#/components/schemas/ZcashNote" - } - } - }, - "examples": [ - { - "name": "ListReceived by Id", - "summary": "Get list of notes received by the address ID", - "description": "Provides the list of notes received by the address identified by the index provided as a parameter", - "params": [ - { - "name": "Address index", - "summary": "The index for the address to use", - "value": "1" - } - ], - "result": { - "name": "ListReceived by Id result", - "value": [ - { - "txid": "987fcdb9bd37cbb5b205a8336de60d043f7028bebaa372828d81f3da296c7ef9", - "pool": "p2pkh", - "amount": 0.13773064, - "amountZats": 13773064, - "memo": "", - "confirmed": true, - "blockheight": 2767099, - "blocktime": 1711132723, - "outindex": 0, - "change": false - }, - { - "txid": "186bdbc64f728c9d0be96082e946a9228153e24a70e20d8a82f0601da679e0c2", - "pool": "orchard", - "amount": 0.0005, - "amountZats": 50000, - "memo": "�", - "confirmed": true, - "blockheight": 2801820, - "blocktime": 1713399060, - "outindex": 0, - "change": false - } - ] - } - }, - { - "name": "ListReceived by Address", - "summary": "Get list of notes received by the address", - "description": "Provides the list of notes received by the address provided as a parameter", - "params": [ - { - "name": "Address", - "summary": "The address to use", - "value": "ztestsapling1mpup3xv2k9clxaf9wjcr0dt5gnmkprz9s9qsn298mqs356pf39wmh30q3pgsp0w5vyrmj6mrzw2" - } - ], - "result": { - "name": "ListReceived by Address result", - "value": [ - { - "txid": "2a104393d72d1e62c94654950a92931e786a1f04aa732512597638b5c4a69a91", - "pool": "sapling", - "amount": 0.11447195, - "amountZats": 11447195, - "memo": "�", - "confirmed": true, - "blockheight": 2800319, - "blocktime": 1713301802, - "outindex": 0, - "change": false - } - ] - } - } - ], - "errors": [ - { "$ref": "#/components/errors/ZebraNotAvailable" }, - { "$ref": "#/components/errors/UnknownAddress" }, - { "$ref": "#/components/errors/InvalidAddress" } - ] - }, - { - "name": "sendmany", - "summary": "Send transaction(s)", - "description": "Send one transaction by specifying the source account, the privacy policy (optional, default 'Full') and an array of proposed outputs. Each output needs a recipient address, an amount and an optional shielded memo.", - "tags": [], - "params": [ - { "$ref": "#/components/contentDescriptors/AccountId"}, - { "$ref": "#/components/contentDescriptors/PrivacyPolicy"}, - { "$ref": "#/components/contentDescriptors/TxRequestArray"} - ], - "paramStructure": "by-position", - "result": { - "name": "Operation ID(s)", - "schema": { - "type": "array", - "items": { "$ref": "#/components/contentDescriptors/OperationId"} - } - }, - "examples": [ - { - "name": "Send a transaction", - "summary": "Send a transaction", - "description": "Send a transaction with one output", - "params": [ - { - "name": "Account index", - "summary": "The index for the account to use", - "value": "1" - }, - { - "name": "Privacy Policy", - "summary": "The selected privacy policy", - "value": "Full" - }, - { - "name": "Transaction request", - "summary": "The transaction to attempt", - "value": [ - { - "address": "utest13dq4u4dnf3yddw8lq2n6zdclshra6xsp8zgkc5ydyu6k20zrsscmuex46qa4vh84rgd78sqnlleapznnz7mnzx9wv0unts8pv32paj8se5ca3kves2u4a89uy6e8cf4hnarxydxh7hq2e9uu39punfmm53k5h45xn9k3dx35la8j7munh9td7774m8gkqgc4mn40t69w20uu2gtks7a", - "amount": 2.45, - "memo": "Simple transaction" - } - ] - } - ], - "result": { - "name": "SendMany result", - "value": [ - "3cc31c07-07cf-4a6e-9190-156c4b8c4088" - ] - } - } - ], - "errors": [ - { "$ref": "#/components/errors/ZebraNotAvailable" }, - { "$ref": "#/components/errors/ZenithBusy" }, - { "$ref": "#/components/errors/InvalidAccount" } - ] - }, - { - "name": "getoperationstatus", - "summary": "Get the status of a Zenith operation", - "description": "Get the status of the given operation", - "tags": [], - "params": [{ "$ref": "#/components/contentDescriptors/OperationId"}], - "paramStructure": "by-position", - "result": { - "name": "Operation", - "schema": { - "$ref": "#/components/schemas/Operation" - } - }, - "errors": [ - { "$ref": "#/components/errors/OpNotFound" } - ] - } - ], - "components": { - "contentDescriptors": { - "WalletId": { - "name": "Wallet ID", - "summary": "The wallet's internal index used for unique identification", - "description": "An Integer value that uniquely identifies a wallet in Zenith", - "required": true, - "schema": { - "type": "integer" - } - }, - "AccountId": { - "name": "Account ID", - "summary": "The account's internal index used for unique identification", - "description": "An Integer value that uniquely identifies an account in Zenith", - "required": true, - "schema": { - "type": "integer" - } - }, - "Address": { - "name": "Address identifier", - "summary": "The address identifier", - "description": "A string that identifies a specific address, either by its index or the [ZIP-316](https://zips.z.cash/zip-0316) encoded address itself", - "required": true, - "schema": { - "type": "string" - } - }, - "Name": { - "name": "Name", - "summary": "A user-friendly name", - "description": "A string that represents an entity in Zenith, like a wallet, an account or an address.", - "required": true, - "schema": { - "type": "string" - } - }, - "ExcludeSapling": { - "name": "ExcludeSapling", - "summary": "Setting that indicates that the new address requested should not contain a Sapling component", - "description": "When this parameter is present, Zenith will generate an address with no Sapling receiver", - "required": false, - "schema" : { - "type": "string" - } - }, - "ExcludeTransparent": { - "name": "ExcludeTransparent", - "summary": "Setting that indicates that the new address requested should not contain a Transparent component", - "description": "When this parameter is present, Zenith will generate an address with no Transparent receiver", - "required": false, - "schema" : { - "type": "string" - } - }, - "OperationId": { - "name": "Operation ID", - "summary": "A unique identifier for Zenith operations", - "description": "A [UUID](http://en.wikipedia.org/wiki/UUID) assigned to an operation (like sending a transaction) that can be used to query Zenith to see the status and outcome of the operation.", - "required": true, - "schema" : { - "type": "string" - } - }, - "TxRequestArray": { - "name": "Transaction Request Array", - "summary": "An array of proposed transactions", - "description": "An array of proposed new outgoing transactions, including the recipient's address, the amount in ZEC, the optional shielded memo, and the optional privacy level.", - "required": true, - "schema": { - "type": "array", - "items": { "$ref": "#/components/schemas/TxRequest"} - } - }, - "PrivacyPolicy": { - "name": "Privacy Policy", - "summary": "The chosen privacy policy to use for the transaction", - "description": "The privacy policy to use for the transaction. `Full` policy allows shielded funds to be transferred within their shielded pools. `Medium` policy allows shielded funds to cross shielded pools. `Low` allows deshielding transactions into transparent receivers but not to exchange addresses. `None` allows for transparent funds to be spent to transparent addresses and exchange addresses.", - "required": false, - "schema": { - "type": "string", - "enum": ["None", "Low", "Medium", "Full"] - } - } - }, - "schemas": { - "ZenithInfo": { - "type": "object", - "properties": { - "version": { "type": "string", "description": "Zenith's version"}, - "network": { "type": "string", "description": "The network the wallet is connected to"}, - "zebraVersion": { "type": "string", "description": "The version of the Zebra node used by Zenith"} - } - }, - "ZcashWallet": { - "type": "object", - "properties": { - "index": { "type": "integer", "description": "Internal index of wallet"}, - "name": { "type": "string", "description": "User-friendly name of the wallet" }, - "network": { "type": "string", "description": "Network the wallet is for. Testnet or MainNet" }, - "birthday": { "type": "integer", "description": "Wallet's birthday height" }, - "lastSync": { "type": "integer", "description": "Last block the wallet is synced to" } - } - }, - "ZcashAccount": { - "type": "object", - "properties": { - "index": { "type": "integer", "description": "Internal index for account"}, - "wallet": { "type": "integer", "description": "ID of the wallet this account belongs to"}, - "name": { "type": "string", "description": "User-friendly name of the account"} - } - }, - "ZcashAddress": { - "type": "object", - "properties": { - "index": { "type": "integer", "description": "Internal index for address"}, - "account": { "type": "integer", "description": "ID of the account this address belongs to"}, - "name": { "type": "string", "description": "User-friendly name of the address"}, - "ua": { "type": "string", "description": "Unified address"}, - "legacy": { "type": "string", "description": "Legacy Sapling address"}, - "transparent": { "type": "string", "description": "Transparent address"} - } - }, - "ZcashNote": { - "type": "object", - "properties": { - "txid": { "type": "string", "description": "Transaction ID"}, - "pool": { "type": "string", "description": "Orchard, Sapling, or Transparent" }, - "amount" : { "type": "number", "description": "The amount of the note in ZEC"}, - "amountZats": { "type": "integer", "description": "The amount of the note in zats"}, - "memo": { "type": "string", "description": "The memo corresponding to the note, if any"}, - "confirmed": { "type": "boolean", "description": "If the note is confirmed per the thresholds in the configuration"}, - "blockheight": { "type": "integer", "description": "The block height containing the transaction"}, - "blocktime": { "type": "integer", "description": "The transaction time in seconds since epoch"}, - "outindex": { "type": "integer", "description": "The Sapling output index, or the Orchard action index"}, - "change": { "type": "boolean", "description": "True if this output was received by a change address"} - } - }, - "Balance": { - "type": "object", - "properties": { - "transparent": { "type": "integer", "description": "Confirmed transparent balance in zats." }, - "sapling": { "type": "integer", "description": "Confirmed Sapling balance in zats." }, - "orchard": { "type": "integer", "description": "Confirmed Orchard balance in zats." } - } - }, - "Operation": { - "type": "object", - "properties": { - "uuid": {"type": "string", "description": "Operation Identifier"}, - "start": {"type": "string", "description": "The date and time the operation started"}, - "end": {"type": ["string", "null"], "description": "The date and time the operation ended. If the operation is still running, this field is null"}, - "status": {"type": "string", "enum": ["Processing", "Failed", "Successful"], "description": "If the operation has started it will show Processing, once it completes it will show Failed or Successful depending on the outcome"}, - "result": {"type": ["string", "null"], "description": "For a succesful transaction operation, the transaction ID. For failed operations, the error message. For pending operations, this field is null."} - } - }, - "TxRequest": { - "type": "object", - "properties": { - "address": { "type": "string", "description": "Recipient's address (unified, Sapling or transparent)" }, - "amount": { "type": "number", "description": "The amount to send in ZEC"}, - "memo": { "type": "string", "description": "The shielded memo to include, if applicable"} - } - } - }, - "examples": {}, - "tags": { - "draft": {"name": "Draft"}, - "wip": {"name": "WIP"} - }, - "errors": { - "ZebraNotAvailable": { - "code": -32000, - "message": "Zebra not available" - }, - "NoWallets": { - "code": -32001, - "message": "No wallets available. Please create one first" - }, - "NoAccounts": { - "code": -32002, - "message": "No accounts available. Please create one first" - }, - "NoAddress": { - "code": -32003, - "message": "No addresses available for this account. Please create one first" - }, - "UnknownAddress": { - "code": -32004, - "message": "Address does not belong to the wallet" - }, - "InvalidAddress": { - "code": -32005, - "message": "Unable to parse address" - }, - "InvalidAccount": { - "code": -32006, - "message": "Account does not exist." - }, - "DuplicateName": { - "code": -32007, - "message": "Entity with that name already exists." - }, - "InvalidWallet": { - "code": -32008, - "message": "Wallet does not exist." - }, - "OpNotFound": { - "code": -32009, - "message": "Operation ID not found." - }, - "InternalError": { - "code": -32010, - "message": "Varies" - }, - "InvalidRecipient": { - "code": -32011, - "message": "The provided recipient address is not valid." - }, - "ZenithBusy": { - "code": -32012, - "message": "The Zenith server is syncing, please try again later." - } - } - } -} diff --git a/zenith.cabal b/zenith.cabal index 8691137..2aacd50 100644 --- a/zenith.cabal +++ b/zenith.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: zenith -version: 0.7.1.0-beta +version: 0.6.0.0-beta license: MIT license-file: LICENSE author: Rene Vergara @@ -35,65 +35,56 @@ library Zenith.Utils Zenith.Zcashd Zenith.Scanner - Zenith.RPC - Zenith.Tree hs-source-dirs: src build-depends: Clipboard - , Hclip - , JuicyPixels , aeson , array , ascii-progress - , async , base >=4.12 && <5 , base64-bytestring - , binary - , borsh , brick , bytestring - , configurator , data-default , directory - , esqueleto - , exceptions , filepath + , esqueleto + , resource-pool + , binary + , exceptions + , monad-logger + , vty-crossplatform + , secp256k1-haskell >= 1 + , pureMD5 , ghc - , generics-sop , haskoin-core , hexstring , http-client , http-conduit , http-types + , JuicyPixels + , qrcode-core + , qrcode-juicypixels , microlens , microlens-mtl , microlens-th - , monad-logger - , transformers , monomer , mtl , persistent + , Hclip , persistent-sqlite , persistent-template , process - , pureMD5 - , qrcode-core - , qrcode-juicypixels , regex-base , regex-compat , regex-posix - , resource-pool , scientific - , secp256k1-haskell >= 1 - , servant-server , text , text-show , time - , uuid , vector , vty - , vty-crossplatform , word-wrap , zcash-haskell --pkgconfig-depends: rustzcash_wrapper @@ -119,21 +110,15 @@ executable zenith pkgconfig-depends: rustzcash_wrapper default-language: Haskell2010 -executable zenithserver - ghc-options: -main-is Server -threaded -rtsopts -with-rtsopts=-N - main-is: Server.hs +executable zenscan + ghc-options: -main-is ZenScan -threaded -rtsopts -with-rtsopts=-N + main-is: ZenScan.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 @@ -147,11 +132,8 @@ test-suite zenith-tests build-depends: base >=4.12 && <5 , bytestring - , aeson , configurator , monad-logger - , borsh - , aeson , data-default , sort , text @@ -166,34 +148,3 @@ 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