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/
|
.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"]
|
[submodule "zcash-haskell"]
|
||||||
path = 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/),
|
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).
|
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]
|
## [0.4.0]
|
||||||
|
|
||||||
### Added
|
### Added
|
||||||
|
|
|
||||||
190
LICENSE
190
LICENSE
|
|
@ -1,178 +1,22 @@
|
||||||
Copyright (c) 2022 Vergara Technologies
|
MIT License
|
||||||
|
|
||||||
=======================================================
|
Copyright (c) 2022-2024 Vergara Technologies LLC
|
||||||
Bootstrap Open Source Licence ("BOSL") v. 1.0
|
|
||||||
=======================================================
|
|
||||||
This Bootstrap Open Source Licence (the "License") applies to any original work
|
|
||||||
of authorship (the "Original Work") whose owner (the "Licensor") has placed the
|
|
||||||
following licensing notice adjacent to the copyright notice for the Original
|
|
||||||
Work:
|
|
||||||
|
|
||||||
*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,
|
The above copyright notice and this permission notice shall be included in all
|
||||||
royalty-free, non-exclusive, sublicensable license, for the duration of the
|
copies or substantial portions of the Software.
|
||||||
copyright in the Original Work, to do the following:
|
|
||||||
|
|
||||||
a. to reproduce the Original Work in copies, either alone or as part of
|
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||||
a collective work;
|
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
|
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:
|
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.
|
- Creating new Unified Addresses.
|
||||||
- Sending transactions with shielded memo support.
|
- 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
|
## Installation
|
||||||
|
|
||||||
- Install dependencies:
|
- 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
|
git clone https://git.vergara.tech/Vergara_Tech/zenith.git
|
||||||
cd zenith
|
cd zenith
|
||||||
git submodule init
|
git submodule init
|
||||||
git submodule update
|
git submodule update --remote
|
||||||
```
|
```
|
||||||
|
|
||||||
- Install using `stack`:
|
- Install using `cabal`:
|
||||||
|
|
||||||
```
|
```
|
||||||
stack install
|
cabal install
|
||||||
```
|
```
|
||||||
|
|
||||||
## Configuration
|
## 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 qualified Data.Text.IO as TIO
|
||||||
import Data.Time.Clock.POSIX
|
import Data.Time.Clock.POSIX
|
||||||
import System.Console.StructuredCLI
|
import System.Console.StructuredCLI
|
||||||
|
import System.Environment (getArgs)
|
||||||
import System.Exit
|
import System.Exit
|
||||||
import System.IO
|
import System.IO
|
||||||
import Text.Read (readMaybe)
|
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 :: String -> IO String
|
||||||
prompt text = do
|
prompt text = do
|
||||||
|
|
@ -194,14 +200,35 @@ processUri user pwd =
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
config <- load ["zenith.cfg"]
|
config <- load ["zenith.cfg"]
|
||||||
|
args <- getArgs
|
||||||
|
dbFilePath <- require config "dbFilePath"
|
||||||
nodeUser <- require config "nodeUser"
|
nodeUser <- require config "nodeUser"
|
||||||
nodePwd <- require config "nodePwd"
|
nodePwd <- require config "nodePwd"
|
||||||
checkServer nodeUser nodePwd
|
zebraPort <- require config "zebraPort"
|
||||||
void $
|
zebraHost <- require config "zebraHost"
|
||||||
runCLI
|
let myConfig = Config dbFilePath zebraHost zebraPort
|
||||||
"Zenith"
|
if not (null args)
|
||||||
def
|
then do
|
||||||
{ getBanner =
|
case head args of
|
||||||
" ______ _ _ _ \n |___ / (_) | | | \n / / ___ _ __ _| |_| |__ \n / / / _ \\ '_ \\| | __| '_ \\ \n / /_| __/ | | | | |_| | | |\n /_____\\___|_| |_|_|\\__|_| |_|\n Zcash Full Node CLI v0.4.0"
|
"legacy" -> do
|
||||||
}
|
checkServer nodeUser nodePwd
|
||||||
(root 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 :: 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
|
custom-setup
|
||||||
version: 0.4.0
|
setup-depends:
|
||||||
synopsis: Haskell CLI for Zcash Full Node
|
base >= 4.12 && < 5
|
||||||
description: Please see the README on repo at <https://git.vergara.tech/Vergara_Tech/zenith#readme>
|
, Cabal >= 3.2.0.0
|
||||||
author: Rene Vergara
|
, directory >= 1.3.6.0
|
||||||
maintainer: rene@vergara.network
|
, filepath >= 1.3.0.2
|
||||||
copyright: Copyright (c) 2022 Vergara Technologies LLC
|
, regex-base
|
||||||
license: BOSL
|
, regex-compat
|
||||||
license-file: LICENSE
|
|
||||||
build-type: Simple
|
|
||||||
extra-source-files:
|
|
||||||
README.md
|
|
||||||
CHANGELOG.md
|
|
||||||
zenith.cfg
|
|
||||||
|
|
||||||
source-repository head
|
|
||||||
type: git
|
|
||||||
location: https://git.vergara.tech/Vergara_Tech/zenith
|
|
||||||
|
|
||||||
library
|
library
|
||||||
|
ghc-options: -Wall -Wunused-imports
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
Zenith
|
Zenith.CLI
|
||||||
other-modules:
|
Zenith.Core
|
||||||
Paths_zenith
|
Zenith.DB
|
||||||
|
Zenith.Types
|
||||||
|
Zenith.Utils
|
||||||
|
Zenith.Zcashd
|
||||||
|
Zenith.Scanner
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
src
|
src
|
||||||
build-depends:
|
build-depends:
|
||||||
Clipboard
|
Clipboard
|
||||||
, aeson
|
, aeson
|
||||||
, array
|
, array
|
||||||
, base >=4.7 && <5
|
, ascii-progress
|
||||||
|
, base >=4.12 && <5
|
||||||
, base64-bytestring
|
, base64-bytestring
|
||||||
, blake2
|
, brick
|
||||||
, bytestring
|
, bytestring
|
||||||
|
, esqueleto
|
||||||
|
, resource-pool
|
||||||
|
, binary
|
||||||
|
, exceptions
|
||||||
|
, monad-logger
|
||||||
|
, vty-crossplatform
|
||||||
|
, secp256k1-haskell
|
||||||
|
, pureMD5
|
||||||
|
, ghc
|
||||||
|
, haskoin-core
|
||||||
, hexstring
|
, hexstring
|
||||||
|
, http-client
|
||||||
, http-conduit
|
, http-conduit
|
||||||
, http-types
|
, http-types
|
||||||
|
, microlens
|
||||||
|
, microlens-mtl
|
||||||
|
, microlens-th
|
||||||
|
, mtl
|
||||||
|
, persistent
|
||||||
|
, Hclip
|
||||||
|
, persistent-sqlite
|
||||||
|
, persistent-template
|
||||||
, process
|
, process
|
||||||
, regex-base
|
, regex-base
|
||||||
, regex-compat
|
, regex-compat
|
||||||
, regex-posix
|
, regex-posix
|
||||||
, scientific
|
, scientific
|
||||||
, text
|
, text
|
||||||
|
, time
|
||||||
, vector
|
, vector
|
||||||
|
, vty
|
||||||
|
, word-wrap
|
||||||
, zcash-haskell
|
, zcash-haskell
|
||||||
|
--pkgconfig-depends: rustzcash_wrapper
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
||||||
executable zenith
|
executable zenith
|
||||||
|
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||||
main-is: Main.hs
|
main-is: Main.hs
|
||||||
other-modules:
|
|
||||||
Paths_zenith
|
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
app
|
app
|
||||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wunused-imports
|
|
||||||
build-depends:
|
build-depends:
|
||||||
base >=4.7 && <5
|
base >=4.12 && <5
|
||||||
|
, brick
|
||||||
, bytestring
|
, bytestring
|
||||||
, configurator
|
, configurator
|
||||||
, data-default
|
, data-default
|
||||||
|
|
@ -68,17 +96,45 @@ executable zenith
|
||||||
, text
|
, text
|
||||||
, time
|
, time
|
||||||
, zenith
|
, zenith
|
||||||
|
, zcash-haskell
|
||||||
|
pkgconfig-depends: rustzcash_wrapper
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
||||||
test-suite zenith-test
|
executable zenscan
|
||||||
type: exitcode-stdio-1.0
|
ghc-options: -main-is ZenScan -threaded -rtsopts -with-rtsopts=-N
|
||||||
main-is: Spec.hs
|
main-is: ZenScan.hs
|
||||||
other-modules:
|
|
||||||
Paths_zenith
|
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
test
|
app
|
||||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
|
||||||
build-depends:
|
build-depends:
|
||||||
base >=4.7 && <5
|
base >=4.12 && <5
|
||||||
|
, configurator
|
||||||
|
, monad-logger
|
||||||
, zenith
|
, 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
|
default-language: Haskell2010
|
||||||
|
|
|
||||||
|
|
@ -1,2 +1,5 @@
|
||||||
nodeUser = "user"
|
nodeUser = "user"
|
||||||
nodePwd = "superSecret"
|
nodePwd = "superSecret"
|
||||||
|
dbFilePath = "zenith.db"
|
||||||
|
zebraHost = "127.0.0.1"
|
||||||
|
zebraPort = 18232
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue