diff --git a/.gitignore b/.gitignore index c368d45..1c231fa 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ .stack-work/ -*~ \ No newline at end of file +*~ +dist-newstyle/ diff --git a/.gitmodules b/.gitmodules index 1c89539..53b8dda 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,6 +1,4 @@ -[submodule "haskoin-core"] - path = haskoin-core - url = https://github.com/khazaddum/haskoin-core.git [submodule "zcash-haskell"] path = zcash-haskell - url = git@git.vergara.tech:Vergara_Tech/zcash-haskell.git + url = https://git.vergara.tech/Vergara_Tech/zcash-haskell.git + branch = dev040 diff --git a/CHANGELOG.md b/CHANGELOG.md index 1f8f2f6..2ebaabf 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,55 @@ 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.5.0.0] + +### Added + +- Core functions for sending transactions + +## [0.4.6.0] + +### Added + +- Display of account balance +- Functions to identify spends +- Functions to display transactions per address + +### Changed + +- Update `zcash-haskell` + +## [0.4.5.0] + +### Added + +- Functions to scan relevant transparent notes +- Functions to scan relevant Sapling notes +- Functions to scan relevant Orchard notes +- Function to query `zebrad` for commitment trees + +### Changed + +- Update `zcash-haskell` + +## [0.4.4.3] + +### Added + +- `Core` module +- `CLI` module +- `DB` module +- Command line arguments to switch to legacy version +- New configuration parameter for Zebra port +- New functions to call `getinfo` and `getblockchaininfo` RPC methods +- `Scanner` module + +## [0.4.1] + +### Fixed + +- Handling of transactions to transparent receivers + ## [0.4.0] ### Added diff --git a/LICENSE b/LICENSE index 099f1aa..03b6d4f 100644 --- a/LICENSE +++ b/LICENSE @@ -1,178 +1,22 @@ -Copyright (c) 2022 Vergara Technologies +MIT License -======================================================= -Bootstrap Open Source Licence ("BOSL") v. 1.0 -======================================================= -This Bootstrap Open Source Licence (the "License") applies to any original work -of authorship (the "Original Work") whose owner (the "Licensor") has placed the -following licensing notice adjacent to the copyright notice for the Original -Work: +Copyright (c) 2022-2024 Vergara Technologies LLC -*Licensed under the Bootstrap Open Source Licence version 1.0* +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: -1. **Grant of Copyright License.** Licensor grants You a worldwide, - royalty-free, non-exclusive, sublicensable license, for the duration of the - copyright in the Original Work, to do the following: +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. - a. to reproduce the Original Work in copies, either alone or as part of - a collective work; +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. - b. to translate, adapt, alter, transform, modify, or arrange the - Original Work, thereby creating derivative works ("Derivative Works") - based upon the Original Work; - - c. to distribute or communicate copies of the Original Work and - Derivative Works to the public, provided that prior to any such - distribution or communication You first place a machine-readable copy - of the Source Code of the Original Work and such Derivative Works that - You intend to distribute or communicate in an information repository - reasonably calculated to permit inexpensive and convenient access - thereto by the public (“Information Repository”) for as long as You - continue to distribute or communicate said copies, accompanied by an - irrevocable offer to license said copies to the public free of charge - under this License, said offer valid starting no later than 12 months - after You first distribute or communicate said copies; - - d. to perform the Original Work publicly; and - - e. to display the Original Work publicly. - -2. **Grant of Patent License.** Licensor grants You a worldwide, royalty-free, -non-exclusive, sublicensable license, under patent claims owned or controlled -by the Licensor that are embodied in the Original Work as furnished by the -Licensor, for the duration of the patents, to make, use, sell, offer for sale, -have made, and import the Original Work and Derivative Works. - -3. **Grant of Source Code License.** The "Source Code" for a work means the -preferred form of the work for making modifications to it and all available -documentation describing how to modify the work. Licensor agrees to provide a -machine-readable copy of the Source Code of the Original Work along with each -copy of the Original Work that Licensor distributes. Licensor reserves the -right to satisfy this obligation by placing a machine-readable copy of said -Source Code in an Information Repository for as long as Licensor continues to -distribute the Original Work. - -4. **Exclusions From License Grant.** Neither the names of Licensor, nor the -names of any contributors to the Original Work, nor any of their trademarks or -service marks, may be used to endorse or promote products derived from this -Original Work without express prior permission of the Licensor. Except as -expressly stated herein, nothing in this License grants any license to -Licensor's trademarks, copyrights, patents, trade secrets or any other -intellectual property. No patent license is granted to make, use, sell, offer -for sale, have made, or import embodiments of any patent claims other than the -licensed claims defined in Section 2. No license is granted to the trademarks -of Licensor even if such marks are included in the Original Work. Nothing in -this License shall be interpreted to prohibit Licensor from licensing under -terms different from this License any Original Work that Licensor otherwise -would have a right to license. - -5. **External Deployment.** The term "External Deployment" means the use, -distribution, or communication of the Original Work or Derivative Works in any -way such that the Original Work or Derivative Works may be used by anyone other -than You, whether those works are distributed or communicated to those persons -or made available as an application intended for use over a network. As an -express condition for the grants of license hereunder, You must treat any -External Deployment by You of the Original Work or a Derivative Work as a -distribution under section 1(c). - -6. **Attribution Rights.** You must retain, in the Source Code of any -Derivative Works that You create, all copyright, patent, or trademark notices -from the Source Code of the Original Work, as well as any notices of licensing -and any descriptive text identified therein as an "Attribution Notice." You -must cause the Source Code for any Derivative Works that You create to carry a -prominent Attribution Notice reasonably calculated to inform recipients that -You have modified the Original Work. - -7. **Warranty of Provenance and Disclaimer of Warranty.** Licensor warrants -that the copyright in and to the Original Work and the patent rights granted -herein by Licensor are owned by the Licensor or are sublicensed to You under -the terms of this License with the permission of the contributor(s) of those -copyrights and patent rights. Except as expressly stated in the immediately -preceding sentence, the Original Work is provided under this License on an "AS -IS" BASIS and WITHOUT WARRANTY, either express or implied, including, without -limitation, the warranties of non-infringement, merchantability or fitness for -a particular purpose. THE ENTIRE RISK AS TO THE QUALITY OF THE ORIGINAL WORK IS -WITH YOU. This DISCLAIMER OF WARRANTY constitutes an essential part of this -License. No license to the Original Work is granted by this License except -under this disclaimer. - -8. **Limitation of Liability.** Under no circumstances and under no legal -theory, whether in tort (including negligence), contract, or otherwise, shall -the Licensor be liable to anyone for any indirect, special, incidental, or -consequential damages of any character arising as a result of this License or -the use of the Original Work including, without limitation, damages for loss of -goodwill, work stoppage, computer failure or malfunction, or any and all other -commercial damages or losses. This limitation of liability shall not apply to -the extent applicable law prohibits such limitation. - -9. **Acceptance and Termination.** If, at any time, You expressly assented to -this License, that assent indicates your clear and irrevocable acceptance of -this License and all of its terms and conditions. If You distribute or -communicate copies of the Original Work or a Derivative Work, You must make a -reasonable effort under the circumstances to obtain the express assent of -recipients to the terms of this License. This License conditions your rights to -undertake the activities listed in Section 1, including your right to create -Derivative Works based upon the Original Work, and doing so without honoring -these terms and conditions is prohibited by copyright law and international -treaty. Nothing in this License is intended to affect copyright exceptions and -limitations (including 'fair use' or 'fair dealing'). This License shall -terminate immediately and You may no longer exercise any of the rights granted -to You by this License upon your failure to honor the conditions in Section -1(c). - -10. **Termination for Patent Action.** This License shall terminate -automatically and You may no longer exercise any of the rights granted to You -by this License as of the date You commence an action, including a cross-claim -or counterclaim, against Licensor or any licensee alleging that the Original -Work infringes a patent. This termination provision shall not apply for an -action alleging patent infringement by combinations of the Original Work with -other software or hardware. - -11. **Jurisdiction, Venue and Governing Law.** Any action or suit relating to -this License may be brought only in the courts of a jurisdiction wherein the -Licensor resides or in which Licensor conducts its primary business, and under -the laws of that jurisdiction excluding its conflict-of-law provisions. The -application of the United Nations Convention on Contracts for the International -Sale of Goods is expressly excluded. Any use of the Original Work outside the -scope of this License or after its termination shall be subject to the -requirements and penalties of copyright or patent law in the appropriate -jurisdiction. This section shall survive the termination of this License. - -12. **Attorneys' Fees.** In any action to enforce the terms of this License or -seeking damages relating thereto, the prevailing party shall be entitled to -recover its costs and expenses, including, without limitation, reasonable -attorneys' fees and costs incurred in connection with such action, including -any appeal of such action. This section shall survive the termination of this -License. - -13. **Miscellaneous.** If any provision of this License is held to be -unenforceable, such provision shall be reformed only to the extent necessary to -make it enforceable. - -14. **Definition of "You" in This License.** "You" throughout this License, -whether in upper or lower case, means an individual or a legal entity -exercising rights under, and complying with all of the terms of, this License. -For legal entities, "You" includes any entity that controls, is controlled by, -or is under common control with you. For purposes of this definition, "control" -means (i) the power, direct or indirect, to cause the direction or management -of such entity, whether by contract or otherwise, or (ii) ownership of fifty -percent (50%) or more of the outstanding shares, or (iii) beneficial ownership -of such entity. - -15. **Right to Use.** You may use the Original Work in all ways not otherwise -restricted or conditioned by this License or by law, and Licensor promises not -to interfere with or be responsible for such uses by You. - -16. **Modification of This License.** This License is Copyright © 2007 Zooko -Wilcox-O'Hearn. Permission is granted to copy, distribute, or communicate this -License without modification. Nothing in this License permits You to modify -this License as applied to the Original Work or to Derivative Works. However, -You may modify the text of this License and copy, distribute or communicate -your modified version (the "Modified License") and apply it to other original -works of authorship subject to the following conditions: (i) You may not -indicate in any way that your Modified License is the "Bootstrap Open Source -Licence" or "BOSL" and you may not use those names in the name of your Modified -License; and (ii) You must replace the notice specified in the first paragraph -above with the notice "Licensed under " or with -a notice of your own that is not confusingly similar to the notice in this -License. diff --git a/README.md b/README.md index 59ac7b3..2c0cfe0 100644 --- a/README.md +++ b/README.md @@ -10,7 +10,8 @@ Zcash Full Node CLI ``` -[![Please don't upload to GitHub](https://nogithub.codeberg.page/badge.svg)](https://nogithub.codeberg.page) +[![Please don't upload to GitHub](https://nogithub.codeberg.page/badge.svg)](https://nogithub.codeberg.page) ![](https://img.shields.io/badge/License-MIT-green +) Zenith is a command-line interface for the Zcash Full Node (`zcashd`). It has the following features: @@ -20,8 +21,6 @@ Zenith is a command-line interface for the Zcash Full Node (`zcashd`). It has th - Creating new Unified Addresses. - Sending transactions with shielded memo support. -Note: Zenith depends on a patched version of the `haskoin-core` Haskell package included in this repo. A pull request to the maintainers of `haskoin-core` has been submitted, if/when it is merged, Zenith will be updated to use the standard package. - ## Installation - Install dependencies: @@ -37,13 +36,13 @@ Note: Zenith depends on a patched version of the `haskoin-core` Haskell package git clone https://git.vergara.tech/Vergara_Tech/zenith.git cd zenith git submodule init -git submodule update +git submodule update --remote ``` -- Install using `stack`: +- Install using `cabal`: ``` -stack install +cabal install ``` ## Configuration diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..3ca9c28 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,131 @@ +import Control.Exception (throw) +import Control.Monad (forM_, when) +import Data.Maybe (isNothing) +import Distribution.PackageDescription +import Distribution.Simple +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), localPkgDescr) +import Distribution.Simple.PreProcess +import Distribution.Simple.Program.Find + ( defaultProgramSearchPath + , findProgramOnSearchPath + ) +import Distribution.Simple.Setup +import Distribution.Simple.Utils + ( IODataMode(IODataModeBinary) + , maybeExit + , rawSystemStdInOut + ) +import Distribution.Verbosity (Verbosity) +import qualified Distribution.Verbosity as Verbosity +import System.Directory + ( XdgDirectory(..) + , copyFile + , createDirectory + , createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , getCurrentDirectory + , getDirectoryContents + , getHomeDirectory + , getXdgDirectory + ) +import System.Environment +import System.FilePath (()) +import Text.Regex +import Text.Regex.Base + +main :: IO () +main = defaultMainWithHooks hooks + where + hooks = + simpleUserHooks + { preConf = + \_ flags -> do + prepDeps (fromFlag $ configVerbosity flags) + pure emptyHookedBuildInfo + --, confHook = \a flags -> confHook simpleUserHooks a flags >>= rsAddDirs + } + +execCargo :: Verbosity -> String -> [String] -> IO () +execCargo verbosity command args = do + cargoPath <- + findProgramOnSearchPath Verbosity.silent defaultProgramSearchPath "cargo" + dir <- getCurrentDirectory + let cargoExec = + case cargoPath of + Just (p, _) -> p + Nothing -> "cargo" + cargoArgs = command : args + workingDir = Just (dir rsFolder) + thirdComponent (_, _, c) = c + maybeExit . fmap thirdComponent $ + rawSystemStdInOut + verbosity + cargoExec + cargoArgs + workingDir + Nothing + Nothing + IODataModeBinary + +rsMake :: Verbosity -> IO () +rsMake verbosity = do + execCargo verbosity "cbuild" [] + +prepDeps :: Verbosity -> IO () +prepDeps verbosity = do + ldPath <- lookupEnv "LD_LIBRARY_PATH" + pkgPath <- lookupEnv "PKG_CONFIG_PATH" + if maybe False (matchTest (mkRegex ".*zcash-haskell.*")) ldPath && + maybe False (matchTest (mkRegex ".*zcash-haskell.*")) pkgPath + then do + execCargo verbosity "cbuild" [] + localData <- getXdgDirectory XdgData "zcash-haskell" + createDirectoryIfMissing True localData + dir <- getCurrentDirectory + let rustLibDir = + dir rsFolder "target/x86_64-unknown-linux-gnu/debug" + copyDir rustLibDir localData + else throw $ + userError "Paths not set correctly, please run the 'configure' script." + +rsFolder :: FilePath +rsFolder = "zcash-haskell/librustzcash-wrapper" + +rsAddDirs :: LocalBuildInfo -> IO LocalBuildInfo +rsAddDirs lbi' = do + dir <- getCurrentDirectory + let rustIncludeDir = + dir rsFolder "target/x86_64-unknown-linux-gnu/debug" + rustLibDir = dir rsFolder "target/x86_64-unknown-linux-gnu/debug" + updateLbi lbi = lbi {localPkgDescr = updatePkgDescr (localPkgDescr lbi)} + updatePkgDescr pkgDescr = + pkgDescr {library = updateLib <$> library pkgDescr} + updateLib lib = lib {libBuildInfo = updateLibBi (libBuildInfo lib)} + updateLibBi libBuild = + libBuild + { includeDirs = rustIncludeDir : includeDirs libBuild + , extraLibDirs = rustLibDir : extraLibDirs libBuild + } + pure $ updateLbi lbi' + +copyDir :: FilePath -> FilePath -> IO () +copyDir src dst = do + whenM (not <$> doesDirectoryExist src) $ + throw (userError "source does not exist") + --whenM (doesFileOrDirectoryExist dst) $ + --throw (userError "destination already exists") + createDirectoryIfMissing True dst + content <- getDirectoryContents src + let xs = filter (`notElem` [".", ".."]) content + forM_ xs $ \name -> do + let srcPath = src name + let dstPath = dst name + isDirectory <- doesDirectoryExist srcPath + if isDirectory + then copyDir srcPath dstPath + else copyFile srcPath dstPath + where + doesFileOrDirectoryExist x = orM [doesDirectoryExist x, doesFileExist x] + orM xs = or <$> sequence xs + whenM s r = s >>= flip when r diff --git a/app/Main.hs b/app/Main.hs index 06a532e..eb13ce7 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -12,10 +12,16 @@ import qualified Data.Text as T import qualified Data.Text.IO as TIO import Data.Time.Clock.POSIX import System.Console.StructuredCLI +import System.Environment (getArgs) import System.Exit import System.IO import Text.Read (readMaybe) -import Zenith +import ZcashHaskell.Types +import Zenith.CLI +import Zenith.Core (clearSync, testSync) +import Zenith.Types (Config(..), ZcashAddress(..), ZcashPool(..), ZcashTx(..)) +import Zenith.Utils +import Zenith.Zcashd prompt :: String -> IO String prompt text = do @@ -194,14 +200,35 @@ processUri user pwd = main :: IO () main = do config <- load ["zenith.cfg"] + args <- getArgs + dbFilePath <- require config "dbFilePath" nodeUser <- require config "nodeUser" nodePwd <- require config "nodePwd" - checkServer nodeUser nodePwd - void $ - runCLI - "Zenith" - def - { getBanner = - " ______ _ _ _ \n |___ / (_) | | | \n / / ___ _ __ _| |_| |__ \n / / / _ \\ '_ \\| | __| '_ \\ \n / /_| __/ | | | | |_| | | |\n /_____\\___|_| |_|_|\\__|_| |_|\n Zcash Full Node CLI v0.4.0" - } - (root nodeUser nodePwd) + zebraPort <- require config "zebraPort" + zebraHost <- require config "zebraHost" + let myConfig = Config dbFilePath zebraHost zebraPort + if not (null args) + then do + case head args of + "legacy" -> do + checkServer nodeUser nodePwd + void $ + runCLI + "Zenith" + def + { getBanner = + " ______ _ _ _ \n |___ / (_) | | | \n / / ___ _ __ _| |_| |__ \n / / / _ \\ '_ \\| | __| '_ \\ \n / /_| __/ | | | | |_| | | |\n /_____\\___|_| |_|_|\\__|_| |_|\n Zcash Full Node CLI v0.4.0" + } + (root nodeUser nodePwd) + "cli" -> runZenithCLI myConfig + "sync" -> testSync myConfig + "rescan" -> clearSync myConfig + _ -> printUsage + else printUsage + +printUsage :: IO () +printUsage = do + putStrLn "zenith [command] [parameters]\n" + putStrLn "Available commands:" + putStrLn "legacy\tLegacy CLI for zcashd" + putStrLn "cli\tCLI for zebrad" diff --git a/app/ZenScan.hs b/app/ZenScan.hs new file mode 100644 index 0000000..05059ca --- /dev/null +++ b/app/ZenScan.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} + +module ZenScan where + +import Control.Monad.Logger (runNoLoggingT) +import Data.Configurator +import Zenith.Scanner (scanZebra) + +main :: IO () +main = do + config <- load ["zenith.cfg"] + dbFilePath <- require config "dbFilePath" + zebraPort <- require config "zebraPort" + zebraHost <- require config "zebraHost" + runNoLoggingT $ scanZebra 2762066 zebraHost zebraPort dbFilePath diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..217198a --- /dev/null +++ b/cabal.project @@ -0,0 +1,15 @@ +packages: + ./*.cabal + zcash-haskell/zcash-haskell.cabal + +with-compiler: ghc-9.4.8 + +source-repository-package + type: git + location: https://git.vergara.tech/Vergara_Tech/haskell-hexstring.git + tag: 39d8da7b11a80269454c2f134a5c834e0f3cb9a7 + +source-repository-package + type: git + location: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git + tag: 335e804454cd30da2c526457be37e477f71e4665 diff --git a/configure b/configure new file mode 100755 index 0000000..df9fc8d --- /dev/null +++ b/configure @@ -0,0 +1,6 @@ +#!/bin/bash + +echo "export PKG_CONFIG_PATH=$HOME/.local/share/zcash-haskell:\$PKG_CONFIG_PATH" | tee -a ~/.bashrc +echo "export LD_LIBRARY_PATH=$HOME/.local/share/zcash-haskell:\$LD_LIBRARY_PATH" | tee -a ~/.bashrc +source ~/.bashrc +cd zcash-haskell && cabal build diff --git a/package.yaml b/package.yaml deleted file mode 100644 index 09eaf30..0000000 --- a/package.yaml +++ /dev/null @@ -1,76 +0,0 @@ -name: zenith -version: 0.4.0 -git: "https://git.vergara.tech/Vergara_Tech/zenith" -license: BOSL -author: "Rene Vergara" -maintainer: "rene@vergara.network" -copyright: "Copyright (c) 2022 Vergara Technologies LLC" - -extra-source-files: -- README.md -- CHANGELOG.md -- zenith.cfg - -# Metadata used when publishing your package -synopsis: Haskell CLI for Zcash Full Node -# category: Web - -# To avoid duplicated efforts in documentation and dealing with the -# complications of embedding Haddock markup inside cabal files, it is -# common to point users to the README.md file. -description: Please see the README on repo at - -dependencies: -- base >= 4.7 && < 5 - -library: - source-dirs: src - dependencies: - - aeson - - text - - bytestring - - http-conduit - - scientific - - vector - - regex-base - - regex-posix - - regex-compat - - Clipboard - - process - - http-types - - array - - base64-bytestring - - hexstring - - blake2 - - zcash-haskell - -executables: - zenith: - main: Main.hs - source-dirs: app - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - - -Wall - - -Wunused-imports - dependencies: - - zenith - - configurator - - structured-cli - - data-default - - bytestring - - text - - time - - sort - -tests: - zenith-test: - main: Spec.hs - source-dirs: test - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - zenith diff --git a/sapling-output.params b/sapling-output.params new file mode 100644 index 0000000..01760fa Binary files /dev/null and b/sapling-output.params differ diff --git a/sapling-spend.params b/sapling-spend.params new file mode 100644 index 0000000..b91cd77 Binary files /dev/null and b/sapling-spend.params differ diff --git a/src/Zenith.hs b/src/Zenith.hs deleted file mode 100644 index 4ad8bb7..0000000 --- a/src/Zenith.hs +++ /dev/null @@ -1,635 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} - -module Zenith where - -import Control.Concurrent (threadDelay) -import Control.Monad -import Crypto.Hash.BLAKE2.BLAKE2b -import Data.Aeson -import Data.Aeson.Types -import qualified Data.Array as A -import Data.Bits -import qualified Data.ByteString as B -import qualified Data.ByteString.Base64 as B64 -import qualified Data.ByteString.Char8 as C -import qualified Data.ByteString.Lazy as LB -import Data.Char -import Data.Functor (void) -import Data.HexString -import Data.Maybe -import qualified Data.Scientific as Scientific -import qualified Data.Text as T -import qualified Data.Text.Encoding as E -import Data.Text.Encoding.Error (lenientDecode) -import qualified Data.Text.IO as TIO -import qualified Data.Vector as V -import Data.Word -import GHC.Generics -import ZcashHaskell.Orchard (isValidUnifiedAddress) -import ZcashHaskell.Sapling (isValidShieldedAddress) - -{-import Haskoin.Address.Bech32-} -import Network.HTTP.Simple -import Network.HTTP.Types -import Numeric -import System.Clipboard -import System.Exit -import System.IO -import System.Process (createProcess_, shell) -import Text.Read (readMaybe) -import Text.Regex -import Text.Regex.Base -import Text.Regex.Posix - --- | A type to model Zcash RPC calls -data RpcCall = RpcCall - { jsonrpc :: T.Text - , id :: T.Text - , method :: T.Text - , params :: [Value] - } deriving (Show, Generic, ToJSON, FromJSON) - --- | Type for modelling the different address sources for Zcash 5.0.0 -data AddressSource - = LegacyRandom - | Imported - | ImportedWatchOnly - | KeyPool - | LegacySeed - | MnemonicSeed - deriving (Read, Show, Eq, Generic, ToJSON) - -instance FromJSON AddressSource where - parseJSON = - withText "AddressSource" $ \case - "legacy_random" -> return LegacyRandom - "imported" -> return Imported - "imported_watchonly" -> return ImportedWatchOnly - "keypool" -> return KeyPool - "legacy_hdseed" -> return LegacySeed - "mnemonic_seed" -> return MnemonicSeed - _ -> fail "Not a known address source" - -data ZcashPool - = Transparent - | Sprout - | Sapling - | Orchard - deriving (Show, Eq, Generic, ToJSON) - -instance FromJSON ZcashPool where - parseJSON = - withText "ZcashPool" $ \case - "p2pkh" -> return Transparent - "sprout" -> return Sprout - "sapling" -> return Sapling - "orchard" -> return Orchard - _ -> fail "Not a known Zcash pool" - -data ZcashAddress = ZcashAddress - { source :: AddressSource - , pool :: [ZcashPool] - , account :: Maybe Integer - , addy :: T.Text - } deriving (Eq) - -instance Show ZcashAddress where - show (ZcashAddress s p i a) = - T.unpack (T.take 8 a) ++ - "..." ++ T.unpack (T.takeEnd 8 a) ++ " Pools: " ++ show p - --- | A type to model the response of the Zcash RPC -data RpcResponse r = RpcResponse - { err :: Maybe T.Text - , respId :: T.Text - , result :: r - } deriving (Show, Generic, ToJSON) - -instance (FromJSON r) => FromJSON (RpcResponse r) where - parseJSON (Object obj) = do - e <- obj .: "error" - rId <- obj .: "id" - r <- obj .: "result" - pure $ RpcResponse e rId r - parseJSON invalid = - prependFailure - "parsing RpcResponse failed, " - (typeMismatch "Object" invalid) - -newtype NodeVersion = - NodeVersion Integer - deriving (Eq, Show) - -instance FromJSON NodeVersion where - parseJSON = - withObject "NodeVersion" $ \obj -> do - v <- obj .: "version" - pure $ NodeVersion v - --- | A type to model an address group -data AddressGroup = AddressGroup - { agsource :: AddressSource - , agtransparent :: [ZcashAddress] - , agsapling :: [ZcashAddress] - , agunified :: [ZcashAddress] - } deriving (Show, Generic) - -instance FromJSON AddressGroup where - parseJSON = - withObject "AddressGroup" $ \obj -> do - s <- obj .: "source" - t <- obj .:? "transparent" - sap <- obj .:? "sapling" - uni <- obj .:? "unified" - sL <- processSapling sap s - tL <- processTransparent t s - uL <- processUnified uni - return $ AddressGroup s tL (concat sL) (concat uL) - where - processTransparent c s1 = - case c of - Nothing -> return [] - Just x -> do - x' <- x .: "addresses" - return $ map (ZcashAddress s1 [Transparent] Nothing) x' - processSapling k s2 = - case k of - Nothing -> return [] - Just y -> mapM (processOneSapling s2) y - where processOneSapling sx = - withObject "Sapling" $ \oS -> do - oS' <- oS .: "addresses" - return $ map (ZcashAddress sx [Sapling] Nothing) oS' - processUnified u = - case u of - Nothing -> return [] - Just z -> mapM processOneAccount z - where processOneAccount = - withObject "UAs" $ \uS -> do - acct <- uS .: "account" - uS' <- uS .: "addresses" - mapM (processUAs acct) uS' - where - processUAs a = - withObject "UAs" $ \v -> do - addr <- v .: "address" - p <- v .: "receiver_types" - return $ ZcashAddress MnemonicSeed p a addr - -displayZec :: Integer -> String -displayZec s - | s < 100 = show s ++ " zats " - | s < 100000 = show (fromIntegral s / 100) ++ " μZEC " - | s < 100000000 = show (fromIntegral s / 100000) ++ " mZEC " - | otherwise = show (fromIntegral s / 100000000) ++ " ZEC " - --- | A type to model a Zcash transaction -data ZcashTx = ZcashTx - { ztxid :: T.Text - , zamount :: Double - , zamountZat :: Integer - , zblockheight :: Integer - , zblocktime :: Integer - , zchange :: Bool - , zconfirmations :: Integer - , zmemo :: T.Text - } deriving (Show, Generic) - -instance FromJSON ZcashTx where - parseJSON = - withObject "ZcashTx" $ \obj -> do - t <- obj .: "txid" - a <- obj .: "amount" - aZ <- obj .: "amountZat" - bh <- obj .: "blockheight" - bt <- obj .: "blocktime" - c <- obj .:? "change" - conf <- obj .: "confirmations" - m <- obj .:? "memo" - pure $ - ZcashTx - t - a - aZ - bh - bt - (fromMaybe False c) - conf - (case m of - Nothing -> "" - Just m' -> T.filter (/= '\NUL') $ decodeHexText m') - -instance ToJSON ZcashTx where - toJSON (ZcashTx t a aZ bh bt c conf m) = - object - [ "amount" .= a - , "amountZat" .= aZ - , "txid" .= t - , "blockheight" .= bh - , "blocktime" .= bt - , "change" .= c - , "confirmations" .= conf - , "memo" .= m - ] - --- | Type for the UA balance -data UABalance = UABalance - { uatransparent :: Integer - , uasapling :: Integer - , uaorchard :: Integer - } deriving (Eq) - -instance Show UABalance where - show (UABalance t s o) = - " T: " ++ show t ++ " S: " ++ show s ++ " O: " ++ show o - -instance FromJSON UABalance where - parseJSON = - withObject "UABalance" $ \obj -> do - p <- obj .: "pools" - t <- p .:? "transparent" - s <- p .:? "sapling" - o <- p .:? "orchard" - vT <- - case t of - Nothing -> return 0 - Just t' -> t' .: "valueZat" - vS <- - case s of - Nothing -> return 0 - Just s' -> s' .: "valueZat" - vO <- - case o of - Nothing -> return 0 - Just o' -> o' .: "valueZat" - pure $ UABalance vT vS vO - --- | Type for Operation Result -data OpResult = OpResult - { opsuccess :: T.Text - , opmessage :: Maybe T.Text - , optxid :: Maybe T.Text - } deriving (Show, Eq) - -instance FromJSON OpResult where - parseJSON = - withObject "OpResult" $ \obj -> do - s <- obj .: "status" - r <- obj .:? "result" - e <- obj .:? "error" - t <- - case r of - Nothing -> return Nothing - Just r' -> r' .: "txid" - m <- - case e of - Nothing -> return Nothing - Just m' -> m' .: "message" - pure $ OpResult s m t - --- | Helper function to turn a hex-encoded memo strings to readable text -decodeHexText :: String -> T.Text -decodeHexText h = E.decodeUtf8With lenientDecode $ B.pack $ hexRead h - where - hexRead hexText - | null chunk = [] - | otherwise = - fromIntegral (read ("0x" <> chunk)) : hexRead (drop 2 hexText) - where - chunk = take 2 hexText - --- | Helper function to turn a string into a hex-encoded string -encodeHexText :: String -> String -encodeHexText t = mconcat (map padHex t) - where - padHex x = - if ord x < 16 - then "0" ++ (showHex . ord) x "" - else showHex (ord x) "" - -encodeHexText' :: T.Text -> String -encodeHexText' t = - if T.length t > 0 - then T.unpack . toText . fromBytes $ E.encodeUtf8 t - else T.unpack . toText . fromBytes $ E.encodeUtf8 "Sent from Zenith" - --- | Helper function to extract addresses from AddressGroups -getAddresses :: AddressGroup -> [ZcashAddress] -getAddresses ag = agtransparent ag <> agsapling ag <> agunified ag - --- | Helper function to validate potential Zcash addresses -validateAddress :: T.Text -> Maybe ZcashPool -validateAddress txt --(tReg || sReg && isJust chk) || (uReg && isJust chk) - | tReg = Just Transparent - | sReg && chkS = Just Sapling - | uReg && chk = Just Orchard - | otherwise = Nothing - where - transparentRegex = "^t1[a-zA-Z0-9]{33}$" :: String - shieldedRegex = "^zs[a-zA-Z0-9]{76}$" :: String - unifiedRegex = "^u[a-zA-Z0-9]" :: String - tReg = T.unpack txt =~ transparentRegex :: Bool - sReg = T.unpack txt =~ shieldedRegex :: Bool - uReg = T.unpack txt =~ unifiedRegex :: Bool - chk = isValidUnifiedAddress $ E.encodeUtf8 txt - chkS = isValidShieldedAddress $ E.encodeUtf8 txt - --- | RPC methods --- | List addresses -listAddresses :: B.ByteString -> B.ByteString -> IO [ZcashAddress] -listAddresses user pwd = do - response <- makeZcashCall user pwd "listaddresses" [] - let rpcResp = decode response :: Maybe (RpcResponse [AddressGroup]) - case rpcResp of - Nothing -> fail "Couldn't parse node response" - Just res -> do - let addys = result res - let addList = concatMap getAddresses addys - return addList - --- | Get address balance -getBalance :: B.ByteString -> B.ByteString -> ZcashAddress -> IO [Integer] -getBalance user pwd zadd = do - let a = account zadd - case a of - Nothing -> do - response <- - makeZcashCall - user - pwd - "z_getbalance" - [ String (addy zadd) - , Number (Scientific.scientific 1 0) - , Data.Aeson.Bool True - ] - let rpcResp = decode response :: Maybe (RpcResponse Integer) - case rpcResp of - Nothing -> fail "Couldn't parse node response" - Just res -> do - return [result res] - Just acct -> do - response <- - makeZcashCall - user - pwd - "z_getbalanceforaccount" - [Number (Scientific.scientific acct 0)] - let rpcResp = decode response :: Maybe (RpcResponse UABalance) - case rpcResp of - Nothing -> fail "Couldn't parse node response" - Just res -> do - return $ readUABalance (result res) - where readUABalance ua = - [uatransparent ua, uasapling ua, uaorchard ua] - --- | List transactions -listTxs :: B.ByteString -> B.ByteString -> ZcashAddress -> IO [ZcashTx] -listTxs user pwd zaddy = do - response <- - makeZcashCall user pwd "z_listreceivedbyaddress" [String $ addy zaddy] - let rpcResp = decode response :: Maybe (RpcResponse [ZcashTx]) - case rpcResp of - Nothing -> fail "listTxs: Couldn't parse node response" - Just res -> do - return $ result res - --- | Send Tx -sendTx :: - B.ByteString - -> B.ByteString - -> ZcashAddress - -> T.Text - -> Double - -> Maybe T.Text - -> IO () -sendTx user pwd fromAddy toAddy amount memo = do - bal <- getBalance user pwd fromAddy - let valAdd = validateAddress toAddy - if sum bal - floor (amount * 100000000) >= 1000 - then do - if source fromAddy /= ImportedWatchOnly - then do - let privacyPolicy - | valAdd == Just Transparent = "AllowRevealedRecipients" - | isNothing (account fromAddy) && - elem Transparent (pool fromAddy) = "AllowRevealedSenders" - | otherwise = "AllowRevealedAmounts" - let pd = - case memo of - Nothing -> - [ Data.Aeson.String (addy fromAddy) - , Data.Aeson.Array - (V.fromList - [object ["address" .= toAddy, "amount" .= amount]]) - , Data.Aeson.Number $ Scientific.scientific 1 1 - , Data.Aeson.Null - , Data.Aeson.String privacyPolicy - ] - Just memo' -> - [ Data.Aeson.String (addy fromAddy) - , Data.Aeson.Array - (V.fromList - [ object - [ "address" .= toAddy - , "amount" .= amount - , "memo" .= encodeHexText' memo' - ] - ]) - , Data.Aeson.Number $ Scientific.scientific 1 1 - , Data.Aeson.Null - , Data.Aeson.String privacyPolicy - ] - response <- makeZcashCall user pwd "z_sendmany" pd - let rpcResp = decode response :: Maybe (RpcResponse T.Text) - case rpcResp of - Nothing -> fail "Couldn't parse node response" - Just res -> do - putStr " Sending." - checkOpResult user pwd (result res) - else putStrLn "Error: Source address is view-only." - else putStrLn "Error: Insufficient balance in source address." - --- | Make a Zcash RPC call -makeZcashCall :: - B.ByteString - -> B.ByteString - -> T.Text - -> [Data.Aeson.Value] - -> IO LB.ByteString -makeZcashCall username password m p = do - let payload = RpcCall "1.0" "test" m p - let myRequest = - setRequestBodyJSON payload $ - setRequestPort 8232 $ - setRequestBasicAuth username password $ - setRequestMethod "POST" defaultRequest - response <- httpLBS myRequest - let respStatus = getResponseStatusCode response - let body = getResponseBody response - case respStatus of - 500 -> do - let rpcResp = decode body :: Maybe (RpcResponse String) - case rpcResp of - Nothing -> fail $ "Unknown server error " ++ show response - Just x -> fail (result x) - 401 -> fail "Incorrect full node credentials" - 200 -> return body - _ -> fail "Unknown error" - --- | Display an address -displayZcashAddress :: - B.ByteString -> B.ByteString -> (Int, ZcashAddress) -> IO () -displayZcashAddress user pwd (idx, zaddy) = do - zats <- getBalance user pwd zaddy - putStr $ show idx ++ ": " - putStr $ show zaddy - when (source zaddy == ImportedWatchOnly) (putStr "[VK]") - putStr " Balance: " - mapM_ (putStr . displayZec) zats - putStrLn "" - --- | Copy an address to the clipboard -copyAddress :: ZcashAddress -> IO () -copyAddress a = - void $ - createProcess_ "toClipboard" $ - shell $ "echo " ++ T.unpack (addy a) ++ " | xclip -r -selection clipboard" - --- | Verify operation result -checkOpResult :: B.ByteString -> B.ByteString -> T.Text -> IO () -checkOpResult user pwd opid = do - response <- - makeZcashCall - user - pwd - "z_getoperationstatus" - [Data.Aeson.Array (V.fromList [Data.Aeson.String opid])] - let rpcResp = decode response :: Maybe (RpcResponse [OpResult]) - case rpcResp of - Nothing -> fail "Couldn't parse node response" - Just res -> do - let r = result res - mapM_ showResult r - where - showResult t = - case opsuccess t of - "success" -> - putStrLn $ " Success! Tx ID: " ++ maybe "" T.unpack (optxid t) - "executing" -> do - putStr "." - hFlush stdout - threadDelay 1000000 >> checkOpResult user pwd opid - _ -> putStrLn $ " Failed :( " ++ maybe "" T.unpack (opmessage t) - --- | Check for accounts -checkAccounts :: B.ByteString -> B.ByteString -> IO Bool -checkAccounts user pwd = do - response <- makeZcashCall user pwd "z_listaccounts" [] - let rpcResp = decode response :: Maybe (RpcResponse [Object]) - case rpcResp of - Nothing -> fail "Couldn't parse node response" - Just res -> do - let r = result res - return $ not (null r) - --- | Add account to node -createAccount :: B.ByteString -> B.ByteString -> IO () -createAccount user pwd = do - response <- makeZcashCall user pwd "z_getnewaccount" [] - let rpcResp = decode response :: Maybe (RpcResponse Object) - case rpcResp of - Nothing -> fail "Couldn't parse node response" - Just res -> do - let r = result res - putStrLn " Account created!" - --- | Create new Unified Address -createUnifiedAddress :: B.ByteString -> B.ByteString -> Bool -> Bool -> IO () -createUnifiedAddress user pwd tRec sRec = do - let recs = getReceivers tRec sRec - let pd = [Data.Aeson.Number $ Scientific.scientific 0 1, recs] - newResp <- makeZcashCall user pwd "z_getaddressforaccount" pd - let rpcResp = decode newResp :: Maybe (RpcResponse Object) - case rpcResp of - Nothing -> fail "Couldn't parse node response" - Just res -> do - let r = result res - putStrLn " New UA created!" - where - getReceivers t s - | t && s = - Data.Aeson.Array - (V.fromList - [ Data.Aeson.String "p2pkh" - , Data.Aeson.String "sapling" - , Data.Aeson.String "orchard" - ]) - | t = - Data.Aeson.Array - (V.fromList [Data.Aeson.String "p2pkh", Data.Aeson.String "orchard"]) - | s = - Data.Aeson.Array - (V.fromList [Data.Aeson.String "sapling", Data.Aeson.String "orchard"]) - | otherwise = Data.Aeson.Array (V.fromList [Data.Aeson.String "orchard"]) - --- | Check Zcash full node server -checkServer :: B.ByteString -> B.ByteString -> IO () -checkServer user pwd = do - resp <- makeZcashCall user pwd "getinfo" [] - let rpcResp = decode resp :: Maybe (RpcResponse NodeVersion) - case rpcResp of - Nothing -> fail "Couldn't parse node response" - Just myResp -> do - let r = result myResp - if isNodeValid r - then putStrLn $ "Connected to Zcash Full Node (" <> show r <> ") :)" - else do - putStrLn "Deprecated Zcash Full Node version found. Exiting" - exitFailure - where isNodeValid (NodeVersion i) = i >= 5000000 - --- | Read ZIP-321 URI -sendWithUri :: - B.ByteString -> B.ByteString -> ZcashAddress -> String -> Bool -> IO () -sendWithUri user pwd fromAddy uri repTo = do - let uriRegex = mkRegex "^zcash:(\\w+)\\?amount=(.*)\\&memo=(.*)$" - if matchTest uriRegex uri - then do - let reg = matchAllText uriRegex uri - let parsedAddress = fst $ head reg A.! 1 - let parsedAmount = fst $ head reg A.! 2 - let parsedEncodedMemo = fst $ head reg A.! 3 - let addType = validateAddress $ T.pack parsedAddress - case addType of - Nothing -> putStrLn " Invalid address" - Just Transparent -> do - putStrLn $ " Address is valid: " ++ parsedAddress - case (readMaybe parsedAmount :: Maybe Double) of - Nothing -> putStrLn " Invalid amount." - Just amt -> do - putStrLn $ " Valid ZEC amount: " ++ show amt - sendTx user pwd fromAddy (T.pack parsedAddress) amt Nothing - Just _ -> do - putStrLn $ " Address is valid: " ++ parsedAddress - case (readMaybe parsedAmount :: Maybe Double) of - Nothing -> putStrLn " Invalid amount." - Just amt -> do - putStrLn $ " Valid ZEC amount: " ++ show amt - let decodedMemo = - E.decodeUtf8With lenientDecode $ - B64.decodeLenient $ C.pack parsedEncodedMemo - TIO.putStrLn $ " Memo: " <> decodedMemo - sendTx - user - pwd - fromAddy - (T.pack parsedAddress) - amt - (if repTo - then Just $ - T.concat [decodedMemo, "\nReply-To:\n", addy fromAddy] - else Just decodedMemo) - else putStrLn "URI is not compliant with ZIP-321" diff --git a/src/Zenith/CLI.hs b/src/Zenith/CLI.hs new file mode 100644 index 0000000..4dabde1 --- /dev/null +++ b/src/Zenith/CLI.hs @@ -0,0 +1,1280 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Zenith.CLI where + +import qualified Brick.AttrMap as A +import qualified Brick.BChan as BC +import qualified Brick.Focus as F +import Brick.Forms + ( Form(..) + , (@@=) + , allFieldsValid + , editShowableFieldWithValidate + , editTextField + , focusedFormInputAttr + , handleFormEvent + , invalidFormInputAttr + , newForm + , renderForm + , setFieldValid + , updateFormState + ) +import qualified Brick.Main as M +import qualified Brick.Types as BT +import Brick.Types (Widget) +import Brick.Util (bg, clamp, fg, on, style) +import qualified Brick.Widgets.Border as B +import Brick.Widgets.Border.Style (unicode, unicodeBold) +import qualified Brick.Widgets.Center as C +import Brick.Widgets.Core + ( Padding(..) + , (<+>) + , (<=>) + , emptyWidget + , fill + , hBox + , hLimit + , joinBorders + , padAll + , padBottom + , str + , strWrap + , strWrapWith + , txt + , txtWrap + , txtWrapWith + , updateAttrMap + , vBox + , vLimit + , withAttr + , withBorderStyle + ) +import qualified Brick.Widgets.Dialog as D +import qualified Brick.Widgets.Edit as E +import qualified Brick.Widgets.List as L +import qualified Brick.Widgets.ProgressBar as P +import Control.Concurrent (forkIO, threadDelay) +import Control.Exception (catch, throw, throwIO, try) +import Control.Monad (forever, void) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Logger (LoggingT, runFileLoggingT, runNoLoggingT) +import Data.Aeson +import Data.HexString (toText) +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import qualified Data.Vector as Vec +import Database.Persist +import Database.Persist.Sqlite +import qualified Graphics.Vty as V +import qualified Graphics.Vty.CrossPlatform as VC +import Lens.Micro ((&), (.~), (^.), set) +import Lens.Micro.Mtl +import Lens.Micro.TH +import System.Hclip +import Text.Wrap (FillScope(..), FillStrategy(..), WrapSettings(..), wrapText) +import ZcashHaskell.Keys (generateWalletSeedPhrase, getWalletSeed) +import ZcashHaskell.Orchard (getSaplingFromUA, isValidUnifiedAddress) +import ZcashHaskell.Sapling (decodeSaplingAddress, isValidShieldedAddress) +import ZcashHaskell.Transparent + ( decodeExchangeAddress + , decodeTransparentAddress + , encodeTransparentReceiver + ) +import ZcashHaskell.Types +import ZcashHaskell.Utils (getBlockTime, makeZebraCall) +import Zenith.Core +import Zenith.DB +import Zenith.Scanner (processTx) +import Zenith.Types + ( Config(..) + , PhraseDB(..) + , UnifiedAddressDB(..) + , ZcashNetDB(..) + ) +import Zenith.Utils (displayTaz, displayZec, jsonNumber, showAddress) + +data Name + = WList + | AList + | AcList + | TList + | HelpDialog + | DialogInputField + | RecField + | AmtField + | MemoField + deriving (Eq, Show, Ord) + +data DialogInput = DialogInput + { _dialogInput :: !T.Text + } deriving (Show) + +makeLenses ''DialogInput + +data SendInput = SendInput + { _sendTo :: !T.Text + , _sendAmt :: !Float + , _sendMemo :: !T.Text + } deriving (Show) + +makeLenses ''SendInput + +data DialogType + = WName + | AName + | AdName + | WSelect + | ASelect + | SendTx + | Blank + +data DisplayType + = AddrDisplay + | MsgDisplay + | PhraseDisplay + | TxDisplay + | SyncDisplay + | SendDisplay + | BlankDisplay + +data Tick + = TickVal !Float + | TickMsg !String + +data State = State + { _network :: !ZcashNet + , _wallets :: !(L.List Name (Entity ZcashWallet)) + , _accounts :: !(L.List Name (Entity ZcashAccount)) + , _addresses :: !(L.List Name (Entity WalletAddress)) + , _transactions :: !(L.List Name (Entity UserTx)) + , _msg :: !String + , _helpBox :: !Bool + , _dialogBox :: !DialogType + , _splashBox :: !Bool + , _inputForm :: !(Form DialogInput () Name) + , _focusRing :: !(F.FocusRing Name) + , _startBlock :: !Int + , _dbPath :: !T.Text + , _zebraHost :: !T.Text + , _zebraPort :: !Int + , _displayBox :: !DisplayType + , _syncBlock :: !Int + , _balance :: !Integer + , _barValue :: !Float + , _eventDispatch :: !(BC.BChan Tick) + , _timer :: !Int + , _txForm :: !(Form SendInput () Name) + } + +makeLenses ''State + +drawUI :: State -> [Widget Name] +drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] + where + ui :: State -> Widget Name + ui st = + joinBorders $ + withBorderStyle unicode $ + B.borderWithLabel + (str + ("Zenith - " <> + show (st ^. network) <> + " - " <> + T.unpack + (maybe + "(None)" + (\(_, w) -> zcashWalletName $ entityVal w) + (L.listSelectedElement (st ^. wallets))))) + (C.hCenter + (str + ("Account: " ++ + T.unpack + (maybe + "(None)" + (\(_, a) -> zcashAccountName $ entityVal a) + (L.listSelectedElement (st ^. accounts))))) <=> + C.hCenter + (str + ("Balance: " ++ + if st ^. network == MainNet + then displayZec (st ^. balance) + else displayTaz (st ^. balance))) <=> + listAddressBox "Addresses" (st ^. addresses) <+> + B.vBorder <+> + (C.hCenter (str ("Last block seen: " ++ show (st ^. syncBlock))) <=> + listTxBox "Transactions" (st ^. network) (st ^. transactions))) <=> + C.hCenter + (hBox + [ capCommand "W" "allets" + , capCommand "A" "ccounts" + , capCommand "V" "iew address" + , capCommand "Q" "uit" + , str $ show (st ^. timer) + ]) + listBox :: Show e => String -> L.List Name e -> Widget Name + listBox titleLabel l = + C.vCenter $ + vBox + [ C.hCenter + (B.borderWithLabel (str titleLabel) $ + hLimit 25 $ vLimit 15 $ L.renderList listDrawElement True l) + , str " " + , C.hCenter $ str "Select " + ] + selectListBox :: + Show e + => String + -> L.List Name e + -> (Bool -> e -> Widget Name) + -> Widget Name + selectListBox titleLabel l drawF = + vBox + [ C.hCenter + (B.borderWithLabel (str titleLabel) $ + hLimit 25 $ vLimit 15 $ L.renderList drawF True l) + , str " " + ] + listAddressBox :: + String -> L.List Name (Entity WalletAddress) -> Widget Name + listAddressBox titleLabel a = + C.vCenter $ + vBox + [ C.hCenter + (B.borderWithLabel (str titleLabel) $ + hLimit 40 $ vLimit 15 $ L.renderList listDrawAddress True a) + , str " " + , C.hCenter + (hBox + [ capCommand "↑↓ " "move" + , capCommand "↲ " "select" + , capCommand "Tab " "->" + ]) + ] + listTxBox :: + String -> ZcashNet -> L.List Name (Entity UserTx) -> Widget Name + listTxBox titleLabel znet tx = + C.vCenter $ + vBox + [ C.hCenter + (B.borderWithLabel (str titleLabel) $ + hLimit 50 $ vLimit 15 $ L.renderList (listDrawTx znet) True tx) + , str " " + , C.hCenter + (hBox + [ capCommand "↑↓ " "move" + , capCommand "T" "x Display" + , capCommand "Tab " "<-" + ]) + ] + helpDialog :: State -> Widget Name + helpDialog st = + if st ^. helpBox + then D.renderDialog + (D.dialog (Just (str "Commands")) Nothing 55) + (vBox ([C.hCenter $ str "Key", B.hBorder] <> keyList) <+> + vBox ([str "Actions", B.hBorder] <> actionList)) + else emptyWidget + where + keyList = map (C.hCenter . str) ["?", "Esc", "w", "a", "v", "q"] + actionList = + map + (hLimit 40 . str) + [ "Open help" + , "Close dialog" + , "Switch wallets" + , "Switch accounts" + , "View address" + , "Quit" + ] + inputDialog :: State -> Widget Name + inputDialog st = + case st ^. dialogBox of + WName -> + D.renderDialog + (D.dialog (Just (str "Create Wallet")) Nothing 50) + (renderForm $ st ^. inputForm) + AName -> + D.renderDialog + (D.dialog (Just (str "Create Account")) Nothing 50) + (renderForm $ st ^. inputForm) + AdName -> + D.renderDialog + (D.dialog (Just (str "Create Address")) Nothing 50) + (renderForm $ st ^. inputForm) + WSelect -> + D.renderDialog + (D.dialog (Just (str "Select Wallet")) Nothing 50) + (selectListBox "Wallets" (st ^. wallets) listDrawWallet <=> + C.hCenter + (hBox + [ capCommand "↑↓ " "move" + , capCommand "↲ " "select" + , capCommand "N" "ew" + , capCommand "S" "how phrase" + , xCommand + ])) + ASelect -> + D.renderDialog + (D.dialog (Just (str "Select Account")) Nothing 50) + (selectListBox "Accounts" (st ^. accounts) listDrawAccount <=> + C.hCenter + (hBox + [ capCommand "↑↓ " "move" + , capCommand "↲ " "select" + , capCommand "N" "ew" + , xCommand + ])) + SendTx -> + D.renderDialog + (D.dialog (Just (str "Send Transaction")) Nothing 50) + (renderForm (st ^. txForm) <=> + C.hCenter + (hBox [capCommand "↲ " "Send", capCommand " " "Cancel"])) + Blank -> emptyWidget + splashDialog :: State -> Widget Name + splashDialog st = + if st ^. splashBox + then withBorderStyle unicodeBold $ + D.renderDialog + (D.dialog Nothing Nothing 30) + (withAttr + titleAttr + (str + " _____ _ _ _ \n|__ /___ _ __ (_) |_| |__\n / // _ \\ '_ \\| | __| '_ \\\n / /| __/ | | | | |_| | | |\n/____\\___|_| |_|_|\\__|_| |_|") <=> + C.hCenter (withAttr titleAttr (str "Zcash Wallet v0.5.0.0")) <=> + C.hCenter (withAttr blinkAttr $ str "Press any key...")) + else emptyWidget + capCommand :: String -> String -> Widget Name + capCommand k comm = hBox [withAttr titleAttr (str k), str comm, str " | "] + xCommand :: Widget Name + xCommand = hBox [str "E", withAttr titleAttr (str "x"), str "it"] + displayDialog :: State -> Widget Name + displayDialog st = + case st ^. displayBox of + AddrDisplay -> + case L.listSelectedElement $ st ^. addresses of + Just (_, a) -> + withBorderStyle unicodeBold $ + D.renderDialog + (D.dialog + (Just $ txt ("Address: " <> walletAddressName (entityVal a))) + Nothing + 60) + (padAll 1 $ + B.borderWithLabel + (str "Unified") + (txtWrapWith (WrapSettings False True NoFill FillAfterFirst) $ + getUA $ walletAddressUAddress $ entityVal a) <=> + B.borderWithLabel + (str "Legacy Shielded") + (txtWrapWith (WrapSettings False True NoFill FillAfterFirst) $ + fromMaybe "None" $ + (getSaplingFromUA . + E.encodeUtf8 . getUA . walletAddressUAddress) + (entityVal a)) <=> + B.borderWithLabel + (str "Transparent") + (txtWrapWith (WrapSettings False True NoFill FillAfterFirst) $ + maybe "None" (encodeTransparentReceiver (st ^. network)) $ + t_rec =<< + (isValidUnifiedAddress . + E.encodeUtf8 . getUA . walletAddressUAddress) + (entityVal a)) <=> + C.hCenter + (hBox + [ str "Copy: " + , capCommand "U" "nified" + , capCommand "S" "apling" + , capCommand "T" "ransparent" + ]) <=> + C.hCenter xCommand) + Nothing -> emptyWidget + PhraseDisplay -> + case L.listSelectedElement $ st ^. wallets of + Just (_, w) -> + withBorderStyle unicodeBold $ + D.renderDialog + (D.dialog (Just $ txt "Seed Phrase") Nothing 50) + (padAll 1 $ + txtWrap $ + E.decodeUtf8Lenient $ + getBytes $ getPhrase $ zcashWalletSeedPhrase $ entityVal w) + Nothing -> emptyWidget + MsgDisplay -> + withBorderStyle unicodeBold $ + D.renderDialog + (D.dialog (Just $ txt "Message") Nothing 50) + (padAll 1 $ strWrap $ st ^. msg) + TxDisplay -> + case L.listSelectedElement $ st ^. transactions of + Nothing -> emptyWidget + Just (_, tx) -> + withBorderStyle unicodeBold $ + D.renderDialog + (D.dialog (Just $ txt "Transaction") Nothing 50) + (padAll + 1 + (str + ("Date: " ++ + show + (posixSecondsToUTCTime + (fromIntegral (userTxTime $ entityVal tx)))) <=> + (str "Tx ID: " <+> + strWrapWith + (WrapSettings False True NoFill FillAfterFirst) + (show (userTxHex $ entityVal tx))) <=> + str + ("Amount: " ++ + if st ^. network == MainNet + then displayZec + (fromIntegral $ userTxAmount $ entityVal tx) + else displayTaz + (fromIntegral $ userTxAmount $ entityVal tx)) <=> + (txt "Memo: " <+> + txtWrapWith + (WrapSettings False True NoFill FillAfterFirst) + (userTxMemo (entityVal tx))))) + SyncDisplay -> + withBorderStyle unicodeBold $ + D.renderDialog + (D.dialog (Just $ txt "Sync") Nothing 50) + (padAll + 1 + (updateAttrMap + (A.mapAttrNames + [ (barDoneAttr, P.progressCompleteAttr) + , (barToDoAttr, P.progressIncompleteAttr) + ]) + (P.progressBar + (Just $ show (st ^. barValue * 100)) + (_barValue st)))) + SendDisplay -> + withBorderStyle unicodeBold $ + D.renderDialog + (D.dialog (Just $ txt "Sending Transaction") Nothing 50) + (padAll 1 (str $ st ^. msg)) + BlankDisplay -> emptyWidget + +mkInputForm :: DialogInput -> Form DialogInput e Name +mkInputForm = + newForm + [label "Name: " @@= editTextField dialogInput DialogInputField (Just 1)] + where + label s w = + padBottom (Pad 1) $ vLimit 1 (hLimit 15 $ str s <+> fill ' ') <+> w + +mkSendForm :: Integer -> SendInput -> Form SendInput e Name +mkSendForm bal = + newForm + [ label "To: " @@= editTextField sendTo RecField (Just 1) + , label "Amount: " @@= + editShowableFieldWithValidate sendAmt AmtField (isAmountValid bal) + , label "Memo: " @@= editTextField sendMemo MemoField (Just 1) + ] + where + isAmountValid :: Integer -> Float -> Bool + isAmountValid b i = (fromIntegral b * 100000000.0) >= i + label s w = + padBottom (Pad 1) $ vLimit 1 (hLimit 15 $ str s <+> fill ' ') <+> w + +isRecipientValid :: T.Text -> Bool +isRecipientValid a = + case isValidUnifiedAddress (E.encodeUtf8 a) of + Just _a1 -> True + Nothing -> + isValidShieldedAddress (E.encodeUtf8 a) || + (case decodeTransparentAddress (E.encodeUtf8 a) of + Just _a3 -> True + Nothing -> + case decodeExchangeAddress a of + Just _a4 -> True + Nothing -> False) + +listDrawElement :: (Show a) => Bool -> a -> Widget Name +listDrawElement sel a = + let selStr s = + if sel + then withAttr customAttr (str $ "<" <> s <> ">") + else str s + in C.hCenter $ selStr $ show a + +listDrawWallet :: Bool -> Entity ZcashWallet -> Widget Name +listDrawWallet sel w = + let selStr s = + if sel + then withAttr customAttr (txt $ "<" <> s <> ">") + else txt s + in C.hCenter $ selStr $ zcashWalletName (entityVal w) + +listDrawAccount :: Bool -> Entity ZcashAccount -> Widget Name +listDrawAccount sel w = + let selStr s = + if sel + then withAttr customAttr (txt $ "<" <> s <> ">") + else txt s + in C.hCenter $ selStr $ zcashAccountName (entityVal w) + +listDrawAddress :: Bool -> Entity WalletAddress -> Widget Name +listDrawAddress sel w = + let selStr s = + if sel + then withAttr customAttr (txt $ "<" <> s <> ">") + else txt s + in C.hCenter $ + selStr $ + walletAddressName (entityVal w) <> + ": " <> showAddress (walletAddressUAddress (entityVal w)) + +listDrawTx :: ZcashNet -> Bool -> Entity UserTx -> Widget Name +listDrawTx znet sel tx = + selStr $ + T.pack + (show $ posixSecondsToUTCTime (fromIntegral (userTxTime $ entityVal tx))) <> + " " <> T.pack fmtAmt + where + amt = fromIntegral $ userTxAmount $ entityVal tx + dispAmount = + if znet == MainNet + then displayZec amt + else displayTaz amt + fmtAmt = + if amt > 0 + then "↘" <> dispAmount <> " " + else " " <> dispAmount <> "↗" + selStr s = + if sel + then withAttr customAttr (txt $ "> " <> s) + else txt $ " " <> s + +customAttr :: A.AttrName +customAttr = L.listSelectedAttr <> A.attrName "custom" + +titleAttr :: A.AttrName +titleAttr = A.attrName "title" + +blinkAttr :: A.AttrName +blinkAttr = A.attrName "blink" + +baseAttr :: A.AttrName +baseAttr = A.attrName "base" + +barDoneAttr :: A.AttrName +barDoneAttr = A.attrName "done" + +barToDoAttr :: A.AttrName +barToDoAttr = A.attrName "remaining" + +validBarValue :: Float -> Float +validBarValue = clamp 0 1 + +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 <- runNoLoggingT $ initPool dbP + dbBlock <- runNoLoggingT $ getMaxBlock pool + let sb = max dbBlock b + if sb > zgb_blocks bStatus || sb < 1 + then do + liftIO $ BC.writeBChan eChan $ TickMsg "Invalid starting block for scan" + else do + let bList = [(sb + 1) .. (zgb_blocks bStatus)] + let step = (1.0 :: Float) / fromIntegral (zgb_blocks bStatus - (sb + 1)) + mapM_ (processBlock pool step) bList + where + processBlock :: ConnectionPool -> Float -> Int -> IO () + processBlock pool step bl = do + r <- + liftIO $ + makeZebraCall + zHost + zPort + "getblock" + [Data.Aeson.String $ T.pack $ show bl, jsonNumber 1] + case r of + Left e1 -> do + liftIO $ BC.writeBChan eChan $ TickMsg e1 + Right blk -> do + r2 <- + liftIO $ + makeZebraCall + zHost + zPort + "getblock" + [Data.Aeson.String $ T.pack $ show bl, jsonNumber 0] + case r2 of + Left e2 -> do + liftIO $ BC.writeBChan eChan $ TickMsg e2 + Right hb -> do + let blockTime = getBlockTime hb + mapM_ (runNoLoggingT . processTx zHost zPort blockTime pool) $ + bl_txs $ addTime blk blockTime + liftIO $ BC.writeBChan eChan $ TickVal step + addTime :: BlockResponse -> Int -> BlockResponse + addTime bl t = + BlockResponse + (bl_confirmations bl) + (bl_height bl) + (fromIntegral t) + (bl_txs bl) + +appEvent :: BT.BrickEvent Name Tick -> BT.EventM Name State () +appEvent (BT.AppEvent t) = do + s <- BT.get + pool <- liftIO $ runNoLoggingT $ initPool $ s ^. dbPath + case t of + TickMsg m -> do + case s ^. displayBox of + AddrDisplay -> return () + MsgDisplay -> return () + PhraseDisplay -> return () + TxDisplay -> return () + SyncDisplay -> return () + SendDisplay -> do + BT.modify $ set msg m + BlankDisplay -> return () + TickVal v -> do + case s ^. displayBox of + AddrDisplay -> return () + MsgDisplay -> return () + PhraseDisplay -> return () + TxDisplay -> return () + SendDisplay -> return () + SyncDisplay -> do + if s ^. barValue == 1.0 + then do + selWallet <- + do case L.listSelectedElement $ s ^. wallets of + Nothing -> do + let fWall = + L.listSelectedElement $ + L.listMoveToBeginning $ s ^. wallets + case fWall of + Nothing -> throw $ userError "Failed to select wallet" + Just (_j, w1) -> return w1 + Just (_k, w) -> return w + _ <- + liftIO $ + syncWallet + (Config (s ^. dbPath) (s ^. zebraHost) (s ^. zebraPort)) + selWallet + BT.modify $ set displayBox BlankDisplay + BT.modify $ set barValue 0.0 + 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 + AName -> return () + AdName -> return () + WName -> return () + WSelect -> return () + ASelect -> return () + SendTx -> return () + Blank -> do + if s ^. timer == 90 + then do + BT.modify $ set barValue 0.0 + BT.modify $ set displayBox SyncDisplay + sBlock <- liftIO $ getMinBirthdayHeight pool + _ <- + liftIO $ + forkIO $ + scanZebra + (s ^. dbPath) + (s ^. zebraHost) + (s ^. zebraPort) + sBlock + (s ^. eventDispatch) + BT.modify $ set timer 0 + return () + else do + BT.modify $ set timer $ 1 + s ^. timer +appEvent (BT.VtyEvent e) = do + r <- F.focusGetCurrent <$> use focusRing + s <- BT.get + if s ^. splashBox + then BT.modify $ set splashBox False + else if s ^. helpBox + then do + case e of + V.EvKey V.KEsc [] -> do + BT.modify $ set helpBox False + _ev -> return () + else do + case s ^. displayBox of + AddrDisplay -> do + case e of + V.EvKey (V.KChar 'x') [] -> + BT.modify $ set displayBox BlankDisplay + V.EvKey (V.KChar 'u') [] -> do + case L.listSelectedElement $ s ^. addresses of + Just (_, a) -> do + liftIO $ + setClipboard $ + T.unpack $ + getUA $ walletAddressUAddress $ entityVal a + BT.modify $ + set msg $ + "Copied Unified Address <" ++ + T.unpack (walletAddressName (entityVal a)) ++ ">!" + BT.modify $ set displayBox MsgDisplay + Nothing -> return () + V.EvKey (V.KChar 's') [] -> do + case L.listSelectedElement $ s ^. addresses of + Just (_, a) -> do + liftIO $ + setClipboard $ + maybe "None" T.unpack $ + getSaplingFromUA $ + E.encodeUtf8 $ + getUA $ walletAddressUAddress $ entityVal a + BT.modify $ + set msg $ + "Copied Sapling Address <" ++ + T.unpack (walletAddressName (entityVal a)) ++ ">!" + BT.modify $ set displayBox MsgDisplay + Nothing -> return () + V.EvKey (V.KChar 't') [] -> do + case L.listSelectedElement $ s ^. addresses of + Just (_, a) -> do + liftIO $ + setClipboard $ + T.unpack $ + maybe + "None" + (encodeTransparentReceiver (s ^. network)) $ + t_rec =<< + (isValidUnifiedAddress . + E.encodeUtf8 . getUA . walletAddressUAddress) + (entityVal a) + BT.modify $ + set msg $ + "Copied Transparent Address <" ++ + T.unpack (walletAddressName (entityVal a)) ++ ">!" + BT.modify $ set displayBox MsgDisplay + Nothing -> return () + _ev -> return () + MsgDisplay -> BT.modify $ set displayBox BlankDisplay + PhraseDisplay -> BT.modify $ set displayBox BlankDisplay + TxDisplay -> BT.modify $ set displayBox BlankDisplay + SendDisplay -> BT.modify $ set displayBox BlankDisplay + SyncDisplay -> BT.modify $ set displayBox BlankDisplay + BlankDisplay -> do + case s ^. dialogBox of + WName -> do + case e of + V.EvKey V.KEsc [] -> BT.modify $ set dialogBox Blank + V.EvKey V.KEnter [] -> do + fs <- BT.zoom inputForm $ BT.gets formState + nw <- liftIO $ addNewWallet (fs ^. dialogInput) s + ns <- liftIO $ refreshWallet nw + BT.put ns + aL <- use accounts + BT.modify $ set displayBox MsgDisplay + BT.modify $ + set dialogBox $ + if not (null $ L.listElements aL) + then Blank + else AName + ev -> + BT.zoom inputForm $ handleFormEvent (BT.VtyEvent ev) + AName -> do + case e of + V.EvKey V.KEsc [] -> BT.modify $ set dialogBox Blank + V.EvKey V.KEnter [] -> do + fs <- BT.zoom inputForm $ BT.gets formState + ns <- + liftIO $ + refreshAccount =<< + addNewAddress "Change" Internal =<< + addNewAccount (fs ^. dialogInput) s + BT.put ns + addrL <- use addresses + BT.modify $ set displayBox MsgDisplay + BT.modify $ + set dialogBox $ + if not (null $ L.listElements addrL) + then Blank + else AdName + ev -> + BT.zoom inputForm $ handleFormEvent (BT.VtyEvent ev) + AdName -> do + case e of + V.EvKey V.KEsc [] -> BT.modify $ set dialogBox Blank + V.EvKey V.KEnter [] -> do + fs <- BT.zoom inputForm $ BT.gets formState + nAddr <- + liftIO $ addNewAddress (fs ^. dialogInput) External s + BT.put nAddr + BT.modify $ set displayBox MsgDisplay + BT.modify $ set dialogBox Blank + ev -> + BT.zoom inputForm $ handleFormEvent (BT.VtyEvent ev) + WSelect -> do + case e of + V.EvKey (V.KChar 'x') [] -> + BT.modify $ set dialogBox Blank + V.EvKey V.KEnter [] -> do + ns <- liftIO $ refreshWallet s + BT.put ns + BT.modify $ set dialogBox Blank + V.EvKey (V.KChar 'n') [] -> do + BT.modify $ + set inputForm $ + updateFormState (DialogInput "New Wallet") $ + s ^. inputForm + BT.modify $ set dialogBox WName + V.EvKey (V.KChar 's') [] -> + BT.modify $ set displayBox PhraseDisplay + ev -> BT.zoom wallets $ L.handleListEvent ev + ASelect -> do + case e of + V.EvKey (V.KChar 'x') [] -> + BT.modify $ set dialogBox Blank + V.EvKey V.KEnter [] -> do + ns <- liftIO $ refreshAccount s + BT.put ns + BT.modify $ set dialogBox Blank + V.EvKey (V.KChar 'n') [] -> do + BT.modify $ + set inputForm $ + updateFormState (DialogInput "New Account") $ + s ^. inputForm + BT.modify $ set dialogBox AName + ev -> BT.zoom accounts $ L.handleListEvent ev + SendTx -> do + case e of + V.EvKey V.KEsc [] -> BT.modify $ set dialogBox Blank + V.EvKey V.KEnter [] -> do + if allFieldsValid (s ^. txForm) + 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 + fs1 <- BT.zoom txForm $ BT.gets formState + bl <- + liftIO $ getLastSyncBlock pool $ entityKey selWal + _ <- + liftIO $ + forkIO $ + sendTransaction + pool + (s ^. eventDispatch) + (s ^. zebraHost) + (s ^. zebraPort) + (s ^. network) + (entityKey selAcc) + bl + (fs1 ^. sendAmt) + (fs1 ^. sendTo) + (fs1 ^. sendMemo) + BT.modify $ set msg "Preparing transaction..." + 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 -> do + BT.zoom txForm $ do + handleFormEvent (BT.VtyEvent ev) + fs <- BT.gets formState + BT.modify $ + setFieldValid + (isRecipientValid (fs ^. sendTo)) + RecField + Blank -> do + case e of + V.EvKey (V.KChar '\t') [] -> focusRing %= F.focusNext + V.EvKey V.KEnter [] -> do + ns <- liftIO $ refreshTxs s + BT.put ns + V.EvKey (V.KChar 'q') [] -> M.halt + V.EvKey (V.KChar '?') [] -> BT.modify $ set helpBox True + V.EvKey (V.KChar 'n') [] -> + BT.modify $ set dialogBox AdName + V.EvKey (V.KChar 'v') [] -> + BT.modify $ set displayBox AddrDisplay + V.EvKey (V.KChar 'w') [] -> + BT.modify $ set dialogBox WSelect + V.EvKey (V.KChar 't') [] -> + BT.modify $ set displayBox TxDisplay + V.EvKey (V.KChar 'a') [] -> + BT.modify $ set dialogBox ASelect + V.EvKey (V.KChar 's') [] -> do + BT.modify $ + set txForm $ + mkSendForm (s ^. balance) (SendInput "" 0.0 "") + BT.modify $ set dialogBox SendTx + ev -> + case r of + Just AList -> + BT.zoom addresses $ L.handleListEvent ev + Just TList -> + BT.zoom transactions $ L.handleListEvent ev + _anyName -> return () + where + printMsg :: String -> BT.EventM Name State () + printMsg s = BT.modify $ updateMsg s + updateMsg :: String -> State -> State + updateMsg = set msg +appEvent _ = return () + +theMap :: A.AttrMap +theMap = + A.attrMap + V.defAttr + [ (L.listAttr, V.white `on` V.blue) + , (L.listSelectedAttr, V.blue `on` V.white) + , (customAttr, fg V.black) + , (titleAttr, V.withStyle (fg V.brightGreen) V.bold) + , (blinkAttr, style V.blink) + , (focusedFormInputAttr, V.white `on` V.blue) + , (invalidFormInputAttr, V.red `on` V.black) + , (E.editAttr, V.white `on` V.blue) + , (E.editFocusedAttr, V.blue `on` V.white) + , (baseAttr, bg V.brightBlack) + , (barDoneAttr, V.white `on` V.blue) + , (barToDoAttr, V.white `on` V.black) + ] + +theApp :: M.App State Tick Name +theApp = + M.App + { M.appDraw = drawUI + , M.appChooseCursor = M.showFirstCursor + , M.appHandleEvent = appEvent + , M.appStartEvent = return () + , M.appAttrMap = const theMap + } + +runZenithCLI :: Config -> IO () +runZenithCLI config = do + let host = c_zebraHost config + let port = c_zebraPort config + let dbFilePath = c_dbPath config + pool <- runNoLoggingT $ initPool dbFilePath + w <- try $ checkZebra host port :: IO (Either IOError ZebraGetInfo) + case w of + Right zebra -> do + bc <- + try $ checkBlockChain host port :: IO + (Either IOError ZebraGetBlockChainInfo) + case bc of + Left e1 -> throwIO e1 + Right chainInfo -> do + 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 zcashWalletLastSync $ entityVal $ head walList + else 0 + bal <- + if not (null accList) + then getBalance pool $ entityKey $ head accList + else return 0 + eventChan <- BC.newBChan 10 + _ <- + forkIO $ + forever $ do + BC.writeBChan eventChan (TickVal 0.0) + threadDelay 1000000 + let buildVty = VC.mkVty V.defaultConfig + initialVty <- buildVty + void $ + M.customMain initialVty buildVty (Just eventChan) theApp $ + State + (zgb_net chainInfo) + (L.list WList (Vec.fromList walList) 1) + (L.list AcList (Vec.fromList accList) 0) + (L.list AList (Vec.fromList addrList) 1) + (L.list TList (Vec.fromList txList) 1) + ("Start up Ok! Connected to Zebra " ++ + (T.unpack . zgi_build) zebra ++ " on port " ++ show port ++ ".") + False + (if null walList + then WName + else Blank) + True + (mkInputForm $ DialogInput "Main") + (F.focusRing [AList, TList]) + (zgb_blocks chainInfo) + dbFilePath + host + port + MsgDisplay + block + bal + 1.0 + eventChan + 0 + (mkSendForm 0 $ SendInput "" 0.0 "") + Left e -> do + print $ + "No Zebra node available on port " <> + show port <> ". Check your configuration." + +refreshWallet :: State -> IO State +refreshWallet s = do + pool <- runNoLoggingT $ initPool $ s ^. dbPath + walList <- getWallets pool $ s ^. network + (ix, 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 (j, w1) + Just (k, w) -> return (k, w) + aL <- runNoLoggingT $ getAccounts pool $ entityKey selWallet + let bl = zcashWalletLastSync $ entityVal selWallet + addrL <- + if not (null aL) + then runNoLoggingT $ getAddresses pool $ entityKey $ head aL + else return [] + bal <- + if not (null aL) + then getBalance pool $ entityKey $ head aL + else return 0 + txL <- + if not (null addrL) + then getUserTx pool $ entityKey $ head addrL + else return [] + let wL = L.listReplace (Vec.fromList walList) (Just ix) (s ^. wallets) + let aL' = L.listReplace (Vec.fromList aL) (Just 0) (s ^. accounts) + let addrL' = L.listReplace (Vec.fromList addrL) (Just 0) (s ^. addresses) + let txL' = L.listReplace (Vec.fromList txL) (Just 0) (s ^. transactions) + return $ + s & wallets .~ wL & accounts .~ aL' & syncBlock .~ bl & balance .~ bal & + addresses .~ + addrL' & + transactions .~ + txL' & + msg .~ + "Switched to wallet: " ++ + T.unpack (zcashWalletName $ entityVal selWallet) + +addNewWallet :: T.Text -> State -> IO State +addNewWallet n s = do + sP <- generateWalletSeedPhrase + pool <- runNoLoggingT $ initPool $ s ^. dbPath + let bH = s ^. startBlock + let netName = s ^. network + r <- saveWallet pool $ ZcashWallet n (ZcashNetDB netName) (PhraseDB sP) bH 0 + case r of + Nothing -> do + return $ s & msg .~ ("Wallet already exists: " ++ T.unpack n) + Just _ -> do + wL <- getWallets pool netName + let aL = + L.listFindBy (\x -> zcashWalletName (entityVal x) == n) $ + L.listReplace (Vec.fromList wL) (Just 0) (s ^. wallets) + return $ (s & wallets .~ aL) & msg .~ "Created new wallet: " ++ T.unpack n + +addNewAccount :: T.Text -> State -> IO State +addNewAccount n s = do + pool <- runNoLoggingT $ initPool $ s ^. dbPath + 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 + aL' <- getMaxAccount pool (entityKey selWallet) + zA <- + try $ createZcashAccount n (aL' + 1) selWallet :: IO + (Either IOError ZcashAccount) + case zA of + Left e -> return $ s & msg .~ ("Error: " ++ show e) + Right zA' -> do + r <- saveAccount pool zA' + case r of + Nothing -> + return $ s & msg .~ ("Account already exists: " ++ T.unpack n) + Just x -> do + aL <- runNoLoggingT $ getAccounts pool (entityKey selWallet) + let nL = + L.listMoveToElement x $ + L.listReplace (Vec.fromList aL) (Just 0) (s ^. accounts) + return $ + (s & accounts .~ nL) & msg .~ "Created new account: " ++ T.unpack n + +refreshAccount :: State -> IO State +refreshAccount s = do + pool <- runNoLoggingT $ initPool $ s ^. dbPath + selAccount <- + 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 + aL <- runNoLoggingT $ getAddresses pool $ entityKey selAccount + bal <- getBalance pool $ entityKey selAccount + let aL' = L.listReplace (Vec.fromList aL) (Just 0) (s ^. addresses) + selAddress <- + do case L.listSelectedElement aL' of + Nothing -> do + let fAdd = L.listSelectedElement $ L.listMoveToBeginning aL' + return fAdd + Just a2 -> return $ Just a2 + case selAddress of + Nothing -> + return $ + s & balance .~ bal & addresses .~ aL' & msg .~ "Switched to account: " ++ + T.unpack (zcashAccountName $ entityVal selAccount) + Just (_i, a) -> do + tList <- getUserTx pool $ entityKey a + let tL' = L.listReplace (Vec.fromList tList) (Just 0) (s ^. transactions) + return $ + s & balance .~ bal & addresses .~ aL' & transactions .~ tL' & msg .~ + "Switched to account: " ++ + T.unpack (zcashAccountName $ entityVal selAccount) + +refreshTxs :: State -> IO State +refreshTxs s = do + pool <- runNoLoggingT $ initPool $ s ^. dbPath + selAddress <- + do case L.listSelectedElement $ s ^. addresses of + Nothing -> do + let fAdd = + L.listSelectedElement $ L.listMoveToBeginning $ s ^. addresses + return fAdd + Just a2 -> return $ Just a2 + case selAddress of + Nothing -> return s + Just (_i, a) -> do + tList <- getUserTx pool $ entityKey a + let tL' = L.listReplace (Vec.fromList tList) (Just 0) (s ^. transactions) + return $ s & transactions .~ tL' + +addNewAddress :: T.Text -> Scope -> State -> IO State +addNewAddress n scope s = do + pool <- runNoLoggingT $ initPool $ s ^. dbPath + selAccount <- + 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, a1) -> return a1 + Just (_k, a) -> return a + maxAddr <- getMaxAddress pool (entityKey selAccount) scope + uA <- + try $ createWalletAddress n (maxAddr + 1) (s ^. network) scope selAccount :: IO + (Either IOError WalletAddress) + case uA of + Left e -> return $ s & msg .~ ("Error: " ++ show e) + Right uA' -> do + nAddr <- saveAddress pool uA' + case nAddr of + Nothing -> + return $ s & msg .~ ("Address already exists: " ++ T.unpack n) + Just x -> do + addrL <- runNoLoggingT $ getAddresses pool (entityKey selAccount) + let nL = + L.listMoveToElement x $ + L.listReplace (Vec.fromList addrL) (Just 0) (s ^. addresses) + return $ + (s & addresses .~ nL) & msg .~ "Created new address: " ++ + T.unpack n ++ + "(" ++ + T.unpack (showAddress $ walletAddressUAddress $ entityVal x) ++ ")" + +sendTransaction :: + ConnectionPool + -> BC.BChan Tick + -> T.Text + -> Int + -> ZcashNet + -> ZcashAccountId + -> Int + -> Float + -> T.Text + -> T.Text + -> IO () +sendTransaction pool chan zHost zPort znet accId bl amt ua memo = do + BC.writeBChan chan $ TickMsg "Preparing transaction..." + outUA <- parseAddress ua + res <- + runFileLoggingT "zenith.log" $ + prepareTx pool zHost zPort znet accId bl amt outUA memo + BC.writeBChan chan $ TickMsg "Transaction ready, sending to Zebra..." + case res of + Left e -> BC.writeBChan chan $ TickMsg $ show e + Right rawTx -> do + 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 $ TickMsg $ "Tx ID: " ++ txId + where + parseAddress :: T.Text -> IO UnifiedAddress + parseAddress a = + case isValidUnifiedAddress (E.encodeUtf8 a) of + Just a1 -> return a1 + Nothing -> + case decodeSaplingAddress (E.encodeUtf8 a) of + Just a2 -> + return $ + UnifiedAddress znet Nothing (Just $ sa_receiver a2) Nothing + Nothing -> + case decodeTransparentAddress (E.encodeUtf8 a) of + Just a3 -> + return $ + UnifiedAddress znet Nothing Nothing (Just $ ta_receiver a3) + Nothing -> throwIO $ userError "Incorrect address" diff --git a/src/Zenith/Core.hs b/src/Zenith/Core.hs new file mode 100644 index 0000000..a8dc6f2 --- /dev/null +++ b/src/Zenith/Core.hs @@ -0,0 +1,774 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Core wallet functionality for Zenith +module Zenith.Core where + +import Control.Exception (throwIO, try) +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 qualified Data.ByteString.Lazy as LBS +import Data.Digest.Pure.MD5 +import Data.HexString (HexString, hexString, toBytes) +import Data.List +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 + , getOrchardNotePosition + , getOrchardWitness + , isValidUnifiedAddress + , updateOrchardCommitmentTree + , updateOrchardWitness + ) +import ZcashHaskell.Sapling + ( decodeSaplingOutputEsk + , genSaplingInternalAddress + , genSaplingPaymentAddress + , genSaplingSpendingKey + , getSaplingNotePosition + , getSaplingWitness + , updateSaplingCommitmentTree + , updateSaplingWitness + ) +import ZcashHaskell.Transparent + ( genTransparentPrvKey + , genTransparentReceiver + , genTransparentSecretKey + ) +import ZcashHaskell.Types +import ZcashHaskell.Utils +import Zenith.DB +import Zenith.Types + ( Config(..) + , HexStringDB(..) + , OrchardSpendingKeyDB(..) + , PhraseDB(..) + , RseedDB(..) + , SaplingSpendingKeyDB(..) + , ScopeDB(..) + , TransparentSpendingKeyDB(..) + , UnifiedAddressDB(..) + , ZcashNetDB(..) + , ZebraTreeInfo(..) + ) + +-- * Zebra Node interaction +-- | Checks the status of the `zebrad` node +checkZebra :: + T.Text -- ^ Host where `zebrad` is available + -> Int -- ^ Port where `zebrad` is available + -> IO ZebraGetInfo +checkZebra nodeHost nodePort = do + res <- makeZebraCall nodeHost nodePort "getinfo" [] + case res of + Left e -> throwIO $ userError e + Right bi -> return bi + +-- | Checks the status of the Zcash blockchain +checkBlockChain :: + T.Text -- ^ Host where `zebrad` is available + -> Int -- ^ Port where `zebrad` is available + -> IO ZebraGetBlockChainInfo +checkBlockChain nodeHost nodePort = do + r <- makeZebraCall nodeHost nodePort "getblockchaininfo" [] + case r of + Left e -> throwIO $ userError e + Right bci -> return bci + +-- | Get commitment trees from Zebra +getCommitmentTrees :: + T.Text -- ^ Host where `zebrad` is avaiable + -> Int -- ^ Port where `zebrad` is available + -> Int -- ^ Block height + -> IO ZebraTreeInfo +getCommitmentTrees nodeHost nodePort block = do + r <- + makeZebraCall + nodeHost + nodePort + "z_gettreestate" + [Data.Aeson.String $ T.pack $ show block] + case r of + Left e -> throwIO $ userError e + Right zti -> return zti + +-- * Spending Keys +-- | Create an Orchard Spending Key for the given wallet and account index +createOrchardSpendingKey :: ZcashWallet -> Int -> IO OrchardSpendingKey +createOrchardSpendingKey zw i = do + let s = getWalletSeed $ getPhrase $ zcashWalletSeedPhrase zw + case s of + Nothing -> throwIO $ userError "Unable to generate seed" + Just s' -> do + let coinType = + case getNet $ zcashWalletNetwork zw of + MainNet -> MainNetCoin + TestNet -> TestNetCoin + RegTestNet -> RegTestNetCoin + let r = genOrchardSpendingKey s' coinType i + case r of + Nothing -> throwIO $ userError "Unable to generate Orchard spending key" + Just sk -> return sk + +-- | Create a Sapling spending key for the given wallet and account index +createSaplingSpendingKey :: ZcashWallet -> Int -> IO SaplingSpendingKey +createSaplingSpendingKey zw i = do + let s = getWalletSeed $ getPhrase $ zcashWalletSeedPhrase zw + case s of + Nothing -> throwIO $ userError "Unable to generate seed" + Just s' -> do + let coinType = + case getNet $ zcashWalletNetwork zw of + MainNet -> MainNetCoin + TestNet -> TestNetCoin + RegTestNet -> RegTestNetCoin + let r = genSaplingSpendingKey s' coinType i + case r of + Nothing -> throwIO $ userError "Unable to generate Sapling spending key" + Just sk -> return sk + +createTransparentSpendingKey :: ZcashWallet -> Int -> IO TransparentSpendingKey +createTransparentSpendingKey zw i = do + let s = getWalletSeed $ getPhrase $ zcashWalletSeedPhrase zw + case s of + Nothing -> throwIO $ userError "Unable to generate seed" + Just s' -> do + let coinType = + case getNet $ zcashWalletNetwork zw of + MainNet -> MainNetCoin + TestNet -> TestNetCoin + RegTestNet -> RegTestNetCoin + genTransparentPrvKey s' coinType i + +-- * Accounts +-- | Create an account for the given wallet and account index +createZcashAccount :: + T.Text -- ^ The account's name + -> Int -- ^ The account's index + -> Entity ZcashWallet -- ^ The Zcash wallet that this account will be attached to + -> IO ZcashAccount +createZcashAccount n i zw = do + orSk <- createOrchardSpendingKey (entityVal zw) i + sapSk <- createSaplingSpendingKey (entityVal zw) i + tSk <- createTransparentSpendingKey (entityVal zw) i + return $ + ZcashAccount + i + (entityKey zw) + n + (OrchardSpendingKeyDB orSk) + (SaplingSpendingKeyDB sapSk) + (TransparentSpendingKeyDB tSk) + +-- * Addresses +-- | Create an external unified address for the given account and index +createWalletAddress :: + 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 + -> IO WalletAddress +createWalletAddress n i zNet scope za = do + let oRec = + genOrchardReceiver i scope $ + getOrchSK $ zcashAccountOrchSpendKey $ entityVal za + let sRec = + case scope of + External -> + genSaplingPaymentAddress i $ + getSapSK $ zcashAccountSapSpendKey $ entityVal za + Internal -> + genSaplingInternalAddress $ + getSapSK $ zcashAccountSapSpendKey $ entityVal za + tRec <- + genTransparentReceiver i scope $ + getTranSK $ zcashAccountTPrivateKey $ entityVal za + return $ + WalletAddress + i + (entityKey za) + n + (UnifiedAddressDB $ + encodeUnifiedAddress $ UnifiedAddress zNet oRec sRec (Just tRec)) + (ScopeDB scope) + +-- * Wallet +-- | Find the Sapling notes that match the given spending key +findSaplingOutputs :: + Config -- ^ the configuration parameters + -> Int -- ^ the starting block + -> ZcashNetDB -- ^ The network + -> Entity ZcashAccount -- ^ The account to use + -> IO () +findSaplingOutputs config b znet za = do + let dbPath = c_dbPath config + let zebraHost = c_zebraHost config + let zebraPort = c_zebraPort config + let zn = getNet znet + pool <- runNoLoggingT $ initPool dbPath + tList <- getShieldedOutputs pool b + trees <- getCommitmentTrees zebraHost zebraPort (b - 1) + let sT = SaplingCommitmentTree $ ztiSapling trees + decryptNotes sT zn pool tList + sapNotes <- getWalletSapNotes pool (entityKey za) + findSapSpends pool (entityKey za) sapNotes + where + sk :: SaplingSpendingKeyDB + sk = zcashAccountSapSpendKey $ entityVal za + decryptNotes :: + SaplingCommitmentTree + -> ZcashNet + -> ConnectionPool + -> [(Entity ZcashTransaction, Entity ShieldOutput)] + -> IO () + decryptNotes _ _ _ [] = return () + decryptNotes st n pool ((zt, o):txs) = do + let updatedTree = + updateSaplingCommitmentTree + st + (getHex $ shieldOutputCmu $ entityVal o) + case updatedTree of + Nothing -> throwIO $ userError "Failed to update commitment tree" + Just uT -> do + let noteWitness = getSaplingWitness uT + let notePos = getSaplingNotePosition <$> noteWitness + case notePos of + Nothing -> throwIO $ userError "Failed to obtain note position" + Just nP -> do + case decodeShOut External n nP o of + Nothing -> do + case decodeShOut Internal n nP o of + Nothing -> do + decryptNotes uT n pool txs + Just dn1 -> do + wId <- saveWalletTransaction pool (entityKey za) zt + saveWalletSapNote + pool + wId + nP + (fromJust noteWitness) + True + (entityKey za) + (entityKey o) + dn1 + decryptNotes uT n pool txs + Just dn0 -> do + wId <- saveWalletTransaction pool (entityKey za) zt + saveWalletSapNote + pool + wId + nP + (fromJust noteWitness) + False + (entityKey za) + (entityKey o) + dn0 + decryptNotes uT n pool txs + decodeShOut :: + Scope + -> ZcashNet + -> Integer + -> Entity ShieldOutput + -> Maybe DecodedNote + decodeShOut scope n pos s = do + decodeSaplingOutputEsk + (getSapSK sk) + (ShieldedOutput + (getHex $ shieldOutputCv $ entityVal s) + (getHex $ shieldOutputCmu $ entityVal s) + (getHex $ shieldOutputEphKey $ entityVal s) + (getHex $ shieldOutputEncCipher $ entityVal s) + (getHex $ shieldOutputOutCipher $ entityVal s) + (getHex $ shieldOutputProof $ entityVal s)) + n + scope + pos + +-- | Get Orchard actions +findOrchardActions :: + Config -- ^ the configuration parameters + -> Int -- ^ the starting block + -> ZcashNetDB -- ^ The network + -> Entity ZcashAccount -- ^ The account to use + -> IO () +findOrchardActions config b znet za = do + let dbPath = c_dbPath config + let zebraHost = c_zebraHost config + let zebraPort = c_zebraPort config + let zn = getNet znet + pool <- runNoLoggingT $ initPool dbPath + tList <- 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 :: + OrchardCommitmentTree + -> ZcashNet + -> ConnectionPool + -> [(Entity ZcashTransaction, Entity OrchAction)] + -> IO () + decryptNotes _ _ _ [] = return () + decryptNotes ot n pool ((zt, o):txs) = do + let updatedTree = + updateOrchardCommitmentTree + ot + (getHex $ orchActionCmx $ entityVal o) + case updatedTree of + Nothing -> throwIO $ userError "Failed to update commitment tree" + Just uT -> do + let noteWitness = getOrchardWitness uT + let notePos = getOrchardNotePosition <$> noteWitness + case notePos of + Nothing -> throwIO $ userError "Failed to obtain note position" + Just nP -> + case decodeOrchAction External nP o of + Nothing -> + case decodeOrchAction Internal nP o of + Nothing -> decryptNotes uT n pool txs + Just dn1 -> do + wId <- saveWalletTransaction pool (entityKey za) zt + saveWalletOrchNote + pool + wId + nP + (fromJust noteWitness) + True + (entityKey za) + (entityKey o) + dn1 + decryptNotes uT n pool txs + Just dn -> do + wId <- saveWalletTransaction pool (entityKey za) zt + saveWalletOrchNote + pool + wId + nP + (fromJust noteWitness) + False + (entityKey za) + (entityKey o) + dn + decryptNotes uT n pool txs + sk :: OrchardSpendingKeyDB + sk = zcashAccountOrchSpendKey $ entityVal za + decodeOrchAction :: + Scope -> Integer -> Entity OrchAction -> Maybe DecodedNote + decodeOrchAction scope pos o = + decryptOrchardActionSK (getOrchSK sk) scope $ + OrchardAction + (getHex $ orchActionNf $ entityVal o) + (getHex $ orchActionRk $ entityVal o) + (getHex $ orchActionCmx $ entityVal o) + (getHex $ orchActionEphKey $ entityVal o) + (getHex $ orchActionEncCipher $ entityVal o) + (getHex $ orchActionOutCipher $ entityVal o) + (getHex $ orchActionCv $ entityVal o) + (getHex $ orchActionAuth $ entityVal o) + +updateSaplingWitnesses :: ConnectionPool -> IO () +updateSaplingWitnesses pool = do + sapNotes <- getUnspentSapNotes pool + maxId <- liftIO $ getMaxSaplingNote pool + mapM_ (updateOneNote maxId) sapNotes + where + updateOneNote :: ShieldOutputId -> Entity WalletSapNote -> IO () + updateOneNote maxId n = do + let noteSync = walletSapNoteWitPos $ entityVal n + when (noteSync < maxId) $ do + cmus <- liftIO $ getSaplingCmus pool $ walletSapNoteWitPos $ entityVal n + let cmuList = map (\(ESQ.Value x) -> getHex x) cmus + let newWitness = + updateSaplingWitness + (SaplingWitness $ getHex $ walletSapNoteWitness $ entityVal n) + cmuList + liftIO $ updateSapNoteRecord pool (entityKey n) newWitness maxId + +updateOrchardWitnesses :: ConnectionPool -> IO () +updateOrchardWitnesses pool = do + orchNotes <- getUnspentOrchNotes pool + maxId <- getMaxOrchardNote pool + mapM_ (updateOneNote maxId) orchNotes + where + updateOneNote :: OrchActionId -> Entity WalletOrchNote -> IO () + updateOneNote maxId n = do + let noteSync = walletOrchNoteWitPos $ entityVal n + when (noteSync < maxId) $ do + cmxs <- liftIO $ getOrchardCmxs pool noteSync + let cmxList = map (\(ESQ.Value x) -> getHex x) cmxs + let newWitness = + updateOrchardWitness + (OrchardWitness $ getHex $ walletOrchNoteWitness $ entityVal n) + cmxList + liftIO $ updateOrchNoteRecord pool (entityKey n) newWitness maxId + +-- | Calculate fee per ZIP-317 +calculateTxFee :: + ([Entity WalletTrNote], [Entity WalletSapNote], [Entity WalletOrchNote]) + -> Int + -> Integer +calculateTxFee (t, s, o) i = + fromIntegral + (5000 * (max (length t) tout + max (length s) sout + length o + oout)) + where + tout = + if i == 1 || i == 2 + then 1 + else 0 + sout = + if i == 3 + then 1 + else 0 + oout = + if i == 4 + then 1 + else 0 + +-- | Prepare a transaction for sending +prepareTx :: + ConnectionPool + -> T.Text + -> Int + -> ZcashNet + -> ZcashAccountId + -> Int + -> Float + -> 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 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 + Just acc -> do + logDebugN $ T.pack $ show acc + spParams <- liftIO $ BS.readFile "sapling-spend.params" + outParams <- liftIO $ BS.readFile "sapling-output.params" + if show (md5 $ LBS.fromStrict spParams) /= + "0f44c12ef115ae019decf18ade583b20" + then logErrorN "Can't validate sapling parameters" + else logInfoN "Valid Sapling spend params" + if show (md5 $ LBS.fromStrict outParams) /= + "924daf81b87a81bbbb9c7d18562046c8" + then logErrorN "Can't validate sapling parameters" + else logInfoN "Valid Sapling output params" + --print $ BS.length spParams + --print $ BS.length outParams + logDebugN "Read Sapling params" + let zats = fromIntegral $ floorFloatInteger $ amt * (10 ^ 8) + logDebugN $ T.pack $ show zats + {-firstPass <- liftIO $ selectUnspentNotes pool za zats-} + --let fee = calculateTxFee firstPass $ fst recipient + --logDebugN $ T.pack $ "calculated fee " ++ show fee + (tList, sList, oList) <- liftIO $ selectUnspentNotes pool za (zats + 5000) + logDebugN "selected notes" + logDebugN $ T.pack $ show tList + logDebugN $ T.pack $ show sList + logDebugN $ T.pack $ show oList + let noteTotal = getTotalAmount (tList, sList, oList) + tSpends <- + liftIO $ + prepTSpends (getTranSK $ zcashAccountTPrivateKey $ entityVal acc) tList + --print tSpends + sSpends <- + liftIO $ + prepSSpends (getSapSK $ zcashAccountSapSpendKey $ entityVal acc) sList + --print sSpends + oSpends <- + liftIO $ + prepOSpends (getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc) oList + --print oSpends + dummy <- + liftIO $ makeOutgoing acc recipient zats (noteTotal - 5000 - zats) + logDebugN "Calculating fee" + let feeResponse = + createTransaction + (Just sT) + (Just oT) + tSpends + sSpends + oSpends + dummy + (SaplingSpendParams spParams) + (SaplingOutputParams outParams) + zn + (bh + 3) + False + case feeResponse of + Left e1 -> return $ Left Fee + Right fee -> do + let feeAmt = + fromIntegral (runGet getInt64le $ LBS.fromStrict $ toBytes fee) + (tList1, sList1, oList1) <- + liftIO $ selectUnspentNotes pool za (zats + feeAmt) + logDebugN $ T.pack $ "selected notes with fee" ++ show feeAmt + logDebugN $ T.pack $ show tList + logDebugN $ T.pack $ show sList + logDebugN $ T.pack $ show oList + outgoing <- + liftIO $ makeOutgoing acc recipient zats (noteTotal - feeAmt - zats) + logDebugN $ T.pack $ show outgoing + let tx = + createTransaction + (Just sT) + (Just oT) + tSpends + sSpends + oSpends + outgoing + (SaplingSpendParams spParams) + (SaplingOutputParams outParams) + zn + (bh + 3) + True + return tx + 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] + , [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 + (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 + +-- | Sync the wallet with the data store +syncWallet :: + Config -- ^ configuration parameters + -> Entity ZcashWallet + -> IO () +syncWallet config w = do + startTime <- liftIO getCurrentTime + let walletDb = c_dbPath config + pool <- runNoLoggingT $ initPool walletDb + accs <- runNoLoggingT $ getAccounts pool $ entityKey w + addrs <- concat <$> mapM (runNoLoggingT . getAddresses pool . entityKey) accs + intAddrs <- + concat <$> mapM (runNoLoggingT . getInternalAddresses pool . entityKey) accs + chainTip <- runNoLoggingT $ getMaxBlock pool + let lastBlock = zcashWalletLastSync $ entityVal w + let startBlock = + if lastBlock > 0 + then lastBlock + else zcashWalletBirthdayHeight $ entityVal w + mapM_ (liftIO . findTransparentNotes pool startBlock) addrs + mapM_ (liftIO . findTransparentNotes pool startBlock) intAddrs + mapM_ (liftIO . findTransparentSpends pool . entityKey) accs + sapNotes <- + liftIO $ + mapM + (findSaplingOutputs config startBlock (zcashWalletNetwork $ entityVal w)) + accs + orchNotes <- + liftIO $ + mapM + (findOrchardActions config startBlock (zcashWalletNetwork $ entityVal w)) + accs + _ <- updateSaplingWitnesses pool + _ <- updateOrchardWitnesses pool + _ <- liftIO $ updateWalletSync pool chainTip (entityKey w) + mapM_ (runNoLoggingT . getWalletTransactions pool) addrs + +testSync :: Config -> IO () +testSync config = do + let dbPath = c_dbPath config + _ <- initDb dbPath + pool <- runNoLoggingT $ initPool dbPath + w <- getWallets pool TestNet + r <- mapM (syncWallet config) w + liftIO $ print r + {-let uaRead =-} + {-isValidUnifiedAddress-} + {-"utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax"-} + {-case uaRead of-} + {-Nothing -> print "wrong address"-} + {-Just ua -> do-} + {-startTime <- getCurrentTime-} + {-print startTime-} + {-tx <--} + {-prepareTx-} + {-"zenith.db"-} + {-"127.0.0.1"-} + {-18232-} + {-TestNet-} + {-(toSqlKey 1)-} + {-2820897-} + {-0.04-} + {-ua-} + {-"sent with Zenith, test"-} + {-print tx-} + {-endTime <- getCurrentTime-} + {-print endTime-} + +{-testSend :: IO ()-} +{-testSend = do-} +clearSync :: Config -> IO () +clearSync config = do + let dbPath = c_dbPath config + pool <- runNoLoggingT $ initPool dbPath + _ <- initDb dbPath + _ <- clearWalletTransactions pool + w <- getWallets pool TestNet + liftIO $ mapM_ (updateWalletSync pool 0 . entityKey) w + w' <- liftIO $ getWallets pool TestNet + r <- mapM (syncWallet config) w' + liftIO $ print r diff --git a/src/Zenith/DB.hs b/src/Zenith/DB.hs new file mode 100644 index 0000000..a48151d --- /dev/null +++ b/src/Zenith/DB.hs @@ -0,0 +1,1471 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} + +module Zenith.DB where + +import Control.Exception (throwIO) +import Control.Monad (forM_, when) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Logger (NoLoggingT, runNoLoggingT) +import Data.Bifunctor (bimap) +import qualified Data.ByteString as BS +import Data.HexString +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.Word +import Database.Esqueleto.Experimental +import qualified Database.Persist as P +import qualified Database.Persist.Sqlite as PS +import Database.Persist.TH +import Haskoin.Transaction.Common + ( OutPoint(..) + , TxIn(..) + , TxOut(..) + , txHashToHex + ) +import qualified Lens.Micro as ML ((&), (.~), (^.)) +import ZcashHaskell.Orchard (isValidUnifiedAddress) +import ZcashHaskell.Sapling (decodeSaplingOutputEsk) +import ZcashHaskell.Types + ( DecodedNote(..) + , OrchardAction(..) + , OrchardBundle(..) + , OrchardSpendingKey(..) + , OrchardWitness(..) + , SaplingBundle(..) + , SaplingCommitmentTree(..) + , SaplingSpendingKey(..) + , SaplingWitness(..) + , Scope(..) + , ShieldedOutput(..) + , ShieldedSpend(..) + , ToBytes(..) + , Transaction(..) + , TransparentAddress(..) + , TransparentBundle(..) + , TransparentReceiver(..) + , UnifiedAddress(..) + , ZcashNet + , decodeHexText + ) +import Zenith.Types + ( Config(..) + , HexStringDB(..) + , OrchardSpendingKeyDB(..) + , PhraseDB(..) + , RseedDB(..) + , SaplingSpendingKeyDB(..) + , ScopeDB(..) + , TransparentSpendingKeyDB + , UnifiedAddressDB(..) + , ZcashNetDB(..) + ) + +share + [mkPersist sqlSettings, mkMigrate "migrateAll"] + [persistLowerCase| + ZcashWallet + name T.Text + network ZcashNetDB + seedPhrase PhraseDB + birthdayHeight Int + lastSync Int default=0 + UniqueWallet name network + deriving Show Eq + ZcashAccount + index Int + walletId ZcashWalletId + name T.Text + orchSpendKey OrchardSpendingKeyDB + sapSpendKey SaplingSpendingKeyDB + tPrivateKey TransparentSpendingKeyDB + UniqueAccount index walletId + UniqueAccName walletId name + deriving Show Eq + WalletAddress + index Int + accId ZcashAccountId + name T.Text + uAddress UnifiedAddressDB + scope ScopeDB + UniqueAddress index scope accId + UniqueAddName accId name + deriving Show Eq + WalletTransaction + txId HexStringDB + accId ZcashAccountId + block Int + conf Int + time Int + UniqueWTx txId accId + deriving Show Eq + UserTx + hex HexStringDB + address WalletAddressId OnDeleteCascade OnUpdateCascade + time Int + amount Int + memo T.Text + UniqueUTx hex address + deriving Show Eq + WalletTrNote + tx WalletTransactionId OnDeleteCascade OnUpdateCascade + accId ZcashAccountId OnDeleteCascade OnUpdateCascade + address WalletAddressId OnDeleteCascade OnUpdateCascade + value Word64 + spent Bool + script BS.ByteString + change Bool + position Word64 + UniqueTNote tx script + deriving Show Eq + WalletTrSpend + tx WalletTransactionId OnDeleteCascade OnUpdateCascade + note WalletTrNoteId OnDeleteCascade OnUpdateCascade + accId ZcashAccountId OnDeleteCascade OnUpdateCascade + value Word64 + UniqueTrSpend tx accId + deriving Show Eq + WalletSapNote + tx WalletTransactionId OnDeleteCascade OnUpdateCascade + accId ZcashAccountId OnDeleteCascade OnUpdateCascade + value Word64 + recipient BS.ByteString + memo T.Text + spent Bool + nullifier HexStringDB + position Word64 + witness HexStringDB + change Bool + witPos ShieldOutputId OnDeleteIgnore OnUpdateIgnore + rseed RseedDB + UniqueSapNote tx nullifier + deriving Show Eq + WalletSapSpend + tx WalletTransactionId OnDeleteCascade OnUpdateCascade + note WalletSapNoteId OnDeleteCascade OnUpdateCascade + accId ZcashAccountId OnDeleteCascade OnUpdateCascade + value Word64 + UniqueSapSepnd tx accId + deriving Show Eq + WalletOrchNote + tx WalletTransactionId OnDeleteCascade OnUpdateCascade + accId ZcashAccountId OnDeleteCascade OnUpdateCascade + value Word64 + recipient BS.ByteString + memo T.Text + spent Bool + nullifier HexStringDB + position Word64 + witness HexStringDB + change Bool + witPos OrchActionId OnDeleteIgnore OnUpdateIgnore + rho BS.ByteString + rseed RseedDB + UniqueOrchNote tx nullifier + deriving Show Eq + WalletOrchSpend + tx WalletTransactionId OnDeleteCascade OnUpdateCascade + note WalletOrchNoteId OnDeleteCascade OnUpdateCascade + accId ZcashAccountId OnDeleteCascade OnUpdateCascade + value Word64 + UniqueOrchSpend tx accId + deriving Show Eq + ZcashTransaction + block Int + txId HexStringDB + conf Int + time Int + UniqueTx block txId + deriving Show Eq + TransparentNote + tx ZcashTransactionId + value Word64 + script BS.ByteString + position Int + UniqueTNPos tx position + deriving Show Eq + TransparentSpend + tx ZcashTransactionId + outPointHash HexStringDB + outPointIndex Word64 + script BS.ByteString + seq Word64 + position Int + UniqueTSPos tx position + deriving Show Eq + OrchAction + tx ZcashTransactionId + nf HexStringDB + rk HexStringDB + cmx HexStringDB + ephKey HexStringDB + encCipher HexStringDB + outCipher HexStringDB + cv HexStringDB + auth HexStringDB + position Int + UniqueOAPos tx position + deriving Show Eq + ShieldOutput + tx ZcashTransactionId + cv HexStringDB + cmu HexStringDB + ephKey HexStringDB + encCipher HexStringDB + outCipher HexStringDB + proof HexStringDB + position Int + UniqueSOPos tx position + deriving Show Eq + ShieldSpend + tx ZcashTransactionId + cv HexStringDB + anchor HexStringDB + nullifier HexStringDB + rk HexStringDB + proof HexStringDB + authSig HexStringDB + position Int + UniqueSSPos tx position + deriving Show Eq + |] + +-- * Database functions +-- | Initializes the database +initDb :: + T.Text -- ^ The database path to check + -> IO () +initDb dbName = do + PS.runSqlite dbName $ do runMigration migrateAll + +initPool :: T.Text -> NoLoggingT IO ConnectionPool +initPool dbPath = do + let dbInfo = PS.mkSqliteConnectionInfo dbPath + PS.createSqlitePoolFromInfo dbInfo 5 + +-- | Upgrade the database +upgradeDb :: + T.Text -- ^ database path + -> IO () +upgradeDb dbName = do + PS.runSqlite dbName $ do runMigrationUnsafe migrateAll + +-- | Get existing wallets from database +getWallets :: ConnectionPool -> ZcashNet -> IO [Entity ZcashWallet] +getWallets pool n = + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + wallets <- from $ table @ZcashWallet + where_ (wallets ^. ZcashWalletNetwork ==. val (ZcashNetDB n)) + pure wallets + +-- | Save a new wallet to the database +saveWallet :: + ConnectionPool -- ^ The database path to use + -> ZcashWallet -- ^ The wallet to add to the database + -> IO (Maybe (Entity ZcashWallet)) +saveWallet pool w = + runNoLoggingT $ + PS.retryOnBusy $ flip PS.runSqlPool pool $ insertUniqueEntity w + +-- | Update the last sync block for the wallet +updateWalletSync :: ConnectionPool -> Int -> ZcashWalletId -> IO () +updateWalletSync pool b i = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + update $ \w -> do + set w [ZcashWalletLastSync =. val b] + where_ $ w ^. ZcashWalletId ==. val i + +-- | Returns a list of accounts associated with the given wallet +getAccounts :: + ConnectionPool -- ^ The database path + -> ZcashWalletId -- ^ The wallet ID to check + -> NoLoggingT IO [Entity ZcashAccount] +getAccounts pool w = + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + accs <- from $ table @ZcashAccount + where_ (accs ^. ZcashAccountWalletId ==. val w) + pure accs + +getAccountById :: + ConnectionPool -> ZcashAccountId -> IO (Maybe (Entity ZcashAccount)) +getAccountById pool za = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + accs <- from $ table @ZcashAccount + where_ (accs ^. ZcashAccountId ==. val za) + pure accs + +-- | Returns the largest account index for the given wallet +getMaxAccount :: + ConnectionPool -- ^ The database path + -> ZcashWalletId -- ^ The wallet ID to check + -> IO Int +getMaxAccount pool w = do + a <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + accs <- from $ table @ZcashAccount + where_ (accs ^. ZcashAccountWalletId ==. val w) + orderBy [desc $ accs ^. ZcashAccountIndex] + pure accs + case a of + Nothing -> return $ -1 + Just x -> return $ zcashAccountIndex $ entityVal x + +-- | Save a new account to the database +saveAccount :: + ConnectionPool -- ^ The database path + -> ZcashAccount -- ^ The account to add to the database + -> IO (Maybe (Entity ZcashAccount)) +saveAccount pool a = + runNoLoggingT $ + PS.retryOnBusy $ flip PS.runSqlPool pool $ insertUniqueEntity a + +-- | Returns the largest block in storage +getMaxBlock :: + Pool SqlBackend -- ^ The database pool + -> NoLoggingT IO Int +getMaxBlock pool = do + b <- + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + txs <- from $ table @ZcashTransaction + where_ (txs ^. ZcashTransactionBlock >. val 0) + orderBy [desc $ txs ^. ZcashTransactionBlock] + pure txs + case b of + Nothing -> return $ -1 + Just x -> return $ zcashTransactionBlock $ entityVal x + +-- | Returns a list of addresses associated with the given account +getAddresses :: + ConnectionPool -- ^ The database path + -> ZcashAccountId -- ^ The account ID to check + -> NoLoggingT IO [Entity WalletAddress] +getAddresses pool a = + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + addrs <- from $ table @WalletAddress + where_ (addrs ^. WalletAddressAccId ==. val a) + where_ (addrs ^. WalletAddressScope ==. val (ScopeDB External)) + pure addrs + +getAddressById :: + ConnectionPool -> WalletAddressId -> IO (Maybe (Entity WalletAddress)) +getAddressById pool a = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + addr <- from $ table @WalletAddress + where_ (addr ^. WalletAddressId ==. val a) + pure addr + +-- | Returns a list of change addresses associated with the given account +getInternalAddresses :: + ConnectionPool -- ^ The database path + -> ZcashAccountId -- ^ The account ID to check + -> NoLoggingT IO [Entity WalletAddress] +getInternalAddresses pool a = + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + addrs <- from $ table @WalletAddress + where_ (addrs ^. WalletAddressAccId ==. val a) + where_ (addrs ^. WalletAddressScope ==. val (ScopeDB Internal)) + pure addrs + +-- | Returns a list of addressess associated with the given wallet +getWalletAddresses :: + ConnectionPool -- ^ The database path + -> ZcashWalletId -- ^ the wallet to search + -> NoLoggingT IO [Entity WalletAddress] +getWalletAddresses pool w = do + accs <- getAccounts pool w + addrs <- mapM (getAddresses pool . entityKey) accs + return $ concat addrs + +-- | Returns the largest address index for the given account +getMaxAddress :: + ConnectionPool -- ^ The database path + -> ZcashAccountId -- ^ The account ID to check + -> Scope -- ^ The scope of the address + -> IO Int +getMaxAddress pool aw s = do + a <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + addrs <- from $ table @WalletAddress + where_ $ addrs ^. WalletAddressAccId ==. val aw + where_ $ addrs ^. WalletAddressScope ==. val (ScopeDB s) + orderBy [desc $ addrs ^. WalletAddressIndex] + pure addrs + case a of + Nothing -> return $ -1 + Just x -> return $ walletAddressIndex $ entityVal x + +-- | Save a new address to the database +saveAddress :: + ConnectionPool -- ^ the database path + -> WalletAddress -- ^ The wallet to add to the database + -> IO (Maybe (Entity WalletAddress)) +saveAddress pool w = + runNoLoggingT $ + PS.retryOnBusy $ flip PS.runSqlPool pool $ insertUniqueEntity w + +-- | Save a transaction to the data model +saveTransaction :: + ConnectionPool -- ^ the database path + -> Int -- ^ block time + -> Transaction -- ^ The transaction to save + -> NoLoggingT IO (Key ZcashTransaction) +saveTransaction pool t wt = + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + let ix = [0 ..] + w <- + insert $ + ZcashTransaction (tx_height wt) (HexStringDB $ tx_id wt) (tx_conf wt) t + when (isJust $ tx_transpBundle wt) $ do + _ <- + insertMany_ $ + zipWith (curry (storeTxOut w)) ix $ + (tb_vout . fromJust . tx_transpBundle) wt + _ <- + insertMany_ $ + zipWith (curry (storeTxIn w)) ix $ + (tb_vin . fromJust . tx_transpBundle) wt + return () + when (isJust $ tx_saplingBundle wt) $ do + _ <- + insertMany_ $ + zipWith (curry (storeSapSpend w)) ix $ + (sbSpends . fromJust . tx_saplingBundle) wt + _ <- + insertMany_ $ + zipWith (curry (storeSapOutput w)) ix $ + (sbOutputs . fromJust . tx_saplingBundle) wt + return () + when (isJust $ tx_orchardBundle wt) $ + insertMany_ $ + zipWith (curry (storeOrchAction w)) ix $ + (obActions . fromJust . tx_orchardBundle) wt + return w + where + storeTxOut :: ZcashTransactionId -> (Int, TxOut) -> TransparentNote + storeTxOut wid (i, TxOut v s) = TransparentNote wid (fromIntegral v) s i + storeTxIn :: ZcashTransactionId -> (Int, TxIn) -> TransparentSpend + storeTxIn wid (i, TxIn (OutPoint h k) s sq) = + TransparentSpend + wid + (HexStringDB . fromText $ txHashToHex h) + (fromIntegral k) + s + (fromIntegral sq) + i + storeSapSpend :: ZcashTransactionId -> (Int, ShieldedSpend) -> ShieldSpend + storeSapSpend wid (i, sp) = + ShieldSpend + wid + (HexStringDB $ sp_cv sp) + (HexStringDB $ sp_anchor sp) + (HexStringDB $ sp_nullifier sp) + (HexStringDB $ sp_rk sp) + (HexStringDB $ sp_proof sp) + (HexStringDB $ sp_auth sp) + i + storeSapOutput :: + ZcashTransactionId -> (Int, ShieldedOutput) -> ShieldOutput + storeSapOutput wid (i, so) = + ShieldOutput + wid + (HexStringDB $ s_cv so) + (HexStringDB $ s_cmu so) + (HexStringDB $ s_ephKey so) + (HexStringDB $ s_encCipherText so) + (HexStringDB $ s_outCipherText so) + (HexStringDB $ s_proof so) + i + storeOrchAction :: ZcashTransactionId -> (Int, OrchardAction) -> OrchAction + storeOrchAction wid (i, oa) = + OrchAction + wid + (HexStringDB $ nf oa) + (HexStringDB $ rk oa) + (HexStringDB $ cmx oa) + (HexStringDB $ eph_key oa) + (HexStringDB $ enc_ciphertext oa) + (HexStringDB $ out_ciphertext oa) + (HexStringDB $ cv oa) + (HexStringDB $ auth oa) + i + +-- | Get the transactions from a particular block forward +getZcashTransactions :: + ConnectionPool -- ^ The database path + -> Int -- ^ Block + -> IO [Entity ZcashTransaction] +getZcashTransactions pool b = + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + txs <- from $ table @ZcashTransaction + where_ $ txs ^. ZcashTransactionBlock >. val b + orderBy [asc $ txs ^. ZcashTransactionBlock] + return txs + +-- * Wallet +-- | Get the block of the last transaction known to the wallet +getMaxWalletBlock :: + ConnectionPool -- ^ The database path + -> IO Int +getMaxWalletBlock pool = do + b <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + txs <- from $ table @WalletTransaction + where_ $ txs ^. WalletTransactionBlock >. val 0 + orderBy [desc $ txs ^. WalletTransactionBlock] + return txs + case b of + Nothing -> return $ -1 + Just x -> return $ walletTransactionBlock $ entityVal x + +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) + orderBy [asc $ w ^. ZcashWalletBirthdayHeight] + pure w + case b of + Nothing -> return 0 + Just x -> return $ zcashWalletBirthdayHeight $ entityVal x + +getLastSyncBlock :: ConnectionPool -> ZcashWalletId -> IO Int +getLastSyncBlock pool zw = do + b <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + w <- from $ table @ZcashWallet + where_ (w ^. ZcashWalletId ==. val zw) + pure w + case b of + Nothing -> throwIO $ userError "Failed to retrieve wallet" + Just x -> return $ zcashWalletLastSync $ entityVal x + +-- | Save a @WalletTransaction@ +saveWalletTransaction :: + ConnectionPool + -> ZcashAccountId + -> Entity ZcashTransaction + -> IO WalletTransactionId +saveWalletTransaction pool za zt = do + let zT' = entityVal zt + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + 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 + -> Integer -- ^ note position + -> SaplingWitness -- ^ the Sapling incremental witness + -> Bool -- ^ change flag + -> ZcashAccountId + -> ShieldOutputId + -> DecodedNote -- The decoded Sapling note + -> IO () +saveWalletSapNote pool wId pos wit ch za zt dn = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + _ <- + upsert + (WalletSapNote + wId + za + (fromIntegral $ a_value dn) + (a_recipient dn) + (T.filter (/= '\NUL') $ TE.decodeUtf8Lenient $ a_memo dn) + False + (HexStringDB $ a_nullifier dn) + (fromIntegral pos) + (HexStringDB $ sapWit wit) + ch + zt + (RseedDB $ a_rseed dn)) + [] + return () + +-- | Save a @WalletOrchNote@ +saveWalletOrchNote :: + ConnectionPool + -> WalletTransactionId + -> Integer + -> OrchardWitness + -> Bool + -> ZcashAccountId + -> OrchActionId + -> DecodedNote + -> IO () +saveWalletOrchNote pool wId pos wit ch za zt dn = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + _ <- + upsert + (WalletOrchNote + wId + za + (fromIntegral $ a_value dn) + (a_recipient dn) + (T.filter (/= '\NUL') $ TE.decodeUtf8Lenient $ a_memo dn) + False + (HexStringDB $ a_nullifier dn) + (fromIntegral pos) + (HexStringDB $ orchWit wit) + ch + zt + (a_rho dn) + (RseedDB $ a_rseed dn)) + [] + return () + +-- | Find the Transparent Notes that match the given transparent receiver +findTransparentNotes :: + ConnectionPool -- ^ The database path + -> Int -- ^ Starting block + -> Entity WalletAddress + -> IO () +findTransparentNotes pool b t = do + let tReceiver = t_rec =<< readUnifiedAddressDB (entityVal t) + case tReceiver of + Just tR -> do + let s = + BS.concat + [ BS.pack [0x76, 0xA9, 0x14] + , (toBytes . tr_bytes) tR + , BS.pack [0x88, 0xAC] + ] + tN <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + (txs :& tNotes) <- + from $ table @ZcashTransaction `innerJoin` table @TransparentNote `on` + (\(txs :& tNotes) -> + txs ^. ZcashTransactionId ==. tNotes ^. TransparentNoteTx) + where_ (txs ^. ZcashTransactionBlock >. val b) + where_ (tNotes ^. TransparentNoteScript ==. val s) + pure (txs, tNotes) + mapM_ + (saveWalletTrNote + pool + (getScope $ walletAddressScope $ entityVal t) + (walletAddressAccId $ entityVal t) + (entityKey t)) + tN + Nothing -> return () + +-- | Add the transparent notes to the wallet +saveWalletTrNote :: + ConnectionPool -- ^ the database path + -> Scope + -> ZcashAccountId + -> WalletAddressId + -> (Entity ZcashTransaction, Entity TransparentNote) + -> IO () +saveWalletTrNote pool ch za wa (zt, tn) = do + let zT' = entityVal zt + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + t <- + upsert + (WalletTransaction + (zcashTransactionTxId zT') + za + (zcashTransactionBlock zT') + (zcashTransactionConf zT') + (zcashTransactionTime zT')) + [] + insert_ $ + WalletTrNote + (entityKey t) + za + wa + (transparentNoteValue $ entityVal tn) + False + (transparentNoteScript $ entityVal tn) + (ch == Internal) + (fromIntegral $ transparentNotePosition $ entityVal tn) + +-- | Save a Sapling note to the wallet database +saveSapNote :: ConnectionPool -> WalletSapNote -> IO () +saveSapNote pool wsn = + runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ insert_ wsn + +-- | Get the shielded outputs from the given blockheight +getShieldedOutputs :: + ConnectionPool -- ^ database path + -> Int -- ^ block + -> IO [(Entity ZcashTransaction, Entity ShieldOutput)] +getShieldedOutputs pool b = + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + (txs :& sOutputs) <- + from $ table @ZcashTransaction `innerJoin` table @ShieldOutput `on` + (\(txs :& sOutputs) -> + txs ^. ZcashTransactionId ==. sOutputs ^. ShieldOutputTx) + where_ (txs ^. ZcashTransactionBlock >=. val b) + orderBy + [ asc $ txs ^. ZcashTransactionId + , asc $ sOutputs ^. ShieldOutputPosition + ] + pure (txs, sOutputs) + +-- | Get the Orchard actions from the given blockheight forward +getOrchardActions :: + ConnectionPool -- ^ database path + -> Int -- ^ block + -> IO [(Entity ZcashTransaction, Entity OrchAction)] +getOrchardActions pool b = + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + (txs :& oActions) <- + from $ table @ZcashTransaction `innerJoin` table @OrchAction `on` + (\(txs :& oActions) -> + txs ^. ZcashTransactionId ==. oActions ^. OrchActionTx) + where_ (txs ^. ZcashTransactionBlock >=. val b) + orderBy + [asc $ txs ^. ZcashTransactionId, asc $ oActions ^. OrchActionPosition] + pure (txs, oActions) + +-- | Get the transactions belonging to the given address +getWalletTransactions :: + ConnectionPool -- ^ database path + -> Entity WalletAddress + -> NoLoggingT IO () +getWalletTransactions pool w = do + let w' = entityVal w + chgAddr <- getInternalAddresses pool $ walletAddressAccId $ entityVal w + let ctReceiver = t_rec =<< readUnifiedAddressDB (entityVal $ head chgAddr) + let csReceiver = s_rec =<< readUnifiedAddressDB (entityVal $ head chgAddr) + let coReceiver = o_rec =<< readUnifiedAddressDB (entityVal $ head chgAddr) + 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 -> 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 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 <> trChgNotes))) + pure trSpends + sapNotes <- + case sReceiver of + Nothing -> return [] + Just sR -> do + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + snotes <- from $ table @WalletSapNote + where_ (snotes ^. WalletSapNoteRecipient ==. val (getBytes sR)) + pure snotes + sapChgNotes <- + case csReceiver of + Nothing -> return [] + Just sR -> do + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + snotes <- from $ table @WalletSapNote + where_ (snotes ^. WalletSapNoteRecipient ==. val (getBytes sR)) + pure snotes + sapSpends <- mapM (getSapSpends . entityKey) (sapNotes <> sapChgNotes) + orchNotes <- + case oReceiver of + Nothing -> return [] + Just oR -> do + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + onotes <- from $ table @WalletOrchNote + where_ (onotes ^. WalletOrchNoteRecipient ==. val (getBytes oR)) + pure onotes + orchChgNotes <- + case coReceiver of + Nothing -> return [] + Just oR -> do + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + onotes <- from $ table @WalletOrchNote + where_ (onotes ^. WalletOrchNoteRecipient ==. val (getBytes oR)) + pure onotes + orchSpends <- mapM (getOrchSpends . entityKey) (orchNotes <> orchChgNotes) + clearUserTx (entityKey w) + mapM_ addTr trNotes + mapM_ addTr trChgNotes + mapM_ addSap sapNotes + mapM_ addSap sapChgNotes + mapM_ addOrch orchNotes + mapM_ addOrch orchChgNotes + mapM_ subTSpend trSpends + mapM_ subSSpend $ catMaybes sapSpends + mapM_ subOSpend $ catMaybes orchSpends + where + clearUserTx :: WalletAddressId -> NoLoggingT IO () + clearUserTx waId = do + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + delete $ do + u <- from $ table @UserTx + where_ (u ^. UserTxAddress ==. val waId) + return () + getSapSpends :: + WalletSapNoteId -> NoLoggingT IO (Maybe (Entity WalletSapSpend)) + getSapSpends n = do + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + sapSpends <- from $ table @WalletSapSpend + where_ (sapSpends ^. WalletSapSpendNote ==. val n) + pure sapSpends + getOrchSpends :: + WalletOrchNoteId -> NoLoggingT IO (Maybe (Entity WalletOrchSpend)) + getOrchSpends n = do + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + orchSpends <- from $ table @WalletOrchSpend + where_ (orchSpends ^. WalletOrchSpendNote ==. val n) + pure orchSpends + addTr :: Entity WalletTrNote -> NoLoggingT IO () + addTr n = + upsertUserTx + (walletTrNoteTx $ entityVal n) + (entityKey w) + (fromIntegral $ walletTrNoteValue $ entityVal n) + "" + addSap :: Entity WalletSapNote -> NoLoggingT IO () + addSap n = + upsertUserTx + (walletSapNoteTx $ entityVal n) + (entityKey w) + (fromIntegral $ walletSapNoteValue $ entityVal n) + (walletSapNoteMemo $ entityVal n) + addOrch :: Entity WalletOrchNote -> NoLoggingT IO () + addOrch n = + upsertUserTx + (walletOrchNoteTx $ entityVal n) + (entityKey w) + (fromIntegral $ walletOrchNoteValue $ entityVal n) + (walletOrchNoteMemo $ entityVal n) + subTSpend :: Entity WalletTrSpend -> NoLoggingT IO () + subTSpend n = + upsertUserTx + (walletTrSpendTx $ entityVal n) + (entityKey w) + (-(fromIntegral $ walletTrSpendValue $ entityVal n)) + "" + subSSpend :: Entity WalletSapSpend -> NoLoggingT IO () + subSSpend n = + upsertUserTx + (walletSapSpendTx $ entityVal n) + (entityKey w) + (-(fromIntegral $ walletSapSpendValue $ entityVal n)) + "" + subOSpend :: Entity WalletOrchSpend -> NoLoggingT IO () + subOSpend n = + upsertUserTx + (walletOrchSpendTx $ entityVal n) + (entityKey w) + (-(fromIntegral $ walletOrchSpendValue $ entityVal n)) + "" + upsertUserTx :: + WalletTransactionId + -> WalletAddressId + -> Int + -> T.Text + -> NoLoggingT IO () + upsertUserTx tId wId amt memo = do + tr <- + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + tx <- from $ table @WalletTransaction + where_ (tx ^. WalletTransactionId ==. val tId) + pure tx + existingUtx <- + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + ut <- from $ table @UserTx + where_ + (ut ^. UserTxHex ==. + val (walletTransactionTxId $ entityVal $ head tr)) + where_ (ut ^. UserTxAddress ==. val wId) + pure ut + case existingUtx of + Nothing -> do + _ <- + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + upsert + (UserTx + (walletTransactionTxId $ entityVal $ head tr) + wId + (walletTransactionTime $ entityVal $ head tr) + amt + memo) + [] + return () + Just uTx -> do + _ <- + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + update $ \t -> do + set + t + [ UserTxAmount +=. val amt + , UserTxMemo =. + val (memo <> " " <> userTxMemo (entityVal uTx)) + ] + where_ (t ^. UserTxId ==. val (entityKey uTx)) + return () + +getUserTx :: ConnectionPool -> WalletAddressId -> IO [Entity UserTx] +getUserTx pool aId = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + uTxs <- from $ table @UserTx + where_ (uTxs ^. UserTxAddress ==. val aId) + orderBy [asc $ uTxs ^. UserTxTime] + return uTxs + +-- | Get wallet transparent notes by account +getWalletTrNotes :: ConnectionPool -> ZcashAccountId -> IO [Entity WalletTrNote] +getWalletTrNotes pool za = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + n <- from $ table @WalletTrNote + where_ (n ^. WalletTrNoteAccId ==. val za) + pure n + +-- | find Transparent spends +findTransparentSpends :: ConnectionPool -> ZcashAccountId -> IO () +findTransparentSpends pool za = do + notes <- getWalletTrNotes pool za + mapM_ findOneTrSpend notes + where + findOneTrSpend :: Entity WalletTrNote -> IO () + findOneTrSpend n = do + mReverseTxId <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + wtx <- from $ table @WalletTransaction + where_ + (wtx ^. WalletTransactionId ==. val (walletTrNoteTx $ entityVal n)) + pure $ wtx ^. WalletTransactionTxId + case mReverseTxId of + Nothing -> throwIO $ userError "failed to get tx ID" + Just (Value reverseTxId) -> do + let flipTxId = + HexStringDB $ + HexString $ BS.reverse $ toBytes $ getHex reverseTxId + s <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + (tx :& trSpends) <- + from $ + table @ZcashTransaction `innerJoin` table @TransparentSpend `on` + (\(tx :& trSpends) -> + tx ^. ZcashTransactionId ==. trSpends ^. TransparentSpendTx) + where_ + (trSpends ^. TransparentSpendOutPointHash ==. val flipTxId) + where_ + (trSpends ^. TransparentSpendOutPointIndex ==. + val (walletTrNotePosition $ entityVal n)) + pure (tx, trSpends) + if null s + then return () + else do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + _ <- + update $ \w -> do + set w [WalletTrNoteSpent =. val True] + where_ $ w ^. WalletTrNoteId ==. val (entityKey n) + t' <- upsertWalTx (entityVal $ fst $ head s) za + _ <- + upsert + (WalletTrSpend + (entityKey t') + (entityKey n) + za + (walletTrNoteValue $ entityVal n)) + [] + return () + +getWalletSapNotes :: + ConnectionPool -> ZcashAccountId -> IO [Entity WalletSapNote] +getWalletSapNotes pool za = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + n <- from $ table @WalletSapNote + where_ (n ^. WalletSapNoteAccId ==. val za) + pure n + +-- | Sapling DAG-aware spend tracking +findSapSpends :: + ConnectionPool -> ZcashAccountId -> [Entity WalletSapNote] -> IO () +findSapSpends _ _ [] = return () +findSapSpends pool za (n:notes) = do + s <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + (tx :& sapSpends) <- + from $ table @ZcashTransaction `innerJoin` table @ShieldSpend `on` + (\(tx :& sapSpends) -> + tx ^. ZcashTransactionId ==. sapSpends ^. ShieldSpendTx) + where_ + (sapSpends ^. ShieldSpendNullifier ==. + val (walletSapNoteNullifier (entityVal n))) + pure (tx, sapSpends) + if null s + then findSapSpends pool za notes + else do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + _ <- + update $ \w -> do + set w [WalletSapNoteSpent =. val True] + where_ $ w ^. WalletSapNoteId ==. val (entityKey n) + t' <- upsertWalTx (entityVal $ fst $ head s) za + _ <- + upsert + (WalletSapSpend + (entityKey t') + (entityKey n) + za + (walletSapNoteValue $ entityVal n)) + [] + return () + findSapSpends pool za notes + +getWalletOrchNotes :: + ConnectionPool -> ZcashAccountId -> IO [Entity WalletOrchNote] +getWalletOrchNotes pool za = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + n <- from $ table @WalletOrchNote + where_ (n ^. WalletOrchNoteAccId ==. val za) + pure n + +getUnspentSapNotes :: ConnectionPool -> IO [Entity WalletSapNote] +getUnspentSapNotes pool = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + n <- from $ table @WalletSapNote + where_ (n ^. WalletSapNoteSpent ==. val False) + pure n + +getSaplingCmus :: Pool SqlBackend -> ShieldOutputId -> IO [Value HexStringDB] +getSaplingCmus pool zt = do + PS.runSqlPool + (select $ do + n <- from $ table @ShieldOutput + where_ (n ^. ShieldOutputId >. val zt) + orderBy [asc $ n ^. ShieldOutputId] + pure $ n ^. ShieldOutputCmu) + pool + +getMaxSaplingNote :: Pool SqlBackend -> IO ShieldOutputId +getMaxSaplingNote pool = do + flip PS.runSqlPool pool $ do + x <- + selectOne $ do + 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 y) -> return y + +updateSapNoteRecord :: + Pool SqlBackend + -> WalletSapNoteId + -> SaplingWitness + -> ShieldOutputId + -> IO () +updateSapNoteRecord pool n w o = do + flip PS.runSqlPool pool $ do + update $ \x -> do + set + x + [ WalletSapNoteWitness =. val (HexStringDB $ sapWit w) + , WalletSapNoteWitPos =. val o + ] + where_ (x ^. WalletSapNoteId ==. val n) + +getUnspentOrchNotes :: ConnectionPool -> IO [Entity WalletOrchNote] +getUnspentOrchNotes pool = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + n <- from $ table @WalletOrchNote + where_ (n ^. WalletOrchNoteSpent ==. val False) + pure n + +getOrchardCmxs :: Pool SqlBackend -> OrchActionId -> IO [Value HexStringDB] +getOrchardCmxs pool zt = do + PS.runSqlPool + (select $ do + n <- from $ table @OrchAction + where_ (n ^. OrchActionId >. val zt) + orderBy [asc $ n ^. OrchActionId] + pure $ n ^. OrchActionCmx) + pool + +getMaxOrchardNote :: Pool SqlBackend -> IO OrchActionId +getMaxOrchardNote pool = do + flip PS.runSqlPool pool $ do + x <- + selectOne $ do + 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 y) -> return y + +updateOrchNoteRecord :: + Pool SqlBackend + -> WalletOrchNoteId + -> OrchardWitness + -> OrchActionId + -> IO () +updateOrchNoteRecord pool n w o = do + flip PS.runSqlPool pool $ do + update $ \x -> do + set + x + [ WalletOrchNoteWitness =. val (HexStringDB $ orchWit w) + , WalletOrchNoteWitPos =. val o + ] + where_ (x ^. WalletOrchNoteId ==. val n) + +findOrchSpends :: + ConnectionPool -> ZcashAccountId -> [Entity WalletOrchNote] -> IO () +findOrchSpends _ _ [] = return () +findOrchSpends pool za (n:notes) = do + s <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + (tx :& orchSpends) <- + from $ table @ZcashTransaction `innerJoin` table @OrchAction `on` + (\(tx :& orchSpends) -> + tx ^. ZcashTransactionId ==. orchSpends ^. OrchActionTx) + where_ + (orchSpends ^. OrchActionNf ==. + val (walletOrchNoteNullifier (entityVal n))) + pure (tx, orchSpends) + if null s + then findOrchSpends pool za notes + else do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + _ <- + update $ \w -> do + set w [WalletOrchNoteSpent =. val True] + where_ $ w ^. WalletOrchNoteId ==. val (entityKey n) + t' <- upsertWalTx (entityVal $ fst $ head s) za + _ <- + upsert + (WalletOrchSpend + (entityKey t') + (entityKey n) + za + (walletOrchNoteValue $ entityVal n)) + [] + return () + findOrchSpends pool za notes + +upsertWalTx :: + MonadIO m + => ZcashTransaction + -> ZcashAccountId + -> SqlPersistT m (Entity WalletTransaction) +upsertWalTx zt za = + upsert + (WalletTransaction + (zcashTransactionTxId zt) + za + (zcashTransactionBlock zt) + (zcashTransactionConf zt) + (zcashTransactionTime zt)) + [] + +getBalance :: ConnectionPool -> ZcashAccountId -> IO Integer +getBalance 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 . fromIntegral $ tBal + sBal + oBal + +clearWalletTransactions :: ConnectionPool -> IO () +clearWalletTransactions pool = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + delete $ do + _ <- from $ table @UserTx + return () + delete $ do + _ <- from $ table @WalletOrchSpend + return () + delete $ do + _ <- from $ table @WalletOrchNote + return () + delete $ do + _ <- from $ table @WalletSapSpend + return () + delete $ do + _ <- from $ table @WalletSapNote + return () + delete $ do + _ <- from $ table @WalletTrNote + return () + delete $ do + _ <- from $ table @WalletTrSpend + return () + delete $ do + _ <- from $ table @WalletTransaction + return () + +getWalletUnspentTrNotes :: + ConnectionPool -> ZcashAccountId -> IO [Entity WalletTrNote] +getWalletUnspentTrNotes pool za = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + n <- from $ table @WalletTrNote + where_ (n ^. WalletTrNoteAccId ==. val za) + where_ (n ^. WalletTrNoteSpent ==. val False) + pure n + +getWalletUnspentSapNotes :: + ConnectionPool -> ZcashAccountId -> IO [Entity WalletSapNote] +getWalletUnspentSapNotes pool za = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + n1 <- from $ table @WalletSapNote + where_ (n1 ^. WalletSapNoteAccId ==. val za) + where_ (n1 ^. WalletSapNoteSpent ==. val False) + pure n1 + +getWalletUnspentOrchNotes :: + ConnectionPool -> ZcashAccountId -> IO [Entity WalletOrchNote] +getWalletUnspentOrchNotes pool za = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + n2 <- from $ table @WalletOrchNote + where_ (n2 ^. WalletOrchNoteAccId ==. val za) + where_ (n2 ^. WalletOrchNoteSpent ==. val False) + pure n2 + +selectUnspentNotes :: + ConnectionPool + -> ZcashAccountId + -> Integer + -> IO ([Entity WalletTrNote], [Entity WalletSapNote], [Entity WalletOrchNote]) +selectUnspentNotes pool za amt = do + trNotes <- getWalletUnspentTrNotes pool za + let (a1, tList) = checkTransparent (fromIntegral amt) trNotes + if a1 > 0 + then do + sapNotes <- getWalletUnspentSapNotes pool za + let (a2, sList) = checkSapling a1 sapNotes + if a2 > 0 + then do + orchNotes <- getWalletUnspentOrchNotes pool za + let (a3, oList) = checkOrchard a2 orchNotes + if a3 > 0 + then throwIO $ userError "Not enough funds" + else return (tList, sList, oList) + else return (tList, sList, []) + else return (tList, [], []) + where + checkTransparent :: + Word64 -> [Entity WalletTrNote] -> (Word64, [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 :: + Word64 -> [Entity WalletSapNote] -> (Word64, [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 :: + Word64 -> [Entity WalletOrchNote] -> (Word64, [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]) + +getWalletTxId :: + ConnectionPool -> WalletTransactionId -> IO (Maybe (Value HexStringDB)) +getWalletTxId pool wId = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + wtx <- from $ table @WalletTransaction + where_ (wtx ^. WalletTransactionId ==. val wId) + pure $ wtx ^. WalletTransactionTxId + +-- | Helper function to extract a Unified Address from the database +readUnifiedAddressDB :: WalletAddress -> Maybe UnifiedAddress +readUnifiedAddressDB = + isValidUnifiedAddress . TE.encodeUtf8 . getUA . walletAddressUAddress + +rmdups :: Ord a => [a] -> [a] +rmdups = map head . group . sort diff --git a/src/Zenith/Scanner.hs b/src/Zenith/Scanner.hs new file mode 100644 index 0000000..df47ed1 --- /dev/null +++ b/src/Zenith/Scanner.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Zenith.Scanner where + +import Control.Exception (throwIO, try) +import qualified Control.Monad.Catch as CM (try) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Logger + ( LoggingT + , NoLoggingT + , logErrorN + , logInfoN + , runNoLoggingT + ) +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(..) + , ZebraGetBlockChainInfo(..) + , ZebraTxResponse(..) + , fromRawOBundle + , fromRawSBundle + , fromRawTBundle + ) +import ZcashHaskell.Utils (getBlockTime, makeZebraCall, readZebraTransaction) +import Zenith.Core (checkBlockChain) +import Zenith.DB (getMaxBlock, initDb, saveTransaction) +import Zenith.Utils (jsonNumber) + +-- | Function to scan the Zcash blockchain through the Zebra node and populate the Zenith database +scanZebra :: + Int -- ^ Starting block + -> T.Text -- ^ Host + -> Int -- ^ Port + -> T.Text -- ^ Path to database file + -> NoLoggingT IO () +scanZebra b host port dbFilePath = do + _ <- liftIO $ initDb dbFilePath + startTime <- liftIO getCurrentTime + logInfoN $ "Started sync: " <> T.pack (show startTime) + bc <- + liftIO $ try $ checkBlockChain host port :: NoLoggingT + IO + (Either IOError ZebraGetBlockChainInfo) + case bc of + Left e -> logErrorN $ T.pack (show e) + Right bStatus -> do + 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 + 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 :: + T.Text -- ^ Host name for `zebrad` + -> Int -- ^ Port for `zebrad` + -> ConnectionPool -- ^ DB file path + -> ProgressBar -- ^ Progress bar + -> Int -- ^ The block number to process + -> NoLoggingT IO () +processBlock host port pool pg b = do + r <- + liftIO $ + makeZebraCall + host + port + "getblock" + [Data.Aeson.String $ T.pack $ show b, jsonNumber 1] + case r of + Left e -> liftIO $ throwIO $ userError e + Right blk -> do + r2 <- + liftIO $ + makeZebraCall + host + port + "getblock" + [Data.Aeson.String $ T.pack $ show b, jsonNumber 0] + case r2 of + Left e2 -> liftIO $ throwIO $ userError e2 + Right hb -> do + let blockTime = getBlockTime hb + mapM_ (processTx host port blockTime pool) $ + bl_txs $ addTime blk blockTime + liftIO $ tick pg + where + addTime :: BlockResponse -> Int -> BlockResponse + addTime bl t = + BlockResponse + (bl_confirmations bl) + (bl_height bl) + (fromIntegral t) + (bl_txs bl) + +-- | Function to process a raw transaction +processTx :: + T.Text -- ^ Host name for `zebrad` + -> Int -- ^ Port for `zebrad` + -> Int -- ^ Block time + -> ConnectionPool -- ^ DB file path + -> HexString -- ^ transaction id + -> NoLoggingT IO () +processTx host port bt pool t = do + r <- + liftIO $ + makeZebraCall + host + port + "getrawtransaction" + [Data.Aeson.String $ toText t, jsonNumber 1] + case r of + Left e -> liftIO $ throwIO $ userError e + Right rawTx -> do + case readZebraTransaction (ztr_hex rawTx) of + Nothing -> return () + Just rzt -> do + _ <- + saveTransaction pool bt $ + Transaction + t + (ztr_blockheight rawTx) + (ztr_conf rawTx) + (fromIntegral $ zt_expiry rzt) + (fromRawTBundle $ zt_tBundle rzt) + (fromRawSBundle $ zt_sBundle rzt) + (fromRawOBundle $ zt_oBundle rzt) + return () diff --git a/src/Zenith/Types.hs b/src/Zenith/Types.hs new file mode 100644 index 0000000..5526aa6 --- /dev/null +++ b/src/Zenith/Types.hs @@ -0,0 +1,350 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Zenith.Types where + +import Data.Aeson +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.Maybe (fromMaybe) +import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import Data.Text.Encoding.Error (lenientDecode) +import Database.Persist.TH +import GHC.Generics +import ZcashHaskell.Types + ( OrchardSpendingKey(..) + , Phrase(..) + , Rseed(..) + , SaplingSpendingKey(..) + , Scope(..) + , TransparentSpendingKey + , ZcashNet(..) + ) + +-- * UI +-- * Database field type wrappers +newtype HexStringDB = HexStringDB + { getHex :: HexString + } deriving newtype (Eq, Show, Read) + +derivePersistField "HexStringDB" + +newtype ZcashNetDB = ZcashNetDB + { getNet :: ZcashNet + } deriving newtype (Eq, Show, Read) + +derivePersistField "ZcashNetDB" + +newtype UnifiedAddressDB = UnifiedAddressDB + { getUA :: T.Text + } deriving newtype (Eq, Show, Read) + +derivePersistField "UnifiedAddressDB" + +newtype PhraseDB = PhraseDB + { getPhrase :: Phrase + } deriving newtype (Eq, Show, Read) + +derivePersistField "PhraseDB" + +newtype ScopeDB = ScopeDB + { getScope :: Scope + } deriving newtype (Eq, Show, Read) + +derivePersistField "ScopeDB" + +newtype OrchardSpendingKeyDB = OrchardSpendingKeyDB + { getOrchSK :: OrchardSpendingKey + } deriving newtype (Eq, Show, Read) + +derivePersistField "OrchardSpendingKeyDB" + +newtype SaplingSpendingKeyDB = SaplingSpendingKeyDB + { getSapSK :: SaplingSpendingKey + } deriving newtype (Eq, Show, Read) + +derivePersistField "SaplingSpendingKeyDB" + +newtype TransparentSpendingKeyDB = TransparentSpendingKeyDB + { getTranSK :: TransparentSpendingKey + } deriving newtype (Eq, Show, Read) + +derivePersistField "TransparentSpendingKeyDB" + +newtype RseedDB = RseedDB + { getRseed :: Rseed + } deriving newtype (Eq, Show, Read) + +derivePersistField "RseedDB" + +-- * RPC +-- | Type for Configuration parameters +data Config = Config + { c_dbPath :: !T.Text + , c_zebraHost :: !T.Text + , c_zebraPort :: !Int + } deriving (Eq, Prelude.Show) + +-- ** `zebrad` +-- | Type for modeling the tree state response +data ZebraTreeInfo = ZebraTreeInfo + { ztiHeight :: !Int + , ztiTime :: !Int + , ztiSapling :: !HexString + , ztiOrchard :: !HexString + } deriving (Eq, Show, Read) + +instance FromJSON ZebraTreeInfo where + parseJSON = + withObject "ZebraTreeInfo" $ \obj -> do + h <- obj .: "height" + t <- obj .: "time" + s <- obj .: "sapling" + o <- obj .: "orchard" + sc <- s .: "commitments" + oc <- o .: "commitments" + sf <- sc .: "finalState" + ocf <- oc .: "finalState" + pure $ ZebraTreeInfo h t sf ocf + +-- ** `zcashd` +-- | Type for modelling the different address sources for `zcashd` 5.0.0 +data AddressSource + = LegacyRandom + | Imported + | ImportedWatchOnly + | KeyPool + | LegacySeed + | MnemonicSeed + deriving (Read, Show, Eq, Generic, ToJSON) + +instance FromJSON AddressSource where + parseJSON = + withText "AddressSource" $ \case + "legacy_random" -> return LegacyRandom + "imported" -> return Imported + "imported_watchonly" -> return ImportedWatchOnly + "keypool" -> return KeyPool + "legacy_hdseed" -> return LegacySeed + "mnemonic_seed" -> return MnemonicSeed + _ -> fail "Not a known address source" + +data ZcashPool + = Transparent + | Sprout + | Sapling + | Orchard + deriving (Show, Eq, Generic, ToJSON) + +instance FromJSON ZcashPool where + parseJSON = + withText "ZcashPool" $ \case + "p2pkh" -> return Transparent + "sprout" -> return Sprout + "sapling" -> return Sapling + "orchard" -> return Orchard + _ -> fail "Not a known Zcash pool" + +data ZcashAddress = ZcashAddress + { source :: AddressSource + , pool :: [ZcashPool] + , account :: Maybe Integer + , addy :: T.Text + } deriving (Eq) + +instance Show ZcashAddress where + show (ZcashAddress s p i a) = + T.unpack (T.take 8 a) ++ + "..." ++ T.unpack (T.takeEnd 8 a) ++ " Pools: " ++ show p + +newtype NodeVersion = + NodeVersion Integer + deriving (Eq, Show) + +instance FromJSON NodeVersion where + parseJSON = + withObject "NodeVersion" $ \obj -> do + v <- obj .: "version" + pure $ NodeVersion v + +-- | A type to model an address group +data AddressGroup = AddressGroup + { agsource :: !AddressSource + , agtransparent :: ![ZcashAddress] + , agsapling :: ![ZcashAddress] + , agunified :: ![ZcashAddress] + } deriving (Show, Generic) + +instance FromJSON AddressGroup where + parseJSON = + withObject "AddressGroup" $ \obj -> do + s <- obj .: "source" + t <- obj .:? "transparent" + sap <- obj .:? "sapling" + uni <- obj .:? "unified" + sL <- processSapling sap s + tL <- processTransparent t s + uL <- processUnified uni + return $ AddressGroup s tL (concat sL) (concat uL) + where + processTransparent c s1 = + case c of + Nothing -> return [] + Just x -> do + x' <- x .:? "addresses" + return $ maybe [] (map (ZcashAddress s1 [Transparent] Nothing)) x' + processSapling k s2 = + case k of + Nothing -> return [] + Just y -> mapM (processOneSapling s2) y + where processOneSapling sx = + withObject "Sapling" $ \oS -> do + oS' <- oS .: "addresses" + return $ map (ZcashAddress sx [Sapling] Nothing) oS' + processUnified u = + case u of + Nothing -> return [] + Just z -> mapM processOneAccount z + where processOneAccount = + withObject "UAs" $ \uS -> do + acct <- uS .: "account" + uS' <- uS .: "addresses" + mapM (processUAs acct) uS' + where + processUAs a = + withObject "UAs" $ \v -> do + addr <- v .: "address" + p <- v .: "receiver_types" + return $ ZcashAddress MnemonicSeed p a addr + +-- | A type to model a Zcash transaction +data ZcashTx = ZcashTx + { ztxid :: !T.Text + , zamount :: !Double + , zamountZat :: !Integer + , zblockheight :: !Integer + , zblocktime :: !Integer + , zchange :: !Bool + , zconfirmations :: !Integer + , zmemo :: !T.Text + } deriving (Show, Generic) + +instance FromJSON ZcashTx where + parseJSON = + withObject "ZcashTx" $ \obj -> do + t <- obj .: "txid" + a <- obj .: "amount" + aZ <- obj .: "amountZat" + bh <- obj .: "blockheight" + bt <- obj .: "blocktime" + c <- obj .:? "change" + conf <- obj .: "confirmations" + m <- obj .:? "memo" + pure $ + ZcashTx + t + a + aZ + bh + bt + (fromMaybe False c) + conf + (case m of + Nothing -> "" + Just m' -> T.filter (/= '\NUL') $ decodeHexText m') + +instance ToJSON ZcashTx where + toJSON (ZcashTx t a aZ bh bt c conf m) = + object + [ "amount" .= a + , "amountZat" .= aZ + , "txid" .= t + , "blockheight" .= bh + , "blocktime" .= bt + , "change" .= c + , "confirmations" .= conf + , "memo" .= m + ] + +-- | Type for the UA balance +data UABalance = UABalance + { uatransparent :: !Integer + , uasapling :: !Integer + , uaorchard :: !Integer + } deriving (Eq) + +instance Show UABalance where + show (UABalance t s o) = + " T: " ++ show t ++ " S: " ++ show s ++ " O: " ++ show o + +instance FromJSON UABalance where + parseJSON = + withObject "UABalance" $ \obj -> do + p <- obj .: "pools" + t <- p .:? "transparent" + s <- p .:? "sapling" + o <- p .:? "orchard" + vT <- + case t of + Nothing -> return 0 + Just t' -> t' .: "valueZat" + vS <- + case s of + Nothing -> return 0 + Just s' -> s' .: "valueZat" + vO <- + case o of + Nothing -> return 0 + Just o' -> o' .: "valueZat" + pure $ UABalance vT vS vO + +-- | Type for Operation Result +data OpResult = OpResult + { opsuccess :: !T.Text + , opmessage :: !(Maybe T.Text) + , optxid :: !(Maybe T.Text) + } deriving (Show, Eq) + +instance FromJSON OpResult where + parseJSON = + withObject "OpResult" $ \obj -> do + s <- obj .: "status" + r <- obj .:? "result" + e <- obj .:? "error" + t <- + case r of + Nothing -> return Nothing + Just r' -> r' .: "txid" + m <- + case e of + Nothing -> return Nothing + Just m' -> m' .: "message" + pure $ OpResult s m t + +-- * Helper functions +-- | Helper function to turn a hex-encoded memo strings to readable text +decodeHexText :: String -> T.Text +decodeHexText h = E.decodeUtf8With lenientDecode $ BS.pack $ hexRead h + where + hexRead hexText + | null chunk = [] + | otherwise = + fromIntegral (read ("0x" <> chunk)) : hexRead (drop 2 hexText) + where + chunk = take 2 hexText + +-- | Helper function to turn a text into a hex-encoded string +encodeHexText' :: T.Text -> String +encodeHexText' t = + if T.length t > 0 + then C.unpack . B64.encode $ E.encodeUtf8 t + else C.unpack . B64.encode $ E.encodeUtf8 "Sent from Zenith" diff --git a/src/Zenith/Utils.hs b/src/Zenith/Utils.hs new file mode 100644 index 0000000..96ca8dd --- /dev/null +++ b/src/Zenith/Utils.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Zenith.Utils where + +import Data.Aeson +import Data.Functor (void) +import Data.Maybe +import Data.Scientific (Scientific(..), scientific) +import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import System.Process (createProcess_, shell) +import Text.Regex.Posix +import ZcashHaskell.Orchard (encodeUnifiedAddress, isValidUnifiedAddress) +import ZcashHaskell.Sapling (isValidShieldedAddress) +import Zenith.Types + ( AddressGroup(..) + , UnifiedAddressDB(..) + , ZcashAddress(..) + , ZcashPool(..) + ) + +-- | Helper function to convert numbers into JSON +jsonNumber :: Int -> Value +jsonNumber i = Number $ scientific (fromIntegral i) 0 + +-- | Helper function to display small amounts of ZEC +displayZec :: Integer -> String +displayZec s + | abs s < 100 = show s ++ " zats " + | abs s < 100000 = show (fromIntegral s / 100) ++ " μZEC " + | abs s < 100000000 = show (fromIntegral s / 100000) ++ " mZEC " + | otherwise = show (fromIntegral s / 100000000) ++ " ZEC " + +-- | Helper function to display small amounts of ZEC +displayTaz :: Integer -> String +displayTaz s + | abs s < 100 = show s ++ " tazs " + | abs s < 100000 = show (fromIntegral s / 100) ++ " μTAZ " + | abs s < 100000000 = show (fromIntegral s / 100000) ++ " mTAZ " + | otherwise = show (fromIntegral s / 100000000) ++ " TAZ " + +-- | Helper function to display abbreviated Unified Address +showAddress :: UnifiedAddressDB -> T.Text +showAddress u = T.take 20 t <> "..." + where + t = getUA u + +-- | Helper function to extract addresses from AddressGroups +getAddresses :: AddressGroup -> [ZcashAddress] +getAddresses ag = agtransparent ag <> agsapling ag <> agunified ag + +-- | Helper function to validate potential Zcash addresses +validateAddress :: T.Text -> Maybe ZcashPool +validateAddress txt --(tReg || sReg && isJust chk) || (uReg && isJust chk) + | tReg = Just Transparent + | sReg && chkS = Just Sapling + | uReg && chk = Just Orchard + | otherwise = Nothing + where + transparentRegex = "^t1[a-zA-Z0-9]{33}$" :: String + shieldedRegex = "^zs[a-zA-Z0-9]{76}$" :: String + unifiedRegex = "^u[a-zA-Z0-9]" :: String + tReg = T.unpack txt =~ transparentRegex :: Bool + sReg = T.unpack txt =~ shieldedRegex :: Bool + uReg = T.unpack txt =~ unifiedRegex :: Bool + chk = isJust $ isValidUnifiedAddress $ E.encodeUtf8 txt + chkS = isValidShieldedAddress $ E.encodeUtf8 txt + +-- | Copy an address to the clipboard +copyAddress :: ZcashAddress -> IO () +copyAddress a = + void $ + createProcess_ "toClipboard" $ + shell $ "echo " ++ T.unpack (addy a) ++ " | xclip -r -selection clipboard" diff --git a/src/Zenith/Zcashd.hs b/src/Zenith/Zcashd.hs new file mode 100644 index 0000000..bc4c2d2 --- /dev/null +++ b/src/Zenith/Zcashd.hs @@ -0,0 +1,343 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Zenith.Zcashd where + +import Control.Concurrent (threadDelay) +import Control.Monad (when) +import Data.Aeson +import qualified Data.Array as A +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy as LBS +import Data.Maybe +import qualified Data.Scientific as Scientific +import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import Data.Text.Encoding.Error (lenientDecode) +import qualified Data.Text.IO as TIO +import qualified Data.Vector as V +import Network.HTTP.Simple +import System.Clipboard +import System.Exit +import System.IO +import Text.Read (readMaybe) +import Text.Regex +import Text.Regex.Base +import ZcashHaskell.Types (RpcCall(..), RpcResponse(..)) +import Zenith.Types + ( AddressGroup + , AddressSource(..) + , NodeVersion(..) + , OpResult(..) + , UABalance(..) + , ZcashAddress(..) + , ZcashPool(..) + , ZcashTx + , encodeHexText' + ) +import Zenith.Utils (displayZec, getAddresses, validateAddress) + +-- * RPC methods +-- | List addresses +listAddresses :: BS.ByteString -> BS.ByteString -> IO [ZcashAddress] +listAddresses user pwd = do + response <- makeZcashCall user pwd "listaddresses" [] + let rpcResp = decode response :: Maybe (RpcResponse [AddressGroup]) + case rpcResp of + Nothing -> fail "Couldn't parse node response" + Just res -> do + let addys = result res + case addys of + Nothing -> fail "Empty response" + Just addys' -> do + let addList = concatMap getAddresses addys' + return addList + +-- | Get address balance +getBalance :: BS.ByteString -> BS.ByteString -> ZcashAddress -> IO [Integer] +getBalance user pwd zadd = do + let a = account zadd + case a of + Nothing -> do + response <- + makeZcashCall + user + pwd + "z_getbalance" + [ String (addy zadd) + , Number (Scientific.scientific 1 0) + , Data.Aeson.Bool True + ] + let rpcResp = decode response :: Maybe (RpcResponse Integer) + case rpcResp of + Nothing -> fail "Couldn't parse node response" + Just res -> do + case result res of + Nothing -> return [] + Just r -> return [r] + Just acct -> do + response <- + makeZcashCall + user + pwd + "z_getbalanceforaccount" + [Number (Scientific.scientific acct 0)] + let rpcResp = decode response :: Maybe (RpcResponse UABalance) + case rpcResp of + Nothing -> fail "Couldn't parse node response" + Just res -> do + case result res of + Nothing -> return [0, 0, 0] + Just r -> return $ readUABalance r + where readUABalance ua = + [uatransparent ua, uasapling ua, uaorchard ua] + +-- | List transactions +listTxs :: BS.ByteString -> BS.ByteString -> ZcashAddress -> IO [ZcashTx] +listTxs user pwd zaddy = do + response <- + makeZcashCall user pwd "z_listreceivedbyaddress" [String $ addy zaddy] + let rpcResp = decode response :: Maybe (RpcResponse [ZcashTx]) + case rpcResp of + Nothing -> fail "listTxs: Couldn't parse node response" + Just res -> do + case result res of + Nothing -> fail "listTxs: Empty response" + Just res' -> return res' + +-- | Send Tx +sendTx :: + BS.ByteString + -> BS.ByteString + -> ZcashAddress + -> T.Text + -> Double + -> Maybe T.Text + -> IO () +sendTx user pwd fromAddy toAddy amount memo = do + bal <- getBalance user pwd fromAddy + let valAdd = validateAddress toAddy + if sum bal - floor (amount * 100000000) >= 1000 + then do + if source fromAddy /= ImportedWatchOnly + then do + let privacyPolicy + | valAdd == Just Transparent = "AllowRevealedRecipients" + | isNothing (account fromAddy) && + elem Transparent (pool fromAddy) = "AllowRevealedSenders" + | otherwise = "AllowRevealedAmounts" + let pd = + case memo of + Nothing -> + [ Data.Aeson.String (addy fromAddy) + , Data.Aeson.Array + (V.fromList + [object ["address" .= toAddy, "amount" .= amount]]) + , Data.Aeson.Number $ Scientific.scientific 1 1 + , Data.Aeson.Null + , Data.Aeson.String privacyPolicy + ] + Just memo' -> + [ Data.Aeson.String (addy fromAddy) + , Data.Aeson.Array + (V.fromList + [ object + [ "address" .= toAddy + , "amount" .= amount + , "memo" .= encodeHexText' memo' + ] + ]) + , Data.Aeson.Number $ Scientific.scientific 1 1 + , Data.Aeson.Null + , Data.Aeson.String privacyPolicy + ] + response <- makeZcashCall user pwd "z_sendmany" pd + let rpcResp = decode response :: Maybe (RpcResponse T.Text) + case rpcResp of + Nothing -> fail "Couldn't parse node response" + Just res -> do + putStr " Sending." + checkOpResult user pwd (fromMaybe "" $ result res) + else putStrLn "Error: Source address is view-only." + else putStrLn "Error: Insufficient balance in source address." + +-- | Check Zcash full node server +checkServer :: BS.ByteString -> BS.ByteString -> IO () +checkServer user pwd = do + resp <- makeZcashCall user pwd "getinfo" [] + let rpcResp = decode resp :: Maybe (RpcResponse NodeVersion) + case rpcResp of + Nothing -> fail "Couldn't parse node response" + Just myResp -> do + let r = result myResp + case r of + Nothing -> fail "Empty node response" + Just r' -> do + if isNodeValid r' + then putStrLn $ "Connected to Zcash Full Node (" <> show r <> ") :)" + else do + putStrLn "Deprecated Zcash Full Node version found. Exiting" + exitFailure + where isNodeValid (NodeVersion i) = i >= 5000000 + +-- | Check for accounts +checkAccounts :: BS.ByteString -> BS.ByteString -> IO Bool +checkAccounts user pwd = do + response <- makeZcashCall user pwd "z_listaccounts" [] + let rpcResp = decode response :: Maybe (RpcResponse [Object]) + case rpcResp of + Nothing -> fail "Couldn't parse node response" + Just res -> do + let r = result res + return $ not (null r) + +-- | Add account to node +createAccount :: BS.ByteString -> BS.ByteString -> IO () +createAccount user pwd = do + response <- makeZcashCall user pwd "z_getnewaccount" [] + let rpcResp = decode response :: Maybe (RpcResponse Object) + case rpcResp of + Nothing -> fail "Couldn't parse node response" + Just res -> do + let r = result res + putStrLn " Account created!" + +-- | Create new Unified Address +createUnifiedAddress :: BS.ByteString -> BS.ByteString -> Bool -> Bool -> IO () +createUnifiedAddress user pwd tRec sRec = do + let recs = getReceivers tRec sRec + let pd = [Data.Aeson.Number $ Scientific.scientific 0 1, recs] + newResp <- makeZcashCall user pwd "z_getaddressforaccount" pd + let rpcResp = decode newResp :: Maybe (RpcResponse Object) + case rpcResp of + Nothing -> fail "Couldn't parse node response" + Just res -> do + let r = result res + putStrLn " New UA created!" + where + getReceivers t s + | t && s = + Data.Aeson.Array + (V.fromList + [ Data.Aeson.String "p2pkh" + , Data.Aeson.String "sapling" + , Data.Aeson.String "orchard" + ]) + | t = + Data.Aeson.Array + (V.fromList [Data.Aeson.String "p2pkh", Data.Aeson.String "orchard"]) + | s = + Data.Aeson.Array + (V.fromList [Data.Aeson.String "sapling", Data.Aeson.String "orchard"]) + | otherwise = Data.Aeson.Array (V.fromList [Data.Aeson.String "orchard"]) + +-- | Verify operation result +checkOpResult :: BS.ByteString -> BS.ByteString -> T.Text -> IO () +checkOpResult user pwd opid = do + response <- + makeZcashCall + user + pwd + "z_getoperationstatus" + [Data.Aeson.Array (V.fromList [Data.Aeson.String opid])] + let rpcResp = decode response :: Maybe (RpcResponse [OpResult]) + case rpcResp of + Nothing -> fail "Couldn't parse node response" + Just res -> do + let r = result res + case r of + Nothing -> fail "Empty node response" + Just r' -> mapM_ showResult r' + where + showResult t = + case opsuccess t of + "success" -> + putStrLn $ " Success! Tx ID: " ++ maybe "" T.unpack (optxid t) + "executing" -> do + putStr "." + hFlush stdout + threadDelay 1000000 >> checkOpResult user pwd opid + _ -> putStrLn $ " Failed :( " ++ maybe "" T.unpack (opmessage t) + +-- | Make a Zcash RPC call +makeZcashCall :: + BS.ByteString + -> BS.ByteString + -> T.Text + -> [Data.Aeson.Value] + -> IO LBS.ByteString +makeZcashCall username password m p = do + let payload = RpcCall "1.0" "test" m p + let myRequest = + setRequestBodyJSON payload $ + setRequestPort 8232 $ + setRequestBasicAuth username password $ + setRequestMethod "POST" defaultRequest + response <- httpLBS myRequest + let respStatus = getResponseStatusCode response + let body = getResponseBody response + case respStatus of + 500 -> do + let rpcResp = decode body :: Maybe (RpcResponse String) + case rpcResp of + Nothing -> fail $ "Unknown server error " ++ show response + Just x -> fail (fromMaybe "" $ result x) + 401 -> fail "Incorrect full node credentials" + 200 -> return body + _ -> fail "Unknown error" + +-- | Read ZIP-321 URI +sendWithUri :: + BS.ByteString -> BS.ByteString -> ZcashAddress -> String -> Bool -> IO () +sendWithUri user pwd fromAddy uri repTo = do + let uriRegex = mkRegex "^zcash:(\\w+)\\?amount=(.*)\\&memo=(.*)$" + if matchTest uriRegex uri + then do + let reg = matchAllText uriRegex uri + let parsedAddress = fst $ head reg A.! 1 + let parsedAmount = fst $ head reg A.! 2 + let parsedEncodedMemo = fst $ head reg A.! 3 + let addType = validateAddress $ T.pack parsedAddress + case addType of + Nothing -> putStrLn " Invalid address" + Just Transparent -> do + putStrLn $ " Address is valid: " ++ parsedAddress + case (readMaybe parsedAmount :: Maybe Double) of + Nothing -> putStrLn " Invalid amount." + Just amt -> do + putStrLn $ " Valid ZEC amount: " ++ show amt + sendTx user pwd fromAddy (T.pack parsedAddress) amt Nothing + Just _ -> do + putStrLn $ " Address is valid: " ++ parsedAddress + case (readMaybe parsedAmount :: Maybe Double) of + Nothing -> putStrLn " Invalid amount." + Just amt -> do + putStrLn $ " Valid ZEC amount: " ++ show amt + let decodedMemo = + E.decodeUtf8With lenientDecode $ + B64.decodeLenient $ C.pack parsedEncodedMemo + TIO.putStrLn $ " Memo: " <> decodedMemo + sendTx + user + pwd + fromAddy + (T.pack parsedAddress) + amt + (if repTo + then Just $ + T.concat [decodedMemo, "\nReply-To:\n", addy fromAddy] + else Just decodedMemo) + else putStrLn "URI is not compliant with ZIP-321" + +-- | Display an address +displayZcashAddress :: + BS.ByteString -> BS.ByteString -> (Int, ZcashAddress) -> IO () +displayZcashAddress user pwd (idx, zaddy) = do + zats <- getBalance user pwd zaddy + putStr $ show idx ++ ": " + putStr $ show zaddy + when (source zaddy == ImportedWatchOnly) (putStr "[VK]") + putStr " Balance: " + mapM_ (putStr . displayZec) zats + putStrLn "" diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 index e202242..0000000 --- a/stack.yaml +++ /dev/null @@ -1,81 +0,0 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# -# The location of a snapshot can be provided as a file or url. Stack assumes -# a snapshot provided as a file might change, whereas a url resource does not. -# -# resolver: ./custom-snapshot.yaml -# resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-21.6 - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# subdirs: -# - auto-update -# - wai -packages: -- . -#- haskoin-core -#- zcash-haskell -# Dependency packages to be pulled from upstream that are not in the resolver. -# These entries can reference officially published versions as well as -# forks / in-progress versions pinned to a git hash. For example: -# -# extra-deps: -# - acme-missiles-0.3 -# - git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# -# extra-deps: [] -extra-deps: - - git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git - commit: fef3d3af35a09db718cddb8fc9166b2d2691a744 - - git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git - commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05 - - git: https://github.com/reach-sh/haskell-hexstring.git - commit: 085c16fb21b9f856a435a3faab980e7e0b319341 - - git: https://github.com/well-typed/borsh.git - commit: d2fcfa159e0a844b1ec5e8ed3e232d4b380fa831 - - vector-0.13.0.0@sha256:fa5cac81a17a5af388716792e8b99c24b3b66770086756d0d8b23f8272a0244c,9112 - - generically-0.1.1 - - vector-algorithms-0.9.0.1 - #- vector-0.12.3.1@sha256:abbfe8830e13549596e1295219d340eb01bd00e1c7124d0dd16586911a291c59,8218 -#extra-lib-dirs: [/home/rav/Documents/programs/haskoin] -# -# Override default flag values for local packages and extra-deps -# flags: {} - -# Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=2.7" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor diff --git a/stack.yaml.lock b/stack.yaml.lock deleted file mode 100644 index f92b46d..0000000 --- a/stack.yaml.lock +++ /dev/null @@ -1,77 +0,0 @@ -# This file was autogenerated by Stack. -# You should not edit this file by hand. -# For more information, please see the documentation at: -# https://docs.haskellstack.org/en/stable/lock_files - -packages: -- completed: - commit: fef3d3af35a09db718cddb8fc9166b2d2691a744 - git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git - name: zcash-haskell - pantry-tree: - sha256: ec7782cf2646da17548d59af0ea98dcbaac1b6c2176258c696a7f508db6dbc21 - size: 1126 - version: 0.1.0 - original: - commit: fef3d3af35a09db718cddb8fc9166b2d2691a744 - git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git -- completed: - commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05 - git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git - name: foreign-rust - pantry-tree: - sha256: be2f6fc0fab58a90fec657bdb6bd0ccf0810c7dccfe95c78b85e174fae227e42 - size: 2315 - version: 0.1.0 - original: - commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05 - git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git -- completed: - commit: 085c16fb21b9f856a435a3faab980e7e0b319341 - git: https://github.com/reach-sh/haskell-hexstring.git - name: hexstring - pantry-tree: - sha256: 9ecf67856f59dfb382b283eceb42e4fc1865935d1a7e59111556ed381c6a2ffd - size: 687 - version: 0.11.1 - original: - commit: 085c16fb21b9f856a435a3faab980e7e0b319341 - git: https://github.com/reach-sh/haskell-hexstring.git -- completed: - commit: d2fcfa159e0a844b1ec5e8ed3e232d4b380fa831 - git: https://github.com/well-typed/borsh.git - name: borsh - pantry-tree: - sha256: 8335925f495a5a653fcb74b6b8bb18cd0b6b7fe7099a1686108704e6ab82f47b - size: 2268 - version: 0.3.0 - original: - commit: d2fcfa159e0a844b1ec5e8ed3e232d4b380fa831 - git: https://github.com/well-typed/borsh.git -- completed: - hackage: vector-0.13.0.0@sha256:fa5cac81a17a5af388716792e8b99c24b3b66770086756d0d8b23f8272a0244c,9112 - pantry-tree: - sha256: d2461d28022c8c0a91da08b579b1bff478f617102d2f5ef596cc5b28d14b8b6a - size: 4092 - original: - hackage: vector-0.13.0.0@sha256:fa5cac81a17a5af388716792e8b99c24b3b66770086756d0d8b23f8272a0244c,9112 -- completed: - hackage: generically-0.1.1@sha256:aa00d9a77b7fb90c08f935699758ed9de55975021b1e979c6a4a4b5b49a940a9,1133 - pantry-tree: - sha256: ec19e6d2aecfbe7a59e789526b9d7ab5c8ba853f017248d0203ee69a9769adb7 - size: 233 - original: - hackage: generically-0.1.1 -- completed: - hackage: vector-algorithms-0.9.0.1@sha256:f3e5c6695529a94edf762117cafd91c989cb642ad3f8ca4014dbb13c8f6c2a20,3826 - pantry-tree: - sha256: aef389e57ae6020e5da719bee40aaf6cccf1c4d1e7743a85d30c9d8c25d170a0 - size: 1510 - original: - hackage: vector-algorithms-0.9.0.1 -snapshots: -- completed: - sha256: 2e7d4a730d8eb5373b2d383fac84efcf7c81e3b7a5fce71b4c2e19a1768f25a6 - size: 640239 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/6.yaml - original: lts-21.6 diff --git a/test/Spec.hs b/test/Spec.hs index cd4753f..35fb3a1 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,2 +1,253 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Control.Monad (when) +import Control.Monad.Logger (runNoLoggingT) +import Data.HexString +import qualified Data.Text.Encoding as E +import Database.Persist +import Database.Persist.Sqlite +import System.Directory +import Test.HUnit +import Test.Hspec +import ZcashHaskell.Orchard (isValidUnifiedAddress) +import ZcashHaskell.Sapling + ( decodeSaplingOutputEsk + , encodeSaplingAddress + , getSaplingNotePosition + , getSaplingWitness + , isValidShieldedAddress + , updateSaplingCommitmentTree + ) +import ZcashHaskell.Transparent + ( decodeExchangeAddress + , decodeTransparentAddress + ) +import ZcashHaskell.Types + ( DecodedNote(..) + , OrchardSpendingKey(..) + , Phrase(..) + , SaplingCommitmentTree(..) + , SaplingReceiver(..) + , SaplingSpendingKey(..) + , Scope(..) + , ShieldedOutput(..) + , ZcashNet(..) + ) +import Zenith.Core +import Zenith.DB +import Zenith.Types + main :: IO () -main = putStrLn "Test suite not yet implemented" +main = do + checkDbFile <- doesFileExist "test.db" + when checkDbFile $ removeFile "test.db" + hspec $ do + describe "Database tests" $ do + it "Create table" $ do + s <- runSqlite "test.db" $ do runMigration migrateAll + s `shouldBe` () + describe "Wallet Table" $ do + it "insert wallet record" $ do + s <- + runSqlite "test.db" $ do + insert $ + ZcashWallet + "Main Wallet" + (ZcashNetDB MainNet) + (PhraseDB $ + Phrase + "one two three four five six seven eight nine ten eleven twelve") + 2000000 + 0 + fromSqlKey s `shouldBe` 1 + it "read wallet record" $ do + s <- + runSqlite "test.db" $ do + selectList [ZcashWalletBirthdayHeight >. 0] [] + length s `shouldBe` 1 + it "modify wallet record" $ do + s <- + runSqlite "test.db" $ do + let recId = toSqlKey 1 :: ZcashWalletId + update recId [ZcashWalletName =. "New Wallet"] + get recId + "New Wallet" `shouldBe` maybe "None" zcashWalletName s + it "delete wallet record" $ do + s <- + runSqlite "test.db" $ do + let recId = toSqlKey 1 :: ZcashWalletId + delete recId + get recId + "None" `shouldBe` maybe "None" zcashWalletName s + describe "Wallet function tests:" $ do + it "Save Wallet:" $ do + pool <- runNoLoggingT $ initPool "test.db" + zw <- + saveWallet pool $ + ZcashWallet + "Testing" + (ZcashNetDB MainNet) + (PhraseDB $ + Phrase + "cloth swing left trap random tornado have great onion element until make shy dad success art tuition canvas thunder apple decade elegant struggle invest") + 2200000 + 0 + zw `shouldNotBe` Nothing + it "Save Account:" $ do + pool <- runNoLoggingT $ initPool "test.db" + s <- + runSqlite "test.db" $ do + selectList [ZcashWalletName ==. "Testing"] [] + za <- saveAccount pool =<< createZcashAccount "TestAccount" 0 (head s) + za `shouldNotBe` Nothing + it "Save address:" $ do + pool <- runNoLoggingT $ initPool "test.db" + acList <- + runSqlite "test.db" $ + selectList [ZcashAccountName ==. "TestAccount"] [] + zAdd <- + saveAddress pool =<< + createWalletAddress "Personal123" 0 MainNet External (head acList) + addList <- + runSqlite "test.db" $ + selectList + [ WalletAddressName ==. "Personal123" + , WalletAddressScope ==. ScopeDB External + ] + [] + getUA (walletAddressUAddress (entityVal $ head addList)) `shouldBe` + "u1trd8cvc6265ywwj4mmvuznsye5ghe2dhhn3zy8kcuyg4vx3svskw9r2dedp5hu6m740vylkqc34t4w9eqkl9fyu5uyzn3af72jg235440ke6tu5cf994eq85n97x69x9824hqejmwz3d8qqthtesrd6gerjupdymldhl9xccejjwfj0dhh9mt4rw4kytp325twlutsxd20rfqhzxu3m" + it "Address components are correct" $ do + let ua = + "utest1mvlny48qd4x94w8vz5u2lrxx0enuquajt72yekgq24p6pjaky3czk6m7x358h7g900ex6gzvdehaekl96qnakjzw8yaasp8y0u3j5jnlfd33trduznh6k3fcn5ek9qc857fgz8ehm37etx94sj58nrkc0k5hurxnuxpcpms3j8uy2t8kt2vy6vetvsfxxdhtjq0yqulqprvh7mf2u3x" + isValidUnifiedAddress ua `shouldNotBe` Nothing + describe "Function tests" $ do + describe "Sapling Decoding" $ do + let sk = + SaplingSpendingKey + "\ETX}\195.\SUB\NUL\NUL\NUL\128\NUL\203\"\229IL\CANJ*\209\EM\145\228m\172\&4\SYNNl\DC3\161\147\SO\157\238H\192\147eQ\143L\201\216\163\180\147\145\156Zs+\146>8\176`ta\161\223\SO\140\177\b;\161\SO\236\151W\148<\STX\171|\DC2\172U\195(I\140\146\214\182\137\211\228\159\128~bV\STXy{m'\224\175\221\219\180!\ENQ_\161\132\240?\255\236\"6\133\181\170t\181\139\143\207\170\211\ENQ\167a\184\163\243\246\140\158t\155\133\138X\a\241\200\140\EMT\GS~\175\249&z\250\214\231\239mi\223\206\STX\t\EM<{V~J\253FB" + let tree = + SaplingCommitmentTree $ + hexString + "01818f2bd58b1e392334d0565181cc7843ae09e3533b2a50a8f1131af657340a5c001001161f962245812ba5e1804fd0a336bc78fa4ee4441a8e0f1525ca5da1b285d35101120f45afa700b8c1854aa8b9c8fe8ed92118ef790584bfcb926078812a10c83a00000000012f4f72c03f8c937a94919a01a07f21165cc8394295291cb888ca91ed003810390107114fe4bb4cd08b47f6ae47477c182d5da9fe5c189061808c1091e9bf3b4524000001447d6b9100cddd5f80c8cf4ddee2b87eba053bd987465aec2293bd0514e68b0d015f6c95e75f4601a0a31670a7deb970fc8988c611685161d2e1629d0a1a0ebd07015f8b9205e0514fa235d75c150b87e23866b882b39786852d1ab42aab11d31a4a0117ddeb3a5f8d2f6b2d0a07f28f01ab25e03a05a9319275bb86d72fcaef6fc01501f08f39275112dd8905b854170b7f247cf2df18454d4fa94e6e4f9320cca05f24011f8322ef806eb2430dc4a7a41c1b344bea5be946efc7b4349c1c9edb14ff9d39" + let nextTree = + SaplingCommitmentTree $ + hexString + "01bd8a3f3cfc964332a2ada8c09a0da9dfc24174befb938abb086b9be5ca049e4900100000019f0d7efb00169bb2202152d3266059d208ab17d14642c3339f9075e997160657000000012f4f72c03f8c937a94919a01a07f21165cc8394295291cb888ca91ed003810390107114fe4bb4cd08b47f6ae47477c182d5da9fe5c189061808c1091e9bf3b4524000001447d6b9100cddd5f80c8cf4ddee2b87eba053bd987465aec2293bd0514e68b0d015f6c95e75f4601a0a31670a7deb970fc8988c611685161d2e1629d0a1a0ebd07015f8b9205e0514fa235d75c150b87e23866b882b39786852d1ab42aab11d31a4a0117ddeb3a5f8d2f6b2d0a07f28f01ab25e03a05a9319275bb86d72fcaef6fc01501f08f39275112dd8905b854170b7f247cf2df18454d4fa94e6e4f9320cca05f24011f8322ef806eb2430dc4a7a41c1b344bea5be946efc7b4349c1c9edb14ff9d39" + it "Sapling is decoded correctly" $ do + so <- + runSqlite "zenith.db" $ + selectList [ShieldOutputTx ==. toSqlKey 38318] [] + let cmus = map (getHex . shieldOutputCmu . entityVal) so + let pos = + getSaplingNotePosition <$> + (getSaplingWitness =<< + updateSaplingCommitmentTree tree (head cmus)) + let pos1 = getSaplingNotePosition <$> getSaplingWitness tree + let pos2 = getSaplingNotePosition <$> getSaplingWitness nextTree + case pos of + Nothing -> assertFailure "couldn't get note position" + Just p -> do + print p + print pos1 + print pos2 + let dn = + decodeSaplingOutputEsk + sk + (ShieldedOutput + (getHex $ shieldOutputCv $ entityVal $ head so) + (getHex $ shieldOutputCmu $ entityVal $ head so) + (getHex $ shieldOutputEphKey $ entityVal $ head so) + (getHex $ shieldOutputEncCipher $ entityVal $ head so) + (getHex $ shieldOutputOutCipher $ entityVal $ head so) + (getHex $ shieldOutputProof $ entityVal $ head so)) + TestNet + External + p + case dn of + Nothing -> assertFailure "couldn't decode Sap output" + Just d -> + a_nullifier d `shouldBe` + hexString + "6c5d1413c63a9a88db71c3f41dc12cd60197ee742fc75b217215e7144db48bd3" + describe "Note selection for Tx" $ do + it "Value less than balance" $ do + pool <- runNoLoggingT $ initPool "zenith.db" + res <- selectUnspentNotes pool (toSqlKey 1) 14000000 + res `shouldNotBe` ([], [], []) + it "Value greater than balance" $ do + 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 = + "utest1zfnw84xuxg0ytzqc008gz0qntr8cvwu4qjsccgtxwdrjywra7uj85x8ldymjc2jd3jvvvhyj3xwsunyvwkr5084t6p5gmvzwdgvwpflrpd6a3squ2dp8vt7cxngmwk30l44wkmvyfegypqmezxfnqj572lr779gkqj5xekp66uv4jga58alnc5j7tuank758zd96ap4f09udg6y6pxu" + True `shouldBe` + (case isValidUnifiedAddress (E.encodeUtf8 a) of + Just _a1 -> True + Nothing -> + isValidShieldedAddress (E.encodeUtf8 a) || + (case decodeTransparentAddress (E.encodeUtf8 a) of + Just _a3 -> True + Nothing -> + case decodeExchangeAddress a of + Just _a4 -> True + Nothing -> False)) + it "Sapling" $ do + let a = + "ztestsapling1tgjr4zppwk4ne8xy6gdq4z2gwq7dmf5jq8z2ctpn8nlmtse0a74fa5z0m8z383gmpgqz6q6duu4" + True `shouldBe` + (case isValidUnifiedAddress (E.encodeUtf8 a) of + Just _a1 -> True + Nothing -> + isValidShieldedAddress (E.encodeUtf8 a) || + (case decodeTransparentAddress (E.encodeUtf8 a) of + Just _a3 -> True + Nothing -> + case decodeExchangeAddress a of + Just _a4 -> True + Nothing -> False)) + it "Transparent" $ do + let a = "tmGfVZHuGVJ5vcLAgBdkUU4w7fLTRE5nXm3" + True `shouldBe` + (case isValidUnifiedAddress (E.encodeUtf8 a) of + Just _a1 -> True + Nothing -> + isValidShieldedAddress (E.encodeUtf8 a) || + (case decodeTransparentAddress (E.encodeUtf8 a) of + Just _a3 -> True + Nothing -> + case decodeExchangeAddress a of + Just _a4 -> True + Nothing -> False)) + it "Check Sapling Address" $ do + let a = + encodeSaplingAddress TestNet $ + SaplingReceiver + "Z$:\136!u\171<\156\196\210\SUB\n\137Hp<\221\166\146\SOH\196\172,3<\255\181\195/\239\170\158\208O\217\197\DC3\197\ESC\n\NUL-" + a `shouldBe` + Just + "ztestsapling1tgjr4zppwk4ne8xy6gdq4z2gwq7dmf5jq8z2ctpn8nlmtse0a74fa5z0m8z383gmpgqz6q6duu4" + {-describe "Creating Tx" $ do-} + {-xit "To Orchard" $ do-} + {-let uaRead =-} + {-isValidUnifiedAddress-} + {-"utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax"-} + {-case uaRead of-} + {-Nothing -> assertFailure "wrong address"-} + {-Just ua -> do-} + {-tx <--} + {-prepareTx-} + {-"zenith.db"-} + {-TestNet-} + {-(toSqlKey 1)-} + {-2819811-} + {-0.04-} + {-ua-} + {-"sent with Zenith, test"-} + {-tx `shouldBe` Right (hexString "deadbeef")-} diff --git a/zcash-haskell b/zcash-haskell new file mode 160000 index 0000000..9dddb42 --- /dev/null +++ b/zcash-haskell @@ -0,0 +1 @@ +Subproject commit 9dddb42bb3ab78ed0c4d44efb00960ac112c2ce6 diff --git a/zebra_openapi.yaml b/zebra_openapi.yaml new file mode 100644 index 0000000..86fff2a --- /dev/null +++ b/zebra_openapi.yaml @@ -0,0 +1,1007 @@ +openapi: 3.0.3 +info: + title: Swagger Zebra API - OpenAPI 3.0 + version: 0.0.1 + description: |- + This is the Zebra API. It is a JSON-RPC 2.0 API that allows you to interact with the Zebra node. + + Useful links: + - [The Zebra repository](https://github.com/ZcashFoundation/zebra) + - [The latests API spec](https://github.com/ZcashFoundation/zebra/blob/main/openapi.yaml) +servers: + - url: http://localhost:18232 +paths: + /sendrawtransaction: + post: + tags: + - transaction + description: |- + Sends the raw bytes of a signed transaction to the local node''s mempool, if the transaction is valid."] + + **Request body `params` arguments:** + + - `raw_transaction_hex` - The hex-encoded raw transaction bytes. + requestBody: + required: true + content: + application/json: + schema: + type: object + properties: + params: + type: array + items: {} + default: '["signedhex"]' + method: + type: string + default: sendrawtransaction + id: + type: number + default: '123' + responses: + '200': + description: OK + content: + application/json: + schema: + type: object + properties: + result: + type: object + default: '{}' + '400': + description: Bad request + content: + application/json: + schema: + type: object + properties: + error: + type: string + default: Invalid parameters + /getinfo: + post: + tags: + - control + description: Returns software information from the RPC server, as a [`GetInfo`] JSON struct."] + requestBody: + required: true + content: + application/json: + schema: + type: object + properties: + method: + type: string + default: getinfo + id: + type: number + default: '123' + params: + type: array + items: {} + default: '[]' + responses: + '200': + description: OK + content: + application/json: + schema: + type: object + properties: + result: + type: object + default: '{"build":"some build version","subversion":"some subversion"}' + /getblockhash: + post: + tags: + - blockchain + description: |- + Returns the hash of the block of a given height iff the index argument correspond"] + + **Request body `params` arguments:** + + - `index` - The block index. + requestBody: + required: true + content: + application/json: + schema: + type: object + properties: + params: + type: array + items: {} + default: '[1]' + method: + type: string + default: getblockhash + id: + type: number + default: '123' + responses: + '200': + description: OK + content: + application/json: + schema: + type: object + properties: + result: + type: object + default: '"0000000000000000000000000000000000000000000000000000000000000000"' + '400': + description: Bad request + content: + application/json: + schema: + type: object + properties: + error: + type: string + default: Invalid parameters + /getmininginfo: + post: + tags: + - mining + description: Returns mining-related information."] + requestBody: + required: true + content: + application/json: + schema: + type: object + properties: + method: + type: string + default: getmininginfo + id: + type: number + default: '123' + params: + type: array + items: {} + default: '[]' + responses: + '200': + description: OK + content: + application/json: + schema: + type: object + properties: + result: + type: object + default: '{}' + /validateaddress: + post: + tags: + - util + description: |- + Checks if a zcash address is valid."] + + **Request body `params` arguments:** + + - `address` - The zcash address to validate. + requestBody: + required: true + content: + application/json: + schema: + type: object + properties: + method: + type: string + default: validateaddress + params: + type: array + items: {} + default: '[]' + id: + type: number + default: '123' + responses: + '200': + description: OK + content: + application/json: + schema: + type: object + properties: + result: + type: object + default: '{}' + /getblocksubsidy: + post: + tags: + - mining + description: |- + Returns the block subsidy reward of the block at `height`, taking into account the mining slow start."] + + **Request body `params` arguments:** + + - `height` - Can be any valid current or future height. + requestBody: + required: true + content: + application/json: + schema: + type: object + properties: + id: + type: number + default: '123' + params: + type: array + items: {} + default: '[1]' + method: + type: string + default: getblocksubsidy + responses: + '200': + description: OK + content: + application/json: + schema: + type: object + properties: + result: + type: object + default: '{}' + '400': + description: Bad request + content: + application/json: + schema: + type: object + properties: + error: + type: string + default: Invalid parameters + /submitblock: + post: + tags: + - mining + description: |- + Submits block to the node to be validated and committed."] + + **Request body `params` arguments:** + + - `jsonparametersobject` - - currently ignored + requestBody: + required: true + content: + application/json: + schema: + type: object + properties: + id: + type: number + default: '123' + params: + type: array + items: {} + default: '[]' + method: + type: string + default: submitblock + responses: + '200': + description: OK + content: + application/json: + schema: + type: object + properties: + result: + type: object + default: '{}' + /z_listunifiedreceivers: + post: + tags: + - wallet + description: |- + Returns the list of individual payment addresses given a unified address."] + + **Request body `params` arguments:** + + - `address` - The zcash unified address to get the list from. + requestBody: + required: true + content: + application/json: + schema: + type: object + properties: + method: + type: string + default: z_listunifiedreceivers + id: + type: number + default: '123' + params: + type: array + items: {} + default: '[]' + responses: + '200': + description: OK + content: + application/json: + schema: + type: object + properties: + result: + type: object + default: '{}' + /getblockcount: + post: + tags: + - blockchain + description: Returns the height of the most recent block in the best valid block chain (equivalently,"] + requestBody: + required: true + content: + application/json: + schema: + type: object + properties: + id: + type: number + default: '123' + params: + type: array + items: {} + default: '[]' + method: + type: string + default: getblockcount + responses: + '200': + description: OK + content: + application/json: + schema: + type: object + properties: + result: + type: object + default: '{}' + /getaddressutxos: + post: + tags: + - address + description: |- + Returns all unspent outputs for a list of addresses."] + + **Request body `params` arguments:** + + - `addresses` - The addresses to get outputs from. + requestBody: + required: true + content: + application/json: + schema: + type: object + properties: + id: + type: number + default: '123' + method: + type: string + default: getaddressutxos + params: + type: array + items: {} + default: '[{"addresses": ["tmYXBYJj1K7vhejSec5osXK2QsGa5MTisUQ"]}]' + responses: + '400': + description: Bad request + content: + application/json: + schema: + type: object + properties: + error: + type: string + default: Invalid parameters + '200': + description: OK + content: + application/json: + schema: + type: object + properties: + result: + type: object + default: '{}' + /getaddresstxids: + post: + tags: + - address + description: |- + Returns the transaction ids made by the provided transparent addresses."] + + **Request body `params` arguments:** + + - `request` - A struct with the following named fields: + requestBody: + required: true + content: + application/json: + schema: + type: object + properties: + method: + type: string + default: getaddresstxids + id: + type: number + default: '123' + params: + type: array + items: {} + default: '[{"addresses": ["tmYXBYJj1K7vhejSec5osXK2QsGa5MTisUQ"], "start": 1000, "end": 2000}]' + responses: + '400': + description: Bad request + content: + application/json: + schema: + type: object + properties: + error: + type: string + default: Invalid parameters + '200': + description: OK + content: + application/json: + schema: + type: object + properties: + result: + type: object + default: '{}' + /z_getsubtreesbyindex: + post: + tags: + - blockchain + description: |- + Returns information about a range of Sapling or Orchard subtrees."] + + **Request body `params` arguments:** + + - `pool` - The pool from which subtrees should be returned. Either \"sapling\" or \"orchard\". + - `start_index` - The index of the first 2^16-leaf subtree to return. + - `limit` - The maximum number of subtree values to return. + requestBody: + required: true + content: + application/json: + schema: + type: object + properties: + params: + type: array + items: {} + default: '[]' + method: + type: string + default: z_getsubtreesbyindex + id: + type: number + default: '123' + responses: + '200': + description: OK + content: + application/json: + schema: + type: object + properties: + result: + type: object + default: '{}' + /getpeerinfo: + post: + tags: + - network + description: Returns data about each connected network node."] + requestBody: + required: true + content: + application/json: + schema: + type: object + properties: + id: + type: number + default: '123' + params: + type: array + items: {} + default: '[]' + method: + type: string + default: getpeerinfo + responses: + '200': + description: OK + content: + application/json: + schema: + type: object + properties: + result: + type: object + default: '{}' + /getbestblockhash: + post: + tags: + - blockchain + description: Returns the hash of the current best blockchain tip block, as a [`GetBlockHash`] JSON string."] + requestBody: + required: true + content: + application/json: + schema: + type: object + properties: + id: + type: number + default: '123' + method: + type: string + default: getbestblockhash + params: + type: array + items: {} + default: '[]' + responses: + '200': + description: OK + content: + application/json: + schema: + type: object + properties: + result: + type: object + default: '"0000000000000000000000000000000000000000000000000000000000000000"' + /getblocktemplate: + post: + tags: + - mining + description: |- + Returns a block template for mining new Zcash blocks."] + + **Request body `params` arguments:** + + - `jsonrequestobject` - A JSON object containing arguments. + requestBody: + required: true + content: + application/json: + schema: + type: object + properties: + id: + type: number + default: '123' + params: + type: array + items: {} + default: '[]' + method: + type: string + default: getblocktemplate + responses: + '200': + description: OK + content: + application/json: + schema: + type: object + properties: + result: + type: object + default: '{}' + /getdifficulty: + post: + tags: + - blockchain + description: Returns the proof-of-work difficulty as a multiple of the minimum difficulty."] + requestBody: + required: true + content: + application/json: + schema: + type: object + properties: + id: + type: number + default: '123' + params: + type: array + items: {} + default: '[]' + method: + type: string + default: getdifficulty + responses: + '200': + description: OK + content: + application/json: + schema: + type: object + properties: + result: + type: object + default: '{}' + /getrawmempool: + post: + tags: + - blockchain + description: Returns all transaction ids in the memory pool, as a JSON array."] + requestBody: + required: true + content: + application/json: + schema: + type: object + properties: + params: + type: array + items: {} + default: '[]' + id: + type: number + default: '123' + method: + type: string + default: getrawmempool + responses: + '200': + description: OK + content: + application/json: + schema: + type: object + properties: + result: + type: object + default: '{}' + /getaddressbalance: + post: + tags: + - address + description: |- + Returns the total balance of a provided `addresses` in an [`AddressBalance`] instance."] + + **Request body `params` arguments:** + + - `address_strings` - A JSON map with a single entry + requestBody: + required: true + content: + application/json: + schema: + type: object + properties: + id: + type: number + default: '123' + method: + type: string + default: getaddressbalance + params: + type: array + items: {} + default: '[{"addresses": ["tmYXBYJj1K7vhejSec5osXK2QsGa5MTisUQ"]}]' + responses: + '200': + description: OK + content: + application/json: + schema: + type: object + properties: + result: + type: object + default: '{}' + '400': + description: Bad request + content: + application/json: + schema: + type: object + properties: + error: + type: string + default: Invalid parameters + /getnetworksolps: + post: + tags: + - mining + description: Returns the estimated network solutions per second based on the last `num_blocks` before"] + requestBody: + required: true + content: + application/json: + schema: + type: object + properties: + params: + type: array + items: {} + default: '[]' + id: + type: number + default: '123' + method: + type: string + default: getnetworksolps + responses: + '200': + description: OK + content: + application/json: + schema: + type: object + properties: + result: + type: object + default: '{}' + /z_gettreestate: + post: + tags: + - blockchain + description: |- + Returns information about the given block''s Sapling & Orchard tree state."] + + **Request body `params` arguments:** + + - `hash | height` - The block hash or height. + requestBody: + required: true + content: + application/json: + schema: + type: object + properties: + id: + type: number + default: '123' + params: + type: array + items: {} + default: '["00000000febc373a1da2bd9f887b105ad79ddc26ac26c2b28652d64e5207c5b5"]' + method: + type: string + default: z_gettreestate + responses: + '200': + description: OK + content: + application/json: + schema: + type: object + properties: + result: + type: object + default: '{"hash":"0000000000000000000000000000000000000000000000000000000000000000","height":0,"time":0}' + '400': + description: Bad request + content: + application/json: + schema: + type: object + properties: + error: + type: string + default: Invalid parameters + /getrawtransaction: + post: + tags: + - transaction + description: |- + Returns the raw transaction data, as a [`GetRawTransaction`] JSON string or structure."] + + **Request body `params` arguments:** + + - `txid` - The transaction ID of the transaction to be returned. + - `verbose` - If 0, return a string of hex-encoded data, otherwise return a JSON object. + requestBody: + required: true + content: + application/json: + schema: + type: object + properties: + method: + type: string + default: getrawtransaction + id: + type: number + default: '123' + params: + type: array + items: {} + default: '["mytxid", 1]' + responses: + '200': + description: OK + content: + application/json: + schema: + type: object + properties: + result: + type: object + default: '{}' + '400': + description: Bad request + content: + application/json: + schema: + type: object + properties: + error: + type: string + default: Invalid parameters + /z_validateaddress: + post: + tags: + - util + description: |- + Checks if a zcash address is valid."] + + **Request body `params` arguments:** + + - `address` - The zcash address to validate. + requestBody: + required: true + content: + application/json: + schema: + type: object + properties: + params: + type: array + items: {} + default: '[]' + id: + type: number + default: '123' + method: + type: string + default: z_validateaddress + responses: + '200': + description: OK + content: + application/json: + schema: + type: object + properties: + result: + type: object + default: '{}' + /getblock: + post: + tags: + - blockchain + description: |- + Returns the requested block by hash or height, as a [`GetBlock`] JSON string."] + + **Request body `params` arguments:** + + - `hash_or_height` - The hash or height for the block to be returned. + - `verbosity` - 0 for hex encoded data, 1 for a json object, and 2 for json object with transaction data. + requestBody: + required: true + content: + application/json: + schema: + type: object + properties: + method: + type: string + default: getblock + params: + type: array + items: {} + default: '["1", 1]' + id: + type: number + default: '123' + responses: + '400': + description: Bad request + content: + application/json: + schema: + type: object + properties: + error: + type: string + default: Invalid parameters + '200': + description: OK + content: + application/json: + schema: + type: object + properties: + result: + type: object + default: '{"hash":"0000000000000000000000000000000000000000000000000000000000000000","confirmations":0,"tx":[],"trees":{}}' + /getnetworkhashps: + post: + tags: + - mining + description: Returns the estimated network solutions per second based on the last `num_blocks` before"] + requestBody: + required: true + content: + application/json: + schema: + type: object + properties: + params: + type: array + items: {} + default: '[]' + method: + type: string + default: getnetworkhashps + id: + type: number + default: '123' + responses: + '200': + description: OK + content: + application/json: + schema: + type: object + properties: + result: + type: object + default: '{}' + /getblockchaininfo: + post: + tags: + - blockchain + description: Returns blockchain state information, as a [`GetBlockChainInfo`] JSON struct."] + requestBody: + required: true + content: + application/json: + schema: + type: object + properties: + method: + type: string + default: getblockchaininfo + id: + type: number + default: '123' + params: + type: array + items: {} + default: '[]' + responses: + '200': + description: OK + content: + application/json: + schema: + type: object + properties: + result: + type: object + default: '{"chain":"main","blocks":1,"bestblockhash":"0000000000000000000000000000000000000000000000000000000000000000","estimatedheight":1,"upgrades":{},"consensus":{"chaintip":"00000000","nextblock":"00000000"}}' \ No newline at end of file diff --git a/zenith.cabal b/zenith.cabal index a2a59ee..12e0b6c 100644 --- a/zenith.cabal +++ b/zenith.cabal @@ -1,65 +1,93 @@ -cabal-version: 1.12 +cabal-version: 3.0 +name: zenith +version: 0.5.0.0 +license: MIT +license-file: LICENSE +author: Rene Vergara +maintainer: pitmutt@vergara.tech +copyright: (c) 2022-2024 Vergara Technologies LLC +build-type: Custom +category: Blockchain +extra-doc-files: + README.md + CHANGELOG.md + zenith.cfg --- This file has been generated from package.yaml by hpack version 0.35.1. --- --- see: https://github.com/sol/hpack -name: zenith -version: 0.4.0 -synopsis: Haskell CLI for Zcash Full Node -description: Please see the README on repo at -author: Rene Vergara -maintainer: rene@vergara.network -copyright: Copyright (c) 2022 Vergara Technologies LLC -license: BOSL -license-file: LICENSE -build-type: Simple -extra-source-files: - README.md - CHANGELOG.md - zenith.cfg - -source-repository head - type: git - location: https://git.vergara.tech/Vergara_Tech/zenith +custom-setup + setup-depends: + base >= 4.12 && < 5 + , Cabal >= 3.2.0.0 + , directory >= 1.3.6.0 + , filepath >= 1.3.0.2 + , regex-base + , regex-compat library + ghc-options: -Wall -Wunused-imports exposed-modules: - Zenith - other-modules: - Paths_zenith + Zenith.CLI + Zenith.Core + Zenith.DB + Zenith.Types + Zenith.Utils + Zenith.Zcashd + Zenith.Scanner hs-source-dirs: - src + src build-depends: Clipboard , aeson , array - , base >=4.7 && <5 + , ascii-progress + , base >=4.12 && <5 , base64-bytestring - , blake2 + , brick , bytestring + , esqueleto + , resource-pool + , binary + , exceptions + , monad-logger + , vty-crossplatform + , secp256k1-haskell + , pureMD5 + , ghc + , haskoin-core , hexstring + , http-client , http-conduit , http-types + , microlens + , microlens-mtl + , microlens-th + , mtl + , persistent + , Hclip + , persistent-sqlite + , persistent-template , process , regex-base , regex-compat , regex-posix , scientific , text + , time , vector + , vty + , word-wrap , zcash-haskell + --pkgconfig-depends: rustzcash_wrapper default-language: Haskell2010 executable zenith + ghc-options: -threaded -rtsopts -with-rtsopts=-N main-is: Main.hs - other-modules: - Paths_zenith hs-source-dirs: - app - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wunused-imports + app build-depends: - base >=4.7 && <5 + base >=4.12 && <5 + , brick , bytestring , configurator , data-default @@ -68,17 +96,45 @@ executable zenith , text , time , zenith + , zcash-haskell + pkgconfig-depends: rustzcash_wrapper default-language: Haskell2010 -test-suite zenith-test - type: exitcode-stdio-1.0 - main-is: Spec.hs - other-modules: - Paths_zenith +executable zenscan + ghc-options: -main-is ZenScan -threaded -rtsopts -with-rtsopts=-N + main-is: ZenScan.hs hs-source-dirs: - test - ghc-options: -threaded -rtsopts -with-rtsopts=-N + app build-depends: - base >=4.7 && <5 + base >=4.12 && <5 + , configurator + , monad-logger , zenith + pkgconfig-depends: rustzcash_wrapper + default-language: Haskell2010 + +test-suite zenith-tests + type: exitcode-stdio-1.0 + ghc-options: -threaded -rtsopts -with-rtsopts=-N + main-is: Spec.hs + hs-source-dirs: + test + build-depends: + base >=4.12 && <5 + , bytestring + , configurator + , monad-logger + , data-default + , sort + , text + , time + , persistent + , persistent-sqlite + , hspec + , hexstring + , HUnit + , directory + , zcash-haskell + , zenith + pkgconfig-depends: rustzcash_wrapper default-language: Haskell2010 diff --git a/zenith.cfg b/zenith.cfg index e1d4a4f..efedae5 100644 --- a/zenith.cfg +++ b/zenith.cfg @@ -1,2 +1,5 @@ nodeUser = "user" nodePwd = "superSecret" +dbFilePath = "zenith.db" +zebraHost = "127.0.0.1" +zebraPort = 18232