diff --git a/.gitignore b/.gitignore index 1c231fa..c368d45 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,2 @@ .stack-work/ -*~ -dist-newstyle/ +*~ \ No newline at end of file diff --git a/.gitmodules b/.gitmodules index 53b8dda..1c89539 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,4 +1,6 @@ +[submodule "haskoin-core"] + path = haskoin-core + url = https://github.com/khazaddum/haskoin-core.git [submodule "zcash-haskell"] path = zcash-haskell - url = https://git.vergara.tech/Vergara_Tech/zcash-haskell.git - branch = dev040 + url = git@git.vergara.tech:Vergara_Tech/zcash-haskell.git diff --git a/CHANGELOG.md b/CHANGELOG.md index 2ebaabf..490447a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,49 +5,6 @@ All notable changes to this project will be documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). -## [0.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 diff --git a/LICENSE b/LICENSE index 03b6d4f..099f1aa 100644 --- a/LICENSE +++ b/LICENSE @@ -1,22 +1,178 @@ -MIT License +Copyright (c) 2022 Vergara Technologies -Copyright (c) 2022-2024 Vergara Technologies LLC +======================================================= +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: -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: +*Licensed under the Bootstrap Open Source Licence version 1.0* -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. +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 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. + a. to reproduce the Original Work in copies, either alone or as part of + a collective work; + 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 efabca0..59ac7b3 100644 --- a/README.md +++ b/README.md @@ -10,28 +10,23 @@ Zcash Full Node CLI ``` -[![Please don't upload to GitHub](https://nogithub.codeberg.page/badge.svg)](https://nogithub.codeberg.page) ![](https://img.shields.io/badge/License-MIT-green -) +[![Please don't upload to GitHub](https://nogithub.codeberg.page/badge.svg)](https://nogithub.codeberg.page) -Zenith is a wallet for the [Zebra](https://zfnd.org/zebra/) Zcash node . It has the following features: +Zenith is a command-line interface for the Zcash Full Node (`zcashd`). It has the following features: -- Creating new wallets. -- Creating new accounts. -- Creating new Unified Addresses. +- Listing transparent and shielded addresses and balances known to the node, including viewing-only. - Listing transactions for specific addresses, decoding memos for easy reading. - Copying addresses to the clipboard. +- 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: - - [Cabal](https://www.haskell.org/cabal/#install-upgrade) - - [Zebra](https://zfnd.org/zebra/) - - [Cargo](https://doc.rust-lang.org/cargo/getting-started/installation.html) - - Install `cargo-c`: - ```shell - cargo install cargo-c - ``` + - [Stack](https://docs.haskellstack.org/en/stable/README/#how-to-install) + - [Zcash Full Node v.5.0.0](https://zcash.readthedocs.io/en/latest/rtd_pages/zcashd.html#install) - `xclip` - `libsecp256k1-dev` - `libxss-dev` @@ -42,27 +37,41 @@ Zenith is a wallet for the [Zebra](https://zfnd.org/zebra/) Zcash node . It has git clone https://git.vergara.tech/Vergara_Tech/zenith.git cd zenith git submodule init -git submodule update --remote +git submodule update ``` -- Install using `cabal`: +- Install using `stack`: ``` -cabal install +stack install ``` ## Configuration -- Copy the sample `zenith.cfg` file to your home directory and update the values of your Zebra host and port. +- Copy the sample `zenith.cfg` file to a location of your choice and update the values of the user and password for the `zcashd` node. These values can be found in the `zcash.conf` file for the Zcash node. ## Usage -**Note:** This is beta software under active development. We recommend to use it on testnet. Zenith runs on the network Zebra is running, to use the testnet you need to configure your Zebra node to run on testnet. +From the location where the configured `zenith.cfg` file is placed, use `zenith` to start. -From the location where the configured `zenith.cfg` file is placed, use `zenith cli` to start. +Zenith will attempt to connect to the node and check compatibility. Connections to `zcashd` versions less than 5.0.0 will fail. -Zenith will attempt to connect to the node and start up, the app will guide you through the creation of the first wallet. +### Available commands + +- `?`: Lists available commands. +- `list`: Lists all transparent and shielded addresses and their balance. + - Notes about balances: + - Addresses from an imported viewing key will list a balance but it may be inaccurate, as viewing keys cannot see ZEC spent out of that address. + - Balances for Unified Addresses *belonging to the same account* are shared. Zenith will list the full account balances for each of the UAs in the account. +- `txs `: Lists all transactions belonging to the address corresponding to the `id` given, in chronological order. +- `copy`: Copies the selected address to the clipboard. +- `new`: Prompts the user for the option to include a transparent receiver, a Sapling receiver or both. An Orchard receiver is always included. +- `send`: Prompts the user to prepare an outgoing transaction, selecting the source address, validating the destination address, the amount and the memo. + - If the source is a transparent address, the privacy policy is set to `AllowRevealedSenders`, favoring the shielding of funds when sent to a UA. + - If the source is a shielded address, the privacy policy is set to `AllowRevealedAmounts`, favoring the move of funds from legacy shielded pools to Orchard. +- `uri`: Prompts the user to select the source account and to enter a [ZIP-321](https://zips.z.cash/zip-0321) compliant URI to generate and send a transaction. +- `exit`: Ends the session. ### Support -If you would have any questions or suggestions, please join us on our [Support channel](https://matrix.to/#/#support:vergara.tech) +If you would like to support the development of Zenith, please visit our [Free2Z](https://free2z.com/zenith-full-node-cli) page. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 index 3ca9c28..0000000 --- a/Setup.hs +++ /dev/null @@ -1,131 +0,0 @@ -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 5911cfc..906d1af 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -12,14 +12,10 @@ 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 ZcashHaskell.Types -import Zenith.CLI -import Zenith.Core (clearSync, testSync) -import Zenith.Types (Config(..), ZcashAddress(..), ZcashPool(..), ZcashTx(..)) +import Zenith.Types (ZcashAddress(..), ZcashPool(..), ZcashTx(..)) import Zenith.Utils import Zenith.Zcashd @@ -200,35 +196,14 @@ 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" - 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 - "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" - putStrLn "rescan\tRescan the existing wallet(s)" + checkServer nodeUser nodePwd + void $ + runCLI + "Zenith" + def + { getBanner = + " ______ _ _ _ \n |___ / (_) | | | \n / / ___ _ __ _| |_| |__ \n / / / _ \\ '_ \\| | __| '_ \\ \n / /_| __/ | | | | |_| | | |\n /_____\\___|_| |_|_|\\__|_| |_|\n Zcash Full Node CLI v0.4.0" + } + (root nodeUser nodePwd) diff --git a/app/ZenScan.hs b/app/ZenScan.hs deleted file mode 100644 index 05059ca..0000000 --- a/app/ZenScan.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# 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 deleted file mode 100644 index 217198a..0000000 --- a/cabal.project +++ /dev/null @@ -1,15 +0,0 @@ -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 deleted file mode 100755 index df9fc8d..0000000 --- a/configure +++ /dev/null @@ -1,6 +0,0 @@ -#!/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 new file mode 100644 index 0000000..af65349 --- /dev/null +++ b/package.yaml @@ -0,0 +1,82 @@ +name: zenith +version: 0.4.1 +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 + - persistent + - persistent-sqlite + - persistent-template + - 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 + - hspec + - persistent + - persistent-sqlite + - persistent-template diff --git a/sapling-output.params b/sapling-output.params deleted file mode 100644 index 01760fa..0000000 Binary files a/sapling-output.params and /dev/null differ diff --git a/sapling-spend.params b/sapling-spend.params deleted file mode 100644 index b91cd77..0000000 Binary files a/sapling-spend.params and /dev/null differ diff --git a/src/Zenith/CLI.hs b/src/Zenith/CLI.hs deleted file mode 100644 index 73409e8..0000000 --- a/src/Zenith/CLI.hs +++ /dev/null @@ -1,1281 +0,0 @@ -{-# 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.1.0-beta")) <=> - 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 deleted file mode 100644 index a8dc6f2..0000000 --- a/src/Zenith/Core.hs +++ /dev/null @@ -1,774 +0,0 @@ -{-# 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 index a48151d..fea47ca 100644 --- a/src/Zenith/DB.hs +++ b/src/Zenith/DB.hs @@ -8,1464 +8,29 @@ {-# 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 +import Database.Persist.Sqlite 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(..) - ) +import ZcashHaskell.Types (Phrase) share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| ZcashWallet - name T.Text - network ZcashNetDB - seedPhrase PhraseDB + seedPhrase Phrase + spendingKey BS.ByteString + tPrivateKey BS.ByteString 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 + deriving Show |] - --- * 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 deleted file mode 100644 index df47ed1..0000000 --- a/src/Zenith/Scanner.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# 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 index 5526aa6..1ec4408 100644 --- a/src/Zenith/Types.hs +++ b/src/Zenith/Types.hs @@ -1,123 +1,30 @@ {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralisedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} module Zenith.Types where import Data.Aeson +import Data.Aeson.Types (prependFailure, typeMismatch) 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) +-- | 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) -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 +-- | Type for modelling the different address sources for Zcash 5.0.0 data AddressSource = LegacyRandom | Imported @@ -166,6 +73,24 @@ instance Show ZcashAddress where 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) diff --git a/src/Zenith/Utils.hs b/src/Zenith/Utils.hs index 96ca8dd..f2b42a4 100644 --- a/src/Zenith/Utils.hs +++ b/src/Zenith/Utils.hs @@ -2,49 +2,34 @@ module Zenith.Utils where -import Data.Aeson +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C +import Data.Char 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 qualified Data.Text.IO as TIO import System.Process (createProcess_, shell) +import Text.Read (readMaybe) import Text.Regex.Posix -import ZcashHaskell.Orchard (encodeUnifiedAddress, isValidUnifiedAddress) +import ZcashHaskell.Orchard (isValidUnifiedAddress) import ZcashHaskell.Sapling (isValidShieldedAddress) import Zenith.Types ( AddressGroup(..) - , UnifiedAddressDB(..) + , AddressSource(..) , 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 " + | 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 " --- | 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 diff --git a/src/Zenith/Zcashd.hs b/src/Zenith/Zcashd.hs index bc4c2d2..d82cd1e 100644 --- a/src/Zenith/Zcashd.hs +++ b/src/Zenith/Zcashd.hs @@ -24,12 +24,13 @@ 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(..) + , RpcCall(..) + , RpcResponse(..) , UABalance(..) , ZcashAddress(..) , ZcashPool(..) @@ -48,11 +49,8 @@ listAddresses user pwd = do 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 + let addList = concatMap getAddresses addys + return addList -- | Get address balance getBalance :: BS.ByteString -> BS.ByteString -> ZcashAddress -> IO [Integer] @@ -73,9 +71,7 @@ getBalance user pwd zadd = do case rpcResp of Nothing -> fail "Couldn't parse node response" Just res -> do - case result res of - Nothing -> return [] - Just r -> return [r] + return [result res] Just acct -> do response <- makeZcashCall @@ -87,9 +83,7 @@ getBalance user pwd zadd = do 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 + return $ readUABalance (result res) where readUABalance ua = [uatransparent ua, uasapling ua, uaorchard ua] @@ -102,9 +96,7 @@ listTxs user pwd zaddy = do 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' + return $ result res -- | Send Tx sendTx :: @@ -158,7 +150,7 @@ sendTx user pwd fromAddy toAddy amount memo = do Nothing -> fail "Couldn't parse node response" Just res -> do putStr " Sending." - checkOpResult user pwd (fromMaybe "" $ result res) + checkOpResult user pwd (result res) else putStrLn "Error: Source address is view-only." else putStrLn "Error: Insufficient balance in source address." @@ -171,14 +163,11 @@ checkServer user pwd = do 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 + 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 @@ -246,9 +235,7 @@ checkOpResult user pwd opid = do 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' + mapM_ showResult r where showResult t = case opsuccess t of @@ -282,7 +269,7 @@ makeZcashCall username password m p = do let rpcResp = decode body :: Maybe (RpcResponse String) case rpcResp of Nothing -> fail $ "Unknown server error " ++ show response - Just x -> fail (fromMaybe "" $ result x) + Just x -> fail (result x) 401 -> fail "Incorrect full node credentials" 200 -> return body _ -> fail "Unknown error" diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..fa604ae --- /dev/null +++ b/stack.yaml @@ -0,0 +1,81 @@ +# 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.22 + +# 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: 0858b805d066d0ce91dcc05594d929e63a99484e + - 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 new file mode 100644 index 0000000..ce8c103 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,77 @@ +# 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: 0858b805d066d0ce91dcc05594d929e63a99484e + git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git + name: zcash-haskell + pantry-tree: + sha256: 1f36dc81c65790bb090acc7b5337a149fe82dfeeea278c89033245cd85c462fc + size: 1430 + version: 0.4.1 + original: + commit: 0858b805d066d0ce91dcc05594d929e63a99484e + 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:378ec049bc2853b8011df116647fbd34bb9f00edce9840e4957f98abc097597c,1169 + pantry-tree: + sha256: 9f30503d1fe709f3849c5dd8b9751697a8db4d66105d7ba9c3b98bf4e36bb232 + size: 233 + original: + hackage: generically-0.1.1 +- completed: + hackage: vector-algorithms-0.9.0.1@sha256:222b01a4c0b9e13d73d04fba7c65930df16d1647acc07d84c47ef0356fa33dba,3880 + pantry-tree: + sha256: f2442ae23235b332dcd8b593bb20bfae02890ec891330c060ac4a410a5f1d64d + size: 1510 + original: + hackage: vector-algorithms-0.9.0.1 +snapshots: +- completed: + sha256: afd5ba64ab602cabc2d3942d3d7e7dd6311bc626dcb415b901eaf576cb62f0ea + size: 640060 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/22.yaml + original: lts-21.22 diff --git a/test/Spec.hs b/test/Spec.hs index 35fb3a1..392e8a4 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,253 +1,49 @@ {-# LANGUAGE OverloadedStrings #-} -import Control.Monad (when) -import Control.Monad.Logger (runNoLoggingT) -import Data.HexString -import qualified Data.Text.Encoding as E +import Control.Monad.IO.Class (liftIO) 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 +import Zenith.DB + ( EntityField(ZcashWalletId, ZcashWalletName) + , ZcashWallet(zcashWalletName) + ) main :: IO () 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")-} + it "insert wallet record" $ do + s <- + runSqlite "test.db" $ do + insert $ + ZcashWallet + "one two three four five six seven eight nine ten eleven twelve" + "123456789" + "987654321" + 2000000 + "Main Wallet" + 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 diff --git a/zcash-haskell b/zcash-haskell deleted file mode 160000 index 9dddb42..0000000 --- a/zcash-haskell +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 9dddb42bb3ab78ed0c4d44efb00960ac112c2ce6 diff --git a/zebra_openapi.yaml b/zebra_openapi.yaml deleted file mode 100644 index 86fff2a..0000000 --- a/zebra_openapi.yaml +++ /dev/null @@ -1,1007 +0,0 @@ -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 3101182..ee2b431 100644 --- a/zenith.cabal +++ b/zenith.cabal @@ -1,69 +1,49 @@ -cabal-version: 3.0 -name: zenith -version: 0.5.1.0-beta -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 +cabal-version: 1.12 +-- This file has been generated from package.yaml by hpack version 0.36.0. +-- +-- see: https://github.com/sol/hpack -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 +name: zenith +version: 0.4.1 +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 library - ghc-options: -Wall -Wunused-imports exposed-modules: - Zenith.CLI - Zenith.Core - Zenith.DB - Zenith.Types - Zenith.Utils - Zenith.Zcashd - Zenith.Scanner + Zenith.DB + Zenith.Types + Zenith.Utils + Zenith.Zcashd + other-modules: + Paths_zenith hs-source-dirs: - src + src build-depends: Clipboard , aeson , array - , ascii-progress - , base >=4.12 && <5 + , base >=4.7 && <5 , base64-bytestring - , 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 @@ -72,22 +52,19 @@ library , 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 + app + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wunused-imports build-depends: - base >=4.12 && <5 - , brick + base >=4.7 && <5 , bytestring , configurator , data-default @@ -96,45 +73,21 @@ executable zenith , text , time , zenith - , zcash-haskell - pkgconfig-depends: rustzcash_wrapper default-language: Haskell2010 -executable zenscan - ghc-options: -main-is ZenScan -threaded -rtsopts -with-rtsopts=-N - main-is: ZenScan.hs - hs-source-dirs: - app - build-depends: - base >=4.12 && <5 - , configurator - , monad-logger - , zenith - pkgconfig-depends: rustzcash_wrapper - default-language: Haskell2010 - -test-suite zenith-tests +test-suite zenith-test type: exitcode-stdio-1.0 - ghc-options: -threaded -rtsopts -with-rtsopts=-N main-is: Spec.hs + other-modules: + Paths_zenith hs-source-dirs: - test + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.12 && <5 - , bytestring - , configurator - , monad-logger - , data-default - , sort - , text - , time + base >=4.7 && <5 + , hspec , persistent , persistent-sqlite - , hspec - , hexstring - , HUnit - , directory - , zcash-haskell + , persistent-template , zenith - pkgconfig-depends: rustzcash_wrapper default-language: Haskell2010 diff --git a/zenith.cfg b/zenith.cfg index efedae5..e1d4a4f 100644 --- a/zenith.cfg +++ b/zenith.cfg @@ -1,5 +1,2 @@ nodeUser = "user" nodePwd = "superSecret" -dbFilePath = "zenith.db" -zebraHost = "127.0.0.1" -zebraPort = 18232