Merge pull request 'Sending transactions' (#78) from rav001 into dev041

Reviewed-on: #78
This commit is contained in:
pitmutt 2024-05-09 15:48:24 +00:00 committed by Vergara Technologies LLC
commit f71426d69f
Signed by: Vergara Technologies LLC
GPG key ID: 99DB473BB4715618
10 changed files with 1348 additions and 779 deletions

View file

@ -18,7 +18,7 @@ import System.IO
import Text.Read (readMaybe)
import ZcashHaskell.Types
import Zenith.CLI
import Zenith.Core (clearSync, testSend, testSync)
import Zenith.Core (clearSync, testSync)
import Zenith.Types (Config(..), ZcashAddress(..), ZcashPool(..), ZcashTx(..))
import Zenith.Utils
import Zenith.Zcashd
@ -223,7 +223,6 @@ main = do
"cli" -> runZenithCLI myConfig
"sync" -> testSync myConfig
"rescan" -> clearSync myConfig
"testsend" -> testSend
_ -> printUsage
else printUsage

View file

@ -2,6 +2,7 @@
module ZenScan where
import Control.Monad.Logger (runNoLoggingT)
import Data.Configurator
import Zenith.Scanner (scanZebra)
@ -11,4 +12,4 @@ main = do
dbFilePath <- require config "dbFilePath"
zebraPort <- require config "zebraPort"
zebraHost <- require config "zebraHost"
scanZebra 2762066 zebraHost zebraPort dbFilePath
runNoLoggingT $ scanZebra 2762066 zebraHost zebraPort dbFilePath

View file

@ -11,11 +11,15 @@ import qualified Brick.Focus as F
import Brick.Forms
( Form(..)
, (@@=)
, allFieldsValid
, editShowableFieldWithValidate
, editTextField
, focusedFormInputAttr
, handleFormEvent
, invalidFormInputAttr
, newForm
, renderForm
, setFieldValid
, updateFormState
)
import qualified Brick.Main as M
@ -49,29 +53,38 @@ import Brick.Widgets.Core
, withBorderStyle
)
import qualified Brick.Widgets.Dialog as D
import qualified Brick.Widgets.Edit as E
import qualified Brick.Widgets.List as L
import qualified Brick.Widgets.ProgressBar as P
import Control.Concurrent (forkIO, threadDelay)
import Control.Exception (catch, throw, throwIO, try)
import Control.Monad (forever, void)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (runFileLoggingT)
import Control.Monad.Logger (LoggingT, runFileLoggingT, runNoLoggingT)
import Data.Aeson
import Data.HexString (toText)
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import qualified Data.Vector as Vec
import Database.Persist
import Database.Persist.Sqlite
import qualified Graphics.Vty as V
import qualified Graphics.Vty.CrossPlatform as VC
import Lens.Micro ((&), (.~), (^.), set)
import Lens.Micro.Mtl
import Lens.Micro.TH
import System.Hclip
import Text.Wrap (FillScope(..), FillStrategy(..), WrapSettings(..), wrapText)
import ZcashHaskell.Keys (generateWalletSeedPhrase, getWalletSeed)
import ZcashHaskell.Orchard (getSaplingFromUA, isValidUnifiedAddress)
import ZcashHaskell.Transparent (encodeTransparentReceiver)
import ZcashHaskell.Sapling (decodeSaplingAddress, isValidShieldedAddress)
import ZcashHaskell.Transparent
( decodeExchangeAddress
, decodeTransparentAddress
, encodeTransparentReceiver
)
import ZcashHaskell.Types
import ZcashHaskell.Utils (getBlockTime, makeZebraCall)
import Zenith.Core
@ -92,6 +105,9 @@ data Name
| TList
| HelpDialog
| DialogInputField
| RecField
| AmtField
| MemoField
deriving (Eq, Show, Ord)
data DialogInput = DialogInput
@ -100,12 +116,21 @@ data DialogInput = DialogInput
makeLenses ''DialogInput
data SendInput = SendInput
{ _sendTo :: !T.Text
, _sendAmt :: !Float
, _sendMemo :: !T.Text
} deriving (Show)
makeLenses ''SendInput
data DialogType
= WName
| AName
| AdName
| WSelect
| ASelect
| SendTx
| Blank
data DisplayType
@ -114,10 +139,12 @@ data DisplayType
| PhraseDisplay
| TxDisplay
| SyncDisplay
| SendDisplay
| BlankDisplay
data Tick =
Tick
data Tick
= TickVal !Float
| TickMsg !String
data State = State
{ _network :: !ZcashNet
@ -140,6 +167,8 @@ data State = State
, _balance :: !Integer
, _barValue :: !Float
, _eventDispatch :: !(BC.BChan Tick)
, _timer :: !Int
, _txForm :: !(Form SendInput () Name)
}
makeLenses ''State
@ -178,13 +207,14 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s]
listAddressBox "Addresses" (st ^. addresses) <+>
B.vBorder <+>
(C.hCenter (str ("Last block seen: " ++ show (st ^. syncBlock))) <=>
listTxBox "Transactions" (st ^. transactions))) <=>
listTxBox "Transactions" (st ^. network) (st ^. transactions))) <=>
C.hCenter
(hBox
[ capCommand "W" "allets"
, capCommand "A" "ccounts"
, capCommand "V" "iew address"
, capCommand "Q" "uit"
, str $ show (st ^. timer)
])
listBox :: Show e => String -> L.List Name e -> Widget Name
listBox titleLabel l =
@ -218,17 +248,28 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s]
(B.borderWithLabel (str titleLabel) $
hLimit 40 $ vLimit 15 $ L.renderList listDrawAddress True a)
, str " "
, C.hCenter $ str "Use arrows to select"
, C.hCenter
(hBox
[ capCommand "↑↓ " "move"
, capCommand "" "select"
, capCommand "Tab " "->"
])
]
listTxBox :: String -> L.List Name (Entity UserTx) -> Widget Name
listTxBox titleLabel tx =
listTxBox ::
String -> ZcashNet -> L.List Name (Entity UserTx) -> Widget Name
listTxBox titleLabel znet tx =
C.vCenter $
vBox
[ C.hCenter
(B.borderWithLabel (str titleLabel) $
hLimit 40 $ vLimit 15 $ L.renderList listDrawTx True tx)
hLimit 50 $ vLimit 15 $ L.renderList (listDrawTx znet) True tx)
, str " "
, C.hCenter $ str "Use arrows to select"
, C.hCenter
(hBox
[ capCommand "↑↓ " "move"
, capCommand "T" "x Display"
, capCommand "Tab " "<-"
])
]
helpDialog :: State -> Widget Name
helpDialog st =
@ -288,6 +329,12 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s]
, capCommand "N" "ew"
, xCommand
]))
SendTx ->
D.renderDialog
(D.dialog (Just (str "Send Transaction")) Nothing 50)
(renderForm (st ^. txForm) <=>
C.hCenter
(hBox [capCommand "" "Send", capCommand "<esc> " "Cancel"]))
Blank -> emptyWidget
splashDialog :: State -> Widget Name
splashDialog st =
@ -337,7 +384,15 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s]
t_rec =<<
(isValidUnifiedAddress .
E.encodeUtf8 . getUA . walletAddressUAddress)
(entityVal a)))
(entityVal a)) <=>
C.hCenter
(hBox
[ str "Copy: "
, capCommand "U" "nified"
, capCommand "S" "apling"
, capCommand "T" "ransparent"
]) <=>
C.hCenter xCommand)
Nothing -> emptyWidget
PhraseDisplay ->
case L.listSelectedElement $ st ^. wallets of
@ -398,6 +453,11 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s]
(P.progressBar
(Just $ show (st ^. barValue * 100))
(_barValue st))))
SendDisplay ->
withBorderStyle unicodeBold $
D.renderDialog
(D.dialog (Just $ txt "Sending Transaction") Nothing 50)
(padAll 1 (str $ st ^. msg))
BlankDisplay -> emptyWidget
mkInputForm :: DialogInput -> Form DialogInput e Name
@ -408,6 +468,33 @@ mkInputForm =
label s w =
padBottom (Pad 1) $ vLimit 1 (hLimit 15 $ str s <+> fill ' ') <+> w
mkSendForm :: Integer -> SendInput -> Form SendInput e Name
mkSendForm bal =
newForm
[ label "To: " @@= editTextField sendTo RecField (Just 1)
, label "Amount: " @@=
editShowableFieldWithValidate sendAmt AmtField (isAmountValid bal)
, label "Memo: " @@= editTextField sendMemo MemoField (Just 1)
]
where
isAmountValid :: Integer -> Float -> Bool
isAmountValid b i = (fromIntegral b * 100000000.0) >= i
label s w =
padBottom (Pad 1) $ vLimit 1 (hLimit 15 $ str s <+> fill ' ') <+> w
isRecipientValid :: T.Text -> Bool
isRecipientValid a =
case isValidUnifiedAddress (E.encodeUtf8 a) of
Just _a1 -> True
Nothing ->
isValidShieldedAddress (E.encodeUtf8 a) ||
(case decodeTransparentAddress (E.encodeUtf8 a) of
Just _a3 -> True
Nothing ->
case decodeExchangeAddress a of
Just _a4 -> True
Nothing -> False)
listDrawElement :: (Show a) => Bool -> a -> Widget Name
listDrawElement sel a =
let selStr s =
@ -443,18 +530,22 @@ listDrawAddress sel w =
walletAddressName (entityVal w) <>
": " <> showAddress (walletAddressUAddress (entityVal w))
listDrawTx :: Bool -> Entity UserTx -> Widget Name
listDrawTx sel tx =
listDrawTx :: ZcashNet -> Bool -> Entity UserTx -> Widget Name
listDrawTx znet sel tx =
selStr $
T.pack
(show $ posixSecondsToUTCTime (fromIntegral (userTxTime $ entityVal tx))) <>
" " <> fmtAmt
" " <> T.pack fmtAmt
where
amt = fromIntegral (userTxAmount $ entityVal tx) / 100000000
amt = fromIntegral $ userTxAmount $ entityVal tx
dispAmount =
if znet == MainNet
then displayZec amt
else displayTaz amt
fmtAmt =
if amt > 0
then "" <> T.pack (show amt) <> " "
else " " <> T.pack (show amt) <> ""
then "" <> dispAmount <> " "
else " " <> dispAmount <> ""
selStr s =
if sel
then withAttr customAttr (txt $ "> " <> s)
@ -481,60 +572,49 @@ barToDoAttr = A.attrName "remaining"
validBarValue :: Float -> Float
validBarValue = clamp 0 1
scanZebra :: Int -> BT.EventM Name State ()
scanZebra b = do
s <- BT.get
_ <- liftIO $ initDb $ s ^. dbPath
bStatus <- liftIO $ checkBlockChain (s ^. zebraHost) (s ^. zebraPort)
dbBlock <- liftIO $ getMaxBlock $ s ^. dbPath
scanZebra :: T.Text -> T.Text -> Int -> Int -> BC.BChan Tick -> IO ()
scanZebra dbP zHost zPort b eChan = do
_ <- liftIO $ initDb dbP
bStatus <- liftIO $ checkBlockChain zHost zPort
pool <- runNoLoggingT $ initPool dbP
dbBlock <- runNoLoggingT $ getMaxBlock pool
let sb = max dbBlock b
if sb > zgb_blocks bStatus || sb < 1
then do
BT.modify $ set msg "Invalid starting block for scan"
BT.modify $ set displayBox MsgDisplay
liftIO $ BC.writeBChan eChan $ TickMsg "Invalid starting block for scan"
else do
let bList = [(sb + 1) .. (zgb_blocks bStatus)]
let step = (1.0 :: Float) / fromIntegral (zgb_blocks bStatus - (sb + 1))
mapM_ (processBlock step) bList
mapM_ (processBlock pool step) bList
where
processBlock :: Float -> Int -> BT.EventM Name State ()
processBlock step bl = do
s <- BT.get
processBlock :: ConnectionPool -> Float -> Int -> IO ()
processBlock pool step bl = do
r <-
liftIO $
makeZebraCall
(s ^. zebraHost)
(s ^. zebraPort)
zHost
zPort
"getblock"
[Data.Aeson.String $ T.pack $ show bl, jsonNumber 1]
case r of
Left e1 -> do
BT.modify $ set msg e1
BT.modify $ set displayBox MsgDisplay
liftIO $ BC.writeBChan eChan $ TickMsg e1
Right blk -> do
r2 <-
liftIO $
makeZebraCall
(s ^. zebraHost)
(s ^. zebraPort)
zHost
zPort
"getblock"
[Data.Aeson.String $ T.pack $ show bl, jsonNumber 0]
case r2 of
Left e2 -> do
BT.modify $ set msg e2
BT.modify $ set displayBox MsgDisplay
liftIO $ BC.writeBChan eChan $ TickMsg e2
Right hb -> do
let blockTime = getBlockTime hb
liftIO $
mapM_
(processTx
(s ^. zebraHost)
(s ^. zebraPort)
blockTime
(s ^. dbPath)) $
mapM_ (runNoLoggingT . processTx zHost zPort blockTime pool) $
bl_txs $ addTime blk blockTime
BT.modify $ set barValue $ validBarValue (s ^. barValue + step)
BT.modify $ set displayBox SyncDisplay
liftIO $ BC.writeBChan eChan $ TickVal step
addTime :: BlockResponse -> Int -> BlockResponse
addTime bl t =
BlockResponse
@ -544,14 +624,78 @@ scanZebra b = do
(bl_txs bl)
appEvent :: BT.BrickEvent Name Tick -> BT.EventM Name State ()
appEvent (BT.AppEvent Tick) = do
appEvent (BT.AppEvent t) = do
s <- BT.get
case s ^. displayBox of
SyncDisplay -> do
if s ^. barValue == 1.0
then BT.modify $ set displayBox BlankDisplay
else BT.modify $ set displayBox SyncDisplay
_ -> return ()
pool <- liftIO $ runNoLoggingT $ initPool $ s ^. dbPath
case t of
TickMsg m -> do
case s ^. displayBox of
AddrDisplay -> return ()
MsgDisplay -> return ()
PhraseDisplay -> return ()
TxDisplay -> return ()
SyncDisplay -> return ()
SendDisplay -> do
BT.modify $ set msg m
BlankDisplay -> return ()
TickVal v -> do
case s ^. displayBox of
AddrDisplay -> return ()
MsgDisplay -> return ()
PhraseDisplay -> return ()
TxDisplay -> return ()
SendDisplay -> return ()
SyncDisplay -> do
if s ^. barValue == 1.0
then do
selWallet <-
do case L.listSelectedElement $ s ^. wallets of
Nothing -> do
let fWall =
L.listSelectedElement $
L.listMoveToBeginning $ s ^. wallets
case fWall of
Nothing -> throw $ userError "Failed to select wallet"
Just (_j, w1) -> return w1
Just (_k, w) -> return w
_ <-
liftIO $
syncWallet
(Config (s ^. dbPath) (s ^. zebraHost) (s ^. zebraPort))
selWallet
BT.modify $ set displayBox BlankDisplay
BT.modify $ set barValue 0.0
updatedState <- BT.get
ns <- liftIO $ refreshWallet updatedState
BT.put ns
else BT.modify $ set barValue $ validBarValue (v + s ^. barValue)
BlankDisplay -> do
case s ^. dialogBox of
AName -> return ()
AdName -> return ()
WName -> return ()
WSelect -> return ()
ASelect -> return ()
SendTx -> return ()
Blank -> do
if s ^. timer == 90
then do
BT.modify $ set barValue 0.0
BT.modify $ set displayBox SyncDisplay
sBlock <- liftIO $ getMinBirthdayHeight pool
_ <-
liftIO $
forkIO $
scanZebra
(s ^. dbPath)
(s ^. zebraHost)
(s ^. zebraPort)
sBlock
(s ^. eventDispatch)
BT.modify $ set timer 0
return ()
else do
BT.modify $ set timer $ 1 + s ^. timer
appEvent (BT.VtyEvent e) = do
r <- F.focusGetCurrent <$> use focusRing
s <- BT.get
@ -565,33 +709,63 @@ appEvent (BT.VtyEvent e) = do
_ev -> return ()
else do
case s ^. displayBox of
AddrDisplay -> BT.modify $ set displayBox BlankDisplay
AddrDisplay -> do
case e of
V.EvKey (V.KChar 'x') [] ->
BT.modify $ set displayBox BlankDisplay
V.EvKey (V.KChar 'u') [] -> do
case L.listSelectedElement $ s ^. addresses of
Just (_, a) -> do
liftIO $
setClipboard $
T.unpack $
getUA $ walletAddressUAddress $ entityVal a
BT.modify $
set msg $
"Copied Unified Address <" ++
T.unpack (walletAddressName (entityVal a)) ++ ">!"
BT.modify $ set displayBox MsgDisplay
Nothing -> return ()
V.EvKey (V.KChar 's') [] -> do
case L.listSelectedElement $ s ^. addresses of
Just (_, a) -> do
liftIO $
setClipboard $
maybe "None" T.unpack $
getSaplingFromUA $
E.encodeUtf8 $
getUA $ walletAddressUAddress $ entityVal a
BT.modify $
set msg $
"Copied Sapling Address <" ++
T.unpack (walletAddressName (entityVal a)) ++ ">!"
BT.modify $ set displayBox MsgDisplay
Nothing -> return ()
V.EvKey (V.KChar 't') [] -> do
case L.listSelectedElement $ s ^. addresses of
Just (_, a) -> do
liftIO $
setClipboard $
T.unpack $
maybe
"None"
(encodeTransparentReceiver (s ^. network)) $
t_rec =<<
(isValidUnifiedAddress .
E.encodeUtf8 . getUA . walletAddressUAddress)
(entityVal a)
BT.modify $
set msg $
"Copied Transparent Address <" ++
T.unpack (walletAddressName (entityVal a)) ++ ">!"
BT.modify $ set displayBox MsgDisplay
Nothing -> return ()
_ev -> return ()
MsgDisplay -> BT.modify $ set displayBox BlankDisplay
PhraseDisplay -> BT.modify $ set displayBox BlankDisplay
TxDisplay -> BT.modify $ set displayBox BlankDisplay
SyncDisplay -> do
if s ^. barValue == 1.0
then BT.modify $ set displayBox BlankDisplay
else do
sBlock <- liftIO $ getMinBirthdayHeight $ s ^. dbPath
selWallet <-
do case L.listSelectedElement $ s ^. wallets of
Nothing -> do
let fWall =
L.listSelectedElement $
L.listMoveToBeginning $ s ^. wallets
case fWall of
Nothing ->
throw $ userError "Failed to select wallet"
Just (_j, w1) -> return w1
Just (_k, w) -> return w
scanZebra sBlock
liftIO $
runFileLoggingT "zenith.log" $
syncWallet
(Config (s ^. dbPath) (s ^. zebraHost) (s ^. zebraPort))
selWallet
BT.modify $ set displayBox SyncDisplay
SendDisplay -> BT.modify $ set displayBox BlankDisplay
SyncDisplay -> BT.modify $ set displayBox BlankDisplay
BlankDisplay -> do
case s ^. dialogBox of
WName -> do
@ -675,6 +849,71 @@ appEvent (BT.VtyEvent e) = do
s ^. inputForm
BT.modify $ set dialogBox AName
ev -> BT.zoom accounts $ L.handleListEvent ev
SendTx -> do
case e of
V.EvKey V.KEsc [] -> BT.modify $ set dialogBox Blank
V.EvKey V.KEnter [] -> do
if allFieldsValid (s ^. txForm)
then do
pool <-
liftIO $ runNoLoggingT $ initPool $ s ^. dbPath
selWal <-
do case L.listSelectedElement $ s ^. wallets of
Nothing -> do
let fWall =
L.listSelectedElement $
L.listMoveToBeginning $ s ^. wallets
case fWall of
Nothing ->
throw $
userError "Failed to select wallet"
Just (_j, w1) -> return w1
Just (_k, w) -> return w
selAcc <-
do case L.listSelectedElement $ s ^. accounts of
Nothing -> do
let fAcc =
L.listSelectedElement $
L.listMoveToBeginning $
s ^. accounts
case fAcc of
Nothing ->
throw $
userError "Failed to select wallet"
Just (_j, w1) -> return w1
Just (_k, w) -> return w
fs1 <- BT.zoom txForm $ BT.gets formState
bl <-
liftIO $ getLastSyncBlock pool $ entityKey selWal
_ <-
liftIO $
forkIO $
sendTransaction
pool
(s ^. eventDispatch)
(s ^. zebraHost)
(s ^. zebraPort)
(s ^. network)
(entityKey selAcc)
bl
(fs1 ^. sendAmt)
(fs1 ^. sendTo)
(fs1 ^. sendMemo)
BT.modify $ set msg "Preparing transaction..."
BT.modify $ set displayBox SendDisplay
BT.modify $ set dialogBox Blank
else do
BT.modify $ set msg "Invalid inputs"
BT.modify $ set displayBox MsgDisplay
BT.modify $ set dialogBox Blank
ev -> do
BT.zoom txForm $ do
handleFormEvent (BT.VtyEvent ev)
fs <- BT.gets formState
BT.modify $
setFieldValid
(isRecipientValid (fs ^. sendTo))
RecField
Blank -> do
case e of
V.EvKey (V.KChar '\t') [] -> focusRing %= F.focusNext
@ -694,8 +933,10 @@ appEvent (BT.VtyEvent e) = do
V.EvKey (V.KChar 'a') [] ->
BT.modify $ set dialogBox ASelect
V.EvKey (V.KChar 's') [] -> do
BT.modify $ set barValue 0.0
BT.modify $ set displayBox SyncDisplay
BT.modify $
set txForm $
mkSendForm (s ^. balance) (SendInput "" 0.0 "")
BT.modify $ set dialogBox SendTx
ev ->
case r of
Just AList ->
@ -720,6 +961,9 @@ theMap =
, (titleAttr, V.withStyle (fg V.brightGreen) V.bold)
, (blinkAttr, style V.blink)
, (focusedFormInputAttr, V.white `on` V.blue)
, (invalidFormInputAttr, V.red `on` V.black)
, (E.editAttr, V.white `on` V.blue)
, (E.editFocusedAttr, V.blue `on` V.white)
, (baseAttr, bg V.brightBlack)
, (barDoneAttr, V.white `on` V.blue)
, (barToDoAttr, V.white `on` V.black)
@ -740,6 +984,7 @@ runZenithCLI config = do
let host = c_zebraHost config
let port = c_zebraPort config
let dbFilePath = c_dbPath config
pool <- runNoLoggingT $ initPool dbFilePath
w <- try $ checkZebra host port :: IO (Either IOError ZebraGetInfo)
case w of
Right zebra -> do
@ -750,18 +995,18 @@ runZenithCLI config = do
Left e1 -> throwIO e1
Right chainInfo -> do
initDb dbFilePath
walList <- getWallets dbFilePath $ zgb_net chainInfo
walList <- getWallets pool $ zgb_net chainInfo
accList <-
if not (null walList)
then getAccounts dbFilePath $ entityKey $ head walList
then runNoLoggingT $ getAccounts pool $ entityKey $ head walList
else return []
addrList <-
if not (null accList)
then getAddresses dbFilePath $ entityKey $ head accList
then runNoLoggingT $ getAddresses pool $ entityKey $ head accList
else return []
txList <-
if not (null addrList)
then getUserTx dbFilePath $ entityKey $ head addrList
then getUserTx pool $ entityKey $ head addrList
else return []
let block =
if not (null walList)
@ -769,9 +1014,14 @@ runZenithCLI config = do
else 0
bal <-
if not (null accList)
then getBalance dbFilePath $ entityKey $ head accList
then getBalance pool $ entityKey $ head accList
else return 0
eventChan <- BC.newBChan 10
_ <-
forkIO $
forever $ do
BC.writeBChan eventChan (TickVal 0.0)
threadDelay 1000000
let buildVty = VC.mkVty V.defaultConfig
initialVty <- buildVty
void $
@ -800,6 +1050,8 @@ runZenithCLI config = do
bal
1.0
eventChan
0
(mkSendForm 0 $ SendInput "" 0.0 "")
Left e -> do
print $
"No Zebra node available on port " <>
@ -807,34 +1059,38 @@ runZenithCLI config = do
refreshWallet :: State -> IO State
refreshWallet s = do
selWallet <-
pool <- runNoLoggingT $ initPool $ s ^. dbPath
walList <- getWallets pool $ s ^. network
(ix, selWallet) <-
do case L.listSelectedElement $ s ^. wallets of
Nothing -> do
let fWall =
L.listSelectedElement $ L.listMoveToBeginning $ s ^. wallets
case fWall of
Nothing -> throw $ userError "Failed to select wallet"
Just (_j, w1) -> return w1
Just (_k, w) -> return w
aL <- getAccounts (s ^. dbPath) $ entityKey selWallet
Just (j, w1) -> return (j, w1)
Just (k, w) -> return (k, w)
aL <- runNoLoggingT $ getAccounts pool $ entityKey selWallet
let bl = zcashWalletLastSync $ entityVal selWallet
addrL <-
if not (null aL)
then getAddresses (s ^. dbPath) $ entityKey $ head aL
then runNoLoggingT $ getAddresses pool $ entityKey $ head aL
else return []
bal <-
if not (null aL)
then getBalance (s ^. dbPath) $ entityKey $ head aL
then getBalance pool $ entityKey $ head aL
else return 0
txL <-
if not (null addrL)
then getUserTx (s ^. dbPath) $ entityKey $ head addrL
then getUserTx pool $ entityKey $ head addrL
else return []
let wL = L.listReplace (Vec.fromList walList) (Just ix) (s ^. wallets)
let aL' = L.listReplace (Vec.fromList aL) (Just 0) (s ^. accounts)
let addrL' = L.listReplace (Vec.fromList addrL) (Just 0) (s ^. addresses)
let txL' = L.listReplace (Vec.fromList txL) (Just 0) (s ^. transactions)
return $
(s & accounts .~ aL') & syncBlock .~ bl & balance .~ bal & addresses .~
s & wallets .~ wL & accounts .~ aL' & syncBlock .~ bl & balance .~ bal &
addresses .~
addrL' &
transactions .~
txL' &
@ -845,16 +1101,15 @@ refreshWallet s = do
addNewWallet :: T.Text -> State -> IO State
addNewWallet n s = do
sP <- generateWalletSeedPhrase
pool <- runNoLoggingT $ initPool $ s ^. dbPath
let bH = s ^. startBlock
let netName = s ^. network
r <-
saveWallet (s ^. dbPath) $
ZcashWallet n (ZcashNetDB netName) (PhraseDB sP) bH 0
r <- saveWallet pool $ ZcashWallet n (ZcashNetDB netName) (PhraseDB sP) bH 0
case r of
Nothing -> do
return $ s & msg .~ ("Wallet already exists: " ++ T.unpack n)
Just _ -> do
wL <- getWallets (s ^. dbPath) netName
wL <- getWallets pool netName
let aL =
L.listFindBy (\x -> zcashWalletName (entityVal x) == n) $
L.listReplace (Vec.fromList wL) (Just 0) (s ^. wallets)
@ -862,6 +1117,7 @@ addNewWallet n s = do
addNewAccount :: T.Text -> State -> IO State
addNewAccount n s = do
pool <- runNoLoggingT $ initPool $ s ^. dbPath
selWallet <-
do case L.listSelectedElement $ s ^. wallets of
Nothing -> do
@ -871,19 +1127,19 @@ addNewAccount n s = do
Nothing -> throw $ userError "Failed to select wallet"
Just (_j, w1) -> return w1
Just (_k, w) -> return w
aL' <- getMaxAccount (s ^. dbPath) (entityKey selWallet)
aL' <- getMaxAccount pool (entityKey selWallet)
zA <-
try $ createZcashAccount n (aL' + 1) selWallet :: IO
(Either IOError ZcashAccount)
case zA of
Left e -> return $ s & msg .~ ("Error: " ++ show e)
Right zA' -> do
r <- saveAccount (s ^. dbPath) zA'
r <- saveAccount pool zA'
case r of
Nothing ->
return $ s & msg .~ ("Account already exists: " ++ T.unpack n)
Just x -> do
aL <- getAccounts (s ^. dbPath) (entityKey selWallet)
aL <- runNoLoggingT $ getAccounts pool (entityKey selWallet)
let nL =
L.listMoveToElement x $
L.listReplace (Vec.fromList aL) (Just 0) (s ^. accounts)
@ -892,6 +1148,7 @@ addNewAccount n s = do
refreshAccount :: State -> IO State
refreshAccount s = do
pool <- runNoLoggingT $ initPool $ s ^. dbPath
selAccount <-
do case L.listSelectedElement $ s ^. accounts of
Nothing -> do
@ -901,8 +1158,8 @@ refreshAccount s = do
Nothing -> throw $ userError "Failed to select account"
Just (_j, w1) -> return w1
Just (_k, w) -> return w
aL <- getAddresses (s ^. dbPath) $ entityKey selAccount
bal <- getBalance (s ^. dbPath) $ entityKey selAccount
aL <- runNoLoggingT $ getAddresses pool $ entityKey selAccount
bal <- getBalance pool $ entityKey selAccount
let aL' = L.listReplace (Vec.fromList aL) (Just 0) (s ^. addresses)
selAddress <-
do case L.listSelectedElement aL' of
@ -916,7 +1173,7 @@ refreshAccount s = do
s & balance .~ bal & addresses .~ aL' & msg .~ "Switched to account: " ++
T.unpack (zcashAccountName $ entityVal selAccount)
Just (_i, a) -> do
tList <- getUserTx (s ^. dbPath) $ entityKey a
tList <- getUserTx pool $ entityKey a
let tL' = L.listReplace (Vec.fromList tList) (Just 0) (s ^. transactions)
return $
s & balance .~ bal & addresses .~ aL' & transactions .~ tL' & msg .~
@ -925,6 +1182,7 @@ refreshAccount s = do
refreshTxs :: State -> IO State
refreshTxs s = do
pool <- runNoLoggingT $ initPool $ s ^. dbPath
selAddress <-
do case L.listSelectedElement $ s ^. addresses of
Nothing -> do
@ -935,12 +1193,13 @@ refreshTxs s = do
case selAddress of
Nothing -> return s
Just (_i, a) -> do
tList <- getUserTx (s ^. dbPath) $ entityKey a
tList <- getUserTx pool $ entityKey a
let tL' = L.listReplace (Vec.fromList tList) (Just 0) (s ^. transactions)
return $ s & transactions .~ tL'
addNewAddress :: T.Text -> Scope -> State -> IO State
addNewAddress n scope s = do
pool <- runNoLoggingT $ initPool $ s ^. dbPath
selAccount <-
do case L.listSelectedElement $ s ^. accounts of
Nothing -> do
@ -950,19 +1209,19 @@ addNewAddress n scope s = do
Nothing -> throw $ userError "Failed to select account"
Just (_j, a1) -> return a1
Just (_k, a) -> return a
maxAddr <- getMaxAddress (s ^. dbPath) (entityKey selAccount) scope
maxAddr <- getMaxAddress pool (entityKey selAccount) scope
uA <-
try $ createWalletAddress n (maxAddr + 1) (s ^. network) scope selAccount :: IO
(Either IOError WalletAddress)
case uA of
Left e -> return $ s & msg .~ ("Error: " ++ show e)
Right uA' -> do
nAddr <- saveAddress (s ^. dbPath) uA'
nAddr <- saveAddress pool uA'
case nAddr of
Nothing ->
return $ s & msg .~ ("Address already exists: " ++ T.unpack n)
Just x -> do
addrL <- getAddresses (s ^. dbPath) (entityKey selAccount)
addrL <- runNoLoggingT $ getAddresses pool (entityKey selAccount)
let nL =
L.listMoveToElement x $
L.listReplace (Vec.fromList addrL) (Just 0) (s ^. addresses)
@ -971,3 +1230,51 @@ addNewAddress n scope s = do
T.unpack n ++
"(" ++
T.unpack (showAddress $ walletAddressUAddress $ entityVal x) ++ ")"
sendTransaction ::
ConnectionPool
-> BC.BChan Tick
-> T.Text
-> Int
-> ZcashNet
-> ZcashAccountId
-> Int
-> Float
-> T.Text
-> T.Text
-> IO ()
sendTransaction pool chan zHost zPort znet accId bl amt ua memo = do
BC.writeBChan chan $ TickMsg "Preparing transaction..."
outUA <- parseAddress ua
res <-
runFileLoggingT "zenith.log" $
prepareTx pool zHost zPort znet accId bl amt outUA memo
BC.writeBChan chan $ TickMsg "Transaction ready, sending to Zebra..."
case res of
Left e -> BC.writeBChan chan $ TickMsg $ show e
Right rawTx -> do
resp <-
makeZebraCall
zHost
zPort
"sendrawtransaction"
[Data.Aeson.String $ toText rawTx]
case resp of
Left e1 -> BC.writeBChan chan $ TickMsg $ "Zebra error: " ++ show e1
Right txId -> BC.writeBChan chan $ TickMsg $ "Tx ID: " ++ txId
where
parseAddress :: T.Text -> IO UnifiedAddress
parseAddress a =
case isValidUnifiedAddress (E.encodeUtf8 a) of
Just a1 -> return a1
Nothing ->
case decodeSaplingAddress (E.encodeUtf8 a) of
Just a2 ->
return $
UnifiedAddress znet Nothing (Just $ sa_receiver a2) Nothing
Nothing ->
case decodeTransparentAddress (E.encodeUtf8 a) of
Just a3 ->
return $
UnifiedAddress znet Nothing Nothing (Just $ ta_receiver a3)
Nothing -> throwIO $ userError "Incorrect address"

View file

@ -9,13 +9,18 @@ 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
@ -31,6 +36,7 @@ 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
@ -230,22 +236,24 @@ findSaplingOutputs config b znet za = do
let zebraHost = c_zebraHost config
let zebraPort = c_zebraPort config
let zn = getNet znet
tList <- getShieldedOutputs dbPath b
pool <- runNoLoggingT $ initPool dbPath
tList <- getShieldedOutputs pool b
trees <- getCommitmentTrees zebraHost zebraPort (b - 1)
let sT = SaplingCommitmentTree $ ztiSapling trees
decryptNotes sT zn tList
sapNotes <- getWalletSapNotes dbPath (entityKey za)
findSapSpends dbPath (entityKey za) sapNotes
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 ((zt, o):txs) = do
decryptNotes _ _ _ [] = return ()
decryptNotes st n pool ((zt, o):txs) = do
let updatedTree =
updateSaplingCommitmentTree
st
@ -262,15 +270,11 @@ findSaplingOutputs config b znet za = do
Nothing -> do
case decodeShOut Internal n nP o of
Nothing -> do
decryptNotes uT n txs
decryptNotes uT n pool txs
Just dn1 -> do
wId <-
saveWalletTransaction
(c_dbPath config)
(entityKey za)
zt
wId <- saveWalletTransaction pool (entityKey za) zt
saveWalletSapNote
(c_dbPath config)
pool
wId
nP
(fromJust noteWitness)
@ -278,12 +282,11 @@ findSaplingOutputs config b znet za = do
(entityKey za)
(entityKey o)
dn1
decryptNotes uT n txs
decryptNotes uT n pool txs
Just dn0 -> do
wId <-
saveWalletTransaction (c_dbPath config) (entityKey za) zt
wId <- saveWalletTransaction pool (entityKey za) zt
saveWalletSapNote
(c_dbPath config)
pool
wId
nP
(fromJust noteWitness)
@ -291,7 +294,7 @@ findSaplingOutputs config b znet za = do
(entityKey za)
(entityKey o)
dn0
decryptNotes uT n txs
decryptNotes uT n pool txs
decodeShOut ::
Scope
-> ZcashNet
@ -324,20 +327,22 @@ findOrchardActions config b znet za = do
let zebraHost = c_zebraHost config
let zebraPort = c_zebraPort config
let zn = getNet znet
tList <- getOrchardActions dbPath b
pool <- runNoLoggingT $ initPool dbPath
tList <- getOrchardActions pool b
trees <- getCommitmentTrees zebraHost zebraPort (b - 1)
let sT = OrchardCommitmentTree $ ztiOrchard trees
decryptNotes sT zn tList
orchNotes <- getWalletOrchNotes dbPath (entityKey za)
findOrchSpends dbPath (entityKey za) orchNotes
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 ((zt, o):txs) = do
decryptNotes _ _ _ [] = return ()
decryptNotes ot n pool ((zt, o):txs) = do
let updatedTree =
updateOrchardCommitmentTree
ot
@ -353,15 +358,11 @@ findOrchardActions config b znet za = do
case decodeOrchAction External nP o of
Nothing ->
case decodeOrchAction Internal nP o of
Nothing -> decryptNotes uT n txs
Nothing -> decryptNotes uT n pool txs
Just dn1 -> do
wId <-
saveWalletTransaction
(c_dbPath config)
(entityKey za)
zt
wId <- saveWalletTransaction pool (entityKey za) zt
saveWalletOrchNote
(c_dbPath config)
pool
wId
nP
(fromJust noteWitness)
@ -369,12 +370,11 @@ findOrchardActions config b znet za = do
(entityKey za)
(entityKey o)
dn1
decryptNotes uT n txs
decryptNotes uT n pool txs
Just dn -> do
wId <-
saveWalletTransaction (c_dbPath config) (entityKey za) zt
wId <- saveWalletTransaction pool (entityKey za) zt
saveWalletOrchNote
(c_dbPath config)
pool
wId
nP
(fromJust noteWitness)
@ -382,7 +382,7 @@ findOrchardActions config b znet za = do
(entityKey za)
(entityKey o)
dn
decryptNotes uT n txs
decryptNotes uT n pool txs
sk :: OrchardSpendingKeyDB
sk = zcashAccountOrchSpendKey $ entityVal za
decodeOrchAction ::
@ -399,56 +399,41 @@ findOrchardActions config b znet za = do
(getHex $ orchActionCv $ entityVal o)
(getHex $ orchActionAuth $ entityVal o)
updateSaplingWitnesses :: T.Text -> LoggingT IO ()
updateSaplingWitnesses dbPath = do
sapNotes <- liftIO $ getUnspentSapNotes dbPath
pool <- createSqlitePool dbPath 5
updateSaplingWitnesses :: ConnectionPool -> IO ()
updateSaplingWitnesses pool = do
sapNotes <- getUnspentSapNotes pool
maxId <- liftIO $ getMaxSaplingNote pool
mapM_ (updateOneNote pool maxId) sapNotes
mapM_ (updateOneNote maxId) sapNotes
where
updateOneNote ::
Pool SqlBackend
-> ShieldOutputId
-> Entity WalletSapNote
-> LoggingT IO ()
updateOneNote pool maxId n = do
updateOneNote :: ShieldOutputId -> Entity WalletSapNote -> IO ()
updateOneNote maxId n = do
let noteSync = walletSapNoteWitPos $ entityVal n
if noteSync < maxId
then 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
else logInfoN "Witness up to date"
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 :: T.Text -> LoggingT IO ()
updateOrchardWitnesses dbPath = do
orchNotes <- liftIO $ getUnspentOrchNotes dbPath
pool <- createSqlitePool dbPath 5
maxId <- liftIO $ getMaxOrchardNote pool
mapM_ (updateOneNote pool maxId) orchNotes
updateOrchardWitnesses :: ConnectionPool -> IO ()
updateOrchardWitnesses pool = do
orchNotes <- getUnspentOrchNotes pool
maxId <- getMaxOrchardNote pool
mapM_ (updateOneNote maxId) orchNotes
where
updateOneNote ::
Pool SqlBackend
-> OrchActionId
-> Entity WalletOrchNote
-> LoggingT IO ()
updateOneNote pool maxId n = do
updateOneNote :: OrchActionId -> Entity WalletOrchNote -> IO ()
updateOneNote maxId n = do
let noteSync = walletOrchNoteWitPos $ entityVal n
if noteSync < maxId
then 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
else logInfoN "Witness up to date"
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 ::
@ -460,21 +445,21 @@ calculateTxFee (t, s, o) i =
(5000 * (max (length t) tout + max (length s) sout + length o + oout))
where
tout =
if i == 1
if i == 1 || i == 2
then 1
else 0
sout =
if i == 2
if i == 3
then 1
else 0
oout =
if i == 3
then 2
else 1
if i == 4
then 1
else 0
-- | Prepare a transaction for sending
prepareTx ::
T.Text
ConnectionPool
-> T.Text
-> Int
-> ZcashNet
@ -483,9 +468,9 @@ prepareTx ::
-> Float
-> UnifiedAddress
-> T.Text
-> IO (Either TxError HexString)
prepareTx dbPath zebraHost zebraPort zn za bh amt ua memo = do
accRead <- getAccountById dbPath za
-> 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 ->
@ -499,63 +484,97 @@ prepareTx dbPath zebraHost zebraPort zn za bh amt ua memo = do
P2SH -> (2, toBytes $ tr_bytes r3)
Just r2 -> (3, getBytes r2)
Just r1 -> (4, getBytes r1)
print recipient
trees <- getCommitmentTrees zebraHost zebraPort bh
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 -> throwIO $ userError "Can't find Account"
Nothing -> do
logErrorN "Can't find Account"
return $ Left ZHError
Just acc -> do
print acc
spParams <- BS.readFile "sapling-spend.params"
outParams <- BS.readFile "sapling-output.params"
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 throwIO $ userError "Can't validate sapling parameters"
else print "Valid Sapling spend params"
then logErrorN "Can't validate sapling parameters"
else logInfoN "Valid Sapling spend params"
if show (md5 $ LBS.fromStrict outParams) /=
"924daf81b87a81bbbb9c7d18562046c8"
then throwIO $ userError "Can't validate sapling parameters"
else print "Valid Sapling output params"
print $ BS.length spParams
print $ BS.length outParams
print "Read Sapling params"
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)
firstPass <- selectUnspentNotes dbPath za zats
let fee = calculateTxFee firstPass 3
print "calculated fee"
print fee
(tList, sList, oList) <- selectUnspentNotes dbPath za (zats + fee)
print "selected notes"
print tList
print sList
print oList
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)
print noteTotal
tSpends <-
liftIO $
prepTSpends (getTranSK $ zcashAccountTPrivateKey $ entityVal acc) tList
print tSpends
--print tSpends
sSpends <-
liftIO $
prepSSpends (getSapSK $ zcashAccountSapSpendKey $ entityVal acc) sList
print sSpends
--print sSpends
oSpends <-
liftIO $
prepOSpends (getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc) oList
print oSpends
outgoing <- makeOutgoing acc recipient zats (noteTotal - fee - zats)
print outgoing
let tx =
--print oSpends
dummy <-
liftIO $ makeOutgoing acc recipient zats (noteTotal - 5000 - zats)
logDebugN "Calculating fee"
let feeResponse =
createTransaction
(Just sT)
(Just oT)
tSpends
sSpends
oSpends
outgoing
dummy
(SaplingSpendParams spParams)
(SaplingOutputParams outParams)
zn
(bh + 3)
return tx
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
@ -564,7 +583,7 @@ prepareTx dbPath zebraHost zebraPort zn za bh amt ua memo = do
-> Integer
-> IO [OutgoingNote]
makeOutgoing acc (k, recvr) zats chg = do
chgAddr <- getInternalAddresses dbPath $ entityKey acc
chgAddr <- runNoLoggingT $ getInternalAddresses pool $ entityKey acc
let internalUA = getUA $ walletAddressUAddress $ entityVal $ head chgAddr
let chgRcvr =
fromJust $ o_rec =<< isValidUnifiedAddress (E.encodeUtf8 internalUA)
@ -604,8 +623,7 @@ prepareTx dbPath zebraHost zebraPort zn za bh amt ua memo = do
-> IO [TransparentTxSpend]
prepTSpends sk notes = do
forM notes $ \n -> do
tAddRead <- getAddressById dbPath $ walletTrNoteAddress $ entityVal n
print n
tAddRead <- getAddressById pool $ walletTrNoteAddress $ entityVal n
case tAddRead of
Nothing -> throwIO $ userError "Couldn't read t-address"
Just tAdd -> do
@ -614,7 +632,7 @@ prepareTx dbPath zebraHost zebraPort zn za bh amt ua memo = do
(walletAddressIndex $ entityVal tAdd)
(getScope $ walletAddressScope $ entityVal tAdd)
sk
mReverseTxId <- getWalletTxId dbPath $ walletTrNoteTx $ entityVal n
mReverseTxId <- getWalletTxId pool $ walletTrNoteTx $ entityVal n
case mReverseTxId of
Nothing -> throwIO $ userError "failed to get tx ID"
Just (ESQ.Value reverseTxId) -> do
@ -632,7 +650,6 @@ prepareTx dbPath zebraHost zebraPort zn za bh amt ua memo = do
SaplingSpendingKey -> [Entity WalletSapNote] -> IO [SaplingTxSpend]
prepSSpends sk notes = do
forM notes $ \n -> do
print n
return $
SaplingTxSpend
(getBytes sk)
@ -648,7 +665,6 @@ prepareTx dbPath zebraHost zebraPort zn za bh amt ua memo = do
OrchardSpendingKey -> [Entity WalletOrchNote] -> IO [OrchardTxSpend]
prepOSpends sk notes = do
forM notes $ \n -> do
print n
return $
OrchardTxSpend
(getBytes sk)
@ -679,22 +695,24 @@ prepareTx dbPath zebraHost zebraPort zn za bh amt ua memo = do
syncWallet ::
Config -- ^ configuration parameters
-> Entity ZcashWallet
-> LoggingT IO ()
-> IO ()
syncWallet config w = do
startTime <- liftIO getCurrentTime
let walletDb = c_dbPath config
accs <- liftIO $ getAccounts walletDb $ entityKey w
addrs <- liftIO $ concat <$> mapM (getAddresses walletDb . entityKey) accs
pool <- runNoLoggingT $ initPool walletDb
accs <- runNoLoggingT $ getAccounts pool $ entityKey w
addrs <- concat <$> mapM (runNoLoggingT . getAddresses pool . entityKey) accs
intAddrs <-
liftIO $ concat <$> mapM (getInternalAddresses walletDb . entityKey) accs
chainTip <- liftIO $ getMaxBlock walletDb
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 walletDb startBlock) addrs
mapM_ (liftIO . findTransparentNotes walletDb startBlock) intAddrs
mapM_ (liftIO . findTransparentSpends walletDb . entityKey) accs
mapM_ (liftIO . findTransparentNotes pool startBlock) addrs
mapM_ (liftIO . findTransparentNotes pool startBlock) intAddrs
mapM_ (liftIO . findTransparentSpends pool . entityKey) accs
sapNotes <-
liftIO $
mapM
@ -705,52 +723,52 @@ syncWallet config w = do
mapM
(findOrchardActions config startBlock (zcashWalletNetwork $ entityVal w))
accs
_ <- updateSaplingWitnesses walletDb
_ <- updateOrchardWitnesses walletDb
_ <- liftIO $ updateWalletSync walletDb chainTip (entityKey w)
_ <- liftIO $ mapM_ (getWalletTransactions walletDb) addrs
logInfoN "Synced wallet"
_ <- 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
w <- getWallets dbPath TestNet
r <- runFileLoggingT "zenith.log" $ mapM (syncWallet config) w
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
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 dbPath
w <- getWallets dbPath TestNet
liftIO $ mapM_ (updateWalletSync dbPath 0 . entityKey) w
w' <- liftIO $ getWallets dbPath TestNet
r <- runFileLoggingT "zenith.log" $ mapM (syncWallet config) w'
_ <- 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

File diff suppressed because it is too large Load diff

View file

@ -3,11 +3,23 @@
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(..)
@ -30,64 +42,77 @@ scanZebra ::
-> T.Text -- ^ Host
-> Int -- ^ Port
-> T.Text -- ^ Path to database file
-> IO ()
-> NoLoggingT IO ()
scanZebra b host port dbFilePath = do
_ <- initDb dbFilePath
_ <- liftIO $ initDb dbFilePath
startTime <- liftIO getCurrentTime
logInfoN $ "Started sync: " <> T.pack (show startTime)
bc <-
try $ checkBlockChain host port :: IO
liftIO $ try $ checkBlockChain host port :: NoLoggingT
IO
(Either IOError ZebraGetBlockChainInfo)
case bc of
Left e -> print e
Left e -> logErrorN $ T.pack (show e)
Right bStatus -> do
dbBlock <- getMaxBlock dbFilePath
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 throwIO $ userError "Invalid starting block for scan"
then liftIO $ throwIO $ userError "Invalid starting block for scan"
else do
print $
liftIO $
print $
"Scanning from " ++
show (sb + 1) ++ " to " ++ show (zgb_blocks bStatus)
let bList = [(sb + 1) .. (zgb_blocks bStatus)]
displayConsoleRegions $ do
pg <- newProgressBar def {pgTotal = fromIntegral $ length bList}
pg <-
liftIO $
newProgressBar def {pgTotal = fromIntegral $ length bList}
txList <-
try $ mapM_ (processBlock host port dbFilePath pg) bList :: IO
CM.try $ mapM_ (processBlock host port pool pg) bList :: NoLoggingT
IO
(Either IOError ())
case txList of
Left e1 -> print e1
Right txList' -> print txList'
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`
-> T.Text -- ^ DB file path
-> ConnectionPool -- ^ DB file path
-> ProgressBar -- ^ Progress bar
-> Int -- ^ The block number to process
-> IO ()
processBlock host port dbFp pg b = do
-> 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 -> throwIO $ userError e
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 -> throwIO $ userError e2
Left e2 -> liftIO $ throwIO $ userError e2
Right hb -> do
let blockTime = getBlockTime hb
mapM_ (processTx host port blockTime dbFp) $
mapM_ (processTx host port blockTime pool) $
bl_txs $ addTime blk blockTime
tick pg
liftIO $ tick pg
where
addTime :: BlockResponse -> Int -> BlockResponse
addTime bl t =
@ -102,24 +127,25 @@ processTx ::
T.Text -- ^ Host name for `zebrad`
-> Int -- ^ Port for `zebrad`
-> Int -- ^ Block time
-> T.Text -- ^ DB file path
-> ConnectionPool -- ^ DB file path
-> HexString -- ^ transaction id
-> IO ()
processTx host port bt dbFp t = do
-> 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 -> throwIO $ userError e
Left e -> liftIO $ throwIO $ userError e
Right rawTx -> do
case readZebraTransaction (ztr_hex rawTx) of
Nothing -> return ()
Just rzt -> do
_ <-
saveTransaction dbFp bt $
saveTransaction pool bt $
Transaction
t
(ztr_blockheight rawTx)

View file

@ -26,17 +26,17 @@ jsonNumber i = Number $ scientific (fromIntegral i) 0
-- | Helper function to display small amounts of ZEC
displayZec :: Integer -> String
displayZec s
| s < 100 = show s ++ " zats "
| s < 100000 = show (fromIntegral s / 100) ++ " μZEC "
| s < 100000000 = show (fromIntegral s / 100000) ++ " mZEC "
| 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
| s < 100 = show s ++ " tazs "
| s < 100000 = show (fromIntegral s / 100) ++ " μTAZ "
| s < 100000000 = show (fromIntegral s / 100000) ++ " mTAZ "
| 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

View file

@ -1,7 +1,9 @@
{-# 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
@ -10,15 +12,22 @@ 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(..)
@ -72,8 +81,9 @@ main = do
"None" `shouldBe` maybe "None" zcashWalletName s
describe "Wallet function tests:" $ do
it "Save Wallet:" $ do
pool <- runNoLoggingT $ initPool "test.db"
zw <-
saveWallet "test.db" $
saveWallet pool $
ZcashWallet
"Testing"
(ZcashNetDB MainNet)
@ -84,19 +94,19 @@ main = do
0
zw `shouldNotBe` Nothing
it "Save Account:" $ do
pool <- runNoLoggingT $ initPool "test.db"
s <-
runSqlite "test.db" $ do
selectList [ZcashWalletName ==. "Testing"] []
za <-
saveAccount "test.db" =<<
createZcashAccount "TestAccount" 0 (head s)
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 "test.db" =<<
saveAddress pool =<<
createWalletAddress "Personal123" 0 MainNet External (head acList)
addList <-
runSqlite "test.db" $
@ -162,29 +172,82 @@ main = do
"6c5d1413c63a9a88db71c3f41dc12cd60197ee742fc75b217215e7144db48bd3"
describe "Note selection for Tx" $ do
it "Value less than balance" $ do
res <- selectUnspentNotes "zenith.db" (toSqlKey 1) 14000000
pool <- runNoLoggingT $ initPool "zenith.db"
res <- selectUnspentNotes pool (toSqlKey 1) 14000000
res `shouldNotBe` ([], [], [])
it "Value greater than balance" $ do
let res = selectUnspentNotes "zenith.db" (toSqlKey 1) 84000000
pool <- runNoLoggingT $ initPool "zenith.db"
let res = selectUnspentNotes pool (toSqlKey 1) 84000000
res `shouldThrow` anyIOException
it "Fee calculation" $ do
res <- selectUnspentNotes "zenith.db" (toSqlKey 1) 14000000
pool <- runNoLoggingT $ initPool "zenith.db"
res <- selectUnspentNotes pool (toSqlKey 1) 14000000
calculateTxFee res 3 `shouldBe` 20000
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")
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 +1 @@
Subproject commit 22c0fe374976d9f2323a8b7cd42f941423d45111
Subproject commit 9dddb42bb3ab78ed0c4d44efb00960ac112c2ce6

View file

@ -46,6 +46,8 @@ library
, bytestring
, esqueleto
, resource-pool
, binary
, exceptions
, monad-logger
, vty-crossplatform
, secp256k1-haskell
@ -61,6 +63,7 @@ library
, microlens-th
, mtl
, persistent
, Hclip
, persistent-sqlite
, persistent-template
, process
@ -105,6 +108,7 @@ executable zenscan
build-depends:
base >=4.12 && <5
, configurator
, monad-logger
, zenith
pkgconfig-depends: rustzcash_wrapper
default-language: Haskell2010
@ -119,6 +123,7 @@ test-suite zenith-tests
base >=4.12 && <5
, bytestring
, configurator
, monad-logger
, data-default
, sort
, text