Vergara_Tech/zenith
2
0
Fork 0
Code Issues 24 Pull requests Projects Releases 9 Packages Wiki Activity Actions

Merge branch 'rvv001' of git.vergara.tech:Vergara_Tech/zenith into rvv001

Browse source
This commit is contained in:
Rene Vergara 2025-01-03 14:33:19 -06:00
commit cc4ce8a280
Signed by: pitmutt
SSH key fingerprint: SHA256:vNa8FIqbBZjV9hOCkXyOzd7gqWCMCfkcfiPH2zaGfQ0
22 changed files with 5202 additions and 1467 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
.gitignore vendored
View file

@ -5,3 +5,7 @@ zenith.db
zenith.log
zenith.db-shm
zenith.db-wal
test.db
test.db-shm
test.db-wal

2
.gitmodules vendored
View file

@ -1,4 +1,4 @@
[submodule "zcash-haskell"]
path = zcash-haskell
url = https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
branch = milestone2
branch = master

9
CHANGELOG.md
View file

@ -5,7 +5,7 @@ All notable changes to this project will be documented in this file.
The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),
and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html).
## [Unreleased]
## [0.7.0.0-beta]
### Added
@ -20,13 +20,20 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
- `getnewaccount` RPC method
- `getnewaddress` RPC method
- `getoperationstatus` RPC method
- `sendmany` RPC method
- Function `prepareTxV2` implementing `PrivacyPolicy`
- Support for TEX addresses
- Functionality to shield transparent balance
- Functionality to de-shield shielded notes
- Native commitment trees
- Batch append to trees in O(log n)
### Changed
- Detection of changes in database schema for automatic re-scan
- Block tracking for chain re-org detection
- Refactored `ZcashPool`
- Preventing write operations to occur during wallet sync
## [0.6.0.0-beta]

11
app/Main.hs
View file

@ -210,9 +210,18 @@ main = do
zebraPort <- require config "zebraPort"
zebraHost <- require config "zebraHost"
nodePort <- require config "nodePort"
currencyCode <- require config "currencyCode"
dbFP <- getZenithPath
let dbFilePath = T.pack $ dbFP ++ dbFileName
let myConfig = Config dbFilePath zebraHost zebraPort nodeUser nodePwd nodePort
let myConfig =
Config
dbFilePath
zebraHost
zebraPort
nodeUser
nodePwd
nodePort
currencyCode
if not (null args)
then do
case head args

58
app/Server.hs
View file

@ -2,28 +2,51 @@
module Server where
import Control.Exception (throwIO, try)
import Control.Monad (when)
import Control.Concurrent (forkIO, threadDelay)
import Control.Exception (throwIO, throwTo, try)
import Control.Monad (forever, when)
import Control.Monad.Logger (runNoLoggingT)
import Data.Configurator
import qualified Data.Text as T
import Network.Wai.Handler.Warp (run)
import Servant
import System.Exit
import System.Posix.Signals
import ZcashHaskell.Types (ZebraGetBlockChainInfo(..), ZebraGetInfo(..))
import Zenith.Core (checkBlockChain, checkZebra)
import Zenith.DB (initDb)
import Zenith.RPC (State(..), ZenithRPC(..), authenticate, zenithServer)
import Zenith.DB (getWallets, initDb, initPool)
import Zenith.RPC
( State(..)
, ZenithRPC(..)
, authenticate
, scanZebra
, zenithServer
)
import Zenith.Scanner (rescanZebra)
import Zenith.Types (Config(..))
import Zenith.Utils (getZenithPath)
main :: IO ()
main = do
config <- load ["$(HOME)/Zenith/zenith.cfg"]
dbFilePath <- require config "dbFilePath"
dbFileName <- require config "dbFileName"
nodeUser <- require config "nodeUser"
nodePwd <- require config "nodePwd"
zebraPort <- require config "zebraPort"
zebraHost <- require config "zebraHost"
nodePort <- require config "nodePort"
let myConfig = Config dbFilePath zebraHost zebraPort nodeUser nodePwd nodePort
currencyCode <- require config "currencyCode"
dbFP <- getZenithPath
let dbFilePath = T.pack $ dbFP ++ dbFileName
let myConfig =
Config
dbFilePath
zebraHost
zebraPort
nodeUser
nodePwd
nodePort
currencyCode
let ctx = authenticate myConfig :. EmptyContext
w <- try $ checkZebra zebraHost zebraPort :: IO (Either IOError ZebraGetInfo)
case w of
@ -39,6 +62,27 @@ main = do
Left e2 -> throwIO $ userError e2
Right x' -> do
when x' $ rescanZebra zebraHost zebraPort dbFilePath
pool <- runNoLoggingT $ initPool dbFilePath
walList <- getWallets pool $ zgb_net chainInfo
if not (null walList)
then do
scanThread <-
forkIO $
forever $ do
_ <-
scanZebra
dbFilePath
zebraHost
zebraPort
(zgb_net chainInfo)
threadDelay 90000000
putStrLn "Zenith RPC Server 0.7.0.0-beta"
putStrLn "------------------------------"
putStrLn $
"Connected to " ++
show (zgb_net chainInfo) ++
" Zebra " ++
T.unpack (zgi_build zebra) ++ " on port " ++ show zebraPort
let myState =
State
(zgb_net chainInfo)
@ -52,3 +96,5 @@ main = do
(Proxy :: Proxy ZenithRPC)
ctx
(zenithServer myState)
else putStrLn
"No wallets available. Please start Zenith interactively to create a wallet"

BIN
sapling-output.params
View file

Binary file not shown.

BIN
sapling-spend.params
View file

Binary file not shown.

759
src/Zenith/CLI.hs
View file

File diff suppressed because it is too large Load diff

1243
src/Zenith/Core.hs
View file

File diff suppressed because it is too large Load diff

867
src/Zenith/DB.hs
View file

File diff suppressed because it is too large Load diff

697
src/Zenith/GUI.hs
View file

@ -1,6 +1,7 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
module Zenith.GUI where
@ -10,13 +11,20 @@ import Codec.QRCode
import Codec.QRCode.JuicyPixels
import Control.Concurrent (threadDelay)
import Control.Exception (throwIO, try)
import Control.Monad (unless, when)
import Control.Monad (forM_, unless, when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (runFileLoggingT, runNoLoggingT)
import Control.Monad.Logger
( LoggingT
, NoLoggingT
, logDebugN
, runNoLoggingT
, runStderrLoggingT
)
import Data.Aeson
import qualified Data.ByteString as BS
import Data.HexString (toText)
import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.Scientific (Scientific, fromFloatDigits)
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
@ -25,10 +33,11 @@ import Database.Persist
import Lens.Micro ((&), (+~), (.~), (?~), (^.), set)
import Lens.Micro.TH
import Monomer
import qualified Monomer.Lens as L
import System.Directory (getHomeDirectory)
import System.FilePath ((</>))
import Text.Printf
import Text.Printf (printf)
import Text.Wrap (FillScope(..), FillStrategy(..), WrapSettings(..), wrapText)
import TextShow hiding (toText)
import ZcashHaskell.Keys (generateWalletSeedPhrase)
@ -37,12 +46,16 @@ import ZcashHaskell.Orchard
, isValidUnifiedAddress
, parseAddress
)
import ZcashHaskell.Transparent (encodeTransparentReceiver)
import ZcashHaskell.Transparent
( decodeTransparentAddress
, encodeTransparentReceiver
)
import ZcashHaskell.Types
( BlockResponse(..)
, Scope(..)
, ToBytes(..)
, UnifiedAddress(..)
, ValidAddress(..)
, ZcashNet(..)
, ZebraGetBlockChainInfo(..)
, ZebraGetInfo(..)
@ -55,15 +68,24 @@ import Zenith.Scanner (checkIntegrity, processTx, rescanZebra, updateConfs)
import Zenith.Types hiding (ZcashAddress(..))
import Zenith.Utils
( displayAmount
, getChainTip
, getZcashPrice
, isRecipientValidGUI
, isValidString
, isZecAddressValid
, jsonNumber
, padWithZero
, parseZcashPayment
, showAddress
, validBarValue
)
data VkTypeDef
= VkNone
| VkFull
| VkIncoming
deriving (Eq, Show)
data AppEvent
= AppInit
| ShowMsg !T.Text
@ -74,6 +96,7 @@ data AppEvent
| AccountClicked
| MenuClicked
| NewClicked
| ViewingKeysClicked
| NewAddress !(Maybe (Entity ZcashAccount))
| NewAccount !(Maybe (Entity ZcashWallet))
| NewWallet
@ -82,7 +105,7 @@ data AppEvent
| SwitchAddr !Int
| SwitchAcc !Int
| SwitchWal !Int
| UpdateBalance !(Integer, Integer)
| UpdateBalance !(Integer, Integer, Integer, Integer)
| CopyAddr !(Maybe (Entity WalletAddress))
| LoadTxs ![Entity UserTx]
| LoadAddrs ![Entity WalletAddress]
@ -130,6 +153,21 @@ data AppEvent
| CloseShield
| ShowDeShield
| CloseDeShield
| SendDeShield
| SendShield
| StartSync
| TreeSync
| ShowFIATBalance
| DisplayFIATBalance Double Double
| CloseFIATBalance
| ShowViewingKey !VkTypeDef !T.Text
| CopyViewingKey !T.Text !T.Text
| CloseShowVK
| DisplayPaymentURI
| ClosePaymentURI
| DisplayPayUsingURI
| ClosePayUsingURI
| ProcIfValidURI
deriving (Eq, Show)
data AppModel = AppModel
@ -189,6 +227,16 @@ data AppModel = AppModel
, _tBalanceValid :: !Bool
, _sBalance :: !Integer
, _sBalanceValid :: !Bool
, _displayFIATBalance :: !Bool
, _zPrice :: !Double
, _aBal :: !Double
, _viewingKeyPopup :: !Bool
, _viewingKeyDisplay :: !Bool
, _vkTypeName :: !T.Text
, _vkData :: !T.Text
, _paymentURIDisplay :: !Bool
, _usepmtURIOverlay :: !Bool
, _uriString :: !T.Text
} deriving (Eq, Show)
makeLenses ''AppModel
@ -232,12 +280,16 @@ buildUI wenv model = widgetTree
, modalOverlay `nodeVisible` isJust (model ^. modalMsg)
, adrbookOverlay `nodeVisible` model ^. showAdrBook
, newAdrBkOverlay `nodeVisible` model ^. newAdrBkEntry
, dfBalOverlay `nodeVisible` model ^. displayFIATBalance
, showABAddressOverlay (model ^. abdescrip) (model ^. abaddress) `nodeVisible`
model ^.
showABAddress
, updateABAddressOverlay (model ^. abdescrip) (model ^. abaddress) `nodeVisible`
model ^.
updateABAddress
, showVKOverlay `nodeVisible` model ^. viewingKeyDisplay
, paymentURIOverlay `nodeVisible` model ^. paymentURIDisplay
, pmtUsingURIOverlay `nodeVisible` model ^. usepmtURIOverlay
, shieldOverlay `nodeVisible` model ^. shieldZec
, deShieldOverlay `nodeVisible` model ^. deShieldZec
, msgAdrBookOverlay `nodeVisible` isJust (model ^. msgAB)
@ -309,6 +361,35 @@ buildUI wenv model = widgetTree
[bgColor white, borderB 1 gray, padding 3]
, box_ [alignLeft, onClick ShowDeShield] (label "De-Shield ZEC") `styleBasic`
[bgColor white, borderB 1 gray, padding 3]
, box_
[alignLeft]
(vstack
[ box_
[alignLeft, onClick ViewingKeysClicked]
(hstack
[ label "Viewing Keys"
, filler
, widgetIf (not $ model ^. viewingKeyPopup) $
remixIcon remixMenuUnfoldFill
, widgetIf (model ^. viewingKeyPopup) $
remixIcon remixMenuFoldFill
])
, widgetIf (model ^. viewingKeyPopup) $
animSlideIn viewingKeysBox
]) `styleBasic`
[bgColor white, borderB 1 gray, padding 3]
, box_
[alignLeft, onClick ShowFIATBalance]
(label
("Balance in " <>
T.toUpper (c_currencyCode (model ^. configuration)))) `styleBasic`
[bgColor white, borderB 1 gray, padding 3]
, box_ [alignLeft, onClick DisplayPaymentURI] (label "Create URI") `styleBasic`
[bgColor white, borderB 1 gray, padding 3]
, box_
[alignLeft, onClick DisplayPayUsingURI]
(label "Pay using URI") `styleBasic`
[bgColor white, borderB 1 gray, padding 3]
]) `styleBasic`
[bgColor btnColor, padding 3]
newBox =
@ -328,6 +409,29 @@ buildUI wenv model = widgetTree
(hstack [label "Wallet", filler]) `styleBasic`
[bgColor white, borderB 1 gray, padding 3]
])
viewingKeysBox =
box_
[alignMiddle]
(vstack
[ box_
[ alignLeft
, onClick
(ShowViewingKey
VkFull
"VKFull->ztestsapling1tgjr4zppwk4ne8xy6gdq4z2gwq7dmf5jq8z2ctpn8nlmtse0a74fa5z0m8z383gmpgqz6q6duu4")
]
(hstack [label "Full VK", filler]) `styleBasic`
[bgColor white, borderB 1 gray, padding 3]
, box_
[ alignLeft
, onClick $
(ShowViewingKey
VkIncoming
"VKIncoming->ztestsapling1tgjr4zppwk4ne8xy6gdq4z2gwq7dmf5jq8z2ctpn8nlmtse0a74fa5z0m8z383gmpgqz6q6duu4")
]
(hstack [label "Incoming VK", filler]) `styleBasic`
[bgColor white, borderB 1 gray, padding 3]
])
walletButton =
hstack
[ label "Wallet: " `styleBasic` [textFont "Bold", textColor white]
@ -740,7 +844,7 @@ buildUI wenv model = widgetTree
box
(label (fromMaybe "?" $ model ^. modalMsg) `styleBasic`
[textSize 12, textFont "Bold"]) `styleBasic`
[bgColor (white & L.a .~ 0.5)]
[bgColor (white & L.a .~ 0.7)]
txOverlay =
case model ^. showTx of
Nothing -> alert CloseTx $ label "N/A"
@ -974,6 +1078,49 @@ buildUI wenv model = widgetTree
, label_ (txtWrapN (fromMaybe "" (model ^. msgAB)) 64) [multiline]
, filler
]
dfBalOverlay =
alert CloseFIATBalance $
vstack
[ box_
[]
(label
("Account Balance in " <>
(T.toUpper (c_currencyCode (model ^. configuration)))) `styleBasic`
[textFont "Bold", textSize 12, textColor white]) `styleBasic`
[bgColor btnColor, radius 2, padding 3]
, filler
, (label
("1 ZEC = " <>
(T.pack (printf "%.2f" (model ^. zPrice))) <>
" " <> (T.toUpper (c_currencyCode (model ^. configuration))))) `styleBasic`
[]
, filler
, (label
((T.pack (printf "%.8f" (model ^. aBal)) <>
" ZEC = " <>
(T.pack (printf "%.2f" ((model ^. zPrice) * (model ^. aBal)))) <>
" " <> (T.toUpper (c_currencyCode (model ^. configuration)))))) `styleBasic`
[]
]
showVKOverlay =
alert CloseShowVK $
vstack
[ box_
[]
(label ((model ^. vkTypeName) <> " Viewing Key") `styleBasic`
[textFont "Bold", textColor white, textSize 12, padding 3]) `styleBasic`
[bgColor btnColor, radius 2, padding 3]
, spacer
, hstack
[filler, label_ (txtWrapN (model ^. vkData) 64) [multiline], filler]
, spacer
, hstack
[ filler
, button "Copy to Clipboard" $
CopyViewingKey (model ^. vkTypeName) (model ^. vkData)
, filler
]
]
shieldOverlay =
box
(vstack
@ -989,39 +1136,21 @@ buildUI wenv model = widgetTree
[textFont "Bold", textSize 12])
, separatorLine `styleBasic` [fgColor btnColor]
, spacer
, hstack
[ filler
, label ("Amount : " ) `styleBasic`
[width 50, textFont "Bold"]
, spacer
, label (displayAmount (model ^. network) 100 ) `styleBasic`
[width 50, textFont "Bold"]
, filler
-- , spacer
-- , numericField_
-- sendAmount
-- [ decimals 8
-- , minValue 0.0
-- , maxValue
-- (fromIntegral (model ^. tBalance) / 100000000.0)
-- , validInput tBalanceValid
-- , onChange CheckAmount
-- ] `styleBasic`
-- [ width 150
-- , styleIf
-- (not $ model ^. tBalanceValid)
-- (textColor red)
-- ]
]
, label
("Shield " <>
displayAmount (model ^. network) (model ^. tBalance) <>
"?") `styleBasic`
[width 50, textFont "Regular"]
, spacer
, box_
[alignMiddle]
(hstack
[ filler
, mainButton "Proceed" NotImplemented `nodeEnabled` True
-- (model ^. amountValid && model ^. recipientValid)
, mainButton "Proceed" SendShield `nodeEnabled`
True
, spacer
, mainButton "Cancel" CloseShield `nodeEnabled` True
, mainButton "Cancel" CloseShield `nodeEnabled`
True
, filler
])
]) `styleBasic`
@ -1046,14 +1175,25 @@ buildUI wenv model = widgetTree
[textFont "Bold", textSize 12])
, separatorLine `styleBasic` [fgColor btnColor]
, spacer
, hstack
[ (label "Total Transparent : " `styleBasic` [ textFont "Bold" ])
, (label "0.00" )
, box_
[]
(vstack
[ hstack
[ label "Total Transparent : " `styleBasic`
[textFont "Bold"]
, label
(displayAmount
(model ^. network)
(model ^. tBalance))
]
, spacer
, hstack
[ (label "Total Shielded : " `styleBasic` [ textFont "Bold" ])
, (label "0.00" )
[ label "Total Shielded : " `styleBasic`
[textFont "Bold"]
, label
(displayAmount
(model ^. network)
(model ^. sBalance))
]
, spacer
, hstack
@ -1065,7 +1205,8 @@ buildUI wenv model = widgetTree
[ decimals 8
, minValue 0.0
, maxValue
(fromIntegral (model ^. sBalance) / 100000000.0)
(fromIntegral (model ^. sBalance) /
100000000.0)
, validInput sBalanceValid
, onChange CheckAmount
] `styleBasic`
@ -1075,15 +1216,17 @@ buildUI wenv model = widgetTree
(textColor red)
]
]
])
, spacer
, box_
[alignMiddle]
(hstack
[ filler
, mainButton "Proceed" NotImplemented `nodeEnabled` True
-- (model ^. amountValid && model ^. recipientValid)
, mainButton "Proceed" SendDeShield `nodeEnabled`
True
, spacer
, mainButton "Cancel" CloseDeShield `nodeEnabled` True
, mainButton "Cancel" CloseDeShield `nodeEnabled`
True
, filler
])
]) `styleBasic`
@ -1093,7 +1236,106 @@ buildUI wenv model = widgetTree
, filler
]) `styleBasic`
[bgColor (white & L.a .~ 0.5)]
notImplemented = NotImplemented
paymentURIOverlay =
box
(vstack
[ filler
, hstack
[ filler
, box_
[]
(vstack
[ box_
[alignMiddle]
(label "Create URI" `styleBasic`
[textColor white, textFont "Bold", textSize 12]) `styleBasic`
[bgColor btnColor]
, separatorLine `styleBasic` [fgColor btnColor]
, spacer
, hstack
[ label "Amount:" `styleBasic`
[width 50, textFont "Bold"]
, spacer
, numericField_
sendAmount
[ decimals 8
, minValue 0.0
, maxValue
(fromIntegral (model ^. balance) / 100000000.0)
, validInput amountValid
, onChange CheckAmount
] `styleBasic`
[ width 150
, styleIf
(not $ model ^. amountValid)
(textColor red)
]
]
, hstack
[ label "Memo:" `styleBasic`
[width 50, textFont "Bold"]
, spacer
, textArea sendMemo `styleBasic`
[width 150, height 40]
]
, spacer
, box_
[alignMiddle]
(hstack
[ spacer
, mainButton "Create URI" NotImplemented `nodeEnabled`
True
, spacer
, button "Cancel" ClosePaymentURI
, spacer
])
]) `styleBasic`
[radius 4, border 2 btnColor, bgColor white, padding 4]
, filler
]
, filler
]) `styleBasic`
[bgColor (white & L.a .~ 0.5)]
pmtUsingURIOverlay =
box
(vstack
[ filler
, hstack
[ filler
, box_
[]
(vstack
[ box_
[alignMiddle]
(label "Pay using URI" `styleBasic`
[textColor white, textFont "Bold", textSize 12]) `styleBasic`
[bgColor btnColor]
, separatorLine `styleBasic` [fgColor btnColor]
, spacer
, hstack
[ label "URI :" `styleBasic`
[width 30, textFont "Bold"]
, spacer
, textArea uriString `styleBasic`
[width 170, height 30]
]
, spacer
, box_
[alignMiddle]
(hstack
[ spacer
, button "Cancel" ClosePayUsingURI
, spacer
, mainButton "Process" ProcIfValidURI
, spacer
])
]) `styleBasic`
[radius 4, border 2 btnColor, bgColor white, padding 4]
, filler
]
, filler
]) `styleBasic`
[bgColor (white & L.a .~ 0.5)]
generateQRCodes :: Config -> IO ()
generateQRCodes config = do
@ -1216,6 +1458,14 @@ handleEvent wenv node model evt =
False
]
ConfirmCancel -> [Model $ model & confirmTitle .~ Nothing & mainInput .~ ""]
ViewingKeysClicked ->
[Model $ model & viewingKeyPopup .~ not (model ^. viewingKeyPopup)]
NewAddress vk ->
[ Model $
model & confirmTitle ?~ "New Address" & confirmCancel .~ "Cancel" &
menuPopup .~
False
]
ShowSeed -> [Model $ model & showSeed .~ True & menuPopup .~ False]
ShowSend ->
[ Model $
@ -1236,7 +1486,7 @@ handleEvent wenv node model evt =
(model ^. network)
(entityKey acc)
(zcashWalletLastSync $ entityVal wal)
(model ^. sendAmount)
(fromFloatDigits $ model ^. sendAmount)
(model ^. sendRecipient)
(model ^. sendMemo)
(model ^. privacyChoice)
@ -1294,11 +1544,13 @@ handleEvent wenv node model evt =
UpdateBalance <$> do
dbPool <- runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration
case selectAccount i of
Nothing -> return (0, 0)
Nothing -> return (0, 0, 0, 0)
Just acc -> do
b <- getBalance dbPool $ entityKey acc
u <- getUnconfirmedBalance dbPool $ entityKey acc
return (b, u)
s <- getShieldedBalance dbPool $ entityKey acc
t <- getTransparentBalance dbPool $ entityKey acc
return (b, u, s, t)
, Event $ SetPool OrchardPool
]
SwitchWal i ->
@ -1310,9 +1562,9 @@ handleEvent wenv node model evt =
Nothing -> return []
Just wal -> runNoLoggingT $ getAccounts dbPool $ entityKey wal
]
UpdateBalance (b, u) ->
UpdateBalance (b, u, s, t) ->
[ Model $
model & balance .~ b & unconfBalance .~
model & balance .~ b & sBalance .~ s & tBalance .~ t & unconfBalance .~
(if u == 0
then Nothing
else Just u)
@ -1362,7 +1614,7 @@ handleEvent wenv node model evt =
else [Event $ NewAccount currentWallet]
LoadWallets a ->
if not (null a)
then [ Model $ model & wallets .~ a
then [ Model $ model & wallets .~ a & modalMsg .~ Nothing
, Event $ SwitchWal $ model ^. selWallet
]
else [Event NewWallet]
@ -1372,11 +1624,15 @@ handleEvent wenv node model evt =
CloseTxId -> [Model $ model & showId .~ Nothing]
ShowTx i -> [Model $ model & showTx ?~ i]
TickUp ->
if (model ^. timer) < 90
if isNothing (model ^. modalMsg)
then if (model ^. timer) < 90
then [Model $ model & timer .~ (1 + model ^. timer)]
else if (model ^. barValue) == 1.0
then [ Model $ model & timer .~ 0 & barValue .~ 0.0
then [ Model $
model & timer .~ 0 & barValue .~ 0.0 & modalMsg ?~
"Downloading blocks..."
, Producer $
runNoLoggingT .
scanZebra
(c_dbPath $ model ^. configuration)
(c_zebraHost $ model ^. configuration)
@ -1384,21 +1640,23 @@ handleEvent wenv node model evt =
(model ^. network)
]
else [Model $ model & timer .~ 0]
SyncVal i ->
if (i + model ^. barValue) >= 0.999
then [ Model $ model & barValue .~ 1.0 & modalMsg .~ Nothing
else [Model $ model & timer .~ 0]
TreeSync -> [Model $ model & modalMsg ?~ "Updating commitment trees..."]
StartSync ->
[ Model $ model & modalMsg ?~ "Updating wallet..."
, Task $ do
case currentWallet of
Nothing -> return $ ShowError "No wallet available"
Just cW -> do
runFileLoggingT "zenith.log" $
syncWallet (model ^. configuration) cW
runNoLoggingT $ syncWallet (model ^. configuration) cW
pool <-
runNoLoggingT $
initPool $ c_dbPath $ model ^. configuration
runNoLoggingT $ initPool $ c_dbPath $ model ^. configuration
wL <- getWallets pool (model ^. network)
return $ LoadWallets wL
]
SyncVal i ->
if (i + model ^. barValue) >= 0.999
then [Model $ model & barValue .~ 1.0 & modalMsg .~ Nothing]
else [ Model $
model & barValue .~ validBarValue (i + model ^. barValue) &
modalMsg ?~
@ -1468,6 +1726,11 @@ handleEvent wenv node model evt =
, setClipboardData $ ClipboardText a
, Event $ ShowMessage "Address copied!!"
]
CopyViewingKey t v ->
[ setClipboardData ClipboardEmpty
, setClipboardData $ ClipboardText v
, Event $ ShowMessage (t <> " viewing key copied!!")
]
DeleteABEntry a ->
[ Task $ deleteAdrBook (model ^. configuration) a
, Model $
@ -1483,9 +1746,101 @@ handleEvent wenv node model evt =
model & msgAB ?~ "Function not implemented..." & menuPopup .~ False
]
CloseMsgAB -> [Model $ model & msgAB .~ Nothing & inError .~ False]
ShowShield -> [ Model $ model & shieldZec .~ True & menuPopup .~ False ]
CloseShowVK ->
[ Model $
model & vkTypeName .~ "" & vkData .~ "" & viewingKeyDisplay .~ False
]
--
-- Show Balance in FIAT
--
DisplayFIATBalance zpr abal ->
[ Model $
model & zPrice .~ zpr & aBal .~ abal & displayFIATBalance .~ True &
menuPopup .~
False
]
ShowFIATBalance ->
if model ^. network == MainNet
then [Task $ sfBalance (model ^. configuration)]
else [ Model $ model & zPrice .~ 0.0 & aBal .~ 0.0
, Event $ ShowError "Balance conversion not available for TestNet"
]
CloseFIATBalance -> [Model $ model & displayFIATBalance .~ False]
--
-- Show Viewing Keys
--
ShowViewingKey vkType vkText ->
case vkType of
VkFull ->
[ Model $
model & vkTypeName .~ "Full" & vkData .~ vkText & viewingKeyDisplay .~
True &
menuPopup .~
False
]
VkIncoming ->
[ Model $
model & vkTypeName .~ "Incoming" & vkData .~ vkText &
viewingKeyDisplay .~
True &
menuPopup .~
False
]
--
-- Display PaymentURI Form
--
DisplayPaymentURI ->
[ Model $
model & paymentURIDisplay .~ True & uriString .~ "" & menuPopup .~ False
]
ClosePaymentURI -> [Model $ model & paymentURIDisplay .~ False]
--
-- Display Pay using URI Form
--
DisplayPayUsingURI ->
[Model $ model & usepmtURIOverlay .~ True & menuPopup .~ False]
ClosePayUsingURI -> [Model $ model & usepmtURIOverlay .~ False]
ProcIfValidURI -> do
let zp = parseZcashPayment $ T.unpack (model ^. uriString)
case zp of
Right p -> do
case uriAmount p of
Just a ->
[ Model $
model & usepmtURIOverlay .~ False & openSend .~ True &
privacyChoice .~
Full &
recipientValid .~
False &
sendRecipient .~
T.pack (uriAddress p) &
sendAmount .~
realToFrac a &
sendMemo .~
(uriMemo p)
, Event $ ClosePaymentURI
]
Nothing ->
[ Model $
model & usepmtURIOverlay .~ False & openSend .~ False &
uriString .~
""
, Event $ ShowError "Invalid URI"
]
Left e ->
[ Model $
model & usepmtURIOverlay .~ False & openSend .~ False & uriString .~
""
, Event $ ShowError "Invalid URI"
]
--
--
ShowShield ->
if model ^. tBalance > 0
then [Model $ model & shieldZec .~ True & menuPopup .~ False]
else [Event $ ShowError "No transparent funds in this account"]
CloseShield -> [Model $ model & shieldZec .~ False]
ShowDeShield -> [ Model $ model & deShieldZec .~ True & menuPopup .~ False ]
ShowDeShield -> [Model $ model & deShieldZec .~ True & menuPopup .~ False]
CloseDeShield -> [Model $ model & deShieldZec .~ False]
LoadAbList a -> [Model $ model & abaddressList .~ a]
UpdateABDescrip d a ->
@ -1499,6 +1854,31 @@ handleEvent wenv node model evt =
abList <- getAdrBook dbPool $ model ^. network
return $ LoadAbList abList
]
SendDeShield ->
case currentAccount of
Nothing ->
[Event $ ShowError "No account available", Event CloseDeShield]
Just acc ->
[ Producer $
deshieldTransaction
(model ^. configuration)
(model ^. network)
(entityKey acc)
currentAddress
(fromFloatDigits $ model ^. sendAmount)
, Event CloseDeShield
]
SendShield ->
case currentAccount of
Nothing -> [Event $ ShowError "No account available", Event CloseShield]
Just acc ->
[ Producer $
shieldTransaction
(model ^. configuration)
(model ^. network)
(entityKey acc)
, Event CloseShield
]
where
currentWallet =
if null (model ^. wallets)
@ -1612,33 +1992,77 @@ handleEvent wenv node model evt =
pool <- runNoLoggingT $ initPool $ c_dbPath config
res <- liftIO $ updateAdrsInAdrBook pool d a a
return $ ShowMessage "Address Book entry updated!!"
--
dbal :: Integer -> Double
dbal a = fromIntegral a
--
sfBalance :: Config -> IO AppEvent
sfBalance config = do
zpr <- liftIO $ getZcashPrice $ c_currencyCode config
case zpr of
Just zp -> do
let zbal = (dbal (model ^. balance)) / 100000000
return $ DisplayFIATBalance zp zbal
Nothing ->
return $
ShowMessage
("Currency not supported [" <> c_currencyCode config <> "]")
--
procIfValidURI :: T.Text -> IO AppEvent
procIfValidURI ustr = do
return $ ShowSend
-- model & recipientValid .~ ((model ^. privacyChoice) == Low) ]
scanZebra :: T.Text -> T.Text -> Int -> ZcashNet -> (AppEvent -> IO ()) -> IO ()
scanZebra ::
T.Text
-> T.Text
-> Int
-> ZcashNet
-> (AppEvent -> IO ())
-> NoLoggingT IO ()
scanZebra dbPath zHost zPort net sendMsg = do
bStatus <- liftIO $ checkBlockChain zHost zPort
pool <- runNoLoggingT $ initPool dbPath
b <- liftIO $ getMinBirthdayHeight pool
dbBlock <- getMaxBlock pool $ ZcashNetDB net
chkBlock <- checkIntegrity dbPath zHost zPort dbBlock 1
unless (chkBlock == dbBlock) $ rewindWalletData pool chkBlock
pool <- liftIO $ runNoLoggingT $ initPool dbPath
b <- liftIO $ getMinBirthdayHeight pool $ ZcashNetDB net
dbBlock <- liftIO $ getMaxBlock pool $ ZcashNetDB net
chkBlock <- liftIO $ checkIntegrity dbPath zHost zPort net dbBlock 1
logDebugN $ "dbBlock: " <> T.pack (show dbBlock)
logDebugN $ "chkBlock: " <> T.pack (show chkBlock)
syncChk <- liftIO $ isSyncing pool
if syncChk
then liftIO $ sendMsg (ShowError "Sync already in progress")
else do
let sb =
if chkBlock == dbBlock
then max dbBlock b
else max chkBlock b
unless (chkBlock == dbBlock || chkBlock == 1) $
rewindWalletData pool sb $ ZcashNetDB net
if sb > zgb_blocks bStatus || sb < 1
then sendMsg (ShowError "Invalid starting block for scan")
then liftIO $ sendMsg (ShowError "Invalid starting block for scan")
else do
let bList = [(sb + 1) .. (zgb_blocks bStatus)]
if not (null bList)
then do
let step = (1.0 :: Float) / fromIntegral (length bList)
mapM_ (processBlock pool step) bList
else sendMsg (SyncVal 1.0)
confUp <- try $ updateConfs zHost zPort pool :: IO (Either IOError ())
_ <- liftIO $ startSync pool
mapM_ (liftIO . processBlock pool step) bList
confUp <-
liftIO $ try $ updateConfs zHost zPort pool :: NoLoggingT
IO
(Either IOError ())
case confUp of
Left _e0 -> sendMsg (ShowError "Failed to update unconfirmed transactions")
Right _ -> return ()
Left _e0 -> do
_ <- liftIO $ completeSync pool Failed
liftIO $
sendMsg
(ShowError "Failed to update unconfirmed transactions")
Right _ -> do
liftIO $ sendMsg TreeSync
_ <- updateCommitmentTrees pool zHost zPort $ ZcashNetDB net
_ <- liftIO $ completeSync pool Successful
logDebugN "Starting wallet sync"
liftIO $ sendMsg StartSync
else liftIO $ sendMsg (SyncVal 1.0)
where
processBlock :: ConnectionPool -> Float -> Int -> IO ()
processBlock pool step bl = do
@ -1650,7 +2074,9 @@ scanZebra dbPath zHost zPort net sendMsg = do
"getblock"
[Data.Aeson.String $ showt bl, jsonNumber 1]
case r of
Left e1 -> sendMsg (ShowError $ showt e1)
Left e1 -> do
_ <- completeSync pool Failed
sendMsg (ShowError $ showt e1)
Right blk -> do
r2 <-
liftIO $
@ -1660,7 +2086,9 @@ scanZebra dbPath zHost zPort net sendMsg = do
"getblock"
[Data.Aeson.String $ showt bl, jsonNumber 0]
case r2 of
Left e2 -> sendMsg (ShowError $ showt e2)
Left e2 -> do
_ <- completeSync pool Failed
sendMsg (ShowError $ showt e2)
Right hb -> do
let blockTime = getBlockTime hb
bi <-
@ -1674,12 +2102,89 @@ scanZebra dbPath zHost zPort net sendMsg = do
mapM_ (processTx zHost zPort bi pool) $ bl_txs blk
sendMsg (SyncVal step)
shieldTransaction ::
Config -> ZcashNet -> ZcashAccountId -> (AppEvent -> IO ()) -> IO ()
shieldTransaction config znet accId sendMsg = do
sendMsg $ ShowModal "Shielding funds..."
let dbPath = c_dbPath config
let zHost = c_zebraHost config
let zPort = c_zebraPort config
pool <- runNoLoggingT $ initPool dbPath
bl <- getChainTip zHost zPort
res <- runNoLoggingT $ shieldTransparentNotes pool zHost zPort znet accId bl
forM_ res $ \case
Left e -> sendMsg $ ShowError $ T.pack (show e)
Right rawTx -> do
sendMsg $ ShowMsg "Transaction ready, sending to Zebra..."
resp <-
makeZebraCall
zHost
zPort
"sendrawtransaction"
[Data.Aeson.String $ toText rawTx]
case resp of
Left e1 -> sendMsg $ ShowError $ "Zebra error: " <> T.pack (show e1)
Right txId -> sendMsg $ ShowTxId txId
deshieldTransaction ::
Config
-> ZcashNet
-> ZcashAccountId
-> Maybe (Entity WalletAddress)
-> Scientific
-> (AppEvent -> IO ())
-> IO ()
deshieldTransaction config znet accId addR pnote sendMsg = do
case addR of
Nothing -> sendMsg $ ShowError "No address available"
Just addr -> do
sendMsg $ ShowModal "De-shielding funds..."
let dbPath = c_dbPath config
let zHost = c_zebraHost config
let zPort = c_zebraPort config
pool <- runNoLoggingT $ initPool dbPath
bl <- getChainTip zHost zPort
let tAddrMaybe =
Transparent <$>
((decodeTransparentAddress .
E.encodeUtf8 . encodeTransparentReceiver znet) =<<
(t_rec =<<
(isValidUnifiedAddress .
E.encodeUtf8 . getUA . walletAddressUAddress)
(entityVal addr)))
case tAddrMaybe of
Nothing -> sendMsg $ ShowError "No transparent address available"
Just tAddr -> do
res <-
runNoLoggingT $
deshieldNotes
pool
zHost
zPort
znet
accId
bl
(ProposedNote (ValidAddressAPI tAddr) pnote Nothing)
case res of
Left e -> sendMsg $ ShowError $ T.pack (show e)
Right rawTx -> do
sendMsg $ ShowModal "Transaction ready, sending to Zebra..."
resp <-
makeZebraCall
zHost
zPort
"sendrawtransaction"
[Data.Aeson.String $ toText rawTx]
case resp of
Left e1 -> sendMsg $ ShowError $ "Zebra error: " <> showt e1
Right txId -> sendMsg $ ShowTxId txId
sendTransaction ::
Config
-> ZcashNet
-> ZcashAccountId
-> Int
-> Float
-> Scientific
-> T.Text
-> T.Text
-> PrivacyPolicy
@ -1695,8 +2200,22 @@ sendTransaction config znet accId bl amt ua memo policy sendMsg = do
let zPort = c_zebraPort config
pool <- runNoLoggingT $ initPool dbPath
res <-
runFileLoggingT "zenith.log" $
prepareTxV2 pool zHost zPort znet accId bl amt addr memo policy
runNoLoggingT $
prepareTxV2
pool
zHost
zPort
znet
accId
bl
[ ProposedNote
(ValidAddressAPI addr)
amt
(if memo == ""
then Nothing
else Just memo)
]
policy
case res of
Left e -> sendMsg $ ShowError $ T.pack $ show e
Right rawTx -> do
@ -1778,6 +2297,14 @@ runZenithGUI config = do
then getUnconfirmedBalance pool $ entityKey $ head accList
else return 0
abList <- getAdrBook pool (zgb_net chainInfo)
shieldBal <-
if not (null accList)
then getShieldedBalance pool $ entityKey $ head accList
else return 0
transBal <-
if not (null accList)
then getTransparentBalance pool $ entityKey $ head accList
else return 0
let model =
AppModel
config
@ -1837,10 +2364,20 @@ runZenithGUI config = do
Full
False
False
0
transBal
False
0
shieldBal
False
False
0.0
0.0
False
False
""
""
False
False
""
startApp model handleEvent buildUI (params hD)
Left _e -> print "Zebra not available"
where

275
src/Zenith/RPC.hs
View file

@ -8,21 +8,28 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DerivingStrategies #-}
module Zenith.RPC where
import Control.Concurrent (forkIO)
import Control.Exception (try)
import Control.Monad (unless, when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (runNoLoggingT)
import Control.Monad.Logger (runFileLoggingT, runNoLoggingT, runStderrLoggingT)
import Data.Aeson
import qualified Data.HexString as H
import Data.Int
import Data.Scientific (floatingOrInteger)
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import Data.Time.Clock (getCurrentTime)
import qualified Data.UUID as U
import Data.UUID.V4 (nextRandom)
import qualified Data.Vector as V
import Database.Esqueleto.Experimental
( entityKey
( ConnectionPool
, entityKey
, entityVal
, fromSqlKey
, toSqlKey
@ -31,43 +38,73 @@ import Servant
import Text.Read (readMaybe)
import ZcashHaskell.Keys (generateWalletSeedPhrase)
import ZcashHaskell.Orchard (parseAddress)
import ZcashHaskell.Types (RpcError(..), Scope(..), ZcashNet(..))
import Zenith.Core (createCustomWalletAddress, createZcashAccount)
import ZcashHaskell.Types
( BlockResponse(..)
, RpcError(..)
, Scope(..)
, ZcashNet(..)
, ZebraGetBlockChainInfo(..)
)
import ZcashHaskell.Utils (getBlockTime, makeZebraCall)
import Zenith.Core
( checkBlockChain
, createCustomWalletAddress
, createZcashAccount
, prepareTxV2
, syncWallet
, updateCommitmentTrees
)
import Zenith.DB
( Operation(..)
, ZcashAccount(..)
, ZcashBlock(..)
, ZcashWallet(..)
, completeSync
, finalizeOperation
, findNotesByAddress
, getAccountById
, getAccounts
, getAddressById
, getAddresses
, getExternalAddresses
, getLastSyncBlock
, getMaxAccount
, getMaxAddress
, getMaxBlock
, getMinBirthdayHeight
, getOperation
, getPoolBalance
, getUnconfPoolBalance
, getWalletNotes
, getWallets
, initPool
, isSyncing
, rewindWalletData
, saveAccount
, saveAddress
, saveBlock
, saveOperation
, saveWallet
, startSync
, toZcashAccountAPI
, toZcashAddressAPI
, toZcashWalletAPI
, walletExists
)
import Zenith.Scanner (checkIntegrity, processTx, updateConfs)
import Zenith.Types
( AccountBalance(..)
, Config(..)
, HexStringDB(..)
, PhraseDB(..)
, PrivacyPolicy(..)
, ProposedNote(..)
, ZcashAccountAPI(..)
, ZcashAddressAPI(..)
, ZcashNetDB(..)
, ZcashNoteAPI(..)
, ZcashWalletAPI(..)
, ZenithStatus(..)
, ZenithUuid(..)
)
import Zenith.Utils (jsonNumber)
@ -83,6 +120,7 @@ data ZenithMethod
| GetNewAccount
| GetNewAddress
| GetOperationStatus
| SendMany
| UnknownMethod
deriving (Eq, Prelude.Show)
@ -97,6 +135,7 @@ instance ToJSON ZenithMethod where
toJSON GetNewAccount = Data.Aeson.String "getnewaccount"
toJSON GetNewAddress = Data.Aeson.String "getnewaddress"
toJSON GetOperationStatus = Data.Aeson.String "getoperationstatus"
toJSON SendMany = Data.Aeson.String "sendmany"
toJSON UnknownMethod = Data.Aeson.Null
instance FromJSON ZenithMethod where
@ -112,6 +151,7 @@ instance FromJSON ZenithMethod where
"getnewaccount" -> pure GetNewAccount
"getnewaddress" -> pure GetNewAddress
"getoperationstatus" -> pure GetOperationStatus
"sendmany" -> pure SendMany
_ -> pure UnknownMethod
data ZenithParams
@ -125,6 +165,7 @@ data ZenithParams
| NameIdParams !T.Text !Int
| NewAddrParams !Int !T.Text !Bool !Bool
| OpParams !ZenithUuid
| SendParams !Int ![ProposedNote] !PrivacyPolicy
| TestParams !T.Text
deriving (Eq, Prelude.Show)
@ -148,6 +189,8 @@ instance ToJSON ZenithParams where
[Data.Aeson.String "ExcludeTransparent" | t]
toJSON (OpParams i) =
Data.Aeson.Array $ V.fromList [Data.Aeson.String $ U.toText $ getUuid i]
toJSON (SendParams i ns p) =
Data.Aeson.Array $ V.fromList [jsonNumber i, toJSON ns, toJSON p]
data ZenithResponse
= InfoResponse !T.Text !ZenithInfo
@ -159,6 +202,7 @@ data ZenithResponse
| NewItemResponse !T.Text !Int64
| NewAddrResponse !T.Text !ZcashAddressAPI
| OpResponse !T.Text !Operation
| SendResponse !T.Text !U.UUID
| ErrorResponse !T.Text !Double !T.Text
deriving (Eq, Prelude.Show)
@ -179,6 +223,7 @@ instance ToJSON ZenithResponse where
toJSON (NewItemResponse i ix) = packRpcResponse i ix
toJSON (NewAddrResponse i a) = packRpcResponse i a
toJSON (OpResponse i u) = packRpcResponse i u
toJSON (SendResponse i o) = packRpcResponse i o
instance FromJSON ZenithResponse where
parseJSON =
@ -258,6 +303,10 @@ instance FromJSON ZenithResponse where
case floatingOrInteger k of
Left _e -> fail "Unknown value"
Right k' -> pure $ NewItemResponse i k'
String s -> do
case U.fromText s of
Nothing -> fail "Unknown value"
Just u -> pure $ SendResponse i u
_anyOther -> fail "Malformed JSON"
Just e1 -> pure $ ErrorResponse i (ecode e1) (emessage e1)
@ -416,6 +465,30 @@ instance FromJSON RpcCall where
Nothing -> pure $ RpcCall v i GetOperationStatus BadParams
else pure $ RpcCall v i GetOperationStatus BadParams
_anyOther -> pure $ RpcCall v i GetOperationStatus BadParams
SendMany -> do
p <- obj .: "params"
case p of
Array a ->
if V.length a >= 2
then do
acc <- parseJSON $ a V.! 0
x <- parseJSON $ a V.! 1
case x of
String _ -> do
x' <- parseJSON $ a V.! 1
y <- parseJSON $ a V.! 2
if not (null y)
then pure $ RpcCall v i SendMany (SendParams acc y x')
else pure $ RpcCall v i SendMany BadParams
Array _ -> do
x' <- parseJSON $ a V.! 1
if not (null x')
then pure $
RpcCall v i SendMany (SendParams acc x' Full)
else pure $ RpcCall v i SendMany BadParams
_anyOther -> pure $ RpcCall v i SendMany BadParams
else pure $ RpcCall v i SendMany BadParams
_anyOther -> pure $ RpcCall v i SendMany BadParams
type ZenithRPC
= "status" :> Get '[ JSON] Value :<|> BasicAuth "zenith-realm" Bool :> ReqBody
@ -573,8 +646,16 @@ zenithServer state = getinfo :<|> handleRPC
case parameters req of
NameParams t -> do
let dbPath = w_dbPath state
sP <- liftIO generateWalletSeedPhrase
pool <- liftIO $ runNoLoggingT $ initPool dbPath
syncChk <- liftIO $ isSyncing pool
if syncChk
then return $
ErrorResponse
(callId req)
(-32012)
"The Zenith server is syncing, please try again later."
else do
sP <- liftIO generateWalletSeedPhrase
r <-
liftIO $
saveWallet pool $
@ -601,6 +682,14 @@ zenithServer state = getinfo :<|> handleRPC
NameIdParams t i -> do
let dbPath = w_dbPath state
pool <- liftIO $ runNoLoggingT $ initPool dbPath
syncChk <- liftIO $ isSyncing pool
if syncChk
then return $
ErrorResponse
(callId req)
(-32012)
"The Zenith server is syncing, please try again later."
else do
w <- liftIO $ walletExists pool i
case w of
Just w' -> do
@ -628,7 +717,10 @@ zenithServer state = getinfo :<|> handleRPC
fromSqlKey $ entityKey x
Nothing ->
return $
ErrorResponse (callId req) (-32008) "Wallet does not exist."
ErrorResponse
(callId req)
(-32008)
"Wallet does not exist."
_anyOtherParams ->
return $ ErrorResponse (callId req) (-32602) "Invalid params"
GetNewAddress ->
@ -637,7 +729,16 @@ zenithServer state = getinfo :<|> handleRPC
let dbPath = w_dbPath state
let net = w_network state
pool <- liftIO $ runNoLoggingT $ initPool dbPath
acc <- liftIO $ getAccountById pool $ toSqlKey $ fromIntegral i
syncChk <- liftIO $ isSyncing pool
if syncChk
then return $
ErrorResponse
(callId req)
(-32012)
"The Zenith server is syncing, please try again later."
else do
acc <-
liftIO $ getAccountById pool $ toSqlKey $ fromIntegral i
case acc of
Just acc' -> do
maxAddr <-
@ -656,7 +757,9 @@ zenithServer state = getinfo :<|> handleRPC
case dbAddr of
Just nAddr -> do
return $
NewAddrResponse (callId req) (toZcashAddressAPI nAddr)
NewAddrResponse
(callId req)
(toZcashAddressAPI nAddr)
Nothing ->
return $
ErrorResponse
@ -665,7 +768,10 @@ zenithServer state = getinfo :<|> handleRPC
"Entity with that name already exists."
Nothing ->
return $
ErrorResponse (callId req) (-32006) "Account does not exist."
ErrorResponse
(callId req)
(-32006)
"Account does not exist."
_anyOtherParams ->
return $ ErrorResponse (callId req) (-32602) "Invalid params"
GetOperationStatus ->
@ -682,6 +788,89 @@ zenithServer state = getinfo :<|> handleRPC
ErrorResponse (callId req) (-32009) "Operation ID not found"
_anyOtherParams ->
return $ ErrorResponse (callId req) (-32602) "Invalid params"
SendMany ->
case parameters req of
SendParams a ns p -> do
let dbPath = w_dbPath state
let zHost = w_host state
let zPort = w_port state
let znet = w_network state
pool <- liftIO $ runNoLoggingT $ initPool dbPath
syncChk <- liftIO $ isSyncing pool
if syncChk
then return $
ErrorResponse
(callId req)
(-32012)
"The Zenith server is syncing, please try again later."
else do
opid <- liftIO nextRandom
startTime <- liftIO getCurrentTime
opkey <-
liftIO $
saveOperation pool $
Operation
(ZenithUuid opid)
startTime
Nothing
Processing
Nothing
case opkey of
Nothing ->
return $
ErrorResponse (callId req) (-32010) "Internal Error"
Just opkey' -> do
acc <-
liftIO $ getAccountById pool $ toSqlKey $ fromIntegral a
case acc of
Just acc' -> do
bl <-
liftIO $
getLastSyncBlock
pool
(zcashAccountWalletId $ entityVal acc')
_ <-
liftIO $
forkIO $ do
res <-
liftIO $
runNoLoggingT $
prepareTxV2
pool
zHost
zPort
znet
(entityKey acc')
bl
ns
p
case res of
Left e ->
finalizeOperation pool opkey' Failed $
T.pack $ show e
Right rawTx -> do
zebraRes <-
makeZebraCall
zHost
zPort
"sendrawtransaction"
[Data.Aeson.String $ H.toText rawTx]
case zebraRes of
Left e1 ->
finalizeOperation pool opkey' Failed $
T.pack $ show e1
Right txId ->
finalizeOperation pool opkey' Successful $
"Tx ID: " <> H.toText txId
return $ SendResponse (callId req) opid
Nothing ->
return $
ErrorResponse
(callId req)
(-32006)
"Account does not exist."
_anyOtherParams ->
return $ ErrorResponse (callId req) (-32602) "Invalid params"
authenticate :: Config -> BasicAuthCheck Bool
authenticate config = BasicAuthCheck check
@ -694,3 +883,71 @@ authenticate config = BasicAuthCheck check
packRpcResponse :: ToJSON a => T.Text -> a -> Value
packRpcResponse i x =
object ["jsonrpc" .= ("2.0" :: String), "id" .= i, "result" .= x]
scanZebra :: T.Text -> T.Text -> Int -> ZcashNet -> IO ()
scanZebra dbPath zHost zPort net = do
bStatus <- checkBlockChain zHost zPort
pool <- runNoLoggingT $ initPool dbPath
b <- getMinBirthdayHeight pool $ ZcashNetDB net
dbBlock <- getMaxBlock pool $ ZcashNetDB net
chkBlock <- checkIntegrity dbPath zHost zPort net dbBlock 1
syncChk <- isSyncing pool
unless syncChk $ do
let sb =
if chkBlock == dbBlock
then max dbBlock b
else max chkBlock b
unless (chkBlock == dbBlock || chkBlock == 1) $
runNoLoggingT $ rewindWalletData pool sb $ ZcashNetDB net
unless (sb > zgb_blocks bStatus || sb < 1) $ do
let bList = [(sb + 1) .. (zgb_blocks bStatus)]
unless (null bList) $ do
_ <- startSync pool
mapM_ (processBlock pool) bList
confUp <- try $ updateConfs zHost zPort pool :: IO (Either IOError ())
case confUp of
Left _e0 -> do
_ <- completeSync pool Failed
return ()
Right _ -> do
wals <- getWallets pool net
_ <-
runNoLoggingT $
updateCommitmentTrees pool zHost zPort $ ZcashNetDB net
runNoLoggingT $
mapM_
(syncWallet (Config dbPath zHost zPort "user" "pwd" 8080 "usd"))
wals
_ <- completeSync pool Successful
return ()
where
processBlock :: ConnectionPool -> Int -> IO ()
processBlock pool bl = do
r <-
makeZebraCall
zHost
zPort
"getblock"
[Data.Aeson.String $ T.pack (show bl), jsonNumber 1]
case r of
Left _ -> completeSync pool Failed
Right blk -> do
r2 <-
makeZebraCall
zHost
zPort
"getblock"
[Data.Aeson.String $ T.pack (show bl), jsonNumber 0]
case r2 of
Left _ -> completeSync pool Failed
Right hb -> do
let blockTime = getBlockTime hb
bi <-
saveBlock pool $
ZcashBlock
(fromIntegral $ bl_height blk)
(HexStringDB $ bl_hash blk)
(fromIntegral $ bl_confirmations blk)
blockTime
(ZcashNetDB net)
mapM_ (processTx zHost zPort bi pool) $ bl_txs blk

39
src/Zenith/Scanner.hs
View file

@ -12,6 +12,7 @@ import Control.Monad.Logger
, logInfoN
, runFileLoggingT
, runNoLoggingT
, runStderrLoggingT
)
import Data.Aeson
import Data.HexString
@ -31,12 +32,13 @@ import ZcashHaskell.Types
, fromRawTBundle
)
import ZcashHaskell.Utils (getBlockTime, makeZebraCall, readZebraTransaction)
import Zenith.Core (checkBlockChain, syncWallet)
import Zenith.Core (checkBlockChain, syncWallet, updateCommitmentTrees)
import Zenith.DB
( ZcashBlock(..)
, ZcashBlockId
, clearWalletData
, clearWalletTransactions
, completeSync
, getBlock
, getMaxBlock
, getMinBirthdayHeight
@ -47,9 +49,16 @@ import Zenith.DB
, saveBlock
, saveConfs
, saveTransaction
, startSync
, updateWalletSync
, upgradeQrTable
)
import Zenith.Types
( Config(..)
, HexStringDB(..)
, ZcashNetDB(..)
, ZenithStatus(..)
)
import Zenith.Types (Config(..), HexStringDB(..), ZcashNetDB(..))
import Zenith.Utils (jsonNumber)
@ -74,8 +83,9 @@ rescanZebra host port dbFilePath = do
upgradeQrTable pool1
clearWalletTransactions pool1
clearWalletData pool1
_ <- startSync pool1
dbBlock <- getMaxBlock pool1 znet
b <- liftIO $ getMinBirthdayHeight pool1
b <- liftIO $ getMinBirthdayHeight pool1 znet
let sb = max dbBlock b
if sb > zgb_blocks bStatus || sb < 1
then liftIO $ throwIO $ userError "Invalid starting block for scan"
@ -99,6 +109,8 @@ rescanZebra host port dbFilePath = do
{-mapM_ (processBlock host port pool2 pg2 znet) bl2 `concurrently_`-}
{-mapM_ (processBlock host port pool3 pg3 znet) bl3-}
print "Please wait..."
_ <- completeSync pool1 Successful
_ <- runNoLoggingT $ updateCommitmentTrees pool1 host port znet
print "Rescan complete"
-- | Function to process a raw block and extract the transaction information
@ -119,7 +131,9 @@ processBlock host port pool pg net b = do
"getblock"
[Data.Aeson.String $ T.pack $ show b, jsonNumber 1]
case r of
Left e -> liftIO $ throwIO $ userError e
Left e -> do
_ <- completeSync pool Failed
liftIO $ throwIO $ userError e
Right blk -> do
r2 <-
liftIO $
@ -129,7 +143,9 @@ processBlock host port pool pg net b = do
"getblock"
[Data.Aeson.String $ T.pack $ show b, jsonNumber 0]
case r2 of
Left e2 -> liftIO $ throwIO $ userError e2
Left e2 -> do
_ <- completeSync pool Failed
liftIO $ throwIO $ userError e2
Right hb -> do
let blockTime = getBlockTime hb
bi <-
@ -160,7 +176,9 @@ processTx host port bt pool t = do
"getrawtransaction"
[Data.Aeson.String $ toText t, jsonNumber 1]
case r of
Left e -> liftIO $ throwIO $ userError e
Left e -> do
_ <- completeSync pool Failed
liftIO $ throwIO $ userError e
Right rawTx -> do
case readZebraTransaction (ztr_hex rawTx) of
Nothing -> return ()
@ -223,7 +241,7 @@ clearSync config = do
w <- getWallets pool $ zgb_net chainInfo
liftIO $ mapM_ (updateWalletSync pool 0 . entityKey) w
w' <- liftIO $ getWallets pool $ zgb_net chainInfo
r <- runFileLoggingT "zenith.log" $ mapM (syncWallet config) w'
r <- runNoLoggingT $ mapM (syncWallet config) w'
liftIO $ print r
-- | Detect chain re-orgs
@ -231,10 +249,11 @@ checkIntegrity ::
T.Text -- ^ Database path
-> T.Text -- ^ Zebra host
-> Int -- ^ Zebra port
-> ZcashNet -- ^ the network to scan
-> Int -- ^ The block to start the check
-> Int -- ^ depth
-> IO Int
checkIntegrity dbP zHost zPort b d =
checkIntegrity dbP zHost zPort znet b d =
if b < 1
then return 1
else do
@ -248,10 +267,10 @@ checkIntegrity dbP zHost zPort b d =
Left e -> throwIO $ userError e
Right blk -> do
pool <- runNoLoggingT $ initPool dbP
dbBlk <- getBlock pool b
dbBlk <- getBlock pool b $ ZcashNetDB znet
case dbBlk of
Nothing -> throwIO $ userError "Block mismatch, rescan needed"
Nothing -> return 1
Just dbBlk' ->
if bl_hash blk == getHex (zcashBlockHash $ entityVal dbBlk')
then return b
else checkIntegrity dbP zHost zPort (b - 5 * d) (d + 1)
else checkIntegrity dbP zHost zPort znet (b - 5 * d) (d + 1)

400
src/Zenith/Tree.hs Normal file
View file

@ -0,0 +1,400 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE UndecidableInstances #-}
module Zenith.Tree where
import Codec.Borsh
import Control.Monad.Logger (NoLoggingT, logDebugN)
import Data.HexString
import Data.Int (Int32, Int64, Int8)
import Data.Maybe (fromJust, isNothing)
import qualified Data.Text as T
import qualified GHC.Generics as GHC
import qualified Generics.SOP as SOP
import ZcashHaskell.Orchard (combineOrchardNodes, getOrchardNodeValue)
import ZcashHaskell.Sapling (combineSaplingNodes, getSaplingNodeValue)
import ZcashHaskell.Types (MerklePath(..), OrchardTree(..), SaplingTree(..))
type Level = Int8
maxLevel :: Level
maxLevel = 32
type Position = Int32
class Monoid v =>
Measured a v
where
measure :: a -> Position -> Int64 -> v
class Node v where
getLevel :: v -> Level
getHash :: v -> HexString
getPosition :: v -> Position
getIndex :: v -> Int64
isFull :: v -> Bool
isMarked :: v -> Bool
mkNode :: Level -> Position -> HexString -> v
type OrchardCommitment = HexString
instance Measured OrchardCommitment OrchardNode where
measure oc p i =
case getOrchardNodeValue (hexBytes oc) of
Nothing -> OrchardNode 0 (hexString "00") 0 True 0 False
Just val -> OrchardNode p val 0 True i False
type SaplingCommitment = HexString
instance Measured SaplingCommitment SaplingNode where
measure sc p i =
case getSaplingNodeValue (hexBytes sc) of
Nothing -> SaplingNode 0 (hexString "00") 0 True 0 False
Just val -> SaplingNode p val 0 True i False
data Tree v
= EmptyLeaf
| Leaf !v
| PrunedBranch !v
| Branch !v !(Tree v) !(Tree v)
| InvalidTree
deriving stock (Eq, GHC.Generic)
deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
deriving (BorshSize, ToBorsh, FromBorsh) via AsEnum (Tree v)
instance (Node v, Show v) => Show (Tree v) where
show EmptyLeaf = "()"
show (Leaf v) = "(" ++ show v ++ ")"
show (PrunedBranch v) = "{" ++ show v ++ "}"
show (Branch s x y) =
"<" ++ show (getHash s) ++ ">\n" ++ show x ++ "\n" ++ show y
show InvalidTree = "InvalidTree"
instance (Monoid v, Node v) => Semigroup (Tree v) where
(<>) InvalidTree _ = InvalidTree
(<>) _ InvalidTree = InvalidTree
(<>) EmptyLeaf EmptyLeaf = PrunedBranch $ value $ branch EmptyLeaf EmptyLeaf
(<>) EmptyLeaf x = x
(<>) (Leaf x) EmptyLeaf = branch (Leaf x) EmptyLeaf
(<>) (Leaf x) (Leaf y) = branch (Leaf x) (Leaf y)
(<>) (Leaf _) Branch {} = InvalidTree
(<>) (Leaf _) (PrunedBranch _) = InvalidTree
(<>) (PrunedBranch x) EmptyLeaf = PrunedBranch $ x <> x
(<>) (PrunedBranch x) (Leaf y) =
if isFull x
then InvalidTree
else mkSubTree (getLevel x) (Leaf y)
(<>) (PrunedBranch x) (Branch s t u) =
if getLevel x == getLevel s
then branch (PrunedBranch x) (Branch s t u)
else InvalidTree
(<>) (PrunedBranch x) (PrunedBranch y) = PrunedBranch $ x <> y
(<>) (Branch s x y) EmptyLeaf =
branch (Branch s x y) $ getEmptyRoot (getLevel s)
(<>) (Branch s x y) (PrunedBranch w)
| getLevel s == getLevel w = branch (Branch s x y) (PrunedBranch w)
| otherwise = InvalidTree
(<>) (Branch s x y) (Leaf w)
| isFull s = InvalidTree
| isFull (value x) = branch x (y <> Leaf w)
| otherwise = branch (x <> Leaf w) y
(<>) (Branch s x y) (Branch s1 x1 y1)
| getLevel s == getLevel s1 = branch (Branch s x y) (Branch s1 x1 y1)
| otherwise = InvalidTree
value :: Monoid v => Tree v -> v
value EmptyLeaf = mempty
value (Leaf v) = v
value (PrunedBranch v) = v
value (Branch v _ _) = v
value InvalidTree = mempty
branch :: Monoid v => Tree v -> Tree v -> Tree v
branch x y = Branch (value x <> value y) x y
leaf :: Measured a v => a -> Int32 -> Int64 -> Tree v
leaf a p i = Leaf (measure a p i)
prunedBranch :: Monoid v => Node v => Level -> Position -> HexString -> Tree v
prunedBranch level pos val = PrunedBranch $ mkNode level pos val
root :: Monoid v => Node v => Tree v -> Tree v
root tree =
if getLevel (value tree) == maxLevel
then tree
else mkSubTree maxLevel tree
getEmptyRoot :: Monoid v => Node v => Level -> Tree v
getEmptyRoot level = iterate (\x -> x <> x) EmptyLeaf !! fromIntegral level
append :: Monoid v => Measured a v => Node v => Tree v -> (a, Int64) -> Tree v
append tree (n, i) = tree <> leaf n p i
where
p = 1 + getPosition (value tree)
mkSubTree :: Node v => Monoid v => Level -> Tree v -> Tree v
mkSubTree level t =
if getLevel (value subtree) == level
then subtree
else mkSubTree level subtree
where
subtree = t <> EmptyLeaf
path :: Monoid v => Node v => Position -> Tree v -> Maybe MerklePath
path pos (Branch s x y) =
if length (collectPath (Branch s x y)) /= 32
then Nothing
else Just $ MerklePath pos $ collectPath (Branch s x y)
where
collectPath :: Monoid v => Node v => Tree v -> [HexString]
collectPath EmptyLeaf = []
collectPath Leaf {} = []
collectPath PrunedBranch {} = []
collectPath InvalidTree = []
collectPath (Branch _ j k)
| getPosition (value k) /= 0 && getPosition (value k) < pos = []
| getPosition (value j) < pos = collectPath k <> [getHash (value j)]
| getPosition (value j) >= pos = collectPath j <> [getHash (value k)]
| otherwise = []
path _ _ = Nothing
nullPath :: MerklePath
nullPath = MerklePath 0 []
getNotePosition :: Monoid v => Node v => Tree v -> Int64 -> Maybe Position
getNotePosition (Leaf x) i
| getIndex x == i = Just $ getPosition x
| otherwise = Nothing
getNotePosition (Branch _ x y) i
| getIndex (value x) >= i = getNotePosition x i
| getIndex (value y) >= i = getNotePosition y i
| otherwise = Nothing
getNotePosition _ _ = Nothing
truncateTree :: Monoid v => Node v => Tree v -> Int64 -> NoLoggingT IO (Tree v)
truncateTree (Branch s x y) i
| getLevel s == 1 && getIndex (value x) == i = do
logDebugN $ T.pack $ show (getLevel s) ++ " Trunc to left leaf"
return $ branch x EmptyLeaf
| getLevel s == 1 && getIndex (value y) == i = do
logDebugN $ T.pack $ show (getLevel s) ++ " Trunc to right leaf"
return $ branch x y
| getIndex (value x) >= i = do
logDebugN $
T.pack $
show (getLevel s) ++
": " ++ show i ++ " left i: " ++ show (getIndex (value x))
l <- truncateTree x i
return $ branch (l) (getEmptyRoot (getLevel (value x)))
| getIndex (value y) /= 0 && getIndex (value y) >= i = do
logDebugN $
T.pack $
show (getLevel s) ++
": " ++ show i ++ " right i: " ++ show (getIndex (value y))
r <- truncateTree y i
return $ branch x (r)
| otherwise = do
logDebugN $
T.pack $
show (getLevel s) ++
": " ++
show (getIndex (value x)) ++ " catchall " ++ show (getIndex (value y))
return InvalidTree
truncateTree x _ = return x
countLeaves :: Node v => Tree v -> Int64
countLeaves (Branch s x y) =
if isFull s
then 2 ^ getLevel s
else countLeaves x + countLeaves y
countLeaves (PrunedBranch x) =
if isFull x
then 2 ^ getLevel x
else 0
countLeaves (Leaf _) = 1
countLeaves EmptyLeaf = 0
countLeaves InvalidTree = 0
batchAppend ::
Measured a v
=> Node v => Monoid v => Tree v -> [(Int32, (a, Int64))] -> Tree v
batchAppend x [] = x
batchAppend (Branch s x y) notes
| isFull s = InvalidTree
| isFull (value x) = branch x (batchAppend y notes)
| otherwise =
branch
(batchAppend x (take leftSide notes))
(batchAppend y (drop leftSide notes))
where
leftSide = fromIntegral $ 2 ^ getLevel (value x) - countLeaves x
batchAppend (PrunedBranch k) notes
| isFull k = InvalidTree
| otherwise =
branch
(batchAppend (getEmptyRoot (getLevel k - 1)) (take leftSide notes))
(batchAppend (getEmptyRoot (getLevel k - 1)) (drop leftSide notes))
where
leftSide = fromIntegral $ 2 ^ (getLevel k - 1)
batchAppend EmptyLeaf notes
| length notes == 1 =
leaf (fst $ snd $ head notes) (fst $ head notes) (snd $ snd $ head notes)
| otherwise = InvalidTree
batchAppend _ notes = InvalidTree
data SaplingNode = SaplingNode
{ sn_position :: !Position
, sn_value :: !HexString
, sn_level :: !Level
, sn_full :: !Bool
, sn_index :: !Int64
, sn_mark :: !Bool
} deriving stock (Eq, GHC.Generic)
deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
deriving (BorshSize, ToBorsh, FromBorsh) via AsStruct SaplingNode
instance Semigroup SaplingNode where
(<>) x y =
case combineSaplingNodes (sn_level x) (sn_value x) (sn_value y) of
Nothing -> x
Just newHash ->
SaplingNode
(max (sn_position x) (sn_position y))
newHash
(1 + sn_level x)
(sn_full x && sn_full y)
(max (sn_index x) (sn_index y))
(sn_mark x || sn_mark y)
instance Monoid SaplingNode where
mempty = SaplingNode 0 (hexString "00") 0 False 0 False
mappend = (<>)
instance Node SaplingNode where
getLevel = sn_level
getHash = sn_value
getPosition = sn_position
getIndex = sn_index
isFull = sn_full
isMarked = sn_mark
mkNode l p v = SaplingNode p v l True 0 False
instance Show SaplingNode where
show = show . sn_value
saplingSize :: SaplingTree -> Int64
saplingSize tree =
(if isNothing (st_left tree)
then 0
else 1) +
(if isNothing (st_right tree)
then 0
else 1) +
foldl
(\x (i, p) ->
case p of
Nothing -> x + 0
Just _ -> x + 2 ^ i)
0
(zip [1 ..] $ st_parents tree)
mkSaplingTree :: SaplingTree -> Tree SaplingNode
mkSaplingTree tree =
foldl
(\t (i, n) ->
case n of
Just n' -> prunedBranch i 0 n' <> t
Nothing -> t <> getEmptyRoot i)
leafRoot
(zip [1 ..] $ st_parents tree)
where
leafRoot =
case st_right tree of
Just r' -> leaf (fromJust $ st_left tree) (pos - 1) 0 <> leaf r' pos 0
Nothing -> leaf (fromJust $ st_left tree) pos 0 <> EmptyLeaf
pos = fromIntegral $ saplingSize tree - 1
-- | Orchard
data OrchardNode = OrchardNode
{ on_position :: !Position
, on_value :: !HexString
, on_level :: !Level
, on_full :: !Bool
, on_index :: !Int64
, on_mark :: !Bool
} deriving stock (Eq, GHC.Generic)
deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
deriving (BorshSize, ToBorsh, FromBorsh) via AsStruct OrchardNode
instance Semigroup OrchardNode where
(<>) x y =
case combineOrchardNodes
(fromIntegral $ on_level x)
(on_value x)
(on_value y) of
Nothing -> x
Just newHash ->
OrchardNode
(max (on_position x) (on_position y))
newHash
(1 + on_level x)
(on_full x && on_full y)
(max (on_index x) (on_index y))
(on_mark x || on_mark y)
instance Monoid OrchardNode where
mempty = OrchardNode 0 (hexString "00") 0 False 0 False
mappend = (<>)
instance Node OrchardNode where
getLevel = on_level
getHash = on_value
getPosition = on_position
getIndex = on_index
isFull = on_full
isMarked = on_mark
mkNode l p v = OrchardNode p v l True 0 False
instance Show OrchardNode where
show = show . on_value
instance Measured OrchardNode OrchardNode where
measure o p i =
OrchardNode p (on_value o) (on_level o) (on_full o) i (on_mark o)
orchardSize :: OrchardTree -> Int64
orchardSize tree =
(if isNothing (ot_left tree)
then 0
else 1) +
(if isNothing (ot_right tree)
then 0
else 1) +
foldl
(\x (i, p) ->
case p of
Nothing -> x + 0
Just _ -> x + 2 ^ i)
0
(zip [1 ..] $ ot_parents tree)
mkOrchardTree :: OrchardTree -> Tree OrchardNode
mkOrchardTree tree =
foldl
(\t (i, n) ->
case n of
Just n' -> prunedBranch i 0 n' <> t
Nothing -> t <> getEmptyRoot i)
leafRoot
(zip [1 ..] $ ot_parents tree)
where
leafRoot =
case ot_right tree of
Just r' -> leaf (fromJust $ ot_left tree) (pos - 1) 0 <> leaf r' pos 0
Nothing -> leaf (fromJust $ ot_left tree) pos 0 <> EmptyLeaf
pos = fromIntegral $ orchardSize tree - 1

68
src/Zenith/Types.hs
View file

@ -17,19 +17,30 @@ import qualified Data.ByteString.Char8 as C
import Data.HexString
import Data.Int (Int64)
import Data.Maybe (fromMaybe)
import Data.Scientific (Scientific)
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.UUID as U
import Database.Persist.TH
import GHC.Generics
import ZcashHaskell.Orchard (encodeUnifiedAddress, parseAddress)
import ZcashHaskell.Sapling (encodeSaplingAddress)
import ZcashHaskell.Transparent
( encodeExchangeAddress
, encodeTransparentReceiver
)
import ZcashHaskell.Types
( OrchardSpendingKey(..)
( ExchangeAddress(..)
, OrchardSpendingKey(..)
, Phrase(..)
, Rseed(..)
, SaplingAddress(..)
, SaplingSpendingKey(..)
, Scope(..)
, TransparentAddress(..)
, TransparentSpendingKey
, ValidAddress(..)
, ZcashNet(..)
)
@ -101,6 +112,7 @@ data Config = Config
, c_zenithUser :: !BS.ByteString
, c_zenithPwd :: !BS.ByteString
, c_zenithPort :: !Int
, c_currencyCode :: !T.Text
} deriving (Eq, Prelude.Show)
data ZcashPool
@ -207,6 +219,51 @@ data PrivacyPolicy
$(deriveJSON defaultOptions ''PrivacyPolicy)
newtype ValidAddressAPI = ValidAddressAPI
{ getVA :: ValidAddress
} deriving newtype (Eq, Show)
instance ToJSON ValidAddressAPI where
toJSON (ValidAddressAPI va) =
case va of
Unified ua -> Data.Aeson.String $ encodeUnifiedAddress ua
Sapling sa ->
maybe
Data.Aeson.Null
Data.Aeson.String
(encodeSaplingAddress (net_type sa) (sa_receiver sa))
Transparent ta ->
Data.Aeson.String $
encodeTransparentReceiver (ta_network ta) (ta_receiver ta)
Exchange ea ->
maybe
Data.Aeson.Null
Data.Aeson.String
(encodeExchangeAddress (ex_network ea) (ex_address ea))
data ProposedNote = ProposedNote
{ pn_addr :: !ValidAddressAPI
, pn_amt :: !Scientific
, pn_memo :: !(Maybe T.Text)
} deriving (Eq, Prelude.Show)
instance FromJSON ProposedNote where
parseJSON =
withObject "ProposedNote" $ \obj -> do
a <- obj .: "address"
n <- obj .: "amount"
m <- obj .:? "memo"
case parseAddress (E.encodeUtf8 a) of
Nothing -> fail "Invalid address"
Just a' ->
if n > 0 && n < 21000000
then pure $ ProposedNote (ValidAddressAPI a') n m
else fail "Invalid amount"
instance ToJSON ProposedNote where
toJSON (ProposedNote a n m) =
object ["address" .= a, "amount" .= n, "memo" .= m]
data ShieldDeshieldOp
= Shield
| Deshield
@ -451,3 +508,12 @@ 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"
-- | Define a data structure for the parsed components
data ZcashPaymentURI = ZcashPaymentURI
{ uriAddress :: String
, uriAmount :: Maybe Double
, uriMemo :: T.Text
, uriLabel :: Maybe String
, uriMessage :: Maybe String
} deriving (Show, Eq)

116
src/Zenith/Utils.hs
View file

@ -2,37 +2,59 @@
module Zenith.Utils where
import Control.Exception (SomeException, try)
import Control.Monad (when)
import Data.Aeson
import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as KM
import Data.Aeson.Types (parseMaybe)
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Char (isAlphaNum, isSpace)
import Data.Functor (void)
import Data.Maybe
import Data.Ord (clamp)
import Data.Scientific (Scientific(..), scientific)
import Data.Scientific (Scientific, toRealFloat)
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Text.Encoding as TE
import Network.HTTP.Simple
import System.Directory
import System.Process (createProcess_, shell)
import Text.Printf (printf)
import Text.Read (readMaybe)
import Text.Regex.Posix
import ZcashHaskell.Orchard (encodeUnifiedAddress, isValidUnifiedAddress, parseAddress)
import ZcashHaskell.Orchard
( encodeUnifiedAddress
, isValidUnifiedAddress
, parseAddress
)
import ZcashHaskell.Sapling (decodeSaplingAddress, isValidShieldedAddress)
import ZcashHaskell.Transparent
( decodeExchangeAddress
, decodeTransparentAddress
)
import ZcashHaskell.Types
( SaplingAddress(..)
( ExchangeAddress(..)
, ExchangeAddress(..)
, SaplingAddress(..)
, TransparentAddress(..)
, UnifiedAddress(..)
, ZcashNet(..)
, ValidAddress(..)
, ExchangeAddress(..)
, ValidAddress(..)
, ZcashNet(..)
)
import ZcashHaskell.Utils (makeZebraCall)
import Zenith.Types
( AddressGroup(..)
, PrivacyPolicy(..)
, UnifiedAddressDB(..)
, ZcashAddress(..)
, ZcashPaymentURI(..)
, ZcashPool(..)
, PrivacyPolicy(..)
)
-- | Helper function to convert numbers into JSON
@ -47,7 +69,7 @@ displayZec s
| abs s < 100000000 = show (fromIntegral s / 100000) ++ " mZEC"
| otherwise = show (fromIntegral s / 100000000) ++ " ZEC "
-- | Helper function to display small amounts of ZEC
-- | Helper function to display small amounts of TAZ
displayTaz :: Integer -> String
displayTaz s
| abs s < 100 = show s ++ " tazs"
@ -150,21 +172,24 @@ isRecipientValidGUI :: PrivacyPolicy -> T.Text -> Bool
isRecipientValidGUI p a = do
let adr = parseAddress (E.encodeUtf8 a)
case p of
Full -> case adr of
Full ->
case adr of
Just a ->
case a of
Unified ua -> True
Sapling sa -> True
_ -> False
Nothing -> False
Medium -> case adr of
Medium ->
case adr of
Just a ->
case a of
Unified ua -> True
Sapling sa -> True
_ -> False
Nothing -> False
Low -> case adr of
Low ->
case adr of
Just a ->
case a of
Unified ua -> True
@ -172,7 +197,8 @@ isRecipientValidGUI p a = do
Transparent ta -> True
_ -> False
Nothing -> False
None -> case adr of
None ->
case adr of
Just a ->
case a of
Transparent ta -> True
@ -232,3 +258,73 @@ padWithZero n s
isEmpty :: [a] -> Bool
isEmpty [] = True
isEmpty _ = False
getChainTip :: T.Text -> Int -> IO Int
getChainTip zHost zPort = do
r <- makeZebraCall zHost zPort "getblockcount" []
case r of
Left e1 -> pure 0
Right i -> pure i
-- Function to fetch Zcash price from CoinGecko
getZcashPrice :: T.Text -> IO (Maybe Double)
getZcashPrice currency = do
let url =
"https://api.coingecko.com/api/v3/simple/price?ids=zcash&vs_currencies=" <>
T.unpack currency
response <- httpJSONEither (parseRequest_ url)
case getResponseBody response of
Right (Object obj)
-- Extract "zcash" object
-> do
case KM.lookup "zcash" obj of
Just (Object zcashObj)
-- Extract the currency price
->
case KM.lookup (K.fromText (T.toLower currency)) zcashObj of
Just (Number price) -> return (Just (toRealFloat price))
_ -> return Nothing
_ -> return Nothing
_ -> return Nothing
-- Parse memo result to convert it to a ByteString
processEither :: Either String BC.ByteString -> BC.ByteString
processEither (Right bs) = bs
processEither (Left e) = BC.pack e -- Returns the error message
-- Parse the query string into key-value pairs
parseQuery :: String -> [(String, String)]
parseQuery query = map (breakOn '=') (splitOn '&' query)
where
splitOn :: Char -> String -> [String]
splitOn _ [] = [""]
splitOn delim (c:cs)
| c == delim = "" : rest
| otherwise = (c : head rest) : tail rest
where
rest = splitOn delim cs
breakOn :: Char -> String -> (String, String)
breakOn delim str = (key, drop 1 value)
where
(key, value) = span (/= delim) str
-- Parse a ZIP-321 encoded string into a ZcashPayment structure
parseZcashPayment :: String -> Either String ZcashPaymentURI
parseZcashPayment input
| not (T.isPrefixOf "zcash:" (T.pack input)) =
Left "Invalid scheme: must start with 'zcash:'"
| otherwise =
let (addrPart, queryPart) = break (== '?') (drop 6 input)
queryParams = parseQuery (drop 1 queryPart)
in Right
ZcashPaymentURI
{ uriAddress = addrPart
, uriAmount = lookup "amount" queryParams >>= readMaybe
, uriMemo =
case lookup "memo" queryParams of
Just m ->
T.pack (BC.unpack (processEither $ B64.decode $ BC.pack m))
_ -> ""
, uriLabel = lookup "label" queryParams
, uriMessage = lookup "message" queryParams
}

119
test/ServerSpec.hs
View file

@ -7,7 +7,7 @@ import Control.Monad.Logger (runNoLoggingT)
import Data.Aeson
import qualified Data.ByteString as BS
import Data.Configurator
import Data.Maybe (fromMaybe)
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import Data.Time.Clock (getCurrentTime)
@ -18,7 +18,7 @@ import Servant
import System.Directory
import Test.HUnit hiding (State)
import Test.Hspec
import ZcashHaskell.Orchard (isValidUnifiedAddress)
import ZcashHaskell.Orchard (isValidUnifiedAddress, parseAddress)
import ZcashHaskell.Types
( ZcashNet(..)
, ZebraGetBlockChainInfo(..)
@ -39,6 +39,9 @@ import Zenith.RPC
)
import Zenith.Types
( Config(..)
, PrivacyPolicy(..)
, ProposedNote(..)
, ValidAddressAPI(..)
, ZcashAccountAPI(..)
, ZcashAddressAPI(..)
, ZcashWalletAPI(..)
@ -55,7 +58,16 @@ main = do
zebraPort <- require config "zebraPort"
zebraHost <- require config "zebraHost"
nodePort <- require config "nodePort"
let myConfig = Config dbFilePath zebraHost zebraPort nodeUser nodePwd nodePort
currencyCode <- require config "currencyCode"
let myConfig =
Config
dbFilePath
zebraHost
zebraPort
nodeUser
nodePwd
nodePort
currencyCode
hspec $ do
describe "RPC methods" $ do
beforeAll_ (startAPI myConfig) $ do
@ -572,6 +584,107 @@ main = do
Left e -> assertFailure e
Right (ErrorResponse i c m) -> c `shouldBe` (-32009)
Right _ -> assertFailure "unexpected response"
describe "Send tx" $ do
describe "sendmany" $ do
it "bad credentials" $ do
res <-
makeZenithCall
"127.0.0.1"
nodePort
"baduser"
"idontknow"
SendMany
BlankParams
res `shouldBe` Left "Invalid credentials"
describe "correct credentials" $ do
it "invalid account" $ do
let uaRead =
parseAddress
"utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax"
res <-
makeZenithCall
"127.0.0.1"
nodePort
nodeUser
nodePwd
SendMany
(SendParams
17
[ ProposedNote
(ValidAddressAPI $ fromJust uaRead)
0.005
(Just "A cool memo")
]
Full)
case res of
Left e -> assertFailure e
Right (ErrorResponse i c m) -> c `shouldBe` (-32006)
it "valid account, empty notes" $ do
let uaRead =
parseAddress
"utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax"
res <-
makeZenithCall
"127.0.0.1"
nodePort
nodeUser
nodePwd
SendMany
(SendParams 1 [] Full)
case res of
Left e -> assertFailure e
Right (ErrorResponse i c m) -> c `shouldBe` (-32602)
it "valid account, single output" $ do
let uaRead =
parseAddress
"utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax"
res <-
makeZenithCall
"127.0.0.1"
nodePort
nodeUser
nodePwd
SendMany
(SendParams
1
[ ProposedNote
(ValidAddressAPI $ fromJust uaRead)
5.0
(Just "A cool memo")
]
Full)
case res of
Left e -> assertFailure e
Right (SendResponse i o) -> o `shouldNotBe` U.nil
it "valid account, multiple outputs" $ do
let uaRead =
parseAddress
"utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax"
let uaRead2 =
parseAddress
"ztestsapling136jp8z89v2jh6kqd5rs4dtvlxym90m43svzdwzxaplyvc5ttzppytpvx80ncllcsqzpmukxjl3y"
res <-
makeZenithCall
"127.0.0.1"
nodePort
nodeUser
nodePwd
SendMany
(SendParams
1
[ ProposedNote
(ValidAddressAPI $ fromJust uaRead)
5.0
(Just "A cool memo")
, ProposedNote
(ValidAddressAPI $ fromJust uaRead2)
1.0
(Just "Not so cool memo")
]
Full)
case res of
Left e -> assertFailure e
Right (SendResponse i o) -> o `shouldNotBe` U.nil
startAPI :: Config -> IO ()
startAPI config = do

827
test/Spec.hs
View file

File diff suppressed because it is too large Load diff

2
zcash-haskell

@ -1 +1 @@
Subproject commit 003293cc3f978c146824d0695c5c458cf2cc9bb5
Subproject commit cfa862ec9495e810e7296fa6fe724b46dbe0ee52

36
zenith-openrpc.json
View file

@ -132,6 +132,7 @@
],
"errors": [
{ "$ref": "#/components/errors/ZebraNotAvailable" },
{ "$ref": "#/components/errors/ZenithBusy" },
{ "$ref": "#/components/errors/DuplicateName" }
]
},
@ -228,6 +229,7 @@
"errors": [
{ "$ref": "#/components/errors/ZebraNotAvailable" },
{ "$ref": "#/components/errors/DuplicateName" },
{ "$ref": "#/components/errors/ZenithBusy" },
{ "$ref": "#/components/errors/InvalidWallet" }
]
},
@ -444,6 +446,7 @@
],
"errors": [
{ "$ref": "#/components/errors/InvalidAccount" },
{ "$ref": "#/components/errors/ZenithBusy" },
{ "$ref": "#/components/errors/DuplicateName" }
]
},
@ -593,10 +596,11 @@
{
"name": "sendmany",
"summary": "Send transaction(s)",
"description": "Send one or more transactions by specifying the source account, the recipient address, the amount, the shielded memo (optional) and the privacy policy (optional).",
"tags": [{"$ref": "#/components/tags/draft"},{"$ref": "#/components/tags/wip"}],
"description": "Send one transaction by specifying the source account, the privacy policy (optional, default 'Full') and an array of proposed outputs. Each output needs a recipient address, an amount and an optional shielded memo.",
"tags": [],
"params": [
{ "$ref": "#/components/contentDescriptors/AccountId"},
{ "$ref": "#/components/contentDescriptors/PrivacyPolicy"},
{ "$ref": "#/components/contentDescriptors/TxRequestArray"}
],
"paramStructure": "by-position",
@ -610,14 +614,19 @@
"examples": [
{
"name": "Send a transaction",
"summary": "Send one transaction",
"description": "Send a single transaction",
"summary": "Send a transaction",
"description": "Send a transaction with one output",
"params": [
{
"name": "Account index",
"summary": "The index for the account to use",
"value": "1"
},
{
"name": "Privacy Policy",
"summary": "The selected privacy policy",
"value": "Full"
},
{
"name": "Transaction request",
"summary": "The transaction to attempt",
@ -640,7 +649,7 @@
],
"errors": [
{ "$ref": "#/components/errors/ZebraNotAvailable" },
{ "$ref": "#/components/errors/InvalidRecipient" },
{ "$ref": "#/components/errors/ZenithBusy" },
{ "$ref": "#/components/errors/InvalidAccount" }
]
},
@ -736,6 +745,16 @@
"type": "array",
"items": { "$ref": "#/components/schemas/TxRequest"}
}
},
"PrivacyPolicy": {
"name": "Privacy Policy",
"summary": "The chosen privacy policy to use for the transaction",
"description": "The privacy policy to use for the transaction. `Full` policy allows shielded funds to be transferred within their shielded pools. `Medium` policy allows shielded funds to cross shielded pools. `Low` allows deshielding transactions into transparent receivers but not to exchange addresses. `None` allows for transparent funds to be spent to transparent addresses and exchange addresses.",
"required": false,
"schema": {
"type": "string",
"enum": ["None", "Low", "Medium", "Full"]
}
}
},
"schemas": {
@ -814,8 +833,7 @@
"properties": {
"address": { "type": "string", "description": "Recipient's address (unified, Sapling or transparent)" },
"amount": { "type": "number", "description": "The amount to send in ZEC"},
"memo": { "type": "string", "description": "The shielded memo to include, if applicable"},
"privacy": { "type": "string", "enum": ["None", "Low", "Medium", "Full"], "description": "The privacy policy to use for the transaction. `Full` policy allows shielded funds to be transferred within their shielded pools. `Medium` policy allows shielded funds to cross shielded pools and deshielding transactions. `Low` allows to spend transparent funds into shielded pools. `None` allows for transparent funds to be spent to transparent addresses."}
"memo": { "type": "string", "description": "The shielded memo to include, if applicable"}
}
}
},
@ -872,6 +890,10 @@
"InvalidRecipient": {
"code": -32011,
"message": "The provided recipient address is not valid."
},
"ZenithBusy": {
"code": -32012,
"message": "The Zenith server is syncing, please try again later."
}
}
}

10
zenith.cabal
View file

@ -36,6 +36,7 @@ library
Zenith.Zcashd
Zenith.Scanner
Zenith.RPC
Zenith.Tree
hs-source-dirs:
src
build-depends:
@ -49,6 +50,7 @@ library
, base >=4.12 && <5
, base64-bytestring
, binary
, borsh
, brick
, bytestring
, configurator
@ -58,6 +60,7 @@ library
, exceptions
, filepath
, ghc
, generics-sop
, haskoin-core
, hexstring
, http-client
@ -93,6 +96,7 @@ library
, vty-crossplatform
, word-wrap
, zcash-haskell
, unordered-containers
--pkgconfig-depends: rustzcash_wrapper
default-language: Haskell2010
@ -124,9 +128,12 @@ executable zenithserver
build-depends:
base >=4.12 && <5
, configurator
, monad-logger
, wai-extra
, warp
, servant-server
, text
, unix
, zcash-haskell
, zenith
pkgconfig-depends: rustzcash_wrapper
@ -141,8 +148,11 @@ test-suite zenith-tests
build-depends:
base >=4.12 && <5
, bytestring
, aeson
, configurator
, monad-logger
, borsh
, aeson
, data-default
, sort
, text

35
zenith.cfg
View file

@ -1,5 +1,38 @@
#
# Zenith Configuration File
#
# -------------------------------------------------------------
# nodeUser -
# -------------------------------------------------------------
nodeUser = "user"
# -------------------------------------------------------------
# nodePwd -
nodePwd = "superSecret"
dbFilePath = "zenith.db"
# -------------------------------------------------------------
# dbFileName - contains the SQLite database name used for
# keeping all Zenith's data
# default = zenith.db
#
dbFileName = "zenith.db"
# -------------------------------------------------------------
# zebraHost - Zebra IP
# Default - "127.0.0.1"
zebraHost = "127.0.0.1"
# -------------------------------------------------------------
# zebraPort - Port used for access Zebra API endpoints
# must be the same port configured for your
# Zebra node
zebraPort = 18232
# -------------------------------------------------------------
# currencyCode - ISO 4217 currency code
#
# Example of currency codes are:
#
# United States -> currencyCode = "usd"
# Canada -> currencyCode = "cnd"
# Australia -> currencyCode = "aud"
# Euro Region -> currencyCode = "eur"
# Great Britain -> currencyCode = "gbp"
# Japan -> currencyCode = "jpy"
#
currencyCode = "usd"