Publish Zenith beta version (#80)
Co-authored-by: Rene V. Vergara <rvergara59@protonmail.com> Reviewed-on: #80 Co-authored-by: pitmutt <rene@vergara.network> Co-committed-by: pitmutt <rene@vergara.network>
This commit is contained in:
parent
158b059596
commit
621ffea3d9
Signed by:
Vergara Technologies LLC
Vergara Technologies LLC
GPG key ID:
99DB473BB4715618
28 changed files with 6088 additions and 1105 deletions
3
.gitignore
vendored
3
.gitignore
vendored
|
|
@ -1,2 +1,3 @@
|
|||
.stack-work/
|
||||
*~
|
||||
*~
|
||||
dist-newstyle/
|
||||
|
|
|
|||
6
.gitmodules
vendored
6
.gitmodules
vendored
|
|
@ -1,6 +1,4 @@
|
|||
[submodule "haskoin-core"]
|
||||
path = haskoin-core
|
||||
url = https://github.com/khazaddum/haskoin-core.git
|
||||
[submodule "zcash-haskell"]
|
||||
path = zcash-haskell
|
||||
url = git@git.vergara.tech:Vergara_Tech/zcash-haskell.git
|
||||
url = https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
|
||||
branch = dev040
|
||||
|
|
|
|||
49
CHANGELOG.md
49
CHANGELOG.md
|
|
@ -5,6 +5,55 @@ All notable changes to this project will be documented in this file.
|
|||
The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),
|
||||
and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html).
|
||||
|
||||
## [0.5.0.0]
|
||||
|
||||
### Added
|
||||
|
||||
- Core functions for sending transactions
|
||||
|
||||
## [0.4.6.0]
|
||||
|
||||
### Added
|
||||
|
||||
- Display of account balance
|
||||
- Functions to identify spends
|
||||
- Functions to display transactions per address
|
||||
|
||||
### Changed
|
||||
|
||||
- Update `zcash-haskell`
|
||||
|
||||
## [0.4.5.0]
|
||||
|
||||
### Added
|
||||
|
||||
- Functions to scan relevant transparent notes
|
||||
- Functions to scan relevant Sapling notes
|
||||
- Functions to scan relevant Orchard notes
|
||||
- Function to query `zebrad` for commitment trees
|
||||
|
||||
### Changed
|
||||
|
||||
- Update `zcash-haskell`
|
||||
|
||||
## [0.4.4.3]
|
||||
|
||||
### Added
|
||||
|
||||
- `Core` module
|
||||
- `CLI` module
|
||||
- `DB` module
|
||||
- Command line arguments to switch to legacy version
|
||||
- New configuration parameter for Zebra port
|
||||
- New functions to call `getinfo` and `getblockchaininfo` RPC methods
|
||||
- `Scanner` module
|
||||
|
||||
## [0.4.1]
|
||||
|
||||
### Fixed
|
||||
|
||||
- Handling of transactions to transparent receivers
|
||||
|
||||
## [0.4.0]
|
||||
|
||||
### Added
|
||||
|
|
|
|||
190
LICENSE
190
LICENSE
|
|
@ -1,178 +1,22 @@
|
|||
Copyright (c) 2022 Vergara Technologies
|
||||
MIT License
|
||||
|
||||
=======================================================
|
||||
Bootstrap Open Source Licence ("BOSL") v. 1.0
|
||||
=======================================================
|
||||
This Bootstrap Open Source Licence (the "License") applies to any original work
|
||||
of authorship (the "Original Work") whose owner (the "Licensor") has placed the
|
||||
following licensing notice adjacent to the copyright notice for the Original
|
||||
Work:
|
||||
Copyright (c) 2022-2024 Vergara Technologies LLC
|
||||
|
||||
*Licensed under the Bootstrap Open Source Licence version 1.0*
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to deal
|
||||
in the Software without restriction, including without limitation the rights
|
||||
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||
copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
1. **Grant of Copyright License.** Licensor grants You a worldwide,
|
||||
royalty-free, non-exclusive, sublicensable license, for the duration of the
|
||||
copyright in the Original Work, to do the following:
|
||||
The above copyright notice and this permission notice shall be included in all
|
||||
copies or substantial portions of the Software.
|
||||
|
||||
a. to reproduce the Original Work in copies, either alone or as part of
|
||||
a collective work;
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||
SOFTWARE.
|
||||
|
||||
b. to translate, adapt, alter, transform, modify, or arrange the
|
||||
Original Work, thereby creating derivative works ("Derivative Works")
|
||||
based upon the Original Work;
|
||||
|
||||
c. to distribute or communicate copies of the Original Work and
|
||||
Derivative Works to the public, provided that prior to any such
|
||||
distribution or communication You first place a machine-readable copy
|
||||
of the Source Code of the Original Work and such Derivative Works that
|
||||
You intend to distribute or communicate in an information repository
|
||||
reasonably calculated to permit inexpensive and convenient access
|
||||
thereto by the public (“Information Repository”) for as long as You
|
||||
continue to distribute or communicate said copies, accompanied by an
|
||||
irrevocable offer to license said copies to the public free of charge
|
||||
under this License, said offer valid starting no later than 12 months
|
||||
after You first distribute or communicate said copies;
|
||||
|
||||
d. to perform the Original Work publicly; and
|
||||
|
||||
e. to display the Original Work publicly.
|
||||
|
||||
2. **Grant of Patent License.** Licensor grants You a worldwide, royalty-free,
|
||||
non-exclusive, sublicensable license, under patent claims owned or controlled
|
||||
by the Licensor that are embodied in the Original Work as furnished by the
|
||||
Licensor, for the duration of the patents, to make, use, sell, offer for sale,
|
||||
have made, and import the Original Work and Derivative Works.
|
||||
|
||||
3. **Grant of Source Code License.** The "Source Code" for a work means the
|
||||
preferred form of the work for making modifications to it and all available
|
||||
documentation describing how to modify the work. Licensor agrees to provide a
|
||||
machine-readable copy of the Source Code of the Original Work along with each
|
||||
copy of the Original Work that Licensor distributes. Licensor reserves the
|
||||
right to satisfy this obligation by placing a machine-readable copy of said
|
||||
Source Code in an Information Repository for as long as Licensor continues to
|
||||
distribute the Original Work.
|
||||
|
||||
4. **Exclusions From License Grant.** Neither the names of Licensor, nor the
|
||||
names of any contributors to the Original Work, nor any of their trademarks or
|
||||
service marks, may be used to endorse or promote products derived from this
|
||||
Original Work without express prior permission of the Licensor. Except as
|
||||
expressly stated herein, nothing in this License grants any license to
|
||||
Licensor's trademarks, copyrights, patents, trade secrets or any other
|
||||
intellectual property. No patent license is granted to make, use, sell, offer
|
||||
for sale, have made, or import embodiments of any patent claims other than the
|
||||
licensed claims defined in Section 2. No license is granted to the trademarks
|
||||
of Licensor even if such marks are included in the Original Work. Nothing in
|
||||
this License shall be interpreted to prohibit Licensor from licensing under
|
||||
terms different from this License any Original Work that Licensor otherwise
|
||||
would have a right to license.
|
||||
|
||||
5. **External Deployment.** The term "External Deployment" means the use,
|
||||
distribution, or communication of the Original Work or Derivative Works in any
|
||||
way such that the Original Work or Derivative Works may be used by anyone other
|
||||
than You, whether those works are distributed or communicated to those persons
|
||||
or made available as an application intended for use over a network. As an
|
||||
express condition for the grants of license hereunder, You must treat any
|
||||
External Deployment by You of the Original Work or a Derivative Work as a
|
||||
distribution under section 1(c).
|
||||
|
||||
6. **Attribution Rights.** You must retain, in the Source Code of any
|
||||
Derivative Works that You create, all copyright, patent, or trademark notices
|
||||
from the Source Code of the Original Work, as well as any notices of licensing
|
||||
and any descriptive text identified therein as an "Attribution Notice." You
|
||||
must cause the Source Code for any Derivative Works that You create to carry a
|
||||
prominent Attribution Notice reasonably calculated to inform recipients that
|
||||
You have modified the Original Work.
|
||||
|
||||
7. **Warranty of Provenance and Disclaimer of Warranty.** Licensor warrants
|
||||
that the copyright in and to the Original Work and the patent rights granted
|
||||
herein by Licensor are owned by the Licensor or are sublicensed to You under
|
||||
the terms of this License with the permission of the contributor(s) of those
|
||||
copyrights and patent rights. Except as expressly stated in the immediately
|
||||
preceding sentence, the Original Work is provided under this License on an "AS
|
||||
IS" BASIS and WITHOUT WARRANTY, either express or implied, including, without
|
||||
limitation, the warranties of non-infringement, merchantability or fitness for
|
||||
a particular purpose. THE ENTIRE RISK AS TO THE QUALITY OF THE ORIGINAL WORK IS
|
||||
WITH YOU. This DISCLAIMER OF WARRANTY constitutes an essential part of this
|
||||
License. No license to the Original Work is granted by this License except
|
||||
under this disclaimer.
|
||||
|
||||
8. **Limitation of Liability.** Under no circumstances and under no legal
|
||||
theory, whether in tort (including negligence), contract, or otherwise, shall
|
||||
the Licensor be liable to anyone for any indirect, special, incidental, or
|
||||
consequential damages of any character arising as a result of this License or
|
||||
the use of the Original Work including, without limitation, damages for loss of
|
||||
goodwill, work stoppage, computer failure or malfunction, or any and all other
|
||||
commercial damages or losses. This limitation of liability shall not apply to
|
||||
the extent applicable law prohibits such limitation.
|
||||
|
||||
9. **Acceptance and Termination.** If, at any time, You expressly assented to
|
||||
this License, that assent indicates your clear and irrevocable acceptance of
|
||||
this License and all of its terms and conditions. If You distribute or
|
||||
communicate copies of the Original Work or a Derivative Work, You must make a
|
||||
reasonable effort under the circumstances to obtain the express assent of
|
||||
recipients to the terms of this License. This License conditions your rights to
|
||||
undertake the activities listed in Section 1, including your right to create
|
||||
Derivative Works based upon the Original Work, and doing so without honoring
|
||||
these terms and conditions is prohibited by copyright law and international
|
||||
treaty. Nothing in this License is intended to affect copyright exceptions and
|
||||
limitations (including 'fair use' or 'fair dealing'). This License shall
|
||||
terminate immediately and You may no longer exercise any of the rights granted
|
||||
to You by this License upon your failure to honor the conditions in Section
|
||||
1(c).
|
||||
|
||||
10. **Termination for Patent Action.** This License shall terminate
|
||||
automatically and You may no longer exercise any of the rights granted to You
|
||||
by this License as of the date You commence an action, including a cross-claim
|
||||
or counterclaim, against Licensor or any licensee alleging that the Original
|
||||
Work infringes a patent. This termination provision shall not apply for an
|
||||
action alleging patent infringement by combinations of the Original Work with
|
||||
other software or hardware.
|
||||
|
||||
11. **Jurisdiction, Venue and Governing Law.** Any action or suit relating to
|
||||
this License may be brought only in the courts of a jurisdiction wherein the
|
||||
Licensor resides or in which Licensor conducts its primary business, and under
|
||||
the laws of that jurisdiction excluding its conflict-of-law provisions. The
|
||||
application of the United Nations Convention on Contracts for the International
|
||||
Sale of Goods is expressly excluded. Any use of the Original Work outside the
|
||||
scope of this License or after its termination shall be subject to the
|
||||
requirements and penalties of copyright or patent law in the appropriate
|
||||
jurisdiction. This section shall survive the termination of this License.
|
||||
|
||||
12. **Attorneys' Fees.** In any action to enforce the terms of this License or
|
||||
seeking damages relating thereto, the prevailing party shall be entitled to
|
||||
recover its costs and expenses, including, without limitation, reasonable
|
||||
attorneys' fees and costs incurred in connection with such action, including
|
||||
any appeal of such action. This section shall survive the termination of this
|
||||
License.
|
||||
|
||||
13. **Miscellaneous.** If any provision of this License is held to be
|
||||
unenforceable, such provision shall be reformed only to the extent necessary to
|
||||
make it enforceable.
|
||||
|
||||
14. **Definition of "You" in This License.** "You" throughout this License,
|
||||
whether in upper or lower case, means an individual or a legal entity
|
||||
exercising rights under, and complying with all of the terms of, this License.
|
||||
For legal entities, "You" includes any entity that controls, is controlled by,
|
||||
or is under common control with you. For purposes of this definition, "control"
|
||||
means (i) the power, direct or indirect, to cause the direction or management
|
||||
of such entity, whether by contract or otherwise, or (ii) ownership of fifty
|
||||
percent (50%) or more of the outstanding shares, or (iii) beneficial ownership
|
||||
of such entity.
|
||||
|
||||
15. **Right to Use.** You may use the Original Work in all ways not otherwise
|
||||
restricted or conditioned by this License or by law, and Licensor promises not
|
||||
to interfere with or be responsible for such uses by You.
|
||||
|
||||
16. **Modification of This License.** This License is Copyright © 2007 Zooko
|
||||
Wilcox-O'Hearn. Permission is granted to copy, distribute, or communicate this
|
||||
License without modification. Nothing in this License permits You to modify
|
||||
this License as applied to the Original Work or to Derivative Works. However,
|
||||
You may modify the text of this License and copy, distribute or communicate
|
||||
your modified version (the "Modified License") and apply it to other original
|
||||
works of authorship subject to the following conditions: (i) You may not
|
||||
indicate in any way that your Modified License is the "Bootstrap Open Source
|
||||
Licence" or "BOSL" and you may not use those names in the name of your Modified
|
||||
License; and (ii) You must replace the notice specified in the first paragraph
|
||||
above with the notice "Licensed under <insert your license name here>" or with
|
||||
a notice of your own that is not confusingly similar to the notice in this
|
||||
License.
|
||||
|
|
|
|||
11
README.md
11
README.md
|
|
@ -10,7 +10,8 @@
|
|||
Zcash Full Node CLI
|
||||
```
|
||||
|
||||
[](https://nogithub.codeberg.page)
|
||||
[](https://nogithub.codeberg.page) 
|
||||
|
||||
Zenith is a command-line interface for the Zcash Full Node (`zcashd`). It has the following features:
|
||||
|
||||
|
|
@ -20,8 +21,6 @@ Zenith is a command-line interface for the Zcash Full Node (`zcashd`). It has th
|
|||
- Creating new Unified Addresses.
|
||||
- Sending transactions with shielded memo support.
|
||||
|
||||
Note: Zenith depends on a patched version of the `haskoin-core` Haskell package included in this repo. A pull request to the maintainers of `haskoin-core` has been submitted, if/when it is merged, Zenith will be updated to use the standard package.
|
||||
|
||||
## Installation
|
||||
|
||||
- Install dependencies:
|
||||
|
|
@ -37,13 +36,13 @@ Note: Zenith depends on a patched version of the `haskoin-core` Haskell package
|
|||
git clone https://git.vergara.tech/Vergara_Tech/zenith.git
|
||||
cd zenith
|
||||
git submodule init
|
||||
git submodule update
|
||||
git submodule update --remote
|
||||
```
|
||||
|
||||
- Install using `stack`:
|
||||
- Install using `cabal`:
|
||||
|
||||
```
|
||||
stack install
|
||||
cabal install
|
||||
```
|
||||
|
||||
## Configuration
|
||||
|
|
|
|||
131
Setup.hs
Normal file
131
Setup.hs
Normal file
|
|
@ -0,0 +1,131 @@
|
|||
import Control.Exception (throw)
|
||||
import Control.Monad (forM_, when)
|
||||
import Data.Maybe (isNothing)
|
||||
import Distribution.PackageDescription
|
||||
import Distribution.Simple
|
||||
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), localPkgDescr)
|
||||
import Distribution.Simple.PreProcess
|
||||
import Distribution.Simple.Program.Find
|
||||
( defaultProgramSearchPath
|
||||
, findProgramOnSearchPath
|
||||
)
|
||||
import Distribution.Simple.Setup
|
||||
import Distribution.Simple.Utils
|
||||
( IODataMode(IODataModeBinary)
|
||||
, maybeExit
|
||||
, rawSystemStdInOut
|
||||
)
|
||||
import Distribution.Verbosity (Verbosity)
|
||||
import qualified Distribution.Verbosity as Verbosity
|
||||
import System.Directory
|
||||
( XdgDirectory(..)
|
||||
, copyFile
|
||||
, createDirectory
|
||||
, createDirectoryIfMissing
|
||||
, doesDirectoryExist
|
||||
, doesFileExist
|
||||
, getCurrentDirectory
|
||||
, getDirectoryContents
|
||||
, getHomeDirectory
|
||||
, getXdgDirectory
|
||||
)
|
||||
import System.Environment
|
||||
import System.FilePath ((</>))
|
||||
import Text.Regex
|
||||
import Text.Regex.Base
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMainWithHooks hooks
|
||||
where
|
||||
hooks =
|
||||
simpleUserHooks
|
||||
{ preConf =
|
||||
\_ flags -> do
|
||||
prepDeps (fromFlag $ configVerbosity flags)
|
||||
pure emptyHookedBuildInfo
|
||||
--, confHook = \a flags -> confHook simpleUserHooks a flags >>= rsAddDirs
|
||||
}
|
||||
|
||||
execCargo :: Verbosity -> String -> [String] -> IO ()
|
||||
execCargo verbosity command args = do
|
||||
cargoPath <-
|
||||
findProgramOnSearchPath Verbosity.silent defaultProgramSearchPath "cargo"
|
||||
dir <- getCurrentDirectory
|
||||
let cargoExec =
|
||||
case cargoPath of
|
||||
Just (p, _) -> p
|
||||
Nothing -> "cargo"
|
||||
cargoArgs = command : args
|
||||
workingDir = Just (dir </> rsFolder)
|
||||
thirdComponent (_, _, c) = c
|
||||
maybeExit . fmap thirdComponent $
|
||||
rawSystemStdInOut
|
||||
verbosity
|
||||
cargoExec
|
||||
cargoArgs
|
||||
workingDir
|
||||
Nothing
|
||||
Nothing
|
||||
IODataModeBinary
|
||||
|
||||
rsMake :: Verbosity -> IO ()
|
||||
rsMake verbosity = do
|
||||
execCargo verbosity "cbuild" []
|
||||
|
||||
prepDeps :: Verbosity -> IO ()
|
||||
prepDeps verbosity = do
|
||||
ldPath <- lookupEnv "LD_LIBRARY_PATH"
|
||||
pkgPath <- lookupEnv "PKG_CONFIG_PATH"
|
||||
if maybe False (matchTest (mkRegex ".*zcash-haskell.*")) ldPath &&
|
||||
maybe False (matchTest (mkRegex ".*zcash-haskell.*")) pkgPath
|
||||
then do
|
||||
execCargo verbosity "cbuild" []
|
||||
localData <- getXdgDirectory XdgData "zcash-haskell"
|
||||
createDirectoryIfMissing True localData
|
||||
dir <- getCurrentDirectory
|
||||
let rustLibDir =
|
||||
dir </> rsFolder </> "target/x86_64-unknown-linux-gnu/debug"
|
||||
copyDir rustLibDir localData
|
||||
else throw $
|
||||
userError "Paths not set correctly, please run the 'configure' script."
|
||||
|
||||
rsFolder :: FilePath
|
||||
rsFolder = "zcash-haskell/librustzcash-wrapper"
|
||||
|
||||
rsAddDirs :: LocalBuildInfo -> IO LocalBuildInfo
|
||||
rsAddDirs lbi' = do
|
||||
dir <- getCurrentDirectory
|
||||
let rustIncludeDir =
|
||||
dir </> rsFolder </> "target/x86_64-unknown-linux-gnu/debug"
|
||||
rustLibDir = dir </> rsFolder </> "target/x86_64-unknown-linux-gnu/debug"
|
||||
updateLbi lbi = lbi {localPkgDescr = updatePkgDescr (localPkgDescr lbi)}
|
||||
updatePkgDescr pkgDescr =
|
||||
pkgDescr {library = updateLib <$> library pkgDescr}
|
||||
updateLib lib = lib {libBuildInfo = updateLibBi (libBuildInfo lib)}
|
||||
updateLibBi libBuild =
|
||||
libBuild
|
||||
{ includeDirs = rustIncludeDir : includeDirs libBuild
|
||||
, extraLibDirs = rustLibDir : extraLibDirs libBuild
|
||||
}
|
||||
pure $ updateLbi lbi'
|
||||
|
||||
copyDir :: FilePath -> FilePath -> IO ()
|
||||
copyDir src dst = do
|
||||
whenM (not <$> doesDirectoryExist src) $
|
||||
throw (userError "source does not exist")
|
||||
--whenM (doesFileOrDirectoryExist dst) $
|
||||
--throw (userError "destination already exists")
|
||||
createDirectoryIfMissing True dst
|
||||
content <- getDirectoryContents src
|
||||
let xs = filter (`notElem` [".", ".."]) content
|
||||
forM_ xs $ \name -> do
|
||||
let srcPath = src </> name
|
||||
let dstPath = dst </> name
|
||||
isDirectory <- doesDirectoryExist srcPath
|
||||
if isDirectory
|
||||
then copyDir srcPath dstPath
|
||||
else copyFile srcPath dstPath
|
||||
where
|
||||
doesFileOrDirectoryExist x = orM [doesDirectoryExist x, doesFileExist x]
|
||||
orM xs = or <$> sequence xs
|
||||
whenM s r = s >>= flip when r
|
||||
47
app/Main.hs
47
app/Main.hs
|
|
@ -12,10 +12,16 @@ import qualified Data.Text as T
|
|||
import qualified Data.Text.IO as TIO
|
||||
import Data.Time.Clock.POSIX
|
||||
import System.Console.StructuredCLI
|
||||
import System.Environment (getArgs)
|
||||
import System.Exit
|
||||
import System.IO
|
||||
import Text.Read (readMaybe)
|
||||
import Zenith
|
||||
import ZcashHaskell.Types
|
||||
import Zenith.CLI
|
||||
import Zenith.Core (clearSync, testSync)
|
||||
import Zenith.Types (Config(..), ZcashAddress(..), ZcashPool(..), ZcashTx(..))
|
||||
import Zenith.Utils
|
||||
import Zenith.Zcashd
|
||||
|
||||
prompt :: String -> IO String
|
||||
prompt text = do
|
||||
|
|
@ -194,14 +200,35 @@ processUri user pwd =
|
|||
main :: IO ()
|
||||
main = do
|
||||
config <- load ["zenith.cfg"]
|
||||
args <- getArgs
|
||||
dbFilePath <- require config "dbFilePath"
|
||||
nodeUser <- require config "nodeUser"
|
||||
nodePwd <- require config "nodePwd"
|
||||
checkServer nodeUser nodePwd
|
||||
void $
|
||||
runCLI
|
||||
"Zenith"
|
||||
def
|
||||
{ getBanner =
|
||||
" ______ _ _ _ \n |___ / (_) | | | \n / / ___ _ __ _| |_| |__ \n / / / _ \\ '_ \\| | __| '_ \\ \n / /_| __/ | | | | |_| | | |\n /_____\\___|_| |_|_|\\__|_| |_|\n Zcash Full Node CLI v0.4.0"
|
||||
}
|
||||
(root nodeUser nodePwd)
|
||||
zebraPort <- require config "zebraPort"
|
||||
zebraHost <- require config "zebraHost"
|
||||
let myConfig = Config dbFilePath zebraHost zebraPort
|
||||
if not (null args)
|
||||
then do
|
||||
case head args of
|
||||
"legacy" -> do
|
||||
checkServer nodeUser nodePwd
|
||||
void $
|
||||
runCLI
|
||||
"Zenith"
|
||||
def
|
||||
{ getBanner =
|
||||
" ______ _ _ _ \n |___ / (_) | | | \n / / ___ _ __ _| |_| |__ \n / / / _ \\ '_ \\| | __| '_ \\ \n / /_| __/ | | | | |_| | | |\n /_____\\___|_| |_|_|\\__|_| |_|\n Zcash Full Node CLI v0.4.0"
|
||||
}
|
||||
(root nodeUser nodePwd)
|
||||
"cli" -> runZenithCLI myConfig
|
||||
"sync" -> testSync myConfig
|
||||
"rescan" -> clearSync myConfig
|
||||
_ -> printUsage
|
||||
else printUsage
|
||||
|
||||
printUsage :: IO ()
|
||||
printUsage = do
|
||||
putStrLn "zenith [command] [parameters]\n"
|
||||
putStrLn "Available commands:"
|
||||
putStrLn "legacy\tLegacy CLI for zcashd"
|
||||
putStrLn "cli\tCLI for zebrad"
|
||||
|
|
|
|||
15
app/ZenScan.hs
Normal file
15
app/ZenScan.hs
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module ZenScan where
|
||||
|
||||
import Control.Monad.Logger (runNoLoggingT)
|
||||
import Data.Configurator
|
||||
import Zenith.Scanner (scanZebra)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
config <- load ["zenith.cfg"]
|
||||
dbFilePath <- require config "dbFilePath"
|
||||
zebraPort <- require config "zebraPort"
|
||||
zebraHost <- require config "zebraHost"
|
||||
runNoLoggingT $ scanZebra 2762066 zebraHost zebraPort dbFilePath
|
||||
15
cabal.project
Normal file
15
cabal.project
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
packages:
|
||||
./*.cabal
|
||||
zcash-haskell/zcash-haskell.cabal
|
||||
|
||||
with-compiler: ghc-9.4.8
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://git.vergara.tech/Vergara_Tech/haskell-hexstring.git
|
||||
tag: 39d8da7b11a80269454c2f134a5c834e0f3cb9a7
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git
|
||||
tag: 335e804454cd30da2c526457be37e477f71e4665
|
||||
6
configure
vendored
Executable file
6
configure
vendored
Executable file
|
|
@ -0,0 +1,6 @@
|
|||
#!/bin/bash
|
||||
|
||||
echo "export PKG_CONFIG_PATH=$HOME/.local/share/zcash-haskell:\$PKG_CONFIG_PATH" | tee -a ~/.bashrc
|
||||
echo "export LD_LIBRARY_PATH=$HOME/.local/share/zcash-haskell:\$LD_LIBRARY_PATH" | tee -a ~/.bashrc
|
||||
source ~/.bashrc
|
||||
cd zcash-haskell && cabal build
|
||||
76
package.yaml
76
package.yaml
|
|
@ -1,76 +0,0 @@
|
|||
name: zenith
|
||||
version: 0.4.0
|
||||
git: "https://git.vergara.tech/Vergara_Tech/zenith"
|
||||
license: BOSL
|
||||
author: "Rene Vergara"
|
||||
maintainer: "rene@vergara.network"
|
||||
copyright: "Copyright (c) 2022 Vergara Technologies LLC"
|
||||
|
||||
extra-source-files:
|
||||
- README.md
|
||||
- CHANGELOG.md
|
||||
- zenith.cfg
|
||||
|
||||
# Metadata used when publishing your package
|
||||
synopsis: Haskell CLI for Zcash Full Node
|
||||
# category: Web
|
||||
|
||||
# To avoid duplicated efforts in documentation and dealing with the
|
||||
# complications of embedding Haddock markup inside cabal files, it is
|
||||
# common to point users to the README.md file.
|
||||
description: Please see the README on repo at <https://git.vergara.tech/Vergara_Tech/zenith#readme>
|
||||
|
||||
dependencies:
|
||||
- base >= 4.7 && < 5
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
dependencies:
|
||||
- aeson
|
||||
- text
|
||||
- bytestring
|
||||
- http-conduit
|
||||
- scientific
|
||||
- vector
|
||||
- regex-base
|
||||
- regex-posix
|
||||
- regex-compat
|
||||
- Clipboard
|
||||
- process
|
||||
- http-types
|
||||
- array
|
||||
- base64-bytestring
|
||||
- hexstring
|
||||
- blake2
|
||||
- zcash-haskell
|
||||
|
||||
executables:
|
||||
zenith:
|
||||
main: Main.hs
|
||||
source-dirs: app
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
- -with-rtsopts=-N
|
||||
- -Wall
|
||||
- -Wunused-imports
|
||||
dependencies:
|
||||
- zenith
|
||||
- configurator
|
||||
- structured-cli
|
||||
- data-default
|
||||
- bytestring
|
||||
- text
|
||||
- time
|
||||
- sort
|
||||
|
||||
tests:
|
||||
zenith-test:
|
||||
main: Spec.hs
|
||||
source-dirs: test
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
- -with-rtsopts=-N
|
||||
dependencies:
|
||||
- zenith
|
||||
BIN
sapling-output.params
Normal file
BIN
sapling-output.params
Normal file
Binary file not shown.
BIN
sapling-spend.params
Normal file
BIN
sapling-spend.params
Normal file
Binary file not shown.
635
src/Zenith.hs
635
src/Zenith.hs
|
|
@ -1,635 +0,0 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module Zenith where
|
||||
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Monad
|
||||
import Crypto.Hash.BLAKE2.BLAKE2b
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Types
|
||||
import qualified Data.Array as A
|
||||
import Data.Bits
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Base64 as B64
|
||||
import qualified Data.ByteString.Char8 as C
|
||||
import qualified Data.ByteString.Lazy as LB
|
||||
import Data.Char
|
||||
import Data.Functor (void)
|
||||
import Data.HexString
|
||||
import Data.Maybe
|
||||
import qualified Data.Scientific as Scientific
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import Data.Text.Encoding.Error (lenientDecode)
|
||||
import qualified Data.Text.IO as TIO
|
||||
import qualified Data.Vector as V
|
||||
import Data.Word
|
||||
import GHC.Generics
|
||||
import ZcashHaskell.Orchard (isValidUnifiedAddress)
|
||||
import ZcashHaskell.Sapling (isValidShieldedAddress)
|
||||
|
||||
{-import Haskoin.Address.Bech32-}
|
||||
import Network.HTTP.Simple
|
||||
import Network.HTTP.Types
|
||||
import Numeric
|
||||
import System.Clipboard
|
||||
import System.Exit
|
||||
import System.IO
|
||||
import System.Process (createProcess_, shell)
|
||||
import Text.Read (readMaybe)
|
||||
import Text.Regex
|
||||
import Text.Regex.Base
|
||||
import Text.Regex.Posix
|
||||
|
||||
-- | A type to model Zcash RPC calls
|
||||
data RpcCall = RpcCall
|
||||
{ jsonrpc :: T.Text
|
||||
, id :: T.Text
|
||||
, method :: T.Text
|
||||
, params :: [Value]
|
||||
} deriving (Show, Generic, ToJSON, FromJSON)
|
||||
|
||||
-- | Type for modelling the different address sources for Zcash 5.0.0
|
||||
data AddressSource
|
||||
= LegacyRandom
|
||||
| Imported
|
||||
| ImportedWatchOnly
|
||||
| KeyPool
|
||||
| LegacySeed
|
||||
| MnemonicSeed
|
||||
deriving (Read, Show, Eq, Generic, ToJSON)
|
||||
|
||||
instance FromJSON AddressSource where
|
||||
parseJSON =
|
||||
withText "AddressSource" $ \case
|
||||
"legacy_random" -> return LegacyRandom
|
||||
"imported" -> return Imported
|
||||
"imported_watchonly" -> return ImportedWatchOnly
|
||||
"keypool" -> return KeyPool
|
||||
"legacy_hdseed" -> return LegacySeed
|
||||
"mnemonic_seed" -> return MnemonicSeed
|
||||
_ -> fail "Not a known address source"
|
||||
|
||||
data ZcashPool
|
||||
= Transparent
|
||||
| Sprout
|
||||
| Sapling
|
||||
| Orchard
|
||||
deriving (Show, Eq, Generic, ToJSON)
|
||||
|
||||
instance FromJSON ZcashPool where
|
||||
parseJSON =
|
||||
withText "ZcashPool" $ \case
|
||||
"p2pkh" -> return Transparent
|
||||
"sprout" -> return Sprout
|
||||
"sapling" -> return Sapling
|
||||
"orchard" -> return Orchard
|
||||
_ -> fail "Not a known Zcash pool"
|
||||
|
||||
data ZcashAddress = ZcashAddress
|
||||
{ source :: AddressSource
|
||||
, pool :: [ZcashPool]
|
||||
, account :: Maybe Integer
|
||||
, addy :: T.Text
|
||||
} deriving (Eq)
|
||||
|
||||
instance Show ZcashAddress where
|
||||
show (ZcashAddress s p i a) =
|
||||
T.unpack (T.take 8 a) ++
|
||||
"..." ++ T.unpack (T.takeEnd 8 a) ++ " Pools: " ++ show p
|
||||
|
||||
-- | A type to model the response of the Zcash RPC
|
||||
data RpcResponse r = RpcResponse
|
||||
{ err :: Maybe T.Text
|
||||
, respId :: T.Text
|
||||
, result :: r
|
||||
} deriving (Show, Generic, ToJSON)
|
||||
|
||||
instance (FromJSON r) => FromJSON (RpcResponse r) where
|
||||
parseJSON (Object obj) = do
|
||||
e <- obj .: "error"
|
||||
rId <- obj .: "id"
|
||||
r <- obj .: "result"
|
||||
pure $ RpcResponse e rId r
|
||||
parseJSON invalid =
|
||||
prependFailure
|
||||
"parsing RpcResponse failed, "
|
||||
(typeMismatch "Object" invalid)
|
||||
|
||||
newtype NodeVersion =
|
||||
NodeVersion Integer
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance FromJSON NodeVersion where
|
||||
parseJSON =
|
||||
withObject "NodeVersion" $ \obj -> do
|
||||
v <- obj .: "version"
|
||||
pure $ NodeVersion v
|
||||
|
||||
-- | A type to model an address group
|
||||
data AddressGroup = AddressGroup
|
||||
{ agsource :: AddressSource
|
||||
, agtransparent :: [ZcashAddress]
|
||||
, agsapling :: [ZcashAddress]
|
||||
, agunified :: [ZcashAddress]
|
||||
} deriving (Show, Generic)
|
||||
|
||||
instance FromJSON AddressGroup where
|
||||
parseJSON =
|
||||
withObject "AddressGroup" $ \obj -> do
|
||||
s <- obj .: "source"
|
||||
t <- obj .:? "transparent"
|
||||
sap <- obj .:? "sapling"
|
||||
uni <- obj .:? "unified"
|
||||
sL <- processSapling sap s
|
||||
tL <- processTransparent t s
|
||||
uL <- processUnified uni
|
||||
return $ AddressGroup s tL (concat sL) (concat uL)
|
||||
where
|
||||
processTransparent c s1 =
|
||||
case c of
|
||||
Nothing -> return []
|
||||
Just x -> do
|
||||
x' <- x .: "addresses"
|
||||
return $ map (ZcashAddress s1 [Transparent] Nothing) x'
|
||||
processSapling k s2 =
|
||||
case k of
|
||||
Nothing -> return []
|
||||
Just y -> mapM (processOneSapling s2) y
|
||||
where processOneSapling sx =
|
||||
withObject "Sapling" $ \oS -> do
|
||||
oS' <- oS .: "addresses"
|
||||
return $ map (ZcashAddress sx [Sapling] Nothing) oS'
|
||||
processUnified u =
|
||||
case u of
|
||||
Nothing -> return []
|
||||
Just z -> mapM processOneAccount z
|
||||
where processOneAccount =
|
||||
withObject "UAs" $ \uS -> do
|
||||
acct <- uS .: "account"
|
||||
uS' <- uS .: "addresses"
|
||||
mapM (processUAs acct) uS'
|
||||
where
|
||||
processUAs a =
|
||||
withObject "UAs" $ \v -> do
|
||||
addr <- v .: "address"
|
||||
p <- v .: "receiver_types"
|
||||
return $ ZcashAddress MnemonicSeed p a addr
|
||||
|
||||
displayZec :: Integer -> String
|
||||
displayZec s
|
||||
| s < 100 = show s ++ " zats "
|
||||
| s < 100000 = show (fromIntegral s / 100) ++ " μZEC "
|
||||
| s < 100000000 = show (fromIntegral s / 100000) ++ " mZEC "
|
||||
| otherwise = show (fromIntegral s / 100000000) ++ " ZEC "
|
||||
|
||||
-- | A type to model a Zcash transaction
|
||||
data ZcashTx = ZcashTx
|
||||
{ ztxid :: T.Text
|
||||
, zamount :: Double
|
||||
, zamountZat :: Integer
|
||||
, zblockheight :: Integer
|
||||
, zblocktime :: Integer
|
||||
, zchange :: Bool
|
||||
, zconfirmations :: Integer
|
||||
, zmemo :: T.Text
|
||||
} deriving (Show, Generic)
|
||||
|
||||
instance FromJSON ZcashTx where
|
||||
parseJSON =
|
||||
withObject "ZcashTx" $ \obj -> do
|
||||
t <- obj .: "txid"
|
||||
a <- obj .: "amount"
|
||||
aZ <- obj .: "amountZat"
|
||||
bh <- obj .: "blockheight"
|
||||
bt <- obj .: "blocktime"
|
||||
c <- obj .:? "change"
|
||||
conf <- obj .: "confirmations"
|
||||
m <- obj .:? "memo"
|
||||
pure $
|
||||
ZcashTx
|
||||
t
|
||||
a
|
||||
aZ
|
||||
bh
|
||||
bt
|
||||
(fromMaybe False c)
|
||||
conf
|
||||
(case m of
|
||||
Nothing -> ""
|
||||
Just m' -> T.filter (/= '\NUL') $ decodeHexText m')
|
||||
|
||||
instance ToJSON ZcashTx where
|
||||
toJSON (ZcashTx t a aZ bh bt c conf m) =
|
||||
object
|
||||
[ "amount" .= a
|
||||
, "amountZat" .= aZ
|
||||
, "txid" .= t
|
||||
, "blockheight" .= bh
|
||||
, "blocktime" .= bt
|
||||
, "change" .= c
|
||||
, "confirmations" .= conf
|
||||
, "memo" .= m
|
||||
]
|
||||
|
||||
-- | Type for the UA balance
|
||||
data UABalance = UABalance
|
||||
{ uatransparent :: Integer
|
||||
, uasapling :: Integer
|
||||
, uaorchard :: Integer
|
||||
} deriving (Eq)
|
||||
|
||||
instance Show UABalance where
|
||||
show (UABalance t s o) =
|
||||
" T: " ++ show t ++ " S: " ++ show s ++ " O: " ++ show o
|
||||
|
||||
instance FromJSON UABalance where
|
||||
parseJSON =
|
||||
withObject "UABalance" $ \obj -> do
|
||||
p <- obj .: "pools"
|
||||
t <- p .:? "transparent"
|
||||
s <- p .:? "sapling"
|
||||
o <- p .:? "orchard"
|
||||
vT <-
|
||||
case t of
|
||||
Nothing -> return 0
|
||||
Just t' -> t' .: "valueZat"
|
||||
vS <-
|
||||
case s of
|
||||
Nothing -> return 0
|
||||
Just s' -> s' .: "valueZat"
|
||||
vO <-
|
||||
case o of
|
||||
Nothing -> return 0
|
||||
Just o' -> o' .: "valueZat"
|
||||
pure $ UABalance vT vS vO
|
||||
|
||||
-- | Type for Operation Result
|
||||
data OpResult = OpResult
|
||||
{ opsuccess :: T.Text
|
||||
, opmessage :: Maybe T.Text
|
||||
, optxid :: Maybe T.Text
|
||||
} deriving (Show, Eq)
|
||||
|
||||
instance FromJSON OpResult where
|
||||
parseJSON =
|
||||
withObject "OpResult" $ \obj -> do
|
||||
s <- obj .: "status"
|
||||
r <- obj .:? "result"
|
||||
e <- obj .:? "error"
|
||||
t <-
|
||||
case r of
|
||||
Nothing -> return Nothing
|
||||
Just r' -> r' .: "txid"
|
||||
m <-
|
||||
case e of
|
||||
Nothing -> return Nothing
|
||||
Just m' -> m' .: "message"
|
||||
pure $ OpResult s m t
|
||||
|
||||
-- | Helper function to turn a hex-encoded memo strings to readable text
|
||||
decodeHexText :: String -> T.Text
|
||||
decodeHexText h = E.decodeUtf8With lenientDecode $ B.pack $ hexRead h
|
||||
where
|
||||
hexRead hexText
|
||||
| null chunk = []
|
||||
| otherwise =
|
||||
fromIntegral (read ("0x" <> chunk)) : hexRead (drop 2 hexText)
|
||||
where
|
||||
chunk = take 2 hexText
|
||||
|
||||
-- | Helper function to turn a string into a hex-encoded string
|
||||
encodeHexText :: String -> String
|
||||
encodeHexText t = mconcat (map padHex t)
|
||||
where
|
||||
padHex x =
|
||||
if ord x < 16
|
||||
then "0" ++ (showHex . ord) x ""
|
||||
else showHex (ord x) ""
|
||||
|
||||
encodeHexText' :: T.Text -> String
|
||||
encodeHexText' t =
|
||||
if T.length t > 0
|
||||
then T.unpack . toText . fromBytes $ E.encodeUtf8 t
|
||||
else T.unpack . toText . fromBytes $ E.encodeUtf8 "Sent from Zenith"
|
||||
|
||||
-- | Helper function to extract addresses from AddressGroups
|
||||
getAddresses :: AddressGroup -> [ZcashAddress]
|
||||
getAddresses ag = agtransparent ag <> agsapling ag <> agunified ag
|
||||
|
||||
-- | Helper function to validate potential Zcash addresses
|
||||
validateAddress :: T.Text -> Maybe ZcashPool
|
||||
validateAddress txt --(tReg || sReg && isJust chk) || (uReg && isJust chk)
|
||||
| tReg = Just Transparent
|
||||
| sReg && chkS = Just Sapling
|
||||
| uReg && chk = Just Orchard
|
||||
| otherwise = Nothing
|
||||
where
|
||||
transparentRegex = "^t1[a-zA-Z0-9]{33}$" :: String
|
||||
shieldedRegex = "^zs[a-zA-Z0-9]{76}$" :: String
|
||||
unifiedRegex = "^u[a-zA-Z0-9]" :: String
|
||||
tReg = T.unpack txt =~ transparentRegex :: Bool
|
||||
sReg = T.unpack txt =~ shieldedRegex :: Bool
|
||||
uReg = T.unpack txt =~ unifiedRegex :: Bool
|
||||
chk = isValidUnifiedAddress $ E.encodeUtf8 txt
|
||||
chkS = isValidShieldedAddress $ E.encodeUtf8 txt
|
||||
|
||||
-- | RPC methods
|
||||
-- | List addresses
|
||||
listAddresses :: B.ByteString -> B.ByteString -> IO [ZcashAddress]
|
||||
listAddresses user pwd = do
|
||||
response <- makeZcashCall user pwd "listaddresses" []
|
||||
let rpcResp = decode response :: Maybe (RpcResponse [AddressGroup])
|
||||
case rpcResp of
|
||||
Nothing -> fail "Couldn't parse node response"
|
||||
Just res -> do
|
||||
let addys = result res
|
||||
let addList = concatMap getAddresses addys
|
||||
return addList
|
||||
|
||||
-- | Get address balance
|
||||
getBalance :: B.ByteString -> B.ByteString -> ZcashAddress -> IO [Integer]
|
||||
getBalance user pwd zadd = do
|
||||
let a = account zadd
|
||||
case a of
|
||||
Nothing -> do
|
||||
response <-
|
||||
makeZcashCall
|
||||
user
|
||||
pwd
|
||||
"z_getbalance"
|
||||
[ String (addy zadd)
|
||||
, Number (Scientific.scientific 1 0)
|
||||
, Data.Aeson.Bool True
|
||||
]
|
||||
let rpcResp = decode response :: Maybe (RpcResponse Integer)
|
||||
case rpcResp of
|
||||
Nothing -> fail "Couldn't parse node response"
|
||||
Just res -> do
|
||||
return [result res]
|
||||
Just acct -> do
|
||||
response <-
|
||||
makeZcashCall
|
||||
user
|
||||
pwd
|
||||
"z_getbalanceforaccount"
|
||||
[Number (Scientific.scientific acct 0)]
|
||||
let rpcResp = decode response :: Maybe (RpcResponse UABalance)
|
||||
case rpcResp of
|
||||
Nothing -> fail "Couldn't parse node response"
|
||||
Just res -> do
|
||||
return $ readUABalance (result res)
|
||||
where readUABalance ua =
|
||||
[uatransparent ua, uasapling ua, uaorchard ua]
|
||||
|
||||
-- | List transactions
|
||||
listTxs :: B.ByteString -> B.ByteString -> ZcashAddress -> IO [ZcashTx]
|
||||
listTxs user pwd zaddy = do
|
||||
response <-
|
||||
makeZcashCall user pwd "z_listreceivedbyaddress" [String $ addy zaddy]
|
||||
let rpcResp = decode response :: Maybe (RpcResponse [ZcashTx])
|
||||
case rpcResp of
|
||||
Nothing -> fail "listTxs: Couldn't parse node response"
|
||||
Just res -> do
|
||||
return $ result res
|
||||
|
||||
-- | Send Tx
|
||||
sendTx ::
|
||||
B.ByteString
|
||||
-> B.ByteString
|
||||
-> ZcashAddress
|
||||
-> T.Text
|
||||
-> Double
|
||||
-> Maybe T.Text
|
||||
-> IO ()
|
||||
sendTx user pwd fromAddy toAddy amount memo = do
|
||||
bal <- getBalance user pwd fromAddy
|
||||
let valAdd = validateAddress toAddy
|
||||
if sum bal - floor (amount * 100000000) >= 1000
|
||||
then do
|
||||
if source fromAddy /= ImportedWatchOnly
|
||||
then do
|
||||
let privacyPolicy
|
||||
| valAdd == Just Transparent = "AllowRevealedRecipients"
|
||||
| isNothing (account fromAddy) &&
|
||||
elem Transparent (pool fromAddy) = "AllowRevealedSenders"
|
||||
| otherwise = "AllowRevealedAmounts"
|
||||
let pd =
|
||||
case memo of
|
||||
Nothing ->
|
||||
[ Data.Aeson.String (addy fromAddy)
|
||||
, Data.Aeson.Array
|
||||
(V.fromList
|
||||
[object ["address" .= toAddy, "amount" .= amount]])
|
||||
, Data.Aeson.Number $ Scientific.scientific 1 1
|
||||
, Data.Aeson.Null
|
||||
, Data.Aeson.String privacyPolicy
|
||||
]
|
||||
Just memo' ->
|
||||
[ Data.Aeson.String (addy fromAddy)
|
||||
, Data.Aeson.Array
|
||||
(V.fromList
|
||||
[ object
|
||||
[ "address" .= toAddy
|
||||
, "amount" .= amount
|
||||
, "memo" .= encodeHexText' memo'
|
||||
]
|
||||
])
|
||||
, Data.Aeson.Number $ Scientific.scientific 1 1
|
||||
, Data.Aeson.Null
|
||||
, Data.Aeson.String privacyPolicy
|
||||
]
|
||||
response <- makeZcashCall user pwd "z_sendmany" pd
|
||||
let rpcResp = decode response :: Maybe (RpcResponse T.Text)
|
||||
case rpcResp of
|
||||
Nothing -> fail "Couldn't parse node response"
|
||||
Just res -> do
|
||||
putStr " Sending."
|
||||
checkOpResult user pwd (result res)
|
||||
else putStrLn "Error: Source address is view-only."
|
||||
else putStrLn "Error: Insufficient balance in source address."
|
||||
|
||||
-- | Make a Zcash RPC call
|
||||
makeZcashCall ::
|
||||
B.ByteString
|
||||
-> B.ByteString
|
||||
-> T.Text
|
||||
-> [Data.Aeson.Value]
|
||||
-> IO LB.ByteString
|
||||
makeZcashCall username password m p = do
|
||||
let payload = RpcCall "1.0" "test" m p
|
||||
let myRequest =
|
||||
setRequestBodyJSON payload $
|
||||
setRequestPort 8232 $
|
||||
setRequestBasicAuth username password $
|
||||
setRequestMethod "POST" defaultRequest
|
||||
response <- httpLBS myRequest
|
||||
let respStatus = getResponseStatusCode response
|
||||
let body = getResponseBody response
|
||||
case respStatus of
|
||||
500 -> do
|
||||
let rpcResp = decode body :: Maybe (RpcResponse String)
|
||||
case rpcResp of
|
||||
Nothing -> fail $ "Unknown server error " ++ show response
|
||||
Just x -> fail (result x)
|
||||
401 -> fail "Incorrect full node credentials"
|
||||
200 -> return body
|
||||
_ -> fail "Unknown error"
|
||||
|
||||
-- | Display an address
|
||||
displayZcashAddress ::
|
||||
B.ByteString -> B.ByteString -> (Int, ZcashAddress) -> IO ()
|
||||
displayZcashAddress user pwd (idx, zaddy) = do
|
||||
zats <- getBalance user pwd zaddy
|
||||
putStr $ show idx ++ ": "
|
||||
putStr $ show zaddy
|
||||
when (source zaddy == ImportedWatchOnly) (putStr "[VK]")
|
||||
putStr " Balance: "
|
||||
mapM_ (putStr . displayZec) zats
|
||||
putStrLn ""
|
||||
|
||||
-- | Copy an address to the clipboard
|
||||
copyAddress :: ZcashAddress -> IO ()
|
||||
copyAddress a =
|
||||
void $
|
||||
createProcess_ "toClipboard" $
|
||||
shell $ "echo " ++ T.unpack (addy a) ++ " | xclip -r -selection clipboard"
|
||||
|
||||
-- | Verify operation result
|
||||
checkOpResult :: B.ByteString -> B.ByteString -> T.Text -> IO ()
|
||||
checkOpResult user pwd opid = do
|
||||
response <-
|
||||
makeZcashCall
|
||||
user
|
||||
pwd
|
||||
"z_getoperationstatus"
|
||||
[Data.Aeson.Array (V.fromList [Data.Aeson.String opid])]
|
||||
let rpcResp = decode response :: Maybe (RpcResponse [OpResult])
|
||||
case rpcResp of
|
||||
Nothing -> fail "Couldn't parse node response"
|
||||
Just res -> do
|
||||
let r = result res
|
||||
mapM_ showResult r
|
||||
where
|
||||
showResult t =
|
||||
case opsuccess t of
|
||||
"success" ->
|
||||
putStrLn $ " Success! Tx ID: " ++ maybe "" T.unpack (optxid t)
|
||||
"executing" -> do
|
||||
putStr "."
|
||||
hFlush stdout
|
||||
threadDelay 1000000 >> checkOpResult user pwd opid
|
||||
_ -> putStrLn $ " Failed :( " ++ maybe "" T.unpack (opmessage t)
|
||||
|
||||
-- | Check for accounts
|
||||
checkAccounts :: B.ByteString -> B.ByteString -> IO Bool
|
||||
checkAccounts user pwd = do
|
||||
response <- makeZcashCall user pwd "z_listaccounts" []
|
||||
let rpcResp = decode response :: Maybe (RpcResponse [Object])
|
||||
case rpcResp of
|
||||
Nothing -> fail "Couldn't parse node response"
|
||||
Just res -> do
|
||||
let r = result res
|
||||
return $ not (null r)
|
||||
|
||||
-- | Add account to node
|
||||
createAccount :: B.ByteString -> B.ByteString -> IO ()
|
||||
createAccount user pwd = do
|
||||
response <- makeZcashCall user pwd "z_getnewaccount" []
|
||||
let rpcResp = decode response :: Maybe (RpcResponse Object)
|
||||
case rpcResp of
|
||||
Nothing -> fail "Couldn't parse node response"
|
||||
Just res -> do
|
||||
let r = result res
|
||||
putStrLn " Account created!"
|
||||
|
||||
-- | Create new Unified Address
|
||||
createUnifiedAddress :: B.ByteString -> B.ByteString -> Bool -> Bool -> IO ()
|
||||
createUnifiedAddress user pwd tRec sRec = do
|
||||
let recs = getReceivers tRec sRec
|
||||
let pd = [Data.Aeson.Number $ Scientific.scientific 0 1, recs]
|
||||
newResp <- makeZcashCall user pwd "z_getaddressforaccount" pd
|
||||
let rpcResp = decode newResp :: Maybe (RpcResponse Object)
|
||||
case rpcResp of
|
||||
Nothing -> fail "Couldn't parse node response"
|
||||
Just res -> do
|
||||
let r = result res
|
||||
putStrLn " New UA created!"
|
||||
where
|
||||
getReceivers t s
|
||||
| t && s =
|
||||
Data.Aeson.Array
|
||||
(V.fromList
|
||||
[ Data.Aeson.String "p2pkh"
|
||||
, Data.Aeson.String "sapling"
|
||||
, Data.Aeson.String "orchard"
|
||||
])
|
||||
| t =
|
||||
Data.Aeson.Array
|
||||
(V.fromList [Data.Aeson.String "p2pkh", Data.Aeson.String "orchard"])
|
||||
| s =
|
||||
Data.Aeson.Array
|
||||
(V.fromList [Data.Aeson.String "sapling", Data.Aeson.String "orchard"])
|
||||
| otherwise = Data.Aeson.Array (V.fromList [Data.Aeson.String "orchard"])
|
||||
|
||||
-- | Check Zcash full node server
|
||||
checkServer :: B.ByteString -> B.ByteString -> IO ()
|
||||
checkServer user pwd = do
|
||||
resp <- makeZcashCall user pwd "getinfo" []
|
||||
let rpcResp = decode resp :: Maybe (RpcResponse NodeVersion)
|
||||
case rpcResp of
|
||||
Nothing -> fail "Couldn't parse node response"
|
||||
Just myResp -> do
|
||||
let r = result myResp
|
||||
if isNodeValid r
|
||||
then putStrLn $ "Connected to Zcash Full Node (" <> show r <> ") :)"
|
||||
else do
|
||||
putStrLn "Deprecated Zcash Full Node version found. Exiting"
|
||||
exitFailure
|
||||
where isNodeValid (NodeVersion i) = i >= 5000000
|
||||
|
||||
-- | Read ZIP-321 URI
|
||||
sendWithUri ::
|
||||
B.ByteString -> B.ByteString -> ZcashAddress -> String -> Bool -> IO ()
|
||||
sendWithUri user pwd fromAddy uri repTo = do
|
||||
let uriRegex = mkRegex "^zcash:(\\w+)\\?amount=(.*)\\&memo=(.*)$"
|
||||
if matchTest uriRegex uri
|
||||
then do
|
||||
let reg = matchAllText uriRegex uri
|
||||
let parsedAddress = fst $ head reg A.! 1
|
||||
let parsedAmount = fst $ head reg A.! 2
|
||||
let parsedEncodedMemo = fst $ head reg A.! 3
|
||||
let addType = validateAddress $ T.pack parsedAddress
|
||||
case addType of
|
||||
Nothing -> putStrLn " Invalid address"
|
||||
Just Transparent -> do
|
||||
putStrLn $ " Address is valid: " ++ parsedAddress
|
||||
case (readMaybe parsedAmount :: Maybe Double) of
|
||||
Nothing -> putStrLn " Invalid amount."
|
||||
Just amt -> do
|
||||
putStrLn $ " Valid ZEC amount: " ++ show amt
|
||||
sendTx user pwd fromAddy (T.pack parsedAddress) amt Nothing
|
||||
Just _ -> do
|
||||
putStrLn $ " Address is valid: " ++ parsedAddress
|
||||
case (readMaybe parsedAmount :: Maybe Double) of
|
||||
Nothing -> putStrLn " Invalid amount."
|
||||
Just amt -> do
|
||||
putStrLn $ " Valid ZEC amount: " ++ show amt
|
||||
let decodedMemo =
|
||||
E.decodeUtf8With lenientDecode $
|
||||
B64.decodeLenient $ C.pack parsedEncodedMemo
|
||||
TIO.putStrLn $ " Memo: " <> decodedMemo
|
||||
sendTx
|
||||
user
|
||||
pwd
|
||||
fromAddy
|
||||
(T.pack parsedAddress)
|
||||
amt
|
||||
(if repTo
|
||||
then Just $
|
||||
T.concat [decodedMemo, "\nReply-To:\n", addy fromAddy]
|
||||
else Just decodedMemo)
|
||||
else putStrLn "URI is not compliant with ZIP-321"
|
||||
1280
src/Zenith/CLI.hs
Normal file
1280
src/Zenith/CLI.hs
Normal file
File diff suppressed because it is too large
Load diff
774
src/Zenith/Core.hs
Normal file
774
src/Zenith/Core.hs
Normal file
|
|
@ -0,0 +1,774 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | Core wallet functionality for Zenith
|
||||
module Zenith.Core where
|
||||
|
||||
import Control.Exception (throwIO, try)
|
||||
import Control.Monad (forM, when)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Logger
|
||||
( LoggingT
|
||||
, MonadLoggerIO
|
||||
, NoLoggingT
|
||||
, logDebugN
|
||||
, logErrorN
|
||||
, logInfoN
|
||||
, logWarnN
|
||||
, runFileLoggingT
|
||||
, runNoLoggingT
|
||||
, runStdoutLoggingT
|
||||
)
|
||||
import Crypto.Secp256k1 (SecKey(..))
|
||||
import Data.Aeson
|
||||
import Data.Binary.Get hiding (getBytes)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Data.Digest.Pure.MD5
|
||||
import Data.HexString (HexString, hexString, toBytes)
|
||||
import Data.List
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Pool (Pool)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import Data.Time
|
||||
import qualified Database.Esqueleto.Experimental as ESQ
|
||||
import Database.Persist
|
||||
import Database.Persist.Sqlite
|
||||
import GHC.Float.RealFracMethods (floorFloatInteger)
|
||||
import Haskoin.Crypto.Keys (XPrvKey(..))
|
||||
import Lens.Micro ((&), (.~), (^.), set)
|
||||
import Network.HTTP.Client
|
||||
import ZcashHaskell.Keys
|
||||
import ZcashHaskell.Orchard
|
||||
( decryptOrchardActionSK
|
||||
, encodeUnifiedAddress
|
||||
, genOrchardReceiver
|
||||
, genOrchardSpendingKey
|
||||
, getOrchardNotePosition
|
||||
, getOrchardWitness
|
||||
, isValidUnifiedAddress
|
||||
, updateOrchardCommitmentTree
|
||||
, updateOrchardWitness
|
||||
)
|
||||
import ZcashHaskell.Sapling
|
||||
( decodeSaplingOutputEsk
|
||||
, genSaplingInternalAddress
|
||||
, genSaplingPaymentAddress
|
||||
, genSaplingSpendingKey
|
||||
, getSaplingNotePosition
|
||||
, getSaplingWitness
|
||||
, updateSaplingCommitmentTree
|
||||
, updateSaplingWitness
|
||||
)
|
||||
import ZcashHaskell.Transparent
|
||||
( genTransparentPrvKey
|
||||
, genTransparentReceiver
|
||||
, genTransparentSecretKey
|
||||
)
|
||||
import ZcashHaskell.Types
|
||||
import ZcashHaskell.Utils
|
||||
import Zenith.DB
|
||||
import Zenith.Types
|
||||
( Config(..)
|
||||
, HexStringDB(..)
|
||||
, OrchardSpendingKeyDB(..)
|
||||
, PhraseDB(..)
|
||||
, RseedDB(..)
|
||||
, SaplingSpendingKeyDB(..)
|
||||
, ScopeDB(..)
|
||||
, TransparentSpendingKeyDB(..)
|
||||
, UnifiedAddressDB(..)
|
||||
, ZcashNetDB(..)
|
||||
, ZebraTreeInfo(..)
|
||||
)
|
||||
|
||||
-- * Zebra Node interaction
|
||||
-- | Checks the status of the `zebrad` node
|
||||
checkZebra ::
|
||||
T.Text -- ^ Host where `zebrad` is available
|
||||
-> Int -- ^ Port where `zebrad` is available
|
||||
-> IO ZebraGetInfo
|
||||
checkZebra nodeHost nodePort = do
|
||||
res <- makeZebraCall nodeHost nodePort "getinfo" []
|
||||
case res of
|
||||
Left e -> throwIO $ userError e
|
||||
Right bi -> return bi
|
||||
|
||||
-- | Checks the status of the Zcash blockchain
|
||||
checkBlockChain ::
|
||||
T.Text -- ^ Host where `zebrad` is available
|
||||
-> Int -- ^ Port where `zebrad` is available
|
||||
-> IO ZebraGetBlockChainInfo
|
||||
checkBlockChain nodeHost nodePort = do
|
||||
r <- makeZebraCall nodeHost nodePort "getblockchaininfo" []
|
||||
case r of
|
||||
Left e -> throwIO $ userError e
|
||||
Right bci -> return bci
|
||||
|
||||
-- | Get commitment trees from Zebra
|
||||
getCommitmentTrees ::
|
||||
T.Text -- ^ Host where `zebrad` is avaiable
|
||||
-> Int -- ^ Port where `zebrad` is available
|
||||
-> Int -- ^ Block height
|
||||
-> IO ZebraTreeInfo
|
||||
getCommitmentTrees nodeHost nodePort block = do
|
||||
r <-
|
||||
makeZebraCall
|
||||
nodeHost
|
||||
nodePort
|
||||
"z_gettreestate"
|
||||
[Data.Aeson.String $ T.pack $ show block]
|
||||
case r of
|
||||
Left e -> throwIO $ userError e
|
||||
Right zti -> return zti
|
||||
|
||||
-- * Spending Keys
|
||||
-- | Create an Orchard Spending Key for the given wallet and account index
|
||||
createOrchardSpendingKey :: ZcashWallet -> Int -> IO OrchardSpendingKey
|
||||
createOrchardSpendingKey zw i = do
|
||||
let s = getWalletSeed $ getPhrase $ zcashWalletSeedPhrase zw
|
||||
case s of
|
||||
Nothing -> throwIO $ userError "Unable to generate seed"
|
||||
Just s' -> do
|
||||
let coinType =
|
||||
case getNet $ zcashWalletNetwork zw of
|
||||
MainNet -> MainNetCoin
|
||||
TestNet -> TestNetCoin
|
||||
RegTestNet -> RegTestNetCoin
|
||||
let r = genOrchardSpendingKey s' coinType i
|
||||
case r of
|
||||
Nothing -> throwIO $ userError "Unable to generate Orchard spending key"
|
||||
Just sk -> return sk
|
||||
|
||||
-- | Create a Sapling spending key for the given wallet and account index
|
||||
createSaplingSpendingKey :: ZcashWallet -> Int -> IO SaplingSpendingKey
|
||||
createSaplingSpendingKey zw i = do
|
||||
let s = getWalletSeed $ getPhrase $ zcashWalletSeedPhrase zw
|
||||
case s of
|
||||
Nothing -> throwIO $ userError "Unable to generate seed"
|
||||
Just s' -> do
|
||||
let coinType =
|
||||
case getNet $ zcashWalletNetwork zw of
|
||||
MainNet -> MainNetCoin
|
||||
TestNet -> TestNetCoin
|
||||
RegTestNet -> RegTestNetCoin
|
||||
let r = genSaplingSpendingKey s' coinType i
|
||||
case r of
|
||||
Nothing -> throwIO $ userError "Unable to generate Sapling spending key"
|
||||
Just sk -> return sk
|
||||
|
||||
createTransparentSpendingKey :: ZcashWallet -> Int -> IO TransparentSpendingKey
|
||||
createTransparentSpendingKey zw i = do
|
||||
let s = getWalletSeed $ getPhrase $ zcashWalletSeedPhrase zw
|
||||
case s of
|
||||
Nothing -> throwIO $ userError "Unable to generate seed"
|
||||
Just s' -> do
|
||||
let coinType =
|
||||
case getNet $ zcashWalletNetwork zw of
|
||||
MainNet -> MainNetCoin
|
||||
TestNet -> TestNetCoin
|
||||
RegTestNet -> RegTestNetCoin
|
||||
genTransparentPrvKey s' coinType i
|
||||
|
||||
-- * Accounts
|
||||
-- | Create an account for the given wallet and account index
|
||||
createZcashAccount ::
|
||||
T.Text -- ^ The account's name
|
||||
-> Int -- ^ The account's index
|
||||
-> Entity ZcashWallet -- ^ The Zcash wallet that this account will be attached to
|
||||
-> IO ZcashAccount
|
||||
createZcashAccount n i zw = do
|
||||
orSk <- createOrchardSpendingKey (entityVal zw) i
|
||||
sapSk <- createSaplingSpendingKey (entityVal zw) i
|
||||
tSk <- createTransparentSpendingKey (entityVal zw) i
|
||||
return $
|
||||
ZcashAccount
|
||||
i
|
||||
(entityKey zw)
|
||||
n
|
||||
(OrchardSpendingKeyDB orSk)
|
||||
(SaplingSpendingKeyDB sapSk)
|
||||
(TransparentSpendingKeyDB tSk)
|
||||
|
||||
-- * Addresses
|
||||
-- | Create an external unified address for the given account and index
|
||||
createWalletAddress ::
|
||||
T.Text -- ^ The address nickname
|
||||
-> Int -- ^ The address' index
|
||||
-> ZcashNet -- ^ The network for this address
|
||||
-> Scope -- ^ External or Internal
|
||||
-> Entity ZcashAccount -- ^ The Zcash account that the address will be attached to
|
||||
-> IO WalletAddress
|
||||
createWalletAddress n i zNet scope za = do
|
||||
let oRec =
|
||||
genOrchardReceiver i scope $
|
||||
getOrchSK $ zcashAccountOrchSpendKey $ entityVal za
|
||||
let sRec =
|
||||
case scope of
|
||||
External ->
|
||||
genSaplingPaymentAddress i $
|
||||
getSapSK $ zcashAccountSapSpendKey $ entityVal za
|
||||
Internal ->
|
||||
genSaplingInternalAddress $
|
||||
getSapSK $ zcashAccountSapSpendKey $ entityVal za
|
||||
tRec <-
|
||||
genTransparentReceiver i scope $
|
||||
getTranSK $ zcashAccountTPrivateKey $ entityVal za
|
||||
return $
|
||||
WalletAddress
|
||||
i
|
||||
(entityKey za)
|
||||
n
|
||||
(UnifiedAddressDB $
|
||||
encodeUnifiedAddress $ UnifiedAddress zNet oRec sRec (Just tRec))
|
||||
(ScopeDB scope)
|
||||
|
||||
-- * Wallet
|
||||
-- | Find the Sapling notes that match the given spending key
|
||||
findSaplingOutputs ::
|
||||
Config -- ^ the configuration parameters
|
||||
-> Int -- ^ the starting block
|
||||
-> ZcashNetDB -- ^ The network
|
||||
-> Entity ZcashAccount -- ^ The account to use
|
||||
-> IO ()
|
||||
findSaplingOutputs config b znet za = do
|
||||
let dbPath = c_dbPath config
|
||||
let zebraHost = c_zebraHost config
|
||||
let zebraPort = c_zebraPort config
|
||||
let zn = getNet znet
|
||||
pool <- runNoLoggingT $ initPool dbPath
|
||||
tList <- getShieldedOutputs pool b
|
||||
trees <- getCommitmentTrees zebraHost zebraPort (b - 1)
|
||||
let sT = SaplingCommitmentTree $ ztiSapling trees
|
||||
decryptNotes sT zn pool tList
|
||||
sapNotes <- getWalletSapNotes pool (entityKey za)
|
||||
findSapSpends pool (entityKey za) sapNotes
|
||||
where
|
||||
sk :: SaplingSpendingKeyDB
|
||||
sk = zcashAccountSapSpendKey $ entityVal za
|
||||
decryptNotes ::
|
||||
SaplingCommitmentTree
|
||||
-> ZcashNet
|
||||
-> ConnectionPool
|
||||
-> [(Entity ZcashTransaction, Entity ShieldOutput)]
|
||||
-> IO ()
|
||||
decryptNotes _ _ _ [] = return ()
|
||||
decryptNotes st n pool ((zt, o):txs) = do
|
||||
let updatedTree =
|
||||
updateSaplingCommitmentTree
|
||||
st
|
||||
(getHex $ shieldOutputCmu $ entityVal o)
|
||||
case updatedTree of
|
||||
Nothing -> throwIO $ userError "Failed to update commitment tree"
|
||||
Just uT -> do
|
||||
let noteWitness = getSaplingWitness uT
|
||||
let notePos = getSaplingNotePosition <$> noteWitness
|
||||
case notePos of
|
||||
Nothing -> throwIO $ userError "Failed to obtain note position"
|
||||
Just nP -> do
|
||||
case decodeShOut External n nP o of
|
||||
Nothing -> do
|
||||
case decodeShOut Internal n nP o of
|
||||
Nothing -> do
|
||||
decryptNotes uT n pool txs
|
||||
Just dn1 -> do
|
||||
wId <- saveWalletTransaction pool (entityKey za) zt
|
||||
saveWalletSapNote
|
||||
pool
|
||||
wId
|
||||
nP
|
||||
(fromJust noteWitness)
|
||||
True
|
||||
(entityKey za)
|
||||
(entityKey o)
|
||||
dn1
|
||||
decryptNotes uT n pool txs
|
||||
Just dn0 -> do
|
||||
wId <- saveWalletTransaction pool (entityKey za) zt
|
||||
saveWalletSapNote
|
||||
pool
|
||||
wId
|
||||
nP
|
||||
(fromJust noteWitness)
|
||||
False
|
||||
(entityKey za)
|
||||
(entityKey o)
|
||||
dn0
|
||||
decryptNotes uT n pool txs
|
||||
decodeShOut ::
|
||||
Scope
|
||||
-> ZcashNet
|
||||
-> Integer
|
||||
-> Entity ShieldOutput
|
||||
-> Maybe DecodedNote
|
||||
decodeShOut scope n pos s = do
|
||||
decodeSaplingOutputEsk
|
||||
(getSapSK sk)
|
||||
(ShieldedOutput
|
||||
(getHex $ shieldOutputCv $ entityVal s)
|
||||
(getHex $ shieldOutputCmu $ entityVal s)
|
||||
(getHex $ shieldOutputEphKey $ entityVal s)
|
||||
(getHex $ shieldOutputEncCipher $ entityVal s)
|
||||
(getHex $ shieldOutputOutCipher $ entityVal s)
|
||||
(getHex $ shieldOutputProof $ entityVal s))
|
||||
n
|
||||
scope
|
||||
pos
|
||||
|
||||
-- | Get Orchard actions
|
||||
findOrchardActions ::
|
||||
Config -- ^ the configuration parameters
|
||||
-> Int -- ^ the starting block
|
||||
-> ZcashNetDB -- ^ The network
|
||||
-> Entity ZcashAccount -- ^ The account to use
|
||||
-> IO ()
|
||||
findOrchardActions config b znet za = do
|
||||
let dbPath = c_dbPath config
|
||||
let zebraHost = c_zebraHost config
|
||||
let zebraPort = c_zebraPort config
|
||||
let zn = getNet znet
|
||||
pool <- runNoLoggingT $ initPool dbPath
|
||||
tList <- getOrchardActions pool b
|
||||
trees <- getCommitmentTrees zebraHost zebraPort (b - 1)
|
||||
let sT = OrchardCommitmentTree $ ztiOrchard trees
|
||||
decryptNotes sT zn pool tList
|
||||
orchNotes <- getWalletOrchNotes pool (entityKey za)
|
||||
findOrchSpends pool (entityKey za) orchNotes
|
||||
where
|
||||
decryptNotes ::
|
||||
OrchardCommitmentTree
|
||||
-> ZcashNet
|
||||
-> ConnectionPool
|
||||
-> [(Entity ZcashTransaction, Entity OrchAction)]
|
||||
-> IO ()
|
||||
decryptNotes _ _ _ [] = return ()
|
||||
decryptNotes ot n pool ((zt, o):txs) = do
|
||||
let updatedTree =
|
||||
updateOrchardCommitmentTree
|
||||
ot
|
||||
(getHex $ orchActionCmx $ entityVal o)
|
||||
case updatedTree of
|
||||
Nothing -> throwIO $ userError "Failed to update commitment tree"
|
||||
Just uT -> do
|
||||
let noteWitness = getOrchardWitness uT
|
||||
let notePos = getOrchardNotePosition <$> noteWitness
|
||||
case notePos of
|
||||
Nothing -> throwIO $ userError "Failed to obtain note position"
|
||||
Just nP ->
|
||||
case decodeOrchAction External nP o of
|
||||
Nothing ->
|
||||
case decodeOrchAction Internal nP o of
|
||||
Nothing -> decryptNotes uT n pool txs
|
||||
Just dn1 -> do
|
||||
wId <- saveWalletTransaction pool (entityKey za) zt
|
||||
saveWalletOrchNote
|
||||
pool
|
||||
wId
|
||||
nP
|
||||
(fromJust noteWitness)
|
||||
True
|
||||
(entityKey za)
|
||||
(entityKey o)
|
||||
dn1
|
||||
decryptNotes uT n pool txs
|
||||
Just dn -> do
|
||||
wId <- saveWalletTransaction pool (entityKey za) zt
|
||||
saveWalletOrchNote
|
||||
pool
|
||||
wId
|
||||
nP
|
||||
(fromJust noteWitness)
|
||||
False
|
||||
(entityKey za)
|
||||
(entityKey o)
|
||||
dn
|
||||
decryptNotes uT n pool txs
|
||||
sk :: OrchardSpendingKeyDB
|
||||
sk = zcashAccountOrchSpendKey $ entityVal za
|
||||
decodeOrchAction ::
|
||||
Scope -> Integer -> Entity OrchAction -> Maybe DecodedNote
|
||||
decodeOrchAction scope pos o =
|
||||
decryptOrchardActionSK (getOrchSK sk) scope $
|
||||
OrchardAction
|
||||
(getHex $ orchActionNf $ entityVal o)
|
||||
(getHex $ orchActionRk $ entityVal o)
|
||||
(getHex $ orchActionCmx $ entityVal o)
|
||||
(getHex $ orchActionEphKey $ entityVal o)
|
||||
(getHex $ orchActionEncCipher $ entityVal o)
|
||||
(getHex $ orchActionOutCipher $ entityVal o)
|
||||
(getHex $ orchActionCv $ entityVal o)
|
||||
(getHex $ orchActionAuth $ entityVal o)
|
||||
|
||||
updateSaplingWitnesses :: ConnectionPool -> IO ()
|
||||
updateSaplingWitnesses pool = do
|
||||
sapNotes <- getUnspentSapNotes pool
|
||||
maxId <- liftIO $ getMaxSaplingNote pool
|
||||
mapM_ (updateOneNote maxId) sapNotes
|
||||
where
|
||||
updateOneNote :: ShieldOutputId -> Entity WalletSapNote -> IO ()
|
||||
updateOneNote maxId n = do
|
||||
let noteSync = walletSapNoteWitPos $ entityVal n
|
||||
when (noteSync < maxId) $ do
|
||||
cmus <- liftIO $ getSaplingCmus pool $ walletSapNoteWitPos $ entityVal n
|
||||
let cmuList = map (\(ESQ.Value x) -> getHex x) cmus
|
||||
let newWitness =
|
||||
updateSaplingWitness
|
||||
(SaplingWitness $ getHex $ walletSapNoteWitness $ entityVal n)
|
||||
cmuList
|
||||
liftIO $ updateSapNoteRecord pool (entityKey n) newWitness maxId
|
||||
|
||||
updateOrchardWitnesses :: ConnectionPool -> IO ()
|
||||
updateOrchardWitnesses pool = do
|
||||
orchNotes <- getUnspentOrchNotes pool
|
||||
maxId <- getMaxOrchardNote pool
|
||||
mapM_ (updateOneNote maxId) orchNotes
|
||||
where
|
||||
updateOneNote :: OrchActionId -> Entity WalletOrchNote -> IO ()
|
||||
updateOneNote maxId n = do
|
||||
let noteSync = walletOrchNoteWitPos $ entityVal n
|
||||
when (noteSync < maxId) $ do
|
||||
cmxs <- liftIO $ getOrchardCmxs pool noteSync
|
||||
let cmxList = map (\(ESQ.Value x) -> getHex x) cmxs
|
||||
let newWitness =
|
||||
updateOrchardWitness
|
||||
(OrchardWitness $ getHex $ walletOrchNoteWitness $ entityVal n)
|
||||
cmxList
|
||||
liftIO $ updateOrchNoteRecord pool (entityKey n) newWitness maxId
|
||||
|
||||
-- | Calculate fee per ZIP-317
|
||||
calculateTxFee ::
|
||||
([Entity WalletTrNote], [Entity WalletSapNote], [Entity WalletOrchNote])
|
||||
-> Int
|
||||
-> Integer
|
||||
calculateTxFee (t, s, o) i =
|
||||
fromIntegral
|
||||
(5000 * (max (length t) tout + max (length s) sout + length o + oout))
|
||||
where
|
||||
tout =
|
||||
if i == 1 || i == 2
|
||||
then 1
|
||||
else 0
|
||||
sout =
|
||||
if i == 3
|
||||
then 1
|
||||
else 0
|
||||
oout =
|
||||
if i == 4
|
||||
then 1
|
||||
else 0
|
||||
|
||||
-- | Prepare a transaction for sending
|
||||
prepareTx ::
|
||||
ConnectionPool
|
||||
-> T.Text
|
||||
-> Int
|
||||
-> ZcashNet
|
||||
-> ZcashAccountId
|
||||
-> Int
|
||||
-> Float
|
||||
-> UnifiedAddress
|
||||
-> T.Text
|
||||
-> LoggingT IO (Either TxError HexString)
|
||||
prepareTx pool zebraHost zebraPort zn za bh amt ua memo = do
|
||||
accRead <- liftIO $ getAccountById pool za
|
||||
let recipient =
|
||||
case o_rec ua of
|
||||
Nothing ->
|
||||
case s_rec ua of
|
||||
Nothing ->
|
||||
case t_rec ua of
|
||||
Nothing -> (0, "")
|
||||
Just r3 ->
|
||||
case tr_type r3 of
|
||||
P2PKH -> (1, toBytes $ tr_bytes r3)
|
||||
P2SH -> (2, toBytes $ tr_bytes r3)
|
||||
Just r2 -> (3, getBytes r2)
|
||||
Just r1 -> (4, getBytes r1)
|
||||
logDebugN $ T.pack $ show recipient
|
||||
logDebugN $ T.pack $ "Target block: " ++ show bh
|
||||
trees <- liftIO $ getCommitmentTrees zebraHost zebraPort bh
|
||||
let sT = SaplingCommitmentTree $ ztiSapling trees
|
||||
let oT = OrchardCommitmentTree $ ztiOrchard trees
|
||||
case accRead of
|
||||
Nothing -> do
|
||||
logErrorN "Can't find Account"
|
||||
return $ Left ZHError
|
||||
Just acc -> do
|
||||
logDebugN $ T.pack $ show acc
|
||||
spParams <- liftIO $ BS.readFile "sapling-spend.params"
|
||||
outParams <- liftIO $ BS.readFile "sapling-output.params"
|
||||
if show (md5 $ LBS.fromStrict spParams) /=
|
||||
"0f44c12ef115ae019decf18ade583b20"
|
||||
then logErrorN "Can't validate sapling parameters"
|
||||
else logInfoN "Valid Sapling spend params"
|
||||
if show (md5 $ LBS.fromStrict outParams) /=
|
||||
"924daf81b87a81bbbb9c7d18562046c8"
|
||||
then logErrorN "Can't validate sapling parameters"
|
||||
else logInfoN "Valid Sapling output params"
|
||||
--print $ BS.length spParams
|
||||
--print $ BS.length outParams
|
||||
logDebugN "Read Sapling params"
|
||||
let zats = fromIntegral $ floorFloatInteger $ amt * (10 ^ 8)
|
||||
logDebugN $ T.pack $ show zats
|
||||
{-firstPass <- liftIO $ selectUnspentNotes pool za zats-}
|
||||
--let fee = calculateTxFee firstPass $ fst recipient
|
||||
--logDebugN $ T.pack $ "calculated fee " ++ show fee
|
||||
(tList, sList, oList) <- liftIO $ selectUnspentNotes pool za (zats + 5000)
|
||||
logDebugN "selected notes"
|
||||
logDebugN $ T.pack $ show tList
|
||||
logDebugN $ T.pack $ show sList
|
||||
logDebugN $ T.pack $ show oList
|
||||
let noteTotal = getTotalAmount (tList, sList, oList)
|
||||
tSpends <-
|
||||
liftIO $
|
||||
prepTSpends (getTranSK $ zcashAccountTPrivateKey $ entityVal acc) tList
|
||||
--print tSpends
|
||||
sSpends <-
|
||||
liftIO $
|
||||
prepSSpends (getSapSK $ zcashAccountSapSpendKey $ entityVal acc) sList
|
||||
--print sSpends
|
||||
oSpends <-
|
||||
liftIO $
|
||||
prepOSpends (getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc) oList
|
||||
--print oSpends
|
||||
dummy <-
|
||||
liftIO $ makeOutgoing acc recipient zats (noteTotal - 5000 - zats)
|
||||
logDebugN "Calculating fee"
|
||||
let feeResponse =
|
||||
createTransaction
|
||||
(Just sT)
|
||||
(Just oT)
|
||||
tSpends
|
||||
sSpends
|
||||
oSpends
|
||||
dummy
|
||||
(SaplingSpendParams spParams)
|
||||
(SaplingOutputParams outParams)
|
||||
zn
|
||||
(bh + 3)
|
||||
False
|
||||
case feeResponse of
|
||||
Left e1 -> return $ Left Fee
|
||||
Right fee -> do
|
||||
let feeAmt =
|
||||
fromIntegral (runGet getInt64le $ LBS.fromStrict $ toBytes fee)
|
||||
(tList1, sList1, oList1) <-
|
||||
liftIO $ selectUnspentNotes pool za (zats + feeAmt)
|
||||
logDebugN $ T.pack $ "selected notes with fee" ++ show feeAmt
|
||||
logDebugN $ T.pack $ show tList
|
||||
logDebugN $ T.pack $ show sList
|
||||
logDebugN $ T.pack $ show oList
|
||||
outgoing <-
|
||||
liftIO $ makeOutgoing acc recipient zats (noteTotal - feeAmt - zats)
|
||||
logDebugN $ T.pack $ show outgoing
|
||||
let tx =
|
||||
createTransaction
|
||||
(Just sT)
|
||||
(Just oT)
|
||||
tSpends
|
||||
sSpends
|
||||
oSpends
|
||||
outgoing
|
||||
(SaplingSpendParams spParams)
|
||||
(SaplingOutputParams outParams)
|
||||
zn
|
||||
(bh + 3)
|
||||
True
|
||||
return tx
|
||||
where
|
||||
makeOutgoing ::
|
||||
Entity ZcashAccount
|
||||
-> (Int, BS.ByteString)
|
||||
-> Integer
|
||||
-> Integer
|
||||
-> IO [OutgoingNote]
|
||||
makeOutgoing acc (k, recvr) zats chg = do
|
||||
chgAddr <- runNoLoggingT $ getInternalAddresses pool $ entityKey acc
|
||||
let internalUA = getUA $ walletAddressUAddress $ entityVal $ head chgAddr
|
||||
let chgRcvr =
|
||||
fromJust $ o_rec =<< isValidUnifiedAddress (E.encodeUtf8 internalUA)
|
||||
return
|
||||
[ OutgoingNote
|
||||
4
|
||||
(getBytes $ getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc)
|
||||
(getBytes chgRcvr)
|
||||
(fromIntegral chg)
|
||||
""
|
||||
True
|
||||
, OutgoingNote
|
||||
(fromIntegral k)
|
||||
(case k of
|
||||
4 ->
|
||||
getBytes $ getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc
|
||||
3 ->
|
||||
getBytes $ getSapSK $ zcashAccountSapSpendKey $ entityVal acc
|
||||
_ -> "")
|
||||
recvr
|
||||
(fromIntegral zats)
|
||||
(E.encodeUtf8 memo)
|
||||
False
|
||||
]
|
||||
getTotalAmount ::
|
||||
( [Entity WalletTrNote]
|
||||
, [Entity WalletSapNote]
|
||||
, [Entity WalletOrchNote])
|
||||
-> Integer
|
||||
getTotalAmount (t, s, o) =
|
||||
sum (map (fromIntegral . walletTrNoteValue . entityVal) t) +
|
||||
sum (map (fromIntegral . walletSapNoteValue . entityVal) s) +
|
||||
sum (map (fromIntegral . walletOrchNoteValue . entityVal) o)
|
||||
prepTSpends ::
|
||||
TransparentSpendingKey
|
||||
-> [Entity WalletTrNote]
|
||||
-> IO [TransparentTxSpend]
|
||||
prepTSpends sk notes = do
|
||||
forM notes $ \n -> do
|
||||
tAddRead <- getAddressById pool $ walletTrNoteAddress $ entityVal n
|
||||
case tAddRead of
|
||||
Nothing -> throwIO $ userError "Couldn't read t-address"
|
||||
Just tAdd -> do
|
||||
(XPrvKey _ _ _ _ (SecKey xp_key)) <-
|
||||
genTransparentSecretKey
|
||||
(walletAddressIndex $ entityVal tAdd)
|
||||
(getScope $ walletAddressScope $ entityVal tAdd)
|
||||
sk
|
||||
mReverseTxId <- getWalletTxId pool $ walletTrNoteTx $ entityVal n
|
||||
case mReverseTxId of
|
||||
Nothing -> throwIO $ userError "failed to get tx ID"
|
||||
Just (ESQ.Value reverseTxId) -> do
|
||||
let flipTxId = BS.reverse $ toBytes $ getHex reverseTxId
|
||||
return $
|
||||
TransparentTxSpend
|
||||
xp_key
|
||||
(RawOutPoint
|
||||
flipTxId
|
||||
(fromIntegral $ walletTrNotePosition $ entityVal n))
|
||||
(RawTxOut
|
||||
(walletTrNoteValue $ entityVal n)
|
||||
(walletTrNoteScript $ entityVal n))
|
||||
prepSSpends ::
|
||||
SaplingSpendingKey -> [Entity WalletSapNote] -> IO [SaplingTxSpend]
|
||||
prepSSpends sk notes = do
|
||||
forM notes $ \n -> do
|
||||
return $
|
||||
SaplingTxSpend
|
||||
(getBytes sk)
|
||||
(DecodedNote
|
||||
(fromIntegral $ walletSapNoteValue $ entityVal n)
|
||||
(walletSapNoteRecipient $ entityVal n)
|
||||
(E.encodeUtf8 $ walletSapNoteMemo $ entityVal n)
|
||||
(getHex $ walletSapNoteNullifier $ entityVal n)
|
||||
""
|
||||
(getRseed $ walletSapNoteRseed $ entityVal n))
|
||||
(toBytes $ getHex $ walletSapNoteWitness $ entityVal n)
|
||||
prepOSpends ::
|
||||
OrchardSpendingKey -> [Entity WalletOrchNote] -> IO [OrchardTxSpend]
|
||||
prepOSpends sk notes = do
|
||||
forM notes $ \n -> do
|
||||
return $
|
||||
OrchardTxSpend
|
||||
(getBytes sk)
|
||||
(DecodedNote
|
||||
(fromIntegral $ walletOrchNoteValue $ entityVal n)
|
||||
(walletOrchNoteRecipient $ entityVal n)
|
||||
(E.encodeUtf8 $ walletOrchNoteMemo $ entityVal n)
|
||||
(getHex $ walletOrchNoteNullifier $ entityVal n)
|
||||
(walletOrchNoteRho $ entityVal n)
|
||||
(getRseed $ walletOrchNoteRseed $ entityVal n))
|
||||
(toBytes $ getHex $ walletOrchNoteWitness $ entityVal n)
|
||||
sapAnchor :: [Entity WalletSapNote] -> Maybe SaplingWitness
|
||||
sapAnchor notes =
|
||||
if not (null notes)
|
||||
then Just $
|
||||
SaplingWitness $
|
||||
getHex $ walletSapNoteWitness $ entityVal $ head notes
|
||||
else Nothing
|
||||
orchAnchor :: [Entity WalletOrchNote] -> Maybe OrchardWitness
|
||||
orchAnchor notes =
|
||||
if not (null notes)
|
||||
then Just $
|
||||
OrchardWitness $
|
||||
getHex $ walletOrchNoteWitness $ entityVal $ head notes
|
||||
else Nothing
|
||||
|
||||
-- | Sync the wallet with the data store
|
||||
syncWallet ::
|
||||
Config -- ^ configuration parameters
|
||||
-> Entity ZcashWallet
|
||||
-> IO ()
|
||||
syncWallet config w = do
|
||||
startTime <- liftIO getCurrentTime
|
||||
let walletDb = c_dbPath config
|
||||
pool <- runNoLoggingT $ initPool walletDb
|
||||
accs <- runNoLoggingT $ getAccounts pool $ entityKey w
|
||||
addrs <- concat <$> mapM (runNoLoggingT . getAddresses pool . entityKey) accs
|
||||
intAddrs <-
|
||||
concat <$> mapM (runNoLoggingT . getInternalAddresses pool . entityKey) accs
|
||||
chainTip <- runNoLoggingT $ getMaxBlock pool
|
||||
let lastBlock = zcashWalletLastSync $ entityVal w
|
||||
let startBlock =
|
||||
if lastBlock > 0
|
||||
then lastBlock
|
||||
else zcashWalletBirthdayHeight $ entityVal w
|
||||
mapM_ (liftIO . findTransparentNotes pool startBlock) addrs
|
||||
mapM_ (liftIO . findTransparentNotes pool startBlock) intAddrs
|
||||
mapM_ (liftIO . findTransparentSpends pool . entityKey) accs
|
||||
sapNotes <-
|
||||
liftIO $
|
||||
mapM
|
||||
(findSaplingOutputs config startBlock (zcashWalletNetwork $ entityVal w))
|
||||
accs
|
||||
orchNotes <-
|
||||
liftIO $
|
||||
mapM
|
||||
(findOrchardActions config startBlock (zcashWalletNetwork $ entityVal w))
|
||||
accs
|
||||
_ <- updateSaplingWitnesses pool
|
||||
_ <- updateOrchardWitnesses pool
|
||||
_ <- liftIO $ updateWalletSync pool chainTip (entityKey w)
|
||||
mapM_ (runNoLoggingT . getWalletTransactions pool) addrs
|
||||
|
||||
testSync :: Config -> IO ()
|
||||
testSync config = do
|
||||
let dbPath = c_dbPath config
|
||||
_ <- initDb dbPath
|
||||
pool <- runNoLoggingT $ initPool dbPath
|
||||
w <- getWallets pool TestNet
|
||||
r <- mapM (syncWallet config) w
|
||||
liftIO $ print r
|
||||
{-let uaRead =-}
|
||||
{-isValidUnifiedAddress-}
|
||||
{-"utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax"-}
|
||||
{-case uaRead of-}
|
||||
{-Nothing -> print "wrong address"-}
|
||||
{-Just ua -> do-}
|
||||
{-startTime <- getCurrentTime-}
|
||||
{-print startTime-}
|
||||
{-tx <--}
|
||||
{-prepareTx-}
|
||||
{-"zenith.db"-}
|
||||
{-"127.0.0.1"-}
|
||||
{-18232-}
|
||||
{-TestNet-}
|
||||
{-(toSqlKey 1)-}
|
||||
{-2820897-}
|
||||
{-0.04-}
|
||||
{-ua-}
|
||||
{-"sent with Zenith, test"-}
|
||||
{-print tx-}
|
||||
{-endTime <- getCurrentTime-}
|
||||
{-print endTime-}
|
||||
|
||||
{-testSend :: IO ()-}
|
||||
{-testSend = do-}
|
||||
clearSync :: Config -> IO ()
|
||||
clearSync config = do
|
||||
let dbPath = c_dbPath config
|
||||
pool <- runNoLoggingT $ initPool dbPath
|
||||
_ <- initDb dbPath
|
||||
_ <- clearWalletTransactions pool
|
||||
w <- getWallets pool TestNet
|
||||
liftIO $ mapM_ (updateWalletSync pool 0 . entityKey) w
|
||||
w' <- liftIO $ getWallets pool TestNet
|
||||
r <- mapM (syncWallet config) w'
|
||||
liftIO $ print r
|
||||
1471
src/Zenith/DB.hs
Normal file
1471
src/Zenith/DB.hs
Normal file
File diff suppressed because it is too large
Load diff
157
src/Zenith/Scanner.hs
Normal file
157
src/Zenith/Scanner.hs
Normal file
|
|
@ -0,0 +1,157 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Zenith.Scanner where
|
||||
|
||||
import Control.Exception (throwIO, try)
|
||||
import qualified Control.Monad.Catch as CM (try)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Logger
|
||||
( LoggingT
|
||||
, NoLoggingT
|
||||
, logErrorN
|
||||
, logInfoN
|
||||
, runNoLoggingT
|
||||
)
|
||||
import Data.Aeson
|
||||
import Data.HexString
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
import Data.Time (getCurrentTime)
|
||||
import Database.Persist.Sqlite
|
||||
import GHC.Utils.Monad (concatMapM)
|
||||
import Lens.Micro ((&), (.~), (^.), set)
|
||||
import System.Console.AsciiProgress
|
||||
import ZcashHaskell.Types
|
||||
( BlockResponse(..)
|
||||
, RawZebraTx(..)
|
||||
, Transaction(..)
|
||||
, ZebraGetBlockChainInfo(..)
|
||||
, ZebraTxResponse(..)
|
||||
, fromRawOBundle
|
||||
, fromRawSBundle
|
||||
, fromRawTBundle
|
||||
)
|
||||
import ZcashHaskell.Utils (getBlockTime, makeZebraCall, readZebraTransaction)
|
||||
import Zenith.Core (checkBlockChain)
|
||||
import Zenith.DB (getMaxBlock, initDb, saveTransaction)
|
||||
import Zenith.Utils (jsonNumber)
|
||||
|
||||
-- | Function to scan the Zcash blockchain through the Zebra node and populate the Zenith database
|
||||
scanZebra ::
|
||||
Int -- ^ Starting block
|
||||
-> T.Text -- ^ Host
|
||||
-> Int -- ^ Port
|
||||
-> T.Text -- ^ Path to database file
|
||||
-> NoLoggingT IO ()
|
||||
scanZebra b host port dbFilePath = do
|
||||
_ <- liftIO $ initDb dbFilePath
|
||||
startTime <- liftIO getCurrentTime
|
||||
logInfoN $ "Started sync: " <> T.pack (show startTime)
|
||||
bc <-
|
||||
liftIO $ try $ checkBlockChain host port :: NoLoggingT
|
||||
IO
|
||||
(Either IOError ZebraGetBlockChainInfo)
|
||||
case bc of
|
||||
Left e -> logErrorN $ T.pack (show e)
|
||||
Right bStatus -> do
|
||||
let dbInfo =
|
||||
mkSqliteConnectionInfo dbFilePath & extraPragmas .~
|
||||
["read_uncommited = true"]
|
||||
pool <- createSqlitePoolFromInfo dbInfo 5
|
||||
dbBlock <- getMaxBlock pool
|
||||
let sb = max dbBlock b
|
||||
if sb > zgb_blocks bStatus || sb < 1
|
||||
then liftIO $ throwIO $ userError "Invalid starting block for scan"
|
||||
else do
|
||||
liftIO $
|
||||
print $
|
||||
"Scanning from " ++
|
||||
show (sb + 1) ++ " to " ++ show (zgb_blocks bStatus)
|
||||
let bList = [(sb + 1) .. (zgb_blocks bStatus)]
|
||||
displayConsoleRegions $ do
|
||||
pg <-
|
||||
liftIO $
|
||||
newProgressBar def {pgTotal = fromIntegral $ length bList}
|
||||
txList <-
|
||||
CM.try $ mapM_ (processBlock host port pool pg) bList :: NoLoggingT
|
||||
IO
|
||||
(Either IOError ())
|
||||
case txList of
|
||||
Left e1 -> logErrorN $ T.pack (show e1)
|
||||
Right txList' -> logInfoN "Finished scan"
|
||||
|
||||
-- | Function to process a raw block and extract the transaction information
|
||||
processBlock ::
|
||||
T.Text -- ^ Host name for `zebrad`
|
||||
-> Int -- ^ Port for `zebrad`
|
||||
-> ConnectionPool -- ^ DB file path
|
||||
-> ProgressBar -- ^ Progress bar
|
||||
-> Int -- ^ The block number to process
|
||||
-> NoLoggingT IO ()
|
||||
processBlock host port pool pg b = do
|
||||
r <-
|
||||
liftIO $
|
||||
makeZebraCall
|
||||
host
|
||||
port
|
||||
"getblock"
|
||||
[Data.Aeson.String $ T.pack $ show b, jsonNumber 1]
|
||||
case r of
|
||||
Left e -> liftIO $ throwIO $ userError e
|
||||
Right blk -> do
|
||||
r2 <-
|
||||
liftIO $
|
||||
makeZebraCall
|
||||
host
|
||||
port
|
||||
"getblock"
|
||||
[Data.Aeson.String $ T.pack $ show b, jsonNumber 0]
|
||||
case r2 of
|
||||
Left e2 -> liftIO $ throwIO $ userError e2
|
||||
Right hb -> do
|
||||
let blockTime = getBlockTime hb
|
||||
mapM_ (processTx host port blockTime pool) $
|
||||
bl_txs $ addTime blk blockTime
|
||||
liftIO $ tick pg
|
||||
where
|
||||
addTime :: BlockResponse -> Int -> BlockResponse
|
||||
addTime bl t =
|
||||
BlockResponse
|
||||
(bl_confirmations bl)
|
||||
(bl_height bl)
|
||||
(fromIntegral t)
|
||||
(bl_txs bl)
|
||||
|
||||
-- | Function to process a raw transaction
|
||||
processTx ::
|
||||
T.Text -- ^ Host name for `zebrad`
|
||||
-> Int -- ^ Port for `zebrad`
|
||||
-> Int -- ^ Block time
|
||||
-> ConnectionPool -- ^ DB file path
|
||||
-> HexString -- ^ transaction id
|
||||
-> NoLoggingT IO ()
|
||||
processTx host port bt pool t = do
|
||||
r <-
|
||||
liftIO $
|
||||
makeZebraCall
|
||||
host
|
||||
port
|
||||
"getrawtransaction"
|
||||
[Data.Aeson.String $ toText t, jsonNumber 1]
|
||||
case r of
|
||||
Left e -> liftIO $ throwIO $ userError e
|
||||
Right rawTx -> do
|
||||
case readZebraTransaction (ztr_hex rawTx) of
|
||||
Nothing -> return ()
|
||||
Just rzt -> do
|
||||
_ <-
|
||||
saveTransaction pool bt $
|
||||
Transaction
|
||||
t
|
||||
(ztr_blockheight rawTx)
|
||||
(ztr_conf rawTx)
|
||||
(fromIntegral $ zt_expiry rzt)
|
||||
(fromRawTBundle $ zt_tBundle rzt)
|
||||
(fromRawSBundle $ zt_sBundle rzt)
|
||||
(fromRawOBundle $ zt_oBundle rzt)
|
||||
return ()
|
||||
350
src/Zenith/Types.hs
Normal file
350
src/Zenith/Types.hs
Normal file
|
|
@ -0,0 +1,350 @@
|
|||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
|
||||
module Zenith.Types where
|
||||
|
||||
import Data.Aeson
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Base64 as B64
|
||||
import qualified Data.ByteString.Char8 as C
|
||||
import Data.HexString
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import Data.Text.Encoding.Error (lenientDecode)
|
||||
import Database.Persist.TH
|
||||
import GHC.Generics
|
||||
import ZcashHaskell.Types
|
||||
( OrchardSpendingKey(..)
|
||||
, Phrase(..)
|
||||
, Rseed(..)
|
||||
, SaplingSpendingKey(..)
|
||||
, Scope(..)
|
||||
, TransparentSpendingKey
|
||||
, ZcashNet(..)
|
||||
)
|
||||
|
||||
-- * UI
|
||||
-- * Database field type wrappers
|
||||
newtype HexStringDB = HexStringDB
|
||||
{ getHex :: HexString
|
||||
} deriving newtype (Eq, Show, Read)
|
||||
|
||||
derivePersistField "HexStringDB"
|
||||
|
||||
newtype ZcashNetDB = ZcashNetDB
|
||||
{ getNet :: ZcashNet
|
||||
} deriving newtype (Eq, Show, Read)
|
||||
|
||||
derivePersistField "ZcashNetDB"
|
||||
|
||||
newtype UnifiedAddressDB = UnifiedAddressDB
|
||||
{ getUA :: T.Text
|
||||
} deriving newtype (Eq, Show, Read)
|
||||
|
||||
derivePersistField "UnifiedAddressDB"
|
||||
|
||||
newtype PhraseDB = PhraseDB
|
||||
{ getPhrase :: Phrase
|
||||
} deriving newtype (Eq, Show, Read)
|
||||
|
||||
derivePersistField "PhraseDB"
|
||||
|
||||
newtype ScopeDB = ScopeDB
|
||||
{ getScope :: Scope
|
||||
} deriving newtype (Eq, Show, Read)
|
||||
|
||||
derivePersistField "ScopeDB"
|
||||
|
||||
newtype OrchardSpendingKeyDB = OrchardSpendingKeyDB
|
||||
{ getOrchSK :: OrchardSpendingKey
|
||||
} deriving newtype (Eq, Show, Read)
|
||||
|
||||
derivePersistField "OrchardSpendingKeyDB"
|
||||
|
||||
newtype SaplingSpendingKeyDB = SaplingSpendingKeyDB
|
||||
{ getSapSK :: SaplingSpendingKey
|
||||
} deriving newtype (Eq, Show, Read)
|
||||
|
||||
derivePersistField "SaplingSpendingKeyDB"
|
||||
|
||||
newtype TransparentSpendingKeyDB = TransparentSpendingKeyDB
|
||||
{ getTranSK :: TransparentSpendingKey
|
||||
} deriving newtype (Eq, Show, Read)
|
||||
|
||||
derivePersistField "TransparentSpendingKeyDB"
|
||||
|
||||
newtype RseedDB = RseedDB
|
||||
{ getRseed :: Rseed
|
||||
} deriving newtype (Eq, Show, Read)
|
||||
|
||||
derivePersistField "RseedDB"
|
||||
|
||||
-- * RPC
|
||||
-- | Type for Configuration parameters
|
||||
data Config = Config
|
||||
{ c_dbPath :: !T.Text
|
||||
, c_zebraHost :: !T.Text
|
||||
, c_zebraPort :: !Int
|
||||
} deriving (Eq, Prelude.Show)
|
||||
|
||||
-- ** `zebrad`
|
||||
-- | Type for modeling the tree state response
|
||||
data ZebraTreeInfo = ZebraTreeInfo
|
||||
{ ztiHeight :: !Int
|
||||
, ztiTime :: !Int
|
||||
, ztiSapling :: !HexString
|
||||
, ztiOrchard :: !HexString
|
||||
} deriving (Eq, Show, Read)
|
||||
|
||||
instance FromJSON ZebraTreeInfo where
|
||||
parseJSON =
|
||||
withObject "ZebraTreeInfo" $ \obj -> do
|
||||
h <- obj .: "height"
|
||||
t <- obj .: "time"
|
||||
s <- obj .: "sapling"
|
||||
o <- obj .: "orchard"
|
||||
sc <- s .: "commitments"
|
||||
oc <- o .: "commitments"
|
||||
sf <- sc .: "finalState"
|
||||
ocf <- oc .: "finalState"
|
||||
pure $ ZebraTreeInfo h t sf ocf
|
||||
|
||||
-- ** `zcashd`
|
||||
-- | Type for modelling the different address sources for `zcashd` 5.0.0
|
||||
data AddressSource
|
||||
= LegacyRandom
|
||||
| Imported
|
||||
| ImportedWatchOnly
|
||||
| KeyPool
|
||||
| LegacySeed
|
||||
| MnemonicSeed
|
||||
deriving (Read, Show, Eq, Generic, ToJSON)
|
||||
|
||||
instance FromJSON AddressSource where
|
||||
parseJSON =
|
||||
withText "AddressSource" $ \case
|
||||
"legacy_random" -> return LegacyRandom
|
||||
"imported" -> return Imported
|
||||
"imported_watchonly" -> return ImportedWatchOnly
|
||||
"keypool" -> return KeyPool
|
||||
"legacy_hdseed" -> return LegacySeed
|
||||
"mnemonic_seed" -> return MnemonicSeed
|
||||
_ -> fail "Not a known address source"
|
||||
|
||||
data ZcashPool
|
||||
= Transparent
|
||||
| Sprout
|
||||
| Sapling
|
||||
| Orchard
|
||||
deriving (Show, Eq, Generic, ToJSON)
|
||||
|
||||
instance FromJSON ZcashPool where
|
||||
parseJSON =
|
||||
withText "ZcashPool" $ \case
|
||||
"p2pkh" -> return Transparent
|
||||
"sprout" -> return Sprout
|
||||
"sapling" -> return Sapling
|
||||
"orchard" -> return Orchard
|
||||
_ -> fail "Not a known Zcash pool"
|
||||
|
||||
data ZcashAddress = ZcashAddress
|
||||
{ source :: AddressSource
|
||||
, pool :: [ZcashPool]
|
||||
, account :: Maybe Integer
|
||||
, addy :: T.Text
|
||||
} deriving (Eq)
|
||||
|
||||
instance Show ZcashAddress where
|
||||
show (ZcashAddress s p i a) =
|
||||
T.unpack (T.take 8 a) ++
|
||||
"..." ++ T.unpack (T.takeEnd 8 a) ++ " Pools: " ++ show p
|
||||
|
||||
newtype NodeVersion =
|
||||
NodeVersion Integer
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance FromJSON NodeVersion where
|
||||
parseJSON =
|
||||
withObject "NodeVersion" $ \obj -> do
|
||||
v <- obj .: "version"
|
||||
pure $ NodeVersion v
|
||||
|
||||
-- | A type to model an address group
|
||||
data AddressGroup = AddressGroup
|
||||
{ agsource :: !AddressSource
|
||||
, agtransparent :: ![ZcashAddress]
|
||||
, agsapling :: ![ZcashAddress]
|
||||
, agunified :: ![ZcashAddress]
|
||||
} deriving (Show, Generic)
|
||||
|
||||
instance FromJSON AddressGroup where
|
||||
parseJSON =
|
||||
withObject "AddressGroup" $ \obj -> do
|
||||
s <- obj .: "source"
|
||||
t <- obj .:? "transparent"
|
||||
sap <- obj .:? "sapling"
|
||||
uni <- obj .:? "unified"
|
||||
sL <- processSapling sap s
|
||||
tL <- processTransparent t s
|
||||
uL <- processUnified uni
|
||||
return $ AddressGroup s tL (concat sL) (concat uL)
|
||||
where
|
||||
processTransparent c s1 =
|
||||
case c of
|
||||
Nothing -> return []
|
||||
Just x -> do
|
||||
x' <- x .:? "addresses"
|
||||
return $ maybe [] (map (ZcashAddress s1 [Transparent] Nothing)) x'
|
||||
processSapling k s2 =
|
||||
case k of
|
||||
Nothing -> return []
|
||||
Just y -> mapM (processOneSapling s2) y
|
||||
where processOneSapling sx =
|
||||
withObject "Sapling" $ \oS -> do
|
||||
oS' <- oS .: "addresses"
|
||||
return $ map (ZcashAddress sx [Sapling] Nothing) oS'
|
||||
processUnified u =
|
||||
case u of
|
||||
Nothing -> return []
|
||||
Just z -> mapM processOneAccount z
|
||||
where processOneAccount =
|
||||
withObject "UAs" $ \uS -> do
|
||||
acct <- uS .: "account"
|
||||
uS' <- uS .: "addresses"
|
||||
mapM (processUAs acct) uS'
|
||||
where
|
||||
processUAs a =
|
||||
withObject "UAs" $ \v -> do
|
||||
addr <- v .: "address"
|
||||
p <- v .: "receiver_types"
|
||||
return $ ZcashAddress MnemonicSeed p a addr
|
||||
|
||||
-- | A type to model a Zcash transaction
|
||||
data ZcashTx = ZcashTx
|
||||
{ ztxid :: !T.Text
|
||||
, zamount :: !Double
|
||||
, zamountZat :: !Integer
|
||||
, zblockheight :: !Integer
|
||||
, zblocktime :: !Integer
|
||||
, zchange :: !Bool
|
||||
, zconfirmations :: !Integer
|
||||
, zmemo :: !T.Text
|
||||
} deriving (Show, Generic)
|
||||
|
||||
instance FromJSON ZcashTx where
|
||||
parseJSON =
|
||||
withObject "ZcashTx" $ \obj -> do
|
||||
t <- obj .: "txid"
|
||||
a <- obj .: "amount"
|
||||
aZ <- obj .: "amountZat"
|
||||
bh <- obj .: "blockheight"
|
||||
bt <- obj .: "blocktime"
|
||||
c <- obj .:? "change"
|
||||
conf <- obj .: "confirmations"
|
||||
m <- obj .:? "memo"
|
||||
pure $
|
||||
ZcashTx
|
||||
t
|
||||
a
|
||||
aZ
|
||||
bh
|
||||
bt
|
||||
(fromMaybe False c)
|
||||
conf
|
||||
(case m of
|
||||
Nothing -> ""
|
||||
Just m' -> T.filter (/= '\NUL') $ decodeHexText m')
|
||||
|
||||
instance ToJSON ZcashTx where
|
||||
toJSON (ZcashTx t a aZ bh bt c conf m) =
|
||||
object
|
||||
[ "amount" .= a
|
||||
, "amountZat" .= aZ
|
||||
, "txid" .= t
|
||||
, "blockheight" .= bh
|
||||
, "blocktime" .= bt
|
||||
, "change" .= c
|
||||
, "confirmations" .= conf
|
||||
, "memo" .= m
|
||||
]
|
||||
|
||||
-- | Type for the UA balance
|
||||
data UABalance = UABalance
|
||||
{ uatransparent :: !Integer
|
||||
, uasapling :: !Integer
|
||||
, uaorchard :: !Integer
|
||||
} deriving (Eq)
|
||||
|
||||
instance Show UABalance where
|
||||
show (UABalance t s o) =
|
||||
" T: " ++ show t ++ " S: " ++ show s ++ " O: " ++ show o
|
||||
|
||||
instance FromJSON UABalance where
|
||||
parseJSON =
|
||||
withObject "UABalance" $ \obj -> do
|
||||
p <- obj .: "pools"
|
||||
t <- p .:? "transparent"
|
||||
s <- p .:? "sapling"
|
||||
o <- p .:? "orchard"
|
||||
vT <-
|
||||
case t of
|
||||
Nothing -> return 0
|
||||
Just t' -> t' .: "valueZat"
|
||||
vS <-
|
||||
case s of
|
||||
Nothing -> return 0
|
||||
Just s' -> s' .: "valueZat"
|
||||
vO <-
|
||||
case o of
|
||||
Nothing -> return 0
|
||||
Just o' -> o' .: "valueZat"
|
||||
pure $ UABalance vT vS vO
|
||||
|
||||
-- | Type for Operation Result
|
||||
data OpResult = OpResult
|
||||
{ opsuccess :: !T.Text
|
||||
, opmessage :: !(Maybe T.Text)
|
||||
, optxid :: !(Maybe T.Text)
|
||||
} deriving (Show, Eq)
|
||||
|
||||
instance FromJSON OpResult where
|
||||
parseJSON =
|
||||
withObject "OpResult" $ \obj -> do
|
||||
s <- obj .: "status"
|
||||
r <- obj .:? "result"
|
||||
e <- obj .:? "error"
|
||||
t <-
|
||||
case r of
|
||||
Nothing -> return Nothing
|
||||
Just r' -> r' .: "txid"
|
||||
m <-
|
||||
case e of
|
||||
Nothing -> return Nothing
|
||||
Just m' -> m' .: "message"
|
||||
pure $ OpResult s m t
|
||||
|
||||
-- * Helper functions
|
||||
-- | Helper function to turn a hex-encoded memo strings to readable text
|
||||
decodeHexText :: String -> T.Text
|
||||
decodeHexText h = E.decodeUtf8With lenientDecode $ BS.pack $ hexRead h
|
||||
where
|
||||
hexRead hexText
|
||||
| null chunk = []
|
||||
| otherwise =
|
||||
fromIntegral (read ("0x" <> chunk)) : hexRead (drop 2 hexText)
|
||||
where
|
||||
chunk = take 2 hexText
|
||||
|
||||
-- | Helper function to turn a text into a hex-encoded string
|
||||
encodeHexText' :: T.Text -> String
|
||||
encodeHexText' t =
|
||||
if T.length t > 0
|
||||
then C.unpack . B64.encode $ E.encodeUtf8 t
|
||||
else C.unpack . B64.encode $ E.encodeUtf8 "Sent from Zenith"
|
||||
74
src/Zenith/Utils.hs
Normal file
74
src/Zenith/Utils.hs
Normal file
|
|
@ -0,0 +1,74 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Zenith.Utils where
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Functor (void)
|
||||
import Data.Maybe
|
||||
import Data.Scientific (Scientific(..), scientific)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import System.Process (createProcess_, shell)
|
||||
import Text.Regex.Posix
|
||||
import ZcashHaskell.Orchard (encodeUnifiedAddress, isValidUnifiedAddress)
|
||||
import ZcashHaskell.Sapling (isValidShieldedAddress)
|
||||
import Zenith.Types
|
||||
( AddressGroup(..)
|
||||
, UnifiedAddressDB(..)
|
||||
, ZcashAddress(..)
|
||||
, ZcashPool(..)
|
||||
)
|
||||
|
||||
-- | Helper function to convert numbers into JSON
|
||||
jsonNumber :: Int -> Value
|
||||
jsonNumber i = Number $ scientific (fromIntegral i) 0
|
||||
|
||||
-- | Helper function to display small amounts of ZEC
|
||||
displayZec :: Integer -> String
|
||||
displayZec s
|
||||
| abs s < 100 = show s ++ " zats "
|
||||
| abs s < 100000 = show (fromIntegral s / 100) ++ " μZEC "
|
||||
| abs s < 100000000 = show (fromIntegral s / 100000) ++ " mZEC "
|
||||
| otherwise = show (fromIntegral s / 100000000) ++ " ZEC "
|
||||
|
||||
-- | Helper function to display small amounts of ZEC
|
||||
displayTaz :: Integer -> String
|
||||
displayTaz s
|
||||
| abs s < 100 = show s ++ " tazs "
|
||||
| abs s < 100000 = show (fromIntegral s / 100) ++ " μTAZ "
|
||||
| abs s < 100000000 = show (fromIntegral s / 100000) ++ " mTAZ "
|
||||
| otherwise = show (fromIntegral s / 100000000) ++ " TAZ "
|
||||
|
||||
-- | Helper function to display abbreviated Unified Address
|
||||
showAddress :: UnifiedAddressDB -> T.Text
|
||||
showAddress u = T.take 20 t <> "..."
|
||||
where
|
||||
t = getUA u
|
||||
|
||||
-- | Helper function to extract addresses from AddressGroups
|
||||
getAddresses :: AddressGroup -> [ZcashAddress]
|
||||
getAddresses ag = agtransparent ag <> agsapling ag <> agunified ag
|
||||
|
||||
-- | Helper function to validate potential Zcash addresses
|
||||
validateAddress :: T.Text -> Maybe ZcashPool
|
||||
validateAddress txt --(tReg || sReg && isJust chk) || (uReg && isJust chk)
|
||||
| tReg = Just Transparent
|
||||
| sReg && chkS = Just Sapling
|
||||
| uReg && chk = Just Orchard
|
||||
| otherwise = Nothing
|
||||
where
|
||||
transparentRegex = "^t1[a-zA-Z0-9]{33}$" :: String
|
||||
shieldedRegex = "^zs[a-zA-Z0-9]{76}$" :: String
|
||||
unifiedRegex = "^u[a-zA-Z0-9]" :: String
|
||||
tReg = T.unpack txt =~ transparentRegex :: Bool
|
||||
sReg = T.unpack txt =~ shieldedRegex :: Bool
|
||||
uReg = T.unpack txt =~ unifiedRegex :: Bool
|
||||
chk = isJust $ isValidUnifiedAddress $ E.encodeUtf8 txt
|
||||
chkS = isValidShieldedAddress $ E.encodeUtf8 txt
|
||||
|
||||
-- | Copy an address to the clipboard
|
||||
copyAddress :: ZcashAddress -> IO ()
|
||||
copyAddress a =
|
||||
void $
|
||||
createProcess_ "toClipboard" $
|
||||
shell $ "echo " ++ T.unpack (addy a) ++ " | xclip -r -selection clipboard"
|
||||
343
src/Zenith/Zcashd.hs
Normal file
343
src/Zenith/Zcashd.hs
Normal file
|
|
@ -0,0 +1,343 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Zenith.Zcashd where
|
||||
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Monad (when)
|
||||
import Data.Aeson
|
||||
import qualified Data.Array as A
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Base64 as B64
|
||||
import qualified Data.ByteString.Char8 as C
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Data.Maybe
|
||||
import qualified Data.Scientific as Scientific
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import Data.Text.Encoding.Error (lenientDecode)
|
||||
import qualified Data.Text.IO as TIO
|
||||
import qualified Data.Vector as V
|
||||
import Network.HTTP.Simple
|
||||
import System.Clipboard
|
||||
import System.Exit
|
||||
import System.IO
|
||||
import Text.Read (readMaybe)
|
||||
import Text.Regex
|
||||
import Text.Regex.Base
|
||||
import ZcashHaskell.Types (RpcCall(..), RpcResponse(..))
|
||||
import Zenith.Types
|
||||
( AddressGroup
|
||||
, AddressSource(..)
|
||||
, NodeVersion(..)
|
||||
, OpResult(..)
|
||||
, UABalance(..)
|
||||
, ZcashAddress(..)
|
||||
, ZcashPool(..)
|
||||
, ZcashTx
|
||||
, encodeHexText'
|
||||
)
|
||||
import Zenith.Utils (displayZec, getAddresses, validateAddress)
|
||||
|
||||
-- * RPC methods
|
||||
-- | List addresses
|
||||
listAddresses :: BS.ByteString -> BS.ByteString -> IO [ZcashAddress]
|
||||
listAddresses user pwd = do
|
||||
response <- makeZcashCall user pwd "listaddresses" []
|
||||
let rpcResp = decode response :: Maybe (RpcResponse [AddressGroup])
|
||||
case rpcResp of
|
||||
Nothing -> fail "Couldn't parse node response"
|
||||
Just res -> do
|
||||
let addys = result res
|
||||
case addys of
|
||||
Nothing -> fail "Empty response"
|
||||
Just addys' -> do
|
||||
let addList = concatMap getAddresses addys'
|
||||
return addList
|
||||
|
||||
-- | Get address balance
|
||||
getBalance :: BS.ByteString -> BS.ByteString -> ZcashAddress -> IO [Integer]
|
||||
getBalance user pwd zadd = do
|
||||
let a = account zadd
|
||||
case a of
|
||||
Nothing -> do
|
||||
response <-
|
||||
makeZcashCall
|
||||
user
|
||||
pwd
|
||||
"z_getbalance"
|
||||
[ String (addy zadd)
|
||||
, Number (Scientific.scientific 1 0)
|
||||
, Data.Aeson.Bool True
|
||||
]
|
||||
let rpcResp = decode response :: Maybe (RpcResponse Integer)
|
||||
case rpcResp of
|
||||
Nothing -> fail "Couldn't parse node response"
|
||||
Just res -> do
|
||||
case result res of
|
||||
Nothing -> return []
|
||||
Just r -> return [r]
|
||||
Just acct -> do
|
||||
response <-
|
||||
makeZcashCall
|
||||
user
|
||||
pwd
|
||||
"z_getbalanceforaccount"
|
||||
[Number (Scientific.scientific acct 0)]
|
||||
let rpcResp = decode response :: Maybe (RpcResponse UABalance)
|
||||
case rpcResp of
|
||||
Nothing -> fail "Couldn't parse node response"
|
||||
Just res -> do
|
||||
case result res of
|
||||
Nothing -> return [0, 0, 0]
|
||||
Just r -> return $ readUABalance r
|
||||
where readUABalance ua =
|
||||
[uatransparent ua, uasapling ua, uaorchard ua]
|
||||
|
||||
-- | List transactions
|
||||
listTxs :: BS.ByteString -> BS.ByteString -> ZcashAddress -> IO [ZcashTx]
|
||||
listTxs user pwd zaddy = do
|
||||
response <-
|
||||
makeZcashCall user pwd "z_listreceivedbyaddress" [String $ addy zaddy]
|
||||
let rpcResp = decode response :: Maybe (RpcResponse [ZcashTx])
|
||||
case rpcResp of
|
||||
Nothing -> fail "listTxs: Couldn't parse node response"
|
||||
Just res -> do
|
||||
case result res of
|
||||
Nothing -> fail "listTxs: Empty response"
|
||||
Just res' -> return res'
|
||||
|
||||
-- | Send Tx
|
||||
sendTx ::
|
||||
BS.ByteString
|
||||
-> BS.ByteString
|
||||
-> ZcashAddress
|
||||
-> T.Text
|
||||
-> Double
|
||||
-> Maybe T.Text
|
||||
-> IO ()
|
||||
sendTx user pwd fromAddy toAddy amount memo = do
|
||||
bal <- getBalance user pwd fromAddy
|
||||
let valAdd = validateAddress toAddy
|
||||
if sum bal - floor (amount * 100000000) >= 1000
|
||||
then do
|
||||
if source fromAddy /= ImportedWatchOnly
|
||||
then do
|
||||
let privacyPolicy
|
||||
| valAdd == Just Transparent = "AllowRevealedRecipients"
|
||||
| isNothing (account fromAddy) &&
|
||||
elem Transparent (pool fromAddy) = "AllowRevealedSenders"
|
||||
| otherwise = "AllowRevealedAmounts"
|
||||
let pd =
|
||||
case memo of
|
||||
Nothing ->
|
||||
[ Data.Aeson.String (addy fromAddy)
|
||||
, Data.Aeson.Array
|
||||
(V.fromList
|
||||
[object ["address" .= toAddy, "amount" .= amount]])
|
||||
, Data.Aeson.Number $ Scientific.scientific 1 1
|
||||
, Data.Aeson.Null
|
||||
, Data.Aeson.String privacyPolicy
|
||||
]
|
||||
Just memo' ->
|
||||
[ Data.Aeson.String (addy fromAddy)
|
||||
, Data.Aeson.Array
|
||||
(V.fromList
|
||||
[ object
|
||||
[ "address" .= toAddy
|
||||
, "amount" .= amount
|
||||
, "memo" .= encodeHexText' memo'
|
||||
]
|
||||
])
|
||||
, Data.Aeson.Number $ Scientific.scientific 1 1
|
||||
, Data.Aeson.Null
|
||||
, Data.Aeson.String privacyPolicy
|
||||
]
|
||||
response <- makeZcashCall user pwd "z_sendmany" pd
|
||||
let rpcResp = decode response :: Maybe (RpcResponse T.Text)
|
||||
case rpcResp of
|
||||
Nothing -> fail "Couldn't parse node response"
|
||||
Just res -> do
|
||||
putStr " Sending."
|
||||
checkOpResult user pwd (fromMaybe "" $ result res)
|
||||
else putStrLn "Error: Source address is view-only."
|
||||
else putStrLn "Error: Insufficient balance in source address."
|
||||
|
||||
-- | Check Zcash full node server
|
||||
checkServer :: BS.ByteString -> BS.ByteString -> IO ()
|
||||
checkServer user pwd = do
|
||||
resp <- makeZcashCall user pwd "getinfo" []
|
||||
let rpcResp = decode resp :: Maybe (RpcResponse NodeVersion)
|
||||
case rpcResp of
|
||||
Nothing -> fail "Couldn't parse node response"
|
||||
Just myResp -> do
|
||||
let r = result myResp
|
||||
case r of
|
||||
Nothing -> fail "Empty node response"
|
||||
Just r' -> do
|
||||
if isNodeValid r'
|
||||
then putStrLn $ "Connected to Zcash Full Node (" <> show r <> ") :)"
|
||||
else do
|
||||
putStrLn "Deprecated Zcash Full Node version found. Exiting"
|
||||
exitFailure
|
||||
where isNodeValid (NodeVersion i) = i >= 5000000
|
||||
|
||||
-- | Check for accounts
|
||||
checkAccounts :: BS.ByteString -> BS.ByteString -> IO Bool
|
||||
checkAccounts user pwd = do
|
||||
response <- makeZcashCall user pwd "z_listaccounts" []
|
||||
let rpcResp = decode response :: Maybe (RpcResponse [Object])
|
||||
case rpcResp of
|
||||
Nothing -> fail "Couldn't parse node response"
|
||||
Just res -> do
|
||||
let r = result res
|
||||
return $ not (null r)
|
||||
|
||||
-- | Add account to node
|
||||
createAccount :: BS.ByteString -> BS.ByteString -> IO ()
|
||||
createAccount user pwd = do
|
||||
response <- makeZcashCall user pwd "z_getnewaccount" []
|
||||
let rpcResp = decode response :: Maybe (RpcResponse Object)
|
||||
case rpcResp of
|
||||
Nothing -> fail "Couldn't parse node response"
|
||||
Just res -> do
|
||||
let r = result res
|
||||
putStrLn " Account created!"
|
||||
|
||||
-- | Create new Unified Address
|
||||
createUnifiedAddress :: BS.ByteString -> BS.ByteString -> Bool -> Bool -> IO ()
|
||||
createUnifiedAddress user pwd tRec sRec = do
|
||||
let recs = getReceivers tRec sRec
|
||||
let pd = [Data.Aeson.Number $ Scientific.scientific 0 1, recs]
|
||||
newResp <- makeZcashCall user pwd "z_getaddressforaccount" pd
|
||||
let rpcResp = decode newResp :: Maybe (RpcResponse Object)
|
||||
case rpcResp of
|
||||
Nothing -> fail "Couldn't parse node response"
|
||||
Just res -> do
|
||||
let r = result res
|
||||
putStrLn " New UA created!"
|
||||
where
|
||||
getReceivers t s
|
||||
| t && s =
|
||||
Data.Aeson.Array
|
||||
(V.fromList
|
||||
[ Data.Aeson.String "p2pkh"
|
||||
, Data.Aeson.String "sapling"
|
||||
, Data.Aeson.String "orchard"
|
||||
])
|
||||
| t =
|
||||
Data.Aeson.Array
|
||||
(V.fromList [Data.Aeson.String "p2pkh", Data.Aeson.String "orchard"])
|
||||
| s =
|
||||
Data.Aeson.Array
|
||||
(V.fromList [Data.Aeson.String "sapling", Data.Aeson.String "orchard"])
|
||||
| otherwise = Data.Aeson.Array (V.fromList [Data.Aeson.String "orchard"])
|
||||
|
||||
-- | Verify operation result
|
||||
checkOpResult :: BS.ByteString -> BS.ByteString -> T.Text -> IO ()
|
||||
checkOpResult user pwd opid = do
|
||||
response <-
|
||||
makeZcashCall
|
||||
user
|
||||
pwd
|
||||
"z_getoperationstatus"
|
||||
[Data.Aeson.Array (V.fromList [Data.Aeson.String opid])]
|
||||
let rpcResp = decode response :: Maybe (RpcResponse [OpResult])
|
||||
case rpcResp of
|
||||
Nothing -> fail "Couldn't parse node response"
|
||||
Just res -> do
|
||||
let r = result res
|
||||
case r of
|
||||
Nothing -> fail "Empty node response"
|
||||
Just r' -> mapM_ showResult r'
|
||||
where
|
||||
showResult t =
|
||||
case opsuccess t of
|
||||
"success" ->
|
||||
putStrLn $ " Success! Tx ID: " ++ maybe "" T.unpack (optxid t)
|
||||
"executing" -> do
|
||||
putStr "."
|
||||
hFlush stdout
|
||||
threadDelay 1000000 >> checkOpResult user pwd opid
|
||||
_ -> putStrLn $ " Failed :( " ++ maybe "" T.unpack (opmessage t)
|
||||
|
||||
-- | Make a Zcash RPC call
|
||||
makeZcashCall ::
|
||||
BS.ByteString
|
||||
-> BS.ByteString
|
||||
-> T.Text
|
||||
-> [Data.Aeson.Value]
|
||||
-> IO LBS.ByteString
|
||||
makeZcashCall username password m p = do
|
||||
let payload = RpcCall "1.0" "test" m p
|
||||
let myRequest =
|
||||
setRequestBodyJSON payload $
|
||||
setRequestPort 8232 $
|
||||
setRequestBasicAuth username password $
|
||||
setRequestMethod "POST" defaultRequest
|
||||
response <- httpLBS myRequest
|
||||
let respStatus = getResponseStatusCode response
|
||||
let body = getResponseBody response
|
||||
case respStatus of
|
||||
500 -> do
|
||||
let rpcResp = decode body :: Maybe (RpcResponse String)
|
||||
case rpcResp of
|
||||
Nothing -> fail $ "Unknown server error " ++ show response
|
||||
Just x -> fail (fromMaybe "" $ result x)
|
||||
401 -> fail "Incorrect full node credentials"
|
||||
200 -> return body
|
||||
_ -> fail "Unknown error"
|
||||
|
||||
-- | Read ZIP-321 URI
|
||||
sendWithUri ::
|
||||
BS.ByteString -> BS.ByteString -> ZcashAddress -> String -> Bool -> IO ()
|
||||
sendWithUri user pwd fromAddy uri repTo = do
|
||||
let uriRegex = mkRegex "^zcash:(\\w+)\\?amount=(.*)\\&memo=(.*)$"
|
||||
if matchTest uriRegex uri
|
||||
then do
|
||||
let reg = matchAllText uriRegex uri
|
||||
let parsedAddress = fst $ head reg A.! 1
|
||||
let parsedAmount = fst $ head reg A.! 2
|
||||
let parsedEncodedMemo = fst $ head reg A.! 3
|
||||
let addType = validateAddress $ T.pack parsedAddress
|
||||
case addType of
|
||||
Nothing -> putStrLn " Invalid address"
|
||||
Just Transparent -> do
|
||||
putStrLn $ " Address is valid: " ++ parsedAddress
|
||||
case (readMaybe parsedAmount :: Maybe Double) of
|
||||
Nothing -> putStrLn " Invalid amount."
|
||||
Just amt -> do
|
||||
putStrLn $ " Valid ZEC amount: " ++ show amt
|
||||
sendTx user pwd fromAddy (T.pack parsedAddress) amt Nothing
|
||||
Just _ -> do
|
||||
putStrLn $ " Address is valid: " ++ parsedAddress
|
||||
case (readMaybe parsedAmount :: Maybe Double) of
|
||||
Nothing -> putStrLn " Invalid amount."
|
||||
Just amt -> do
|
||||
putStrLn $ " Valid ZEC amount: " ++ show amt
|
||||
let decodedMemo =
|
||||
E.decodeUtf8With lenientDecode $
|
||||
B64.decodeLenient $ C.pack parsedEncodedMemo
|
||||
TIO.putStrLn $ " Memo: " <> decodedMemo
|
||||
sendTx
|
||||
user
|
||||
pwd
|
||||
fromAddy
|
||||
(T.pack parsedAddress)
|
||||
amt
|
||||
(if repTo
|
||||
then Just $
|
||||
T.concat [decodedMemo, "\nReply-To:\n", addy fromAddy]
|
||||
else Just decodedMemo)
|
||||
else putStrLn "URI is not compliant with ZIP-321"
|
||||
|
||||
-- | Display an address
|
||||
displayZcashAddress ::
|
||||
BS.ByteString -> BS.ByteString -> (Int, ZcashAddress) -> IO ()
|
||||
displayZcashAddress user pwd (idx, zaddy) = do
|
||||
zats <- getBalance user pwd zaddy
|
||||
putStr $ show idx ++ ": "
|
||||
putStr $ show zaddy
|
||||
when (source zaddy == ImportedWatchOnly) (putStr "[VK]")
|
||||
putStr " Balance: "
|
||||
mapM_ (putStr . displayZec) zats
|
||||
putStrLn ""
|
||||
81
stack.yaml
81
stack.yaml
|
|
@ -1,81 +0,0 @@
|
|||
# This file was automatically generated by 'stack init'
|
||||
#
|
||||
# Some commonly used options have been documented as comments in this file.
|
||||
# For advanced use and comprehensive documentation of the format, please see:
|
||||
# https://docs.haskellstack.org/en/stable/yaml_configuration/
|
||||
|
||||
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
|
||||
# A snapshot resolver dictates the compiler version and the set of packages
|
||||
# to be used for project dependencies. For example:
|
||||
#
|
||||
# resolver: lts-3.5
|
||||
# resolver: nightly-2015-09-21
|
||||
# resolver: ghc-7.10.2
|
||||
#
|
||||
# The location of a snapshot can be provided as a file or url. Stack assumes
|
||||
# a snapshot provided as a file might change, whereas a url resource does not.
|
||||
#
|
||||
# resolver: ./custom-snapshot.yaml
|
||||
# resolver: https://example.com/snapshots/2018-01-01.yaml
|
||||
resolver: lts-21.6
|
||||
|
||||
# User packages to be built.
|
||||
# Various formats can be used as shown in the example below.
|
||||
#
|
||||
# packages:
|
||||
# - some-directory
|
||||
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
|
||||
# subdirs:
|
||||
# - auto-update
|
||||
# - wai
|
||||
packages:
|
||||
- .
|
||||
#- haskoin-core
|
||||
#- zcash-haskell
|
||||
# Dependency packages to be pulled from upstream that are not in the resolver.
|
||||
# These entries can reference officially published versions as well as
|
||||
# forks / in-progress versions pinned to a git hash. For example:
|
||||
#
|
||||
# extra-deps:
|
||||
# - acme-missiles-0.3
|
||||
# - git: https://github.com/commercialhaskell/stack.git
|
||||
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
|
||||
#
|
||||
# extra-deps: []
|
||||
extra-deps:
|
||||
- git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
|
||||
commit: fef3d3af35a09db718cddb8fc9166b2d2691a744
|
||||
- git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git
|
||||
commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05
|
||||
- git: https://github.com/reach-sh/haskell-hexstring.git
|
||||
commit: 085c16fb21b9f856a435a3faab980e7e0b319341
|
||||
- git: https://github.com/well-typed/borsh.git
|
||||
commit: d2fcfa159e0a844b1ec5e8ed3e232d4b380fa831
|
||||
- vector-0.13.0.0@sha256:fa5cac81a17a5af388716792e8b99c24b3b66770086756d0d8b23f8272a0244c,9112
|
||||
- generically-0.1.1
|
||||
- vector-algorithms-0.9.0.1
|
||||
#- vector-0.12.3.1@sha256:abbfe8830e13549596e1295219d340eb01bd00e1c7124d0dd16586911a291c59,8218
|
||||
#extra-lib-dirs: [/home/rav/Documents/programs/haskoin]
|
||||
#
|
||||
# Override default flag values for local packages and extra-deps
|
||||
# flags: {}
|
||||
|
||||
# Extra package databases containing global packages
|
||||
# extra-package-dbs: []
|
||||
|
||||
# Control whether we use the GHC we find on the path
|
||||
# system-ghc: true
|
||||
#
|
||||
# Require a specific version of stack, using version ranges
|
||||
# require-stack-version: -any # Default
|
||||
# require-stack-version: ">=2.7"
|
||||
#
|
||||
# Override the architecture used by stack, especially useful on Windows
|
||||
# arch: i386
|
||||
# arch: x86_64
|
||||
#
|
||||
# Extra directories used by stack for building
|
||||
# extra-include-dirs: [/path/to/dir]
|
||||
#
|
||||
# Allow a newer minor version of GHC than the snapshot specifies
|
||||
# compiler-check: newer-minor
|
||||
|
|
@ -1,77 +0,0 @@
|
|||
# This file was autogenerated by Stack.
|
||||
# You should not edit this file by hand.
|
||||
# For more information, please see the documentation at:
|
||||
# https://docs.haskellstack.org/en/stable/lock_files
|
||||
|
||||
packages:
|
||||
- completed:
|
||||
commit: fef3d3af35a09db718cddb8fc9166b2d2691a744
|
||||
git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
|
||||
name: zcash-haskell
|
||||
pantry-tree:
|
||||
sha256: ec7782cf2646da17548d59af0ea98dcbaac1b6c2176258c696a7f508db6dbc21
|
||||
size: 1126
|
||||
version: 0.1.0
|
||||
original:
|
||||
commit: fef3d3af35a09db718cddb8fc9166b2d2691a744
|
||||
git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
|
||||
- completed:
|
||||
commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05
|
||||
git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git
|
||||
name: foreign-rust
|
||||
pantry-tree:
|
||||
sha256: be2f6fc0fab58a90fec657bdb6bd0ccf0810c7dccfe95c78b85e174fae227e42
|
||||
size: 2315
|
||||
version: 0.1.0
|
||||
original:
|
||||
commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05
|
||||
git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git
|
||||
- completed:
|
||||
commit: 085c16fb21b9f856a435a3faab980e7e0b319341
|
||||
git: https://github.com/reach-sh/haskell-hexstring.git
|
||||
name: hexstring
|
||||
pantry-tree:
|
||||
sha256: 9ecf67856f59dfb382b283eceb42e4fc1865935d1a7e59111556ed381c6a2ffd
|
||||
size: 687
|
||||
version: 0.11.1
|
||||
original:
|
||||
commit: 085c16fb21b9f856a435a3faab980e7e0b319341
|
||||
git: https://github.com/reach-sh/haskell-hexstring.git
|
||||
- completed:
|
||||
commit: d2fcfa159e0a844b1ec5e8ed3e232d4b380fa831
|
||||
git: https://github.com/well-typed/borsh.git
|
||||
name: borsh
|
||||
pantry-tree:
|
||||
sha256: 8335925f495a5a653fcb74b6b8bb18cd0b6b7fe7099a1686108704e6ab82f47b
|
||||
size: 2268
|
||||
version: 0.3.0
|
||||
original:
|
||||
commit: d2fcfa159e0a844b1ec5e8ed3e232d4b380fa831
|
||||
git: https://github.com/well-typed/borsh.git
|
||||
- completed:
|
||||
hackage: vector-0.13.0.0@sha256:fa5cac81a17a5af388716792e8b99c24b3b66770086756d0d8b23f8272a0244c,9112
|
||||
pantry-tree:
|
||||
sha256: d2461d28022c8c0a91da08b579b1bff478f617102d2f5ef596cc5b28d14b8b6a
|
||||
size: 4092
|
||||
original:
|
||||
hackage: vector-0.13.0.0@sha256:fa5cac81a17a5af388716792e8b99c24b3b66770086756d0d8b23f8272a0244c,9112
|
||||
- completed:
|
||||
hackage: generically-0.1.1@sha256:aa00d9a77b7fb90c08f935699758ed9de55975021b1e979c6a4a4b5b49a940a9,1133
|
||||
pantry-tree:
|
||||
sha256: ec19e6d2aecfbe7a59e789526b9d7ab5c8ba853f017248d0203ee69a9769adb7
|
||||
size: 233
|
||||
original:
|
||||
hackage: generically-0.1.1
|
||||
- completed:
|
||||
hackage: vector-algorithms-0.9.0.1@sha256:f3e5c6695529a94edf762117cafd91c989cb642ad3f8ca4014dbb13c8f6c2a20,3826
|
||||
pantry-tree:
|
||||
sha256: aef389e57ae6020e5da719bee40aaf6cccf1c4d1e7743a85d30c9d8c25d170a0
|
||||
size: 1510
|
||||
original:
|
||||
hackage: vector-algorithms-0.9.0.1
|
||||
snapshots:
|
||||
- completed:
|
||||
sha256: 2e7d4a730d8eb5373b2d383fac84efcf7c81e3b7a5fce71b4c2e19a1768f25a6
|
||||
size: 640239
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/6.yaml
|
||||
original: lts-21.6
|
||||
253
test/Spec.hs
253
test/Spec.hs
|
|
@ -1,2 +1,253 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
import Control.Monad (when)
|
||||
import Control.Monad.Logger (runNoLoggingT)
|
||||
import Data.HexString
|
||||
import qualified Data.Text.Encoding as E
|
||||
import Database.Persist
|
||||
import Database.Persist.Sqlite
|
||||
import System.Directory
|
||||
import Test.HUnit
|
||||
import Test.Hspec
|
||||
import ZcashHaskell.Orchard (isValidUnifiedAddress)
|
||||
import ZcashHaskell.Sapling
|
||||
( decodeSaplingOutputEsk
|
||||
, encodeSaplingAddress
|
||||
, getSaplingNotePosition
|
||||
, getSaplingWitness
|
||||
, isValidShieldedAddress
|
||||
, updateSaplingCommitmentTree
|
||||
)
|
||||
import ZcashHaskell.Transparent
|
||||
( decodeExchangeAddress
|
||||
, decodeTransparentAddress
|
||||
)
|
||||
import ZcashHaskell.Types
|
||||
( DecodedNote(..)
|
||||
, OrchardSpendingKey(..)
|
||||
, Phrase(..)
|
||||
, SaplingCommitmentTree(..)
|
||||
, SaplingReceiver(..)
|
||||
, SaplingSpendingKey(..)
|
||||
, Scope(..)
|
||||
, ShieldedOutput(..)
|
||||
, ZcashNet(..)
|
||||
)
|
||||
import Zenith.Core
|
||||
import Zenith.DB
|
||||
import Zenith.Types
|
||||
|
||||
main :: IO ()
|
||||
main = putStrLn "Test suite not yet implemented"
|
||||
main = do
|
||||
checkDbFile <- doesFileExist "test.db"
|
||||
when checkDbFile $ removeFile "test.db"
|
||||
hspec $ do
|
||||
describe "Database tests" $ do
|
||||
it "Create table" $ do
|
||||
s <- runSqlite "test.db" $ do runMigration migrateAll
|
||||
s `shouldBe` ()
|
||||
describe "Wallet Table" $ do
|
||||
it "insert wallet record" $ do
|
||||
s <-
|
||||
runSqlite "test.db" $ do
|
||||
insert $
|
||||
ZcashWallet
|
||||
"Main Wallet"
|
||||
(ZcashNetDB MainNet)
|
||||
(PhraseDB $
|
||||
Phrase
|
||||
"one two three four five six seven eight nine ten eleven twelve")
|
||||
2000000
|
||||
0
|
||||
fromSqlKey s `shouldBe` 1
|
||||
it "read wallet record" $ do
|
||||
s <-
|
||||
runSqlite "test.db" $ do
|
||||
selectList [ZcashWalletBirthdayHeight >. 0] []
|
||||
length s `shouldBe` 1
|
||||
it "modify wallet record" $ do
|
||||
s <-
|
||||
runSqlite "test.db" $ do
|
||||
let recId = toSqlKey 1 :: ZcashWalletId
|
||||
update recId [ZcashWalletName =. "New Wallet"]
|
||||
get recId
|
||||
"New Wallet" `shouldBe` maybe "None" zcashWalletName s
|
||||
it "delete wallet record" $ do
|
||||
s <-
|
||||
runSqlite "test.db" $ do
|
||||
let recId = toSqlKey 1 :: ZcashWalletId
|
||||
delete recId
|
||||
get recId
|
||||
"None" `shouldBe` maybe "None" zcashWalletName s
|
||||
describe "Wallet function tests:" $ do
|
||||
it "Save Wallet:" $ do
|
||||
pool <- runNoLoggingT $ initPool "test.db"
|
||||
zw <-
|
||||
saveWallet pool $
|
||||
ZcashWallet
|
||||
"Testing"
|
||||
(ZcashNetDB MainNet)
|
||||
(PhraseDB $
|
||||
Phrase
|
||||
"cloth swing left trap random tornado have great onion element until make shy dad success art tuition canvas thunder apple decade elegant struggle invest")
|
||||
2200000
|
||||
0
|
||||
zw `shouldNotBe` Nothing
|
||||
it "Save Account:" $ do
|
||||
pool <- runNoLoggingT $ initPool "test.db"
|
||||
s <-
|
||||
runSqlite "test.db" $ do
|
||||
selectList [ZcashWalletName ==. "Testing"] []
|
||||
za <- saveAccount pool =<< createZcashAccount "TestAccount" 0 (head s)
|
||||
za `shouldNotBe` Nothing
|
||||
it "Save address:" $ do
|
||||
pool <- runNoLoggingT $ initPool "test.db"
|
||||
acList <-
|
||||
runSqlite "test.db" $
|
||||
selectList [ZcashAccountName ==. "TestAccount"] []
|
||||
zAdd <-
|
||||
saveAddress pool =<<
|
||||
createWalletAddress "Personal123" 0 MainNet External (head acList)
|
||||
addList <-
|
||||
runSqlite "test.db" $
|
||||
selectList
|
||||
[ WalletAddressName ==. "Personal123"
|
||||
, WalletAddressScope ==. ScopeDB External
|
||||
]
|
||||
[]
|
||||
getUA (walletAddressUAddress (entityVal $ head addList)) `shouldBe`
|
||||
"u1trd8cvc6265ywwj4mmvuznsye5ghe2dhhn3zy8kcuyg4vx3svskw9r2dedp5hu6m740vylkqc34t4w9eqkl9fyu5uyzn3af72jg235440ke6tu5cf994eq85n97x69x9824hqejmwz3d8qqthtesrd6gerjupdymldhl9xccejjwfj0dhh9mt4rw4kytp325twlutsxd20rfqhzxu3m"
|
||||
it "Address components are correct" $ do
|
||||
let ua =
|
||||
"utest1mvlny48qd4x94w8vz5u2lrxx0enuquajt72yekgq24p6pjaky3czk6m7x358h7g900ex6gzvdehaekl96qnakjzw8yaasp8y0u3j5jnlfd33trduznh6k3fcn5ek9qc857fgz8ehm37etx94sj58nrkc0k5hurxnuxpcpms3j8uy2t8kt2vy6vetvsfxxdhtjq0yqulqprvh7mf2u3x"
|
||||
isValidUnifiedAddress ua `shouldNotBe` Nothing
|
||||
describe "Function tests" $ do
|
||||
describe "Sapling Decoding" $ do
|
||||
let sk =
|
||||
SaplingSpendingKey
|
||||
"\ETX}\195.\SUB\NUL\NUL\NUL\128\NUL\203\"\229IL\CANJ*\209\EM\145\228m\172\&4\SYNNl\DC3\161\147\SO\157\238H\192\147eQ\143L\201\216\163\180\147\145\156Zs+\146>8\176`ta\161\223\SO\140\177\b;\161\SO\236\151W\148<\STX\171|\DC2\172U\195(I\140\146\214\182\137\211\228\159\128~bV\STXy{m'\224\175\221\219\180!\ENQ_\161\132\240?\255\236\"6\133\181\170t\181\139\143\207\170\211\ENQ\167a\184\163\243\246\140\158t\155\133\138X\a\241\200\140\EMT\GS~\175\249&z\250\214\231\239mi\223\206\STX\t\EM<{V~J\253FB"
|
||||
let tree =
|
||||
SaplingCommitmentTree $
|
||||
hexString
|
||||
"01818f2bd58b1e392334d0565181cc7843ae09e3533b2a50a8f1131af657340a5c001001161f962245812ba5e1804fd0a336bc78fa4ee4441a8e0f1525ca5da1b285d35101120f45afa700b8c1854aa8b9c8fe8ed92118ef790584bfcb926078812a10c83a00000000012f4f72c03f8c937a94919a01a07f21165cc8394295291cb888ca91ed003810390107114fe4bb4cd08b47f6ae47477c182d5da9fe5c189061808c1091e9bf3b4524000001447d6b9100cddd5f80c8cf4ddee2b87eba053bd987465aec2293bd0514e68b0d015f6c95e75f4601a0a31670a7deb970fc8988c611685161d2e1629d0a1a0ebd07015f8b9205e0514fa235d75c150b87e23866b882b39786852d1ab42aab11d31a4a0117ddeb3a5f8d2f6b2d0a07f28f01ab25e03a05a9319275bb86d72fcaef6fc01501f08f39275112dd8905b854170b7f247cf2df18454d4fa94e6e4f9320cca05f24011f8322ef806eb2430dc4a7a41c1b344bea5be946efc7b4349c1c9edb14ff9d39"
|
||||
let nextTree =
|
||||
SaplingCommitmentTree $
|
||||
hexString
|
||||
"01bd8a3f3cfc964332a2ada8c09a0da9dfc24174befb938abb086b9be5ca049e4900100000019f0d7efb00169bb2202152d3266059d208ab17d14642c3339f9075e997160657000000012f4f72c03f8c937a94919a01a07f21165cc8394295291cb888ca91ed003810390107114fe4bb4cd08b47f6ae47477c182d5da9fe5c189061808c1091e9bf3b4524000001447d6b9100cddd5f80c8cf4ddee2b87eba053bd987465aec2293bd0514e68b0d015f6c95e75f4601a0a31670a7deb970fc8988c611685161d2e1629d0a1a0ebd07015f8b9205e0514fa235d75c150b87e23866b882b39786852d1ab42aab11d31a4a0117ddeb3a5f8d2f6b2d0a07f28f01ab25e03a05a9319275bb86d72fcaef6fc01501f08f39275112dd8905b854170b7f247cf2df18454d4fa94e6e4f9320cca05f24011f8322ef806eb2430dc4a7a41c1b344bea5be946efc7b4349c1c9edb14ff9d39"
|
||||
it "Sapling is decoded correctly" $ do
|
||||
so <-
|
||||
runSqlite "zenith.db" $
|
||||
selectList [ShieldOutputTx ==. toSqlKey 38318] []
|
||||
let cmus = map (getHex . shieldOutputCmu . entityVal) so
|
||||
let pos =
|
||||
getSaplingNotePosition <$>
|
||||
(getSaplingWitness =<<
|
||||
updateSaplingCommitmentTree tree (head cmus))
|
||||
let pos1 = getSaplingNotePosition <$> getSaplingWitness tree
|
||||
let pos2 = getSaplingNotePosition <$> getSaplingWitness nextTree
|
||||
case pos of
|
||||
Nothing -> assertFailure "couldn't get note position"
|
||||
Just p -> do
|
||||
print p
|
||||
print pos1
|
||||
print pos2
|
||||
let dn =
|
||||
decodeSaplingOutputEsk
|
||||
sk
|
||||
(ShieldedOutput
|
||||
(getHex $ shieldOutputCv $ entityVal $ head so)
|
||||
(getHex $ shieldOutputCmu $ entityVal $ head so)
|
||||
(getHex $ shieldOutputEphKey $ entityVal $ head so)
|
||||
(getHex $ shieldOutputEncCipher $ entityVal $ head so)
|
||||
(getHex $ shieldOutputOutCipher $ entityVal $ head so)
|
||||
(getHex $ shieldOutputProof $ entityVal $ head so))
|
||||
TestNet
|
||||
External
|
||||
p
|
||||
case dn of
|
||||
Nothing -> assertFailure "couldn't decode Sap output"
|
||||
Just d ->
|
||||
a_nullifier d `shouldBe`
|
||||
hexString
|
||||
"6c5d1413c63a9a88db71c3f41dc12cd60197ee742fc75b217215e7144db48bd3"
|
||||
describe "Note selection for Tx" $ do
|
||||
it "Value less than balance" $ do
|
||||
pool <- runNoLoggingT $ initPool "zenith.db"
|
||||
res <- selectUnspentNotes pool (toSqlKey 1) 14000000
|
||||
res `shouldNotBe` ([], [], [])
|
||||
it "Value greater than balance" $ do
|
||||
pool <- runNoLoggingT $ initPool "zenith.db"
|
||||
let res = selectUnspentNotes pool (toSqlKey 1) 84000000
|
||||
res `shouldThrow` anyIOException
|
||||
it "Fee calculation" $ do
|
||||
pool <- runNoLoggingT $ initPool "zenith.db"
|
||||
res <- selectUnspentNotes pool (toSqlKey 1) 14000000
|
||||
calculateTxFee res 3 `shouldBe` 20000
|
||||
describe "Testing validation" $ do
|
||||
it "Unified" $ do
|
||||
let a =
|
||||
"utest1zfnw84xuxg0ytzqc008gz0qntr8cvwu4qjsccgtxwdrjywra7uj85x8ldymjc2jd3jvvvhyj3xwsunyvwkr5084t6p5gmvzwdgvwpflrpd6a3squ2dp8vt7cxngmwk30l44wkmvyfegypqmezxfnqj572lr779gkqj5xekp66uv4jga58alnc5j7tuank758zd96ap4f09udg6y6pxu"
|
||||
True `shouldBe`
|
||||
(case isValidUnifiedAddress (E.encodeUtf8 a) of
|
||||
Just _a1 -> True
|
||||
Nothing ->
|
||||
isValidShieldedAddress (E.encodeUtf8 a) ||
|
||||
(case decodeTransparentAddress (E.encodeUtf8 a) of
|
||||
Just _a3 -> True
|
||||
Nothing ->
|
||||
case decodeExchangeAddress a of
|
||||
Just _a4 -> True
|
||||
Nothing -> False))
|
||||
it "Sapling" $ do
|
||||
let a =
|
||||
"ztestsapling1tgjr4zppwk4ne8xy6gdq4z2gwq7dmf5jq8z2ctpn8nlmtse0a74fa5z0m8z383gmpgqz6q6duu4"
|
||||
True `shouldBe`
|
||||
(case isValidUnifiedAddress (E.encodeUtf8 a) of
|
||||
Just _a1 -> True
|
||||
Nothing ->
|
||||
isValidShieldedAddress (E.encodeUtf8 a) ||
|
||||
(case decodeTransparentAddress (E.encodeUtf8 a) of
|
||||
Just _a3 -> True
|
||||
Nothing ->
|
||||
case decodeExchangeAddress a of
|
||||
Just _a4 -> True
|
||||
Nothing -> False))
|
||||
it "Transparent" $ do
|
||||
let a = "tmGfVZHuGVJ5vcLAgBdkUU4w7fLTRE5nXm3"
|
||||
True `shouldBe`
|
||||
(case isValidUnifiedAddress (E.encodeUtf8 a) of
|
||||
Just _a1 -> True
|
||||
Nothing ->
|
||||
isValidShieldedAddress (E.encodeUtf8 a) ||
|
||||
(case decodeTransparentAddress (E.encodeUtf8 a) of
|
||||
Just _a3 -> True
|
||||
Nothing ->
|
||||
case decodeExchangeAddress a of
|
||||
Just _a4 -> True
|
||||
Nothing -> False))
|
||||
it "Check Sapling Address" $ do
|
||||
let a =
|
||||
encodeSaplingAddress TestNet $
|
||||
SaplingReceiver
|
||||
"Z$:\136!u\171<\156\196\210\SUB\n\137Hp<\221\166\146\SOH\196\172,3<\255\181\195/\239\170\158\208O\217\197\DC3\197\ESC\n\NUL-"
|
||||
a `shouldBe`
|
||||
Just
|
||||
"ztestsapling1tgjr4zppwk4ne8xy6gdq4z2gwq7dmf5jq8z2ctpn8nlmtse0a74fa5z0m8z383gmpgqz6q6duu4"
|
||||
{-describe "Creating Tx" $ do-}
|
||||
{-xit "To Orchard" $ do-}
|
||||
{-let uaRead =-}
|
||||
{-isValidUnifiedAddress-}
|
||||
{-"utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax"-}
|
||||
{-case uaRead of-}
|
||||
{-Nothing -> assertFailure "wrong address"-}
|
||||
{-Just ua -> do-}
|
||||
{-tx <--}
|
||||
{-prepareTx-}
|
||||
{-"zenith.db"-}
|
||||
{-TestNet-}
|
||||
{-(toSqlKey 1)-}
|
||||
{-2819811-}
|
||||
{-0.04-}
|
||||
{-ua-}
|
||||
{-"sent with Zenith, test"-}
|
||||
{-tx `shouldBe` Right (hexString "deadbeef")-}
|
||||
|
|
|
|||
1
zcash-haskell
Submodule
1
zcash-haskell
Submodule
|
|
@ -0,0 +1 @@
|
|||
Subproject commit 9dddb42bb3ab78ed0c4d44efb00960ac112c2ce6
|
||||
1007
zebra_openapi.yaml
Normal file
1007
zebra_openapi.yaml
Normal file
File diff suppressed because it is too large
Load diff
138
zenith.cabal
138
zenith.cabal
|
|
@ -1,65 +1,93 @@
|
|||
cabal-version: 1.12
|
||||
cabal-version: 3.0
|
||||
name: zenith
|
||||
version: 0.5.0.0
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Rene Vergara
|
||||
maintainer: pitmutt@vergara.tech
|
||||
copyright: (c) 2022-2024 Vergara Technologies LLC
|
||||
build-type: Custom
|
||||
category: Blockchain
|
||||
extra-doc-files:
|
||||
README.md
|
||||
CHANGELOG.md
|
||||
zenith.cfg
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.35.1.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
name: zenith
|
||||
version: 0.4.0
|
||||
synopsis: Haskell CLI for Zcash Full Node
|
||||
description: Please see the README on repo at <https://git.vergara.tech/Vergara_Tech/zenith#readme>
|
||||
author: Rene Vergara
|
||||
maintainer: rene@vergara.network
|
||||
copyright: Copyright (c) 2022 Vergara Technologies LLC
|
||||
license: BOSL
|
||||
license-file: LICENSE
|
||||
build-type: Simple
|
||||
extra-source-files:
|
||||
README.md
|
||||
CHANGELOG.md
|
||||
zenith.cfg
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://git.vergara.tech/Vergara_Tech/zenith
|
||||
custom-setup
|
||||
setup-depends:
|
||||
base >= 4.12 && < 5
|
||||
, Cabal >= 3.2.0.0
|
||||
, directory >= 1.3.6.0
|
||||
, filepath >= 1.3.0.2
|
||||
, regex-base
|
||||
, regex-compat
|
||||
|
||||
library
|
||||
ghc-options: -Wall -Wunused-imports
|
||||
exposed-modules:
|
||||
Zenith
|
||||
other-modules:
|
||||
Paths_zenith
|
||||
Zenith.CLI
|
||||
Zenith.Core
|
||||
Zenith.DB
|
||||
Zenith.Types
|
||||
Zenith.Utils
|
||||
Zenith.Zcashd
|
||||
Zenith.Scanner
|
||||
hs-source-dirs:
|
||||
src
|
||||
src
|
||||
build-depends:
|
||||
Clipboard
|
||||
, aeson
|
||||
, array
|
||||
, base >=4.7 && <5
|
||||
, ascii-progress
|
||||
, base >=4.12 && <5
|
||||
, base64-bytestring
|
||||
, blake2
|
||||
, brick
|
||||
, bytestring
|
||||
, esqueleto
|
||||
, resource-pool
|
||||
, binary
|
||||
, exceptions
|
||||
, monad-logger
|
||||
, vty-crossplatform
|
||||
, secp256k1-haskell
|
||||
, pureMD5
|
||||
, ghc
|
||||
, haskoin-core
|
||||
, hexstring
|
||||
, http-client
|
||||
, http-conduit
|
||||
, http-types
|
||||
, microlens
|
||||
, microlens-mtl
|
||||
, microlens-th
|
||||
, mtl
|
||||
, persistent
|
||||
, Hclip
|
||||
, persistent-sqlite
|
||||
, persistent-template
|
||||
, process
|
||||
, regex-base
|
||||
, regex-compat
|
||||
, regex-posix
|
||||
, scientific
|
||||
, text
|
||||
, time
|
||||
, vector
|
||||
, vty
|
||||
, word-wrap
|
||||
, zcash-haskell
|
||||
--pkgconfig-depends: rustzcash_wrapper
|
||||
default-language: Haskell2010
|
||||
|
||||
executable zenith
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
Paths_zenith
|
||||
hs-source-dirs:
|
||||
app
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wunused-imports
|
||||
app
|
||||
build-depends:
|
||||
base >=4.7 && <5
|
||||
base >=4.12 && <5
|
||||
, brick
|
||||
, bytestring
|
||||
, configurator
|
||||
, data-default
|
||||
|
|
@ -68,17 +96,45 @@ executable zenith
|
|||
, text
|
||||
, time
|
||||
, zenith
|
||||
, zcash-haskell
|
||||
pkgconfig-depends: rustzcash_wrapper
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite zenith-test
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
other-modules:
|
||||
Paths_zenith
|
||||
executable zenscan
|
||||
ghc-options: -main-is ZenScan -threaded -rtsopts -with-rtsopts=-N
|
||||
main-is: ZenScan.hs
|
||||
hs-source-dirs:
|
||||
test
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||
app
|
||||
build-depends:
|
||||
base >=4.7 && <5
|
||||
base >=4.12 && <5
|
||||
, configurator
|
||||
, monad-logger
|
||||
, zenith
|
||||
pkgconfig-depends: rustzcash_wrapper
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite zenith-tests
|
||||
type: exitcode-stdio-1.0
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||
main-is: Spec.hs
|
||||
hs-source-dirs:
|
||||
test
|
||||
build-depends:
|
||||
base >=4.12 && <5
|
||||
, bytestring
|
||||
, configurator
|
||||
, monad-logger
|
||||
, data-default
|
||||
, sort
|
||||
, text
|
||||
, time
|
||||
, persistent
|
||||
, persistent-sqlite
|
||||
, hspec
|
||||
, hexstring
|
||||
, HUnit
|
||||
, directory
|
||||
, zcash-haskell
|
||||
, zenith
|
||||
pkgconfig-depends: rustzcash_wrapper
|
||||
default-language: Haskell2010
|
||||
|
|
|
|||
|
|
@ -1,2 +1,5 @@
|
|||
nodeUser = "user"
|
||||
nodePwd = "superSecret"
|
||||
dbFilePath = "zenith.db"
|
||||
zebraHost = "127.0.0.1"
|
||||
zebraPort = 18232
|
||||
|
|
|
|||
Loading…
Reference in a new issue