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

rvv001 - Merge branch 'rav001' into rvv001

Browse source
This commit is contained in:
Rene V. Vergara A. 2024-10-18 15:55:43 -04:00
commit 8a54f8fda9
7 changed files with 262 additions and 114 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
src/Zenith/CLI.hs
View file

@ -839,7 +839,7 @@ scanZebra dbP zHost zPort b eChan znet = do
logDebugN $ logDebugN $
"dbBlock: " <> "dbBlock: " <>
T.pack (show dbBlock) <> " chkBlock: " <> T.pack (show chkBlock) T.pack (show dbBlock) <> " chkBlock: " <> T.pack (show chkBlock)
when (chkBlock /= dbBlock) $ liftIO $ rewindWalletData pool chkBlock when (chkBlock /= dbBlock) $ rewindWalletData pool chkBlock
let sb = let sb =
if chkBlock == dbBlock if chkBlock == dbBlock
then max dbBlock b then max dbBlock b
@ -953,7 +953,7 @@ appEvent (BT.AppEvent t) = do
Just (_k, w) -> return w Just (_k, w) -> return w
_ <- _ <-
liftIO $ liftIO $
runNoLoggingT $ runStderrLoggingT $
syncWallet syncWallet
(Config (Config
(s ^. dbPath) (s ^. dbPath)

69
src/Zenith/Core.hs
View file

@ -60,6 +60,7 @@ import ZcashHaskell.Sapling
, genSaplingInternalAddress , genSaplingInternalAddress
, genSaplingPaymentAddress , genSaplingPaymentAddress
, genSaplingSpendingKey , genSaplingSpendingKey
, getSaplingFrontier
, getSaplingNotePosition , getSaplingNotePosition
, getSaplingWitness , getSaplingWitness
, updateSaplingCommitmentTree , updateSaplingCommitmentTree
@ -279,49 +280,64 @@ findSaplingOutputs ::
-> Int -- ^ the starting block -> Int -- ^ the starting block
-> ZcashNetDB -- ^ The network -> ZcashNetDB -- ^ The network
-> Entity ZcashAccount -- ^ The account to use -> Entity ZcashAccount -- ^ The account to use
-> IO () -> LoggingT IO ()
findSaplingOutputs config b znet za = do findSaplingOutputs config b znet za = do
let dbPath = c_dbPath config let dbPath = c_dbPath config
let zebraHost = c_zebraHost config let zebraHost = c_zebraHost config
let zebraPort = c_zebraPort config let zebraPort = c_zebraPort config
let zn = getNet znet let zn = getNet znet
pool <- runNoLoggingT $ initPool dbPath pool <- liftIO $ runNoLoggingT $ initPool dbPath
tList <- getShieldedOutputs pool b znet tList <- liftIO $ getShieldedOutputs pool b znet
trees <- getCommitmentTrees zebraHost zebraPort (b - 1) trees <- liftIO $ getCommitmentTrees zebraHost zebraPort (b - 1)
let sT = SaplingCommitmentTree $ ztiSapling trees logDebugN "getting Sapling frontier"
decryptNotes sT zn pool tList let sT = getSaplingFrontier $ SaplingCommitmentTree $ ztiSapling trees
sapNotes <- getWalletSapNotes pool (entityKey za) case sT of
findSapSpends pool (entityKey za) sapNotes Nothing ->
liftIO $ throwIO $ userError "Failed to read Sapling commitment tree"
Just sT' -> do
logDebugN "Sapling frontier valid"
decryptNotes sT' zn pool tList
sapNotes <- liftIO $ getWalletSapNotes pool (entityKey za)
liftIO $ findSapSpends pool (entityKey za) sapNotes
where where
sk :: SaplingSpendingKeyDB sk :: SaplingSpendingKeyDB
sk = zcashAccountSapSpendKey $ entityVal za sk = zcashAccountSapSpendKey $ entityVal za
decryptNotes :: decryptNotes ::
SaplingCommitmentTree SaplingFrontier
-> ZcashNet -> ZcashNet
-> ConnectionPool -> ConnectionPool
-> [(Entity ZcashTransaction, Entity ShieldOutput)] -> [(Entity ZcashTransaction, Entity ShieldOutput)]
-> IO () -> LoggingT IO ()
decryptNotes _ _ _ [] = return () decryptNotes _ _ _ [] = return ()
decryptNotes st n pool ((zt, o):txs) = do decryptNotes st n pool ((zt, o):txs) = do
let updatedTree = let updatedTree =
updateSaplingCommitmentTree updateSaplingCommitmentTree
st st
(getHex $ shieldOutputCmu $ entityVal o) (getHex $ shieldOutputCmu $ entityVal o)
logDebugN "updated frontier"
case updatedTree of case updatedTree of
Nothing -> throwIO $ userError "Failed to update commitment tree" Nothing ->
liftIO $ throwIO $ userError "Failed to update commitment tree"
Just uT -> do Just uT -> do
let noteWitness = getSaplingWitness uT let noteWitness = getSaplingWitness uT
logDebugN "got witness"
let notePos = getSaplingNotePosition <$> noteWitness let notePos = getSaplingNotePosition <$> noteWitness
logDebugN "got position"
case notePos of case notePos of
Nothing -> throwIO $ userError "Failed to obtain note position" Nothing ->
liftIO $ throwIO $ userError "Failed to obtain note position"
Just nP -> do Just nP -> do
case decodeShOut External n nP o of case decodeShOut External n nP o of
Nothing -> do Nothing -> do
logDebugN "couldn't decode external"
case decodeShOut Internal n nP o of case decodeShOut Internal n nP o of
Nothing -> do Nothing -> do
logDebugN "couldn't decode internal"
decryptNotes uT n pool txs decryptNotes uT n pool txs
Just dn1 -> do Just dn1 -> do
wId <- saveWalletTransaction pool (entityKey za) zt wId <-
liftIO $ saveWalletTransaction pool (entityKey za) zt
liftIO $
saveWalletSapNote saveWalletSapNote
pool pool
wId wId
@ -333,7 +349,8 @@ findSaplingOutputs config b znet za = do
dn1 dn1
decryptNotes uT n pool txs decryptNotes uT n pool txs
Just dn0 -> do Just dn0 -> do
wId <- saveWalletTransaction pool (entityKey za) zt wId <- liftIO $ saveWalletTransaction pool (entityKey za) zt
liftIO $
saveWalletSapNote saveWalletSapNote
pool pool
wId wId
@ -926,7 +943,7 @@ prepareTxV2 pool zebraHost zebraPort zn za bh pnotes policy = do
oSpends oSpends
dummy dummy
zn zn
(bh + 3) bh
False False
case feeResponse of case feeResponse of
Left e1 -> return $ Left Fee Left e1 -> return $ Left Fee
@ -985,7 +1002,7 @@ prepareTxV2 pool zebraHost zebraPort zn za bh pnotes policy = do
oSpends1 oSpends1
outgoing outgoing
zn zn
(bh + 3) bh
True True
logDebugN $ T.pack $ show tx logDebugN $ T.pack $ show tx
return tx return tx
@ -1261,14 +1278,14 @@ prepareTxV2 pool zebraHost zebraPort zn za bh pnotes policy = do
syncWallet :: syncWallet ::
Config -- ^ configuration parameters Config -- ^ configuration parameters
-> Entity ZcashWallet -> Entity ZcashWallet
-> NoLoggingT IO () -> LoggingT IO ()
syncWallet config w = do syncWallet config w = do
startTime <- liftIO getCurrentTime startTime <- liftIO getCurrentTime
logDebugN $ T.pack $ show startTime
let walletDb = c_dbPath config let walletDb = c_dbPath config
let znet = zcashWalletNetwork $ entityVal w let znet = zcashWalletNetwork $ entityVal w
pool <- liftIO $ runNoLoggingT $ initPool walletDb pool <- liftIO $ runNoLoggingT $ initPool walletDb
accs <- liftIO $ runNoLoggingT $ getAccounts pool $ entityKey w accs <- liftIO $ runNoLoggingT $ getAccounts pool $ entityKey w
logDebugN $ "Accounts: " <> T.pack (show accs)
addrs <- addrs <-
concat <$> concat <$>
mapM (liftIO . runNoLoggingT . getAddresses pool . entityKey) accs mapM (liftIO . runNoLoggingT . getAddresses pool . entityKey) accs
@ -1278,7 +1295,7 @@ syncWallet config w = do
mapM (liftIO . runNoLoggingT . getInternalAddresses pool . entityKey) accs mapM (liftIO . runNoLoggingT . getInternalAddresses pool . entityKey) accs
chainTip <- liftIO $ getMaxBlock pool znet chainTip <- liftIO $ getMaxBlock pool znet
logDebugN $ "chain tip: " <> T.pack (show chainTip) logDebugN $ "chain tip: " <> T.pack (show chainTip)
let lastBlock = zcashWalletLastSync $ entityVal w lastBlock <- liftIO $ getLastSyncBlock pool $ entityKey w
logDebugN $ "last block: " <> T.pack (show lastBlock) logDebugN $ "last block: " <> T.pack (show lastBlock)
let startBlock = let startBlock =
if lastBlock > 0 if lastBlock > 0
@ -1287,18 +1304,22 @@ syncWallet config w = do
logDebugN $ "start block: " <> T.pack (show startBlock) logDebugN $ "start block: " <> T.pack (show startBlock)
mapM_ (liftIO . findTransparentNotes pool startBlock znet) addrs mapM_ (liftIO . findTransparentNotes pool startBlock znet) addrs
mapM_ (liftIO . findTransparentNotes pool startBlock znet) intAddrs mapM_ (liftIO . findTransparentNotes pool startBlock znet) intAddrs
logDebugN "processed transparent notes"
mapM_ (liftIO . findTransparentSpends pool . entityKey) accs mapM_ (liftIO . findTransparentSpends pool . entityKey) accs
sapNotes <- logDebugN "processed transparent spends"
liftIO $ mapM_
mapM
(findSaplingOutputs config startBlock (zcashWalletNetwork $ entityVal w)) (findSaplingOutputs config startBlock (zcashWalletNetwork $ entityVal w))
accs accs
orchNotes <- logDebugN "processed sapling outputs"
liftIO $ liftIO $
mapM mapM_
(findOrchardActions config startBlock (zcashWalletNetwork $ entityVal w)) (findOrchardActions config startBlock (zcashWalletNetwork $ entityVal w))
accs accs
logDebugN "processed orchard actions"
_ <- liftIO $ updateSaplingWitnesses pool _ <- liftIO $ updateSaplingWitnesses pool
logDebugN "updated sapling witnesses"
_ <- liftIO $ updateOrchardWitnesses pool _ <- liftIO $ updateOrchardWitnesses pool
logDebugN "updated orchard witnesses"
_ <- liftIO $ updateWalletSync pool chainTip (entityKey w) _ <- liftIO $ updateWalletSync pool chainTip (entityKey w)
logDebugN "updated wallet lastSync"
mapM_ (liftIO . runNoLoggingT . getWalletTransactions pool) addrs mapM_ (liftIO . runNoLoggingT . getWalletTransactions pool) addrs

141
src/Zenith/DB.hs
View file

@ -21,7 +21,13 @@ module Zenith.DB where
import Control.Exception (SomeException(..), throw, throwIO, try) import Control.Exception (SomeException(..), throw, throwIO, try)
import Control.Monad (unless, when) import Control.Monad (unless, when)
import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Logger (NoLoggingT, runNoLoggingT) import Control.Monad.Logger
( LoggingT
, NoLoggingT
, logDebugN
, runNoLoggingT
, runStderrLoggingT
)
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.HexString import Data.HexString
import Data.Int import Data.Int
@ -1783,10 +1789,25 @@ getSaplingCmus pool zt = do
getMaxSaplingNote :: Pool SqlBackend -> IO ShieldOutputId getMaxSaplingNote :: Pool SqlBackend -> IO ShieldOutputId
getMaxSaplingNote pool = do getMaxSaplingNote pool = do
flip PS.runSqlPool pool $ do flip PS.runSqlPool pool $ do
maxBlock <-
selectOne $ do
blks <- from $ table @ZcashBlock
where_ $ blks ^. ZcashBlockHeight >. val 0
orderBy [desc $ blks ^. ZcashBlockHeight]
pure $ blks ^. ZcashBlockHeight
case maxBlock of
Nothing -> return $ toSqlKey 0
Just (Value mb) -> do
x <- x <-
selectOne $ do selectOne $ do
n <- from $ table @ShieldOutput (blks :& txs :& n) <-
where_ (n ^. ShieldOutputId >. val (toSqlKey 0)) from $ table @ZcashBlock `innerJoin` table @ZcashTransaction `on`
(\(blks :& txs) ->
blks ^. ZcashBlockId ==. txs ^. ZcashTransactionBlockId) `innerJoin`
table @ShieldOutput `on`
(\(_ :& txs :& n) ->
txs ^. ZcashTransactionId ==. n ^. ShieldOutputTx)
where_ (blks ^. ZcashBlockHeight <=. val (mb - 5))
orderBy [desc $ n ^. ShieldOutputId] orderBy [desc $ n ^. ShieldOutputId]
pure (n ^. ShieldOutputId) pure (n ^. ShieldOutputId)
case x of case x of
@ -1836,6 +1857,7 @@ getMaxOrchardNote pool = do
selectOne $ do selectOne $ do
blks <- from $ table @ZcashBlock blks <- from $ table @ZcashBlock
where_ $ blks ^. ZcashBlockHeight >. val 0 where_ $ blks ^. ZcashBlockHeight >. val 0
orderBy [desc $ blks ^. ZcashBlockHeight]
pure $ blks ^. ZcashBlockHeight pure $ blks ^. ZcashBlockHeight
case maxBlock of case maxBlock of
Nothing -> return $ toSqlKey 0 Nothing -> return $ toSqlKey 0
@ -2052,22 +2074,22 @@ rewindWalletTransactions pool b = do
x <- from $ table @WalletOrchNote x <- from $ table @WalletOrchNote
where_ $ x ^. WalletOrchNoteTx `in_` valList oldKeys where_ $ x ^. WalletOrchNoteTx `in_` valList oldKeys
return () return ()
delete $ do
x <- from $ table @WalletSapNote
where_ $ x ^. WalletSapNoteTx `in_` valList oldKeys
return ()
delete $ do delete $ do
x <- from $ table @WalletSapSpend x <- from $ table @WalletSapSpend
where_ $ x ^. WalletSapSpendTx `in_` valList oldKeys where_ $ x ^. WalletSapSpendTx `in_` valList oldKeys
return () return ()
delete $ do delete $ do
x <- from $ table @WalletTrNote x <- from $ table @WalletSapNote
where_ $ x ^. WalletTrNoteTx `in_` valList oldKeys where_ $ x ^. WalletSapNoteTx `in_` valList oldKeys
return () return ()
delete $ do delete $ do
x <- from $ table @WalletTrSpend x <- from $ table @WalletTrSpend
where_ $ x ^. WalletTrSpendTx `in_` valList oldKeys where_ $ x ^. WalletTrSpendTx `in_` valList oldKeys
return () return ()
delete $ do
x <- from $ table @WalletTrNote
where_ $ x ^. WalletTrNoteTx `in_` valList oldKeys
return ()
delete $ do delete $ do
txs <- from $ table @WalletTransaction txs <- from $ table @WalletTransaction
where_ $ txs ^. WalletTransactionBlock >. val b where_ $ txs ^. WalletTransactionBlock >. val b
@ -2621,10 +2643,14 @@ completeSync pool st = do
return () return ()
-- | Rewind the data store to a given block height -- | Rewind the data store to a given block height
rewindWalletData :: ConnectionPool -> Int -> IO () rewindWalletData :: ConnectionPool -> Int -> LoggingT IO ()
rewindWalletData pool b = do rewindWalletData pool b = do
rewindWalletTransactions pool b logDebugN "Starting transaction rewind"
runNoLoggingT $ liftIO $ clearWalletTransactions pool
logDebugN "Completed transaction rewind"
logDebugN "Starting data store rewind"
_ <-
runStderrLoggingT $
PS.retryOnBusy $ PS.retryOnBusy $
flip PS.runSqlPool pool $ do flip PS.runSqlPool pool $ do
oldBlocks <- oldBlocks <-
@ -2642,21 +2668,112 @@ rewindWalletData pool b = do
delete $ do delete $ do
x <- from $ table @TransparentNote x <- from $ table @TransparentNote
where_ $ x ^. TransparentNoteTx `in_` valList oldTxKeys where_ $ x ^. TransparentNoteTx `in_` valList oldTxKeys
logDebugN "Completed TransparentNote delete"
_ <-
runStderrLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
oldBlocks <-
select $ do
blk <- from $ table @ZcashBlock
where_ $ blk ^. ZcashBlockHeight >. val b
pure blk
let oldBlkKeys = map entityKey oldBlocks
oldTxs <-
select $ do
txs <- from $ table @ZcashTransaction
where_ $ txs ^. ZcashTransactionBlockId `in_` valList oldBlkKeys
pure txs
let oldTxKeys = map entityKey oldTxs
delete $ do delete $ do
x <- from $ table @TransparentSpend x <- from $ table @TransparentSpend
where_ $ x ^. TransparentSpendTx `in_` valList oldTxKeys where_ $ x ^. TransparentSpendTx `in_` valList oldTxKeys
logDebugN "Completed TransparentSpend delete"
_ <-
runStderrLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
oldBlocks <-
select $ do
blk <- from $ table @ZcashBlock
where_ $ blk ^. ZcashBlockHeight >. val b
pure blk
let oldBlkKeys = map entityKey oldBlocks
oldTxs <-
select $ do
txs <- from $ table @ZcashTransaction
where_ $ txs ^. ZcashTransactionBlockId `in_` valList oldBlkKeys
pure txs
let oldTxKeys = map entityKey oldTxs
delete $ do delete $ do
x <- from $ table @ShieldOutput x <- from $ table @ShieldOutput
where_ $ x ^. ShieldOutputTx `in_` valList oldTxKeys where_ $ x ^. ShieldOutputTx `in_` valList oldTxKeys
logDebugN "Completed ShieldOutput delete"
_ <-
runStderrLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
oldBlocks <-
select $ do
blk <- from $ table @ZcashBlock
where_ $ blk ^. ZcashBlockHeight >. val b
pure blk
let oldBlkKeys = map entityKey oldBlocks
oldTxs <-
select $ do
txs <- from $ table @ZcashTransaction
where_ $ txs ^. ZcashTransactionBlockId `in_` valList oldBlkKeys
pure txs
let oldTxKeys = map entityKey oldTxs
delete $ do delete $ do
x <- from $ table @ShieldSpend x <- from $ table @ShieldSpend
where_ $ x ^. ShieldSpendTx `in_` valList oldTxKeys where_ $ x ^. ShieldSpendTx `in_` valList oldTxKeys
logDebugN "Completed ShieldSpend delete"
_ <-
runStderrLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
oldBlocks <-
select $ do
blk <- from $ table @ZcashBlock
where_ $ blk ^. ZcashBlockHeight >. val b
pure blk
let oldBlkKeys = map entityKey oldBlocks
oldTxs <-
select $ do
txs <- from $ table @ZcashTransaction
where_ $ txs ^. ZcashTransactionBlockId `in_` valList oldBlkKeys
pure txs
let oldTxKeys = map entityKey oldTxs
delete $ do delete $ do
x <- from $ table @OrchAction x <- from $ table @OrchAction
where_ $ x ^. OrchActionTx `in_` valList oldTxKeys where_ $ x ^. OrchActionTx `in_` valList oldTxKeys
logDebugN "Completed OrchAction delete"
_ <-
runStderrLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
oldBlocks <-
select $ do
blk <- from $ table @ZcashBlock
where_ $ blk ^. ZcashBlockHeight >. val b
pure blk
let oldBlkKeys = map entityKey oldBlocks
oldTxs <-
select $ do
txs <- from $ table @ZcashTransaction
where_ $ txs ^. ZcashTransactionBlockId `in_` valList oldBlkKeys
pure txs
let oldTxKeys = map entityKey oldTxs
delete $ do delete $ do
x <- from $ table @ZcashTransaction x <- from $ table @ZcashTransaction
where_ $ x ^. ZcashTransactionId `in_` valList oldTxKeys where_ $ x ^. ZcashTransactionId `in_` valList oldTxKeys
logDebugN "Completed ZcashTransaction delete"
_ <-
runStderrLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
delete $ do delete $ do
blk <- from $ table @ZcashBlock blk <- from $ table @ZcashBlock
where_ $ blk ^. ZcashBlockHeight >. val b where_ $ blk ^. ZcashBlockHeight >. val b
logDebugN "Completed data store rewind"

63
src/Zenith/GUI.hs
View file

@ -12,7 +12,7 @@ import Control.Concurrent (threadDelay)
import Control.Exception (throwIO, try) import Control.Exception (throwIO, try)
import Control.Monad (unless, when) import Control.Monad (unless, when)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (runFileLoggingT, runNoLoggingT) import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT)
import Data.Aeson import Data.Aeson
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.HexString (toText) import Data.HexString (toText)
@ -997,31 +997,17 @@ buildUI wenv model = widgetTree
, label (displayAmount (model ^. network) 100) `styleBasic` , label (displayAmount (model ^. network) 100) `styleBasic`
[width 50, textFont "Bold"] [width 50, textFont "Bold"]
, filler , 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)
-- ]
] ]
, spacer , spacer
, box_ , box_
[alignMiddle] [alignMiddle]
(hstack (hstack
[ filler [ filler
, mainButton "Proceed" NotImplemented `nodeEnabled` True , mainButton "Proceed" NotImplemented `nodeEnabled`
-- (model ^. amountValid && model ^. recipientValid) True
, spacer , spacer
, mainButton "Cancel" CloseShield `nodeEnabled` True , mainButton "Cancel" CloseShield `nodeEnabled`
True
, filler , filler
]) ])
]) `styleBasic` ]) `styleBasic`
@ -1047,12 +1033,14 @@ buildUI wenv model = widgetTree
, separatorLine `styleBasic` [fgColor btnColor] , separatorLine `styleBasic` [fgColor btnColor]
, spacer , spacer
, hstack , hstack
[ (label "Total Transparent : " `styleBasic` [ textFont "Bold" ]) [ (label "Total Transparent : " `styleBasic`
[textFont "Bold"])
, (label "0.00") , (label "0.00")
] ]
, spacer , spacer
, hstack , hstack
[ (label "Total Shielded : " `styleBasic` [ textFont "Bold" ]) [ (label "Total Shielded : " `styleBasic`
[textFont "Bold"])
, (label "0.00") , (label "0.00")
] ]
, spacer , spacer
@ -1065,7 +1053,8 @@ buildUI wenv model = widgetTree
[ decimals 8 [ decimals 8
, minValue 0.0 , minValue 0.0
, maxValue , maxValue
(fromIntegral (model ^. sBalance) / 100000000.0) (fromIntegral (model ^. sBalance) /
100000000.0)
, validInput sBalanceValid , validInput sBalanceValid
, onChange CheckAmount , onChange CheckAmount
] `styleBasic` ] `styleBasic`
@ -1080,10 +1069,11 @@ buildUI wenv model = widgetTree
[alignMiddle] [alignMiddle]
(hstack (hstack
[ filler [ filler
, mainButton "Proceed" NotImplemented `nodeEnabled` True , mainButton "Proceed" NotImplemented `nodeEnabled`
-- (model ^. amountValid && model ^. recipientValid) True
, spacer , spacer
, mainButton "Cancel" CloseDeShield `nodeEnabled` True , mainButton "Cancel" CloseDeShield `nodeEnabled`
True
, filler , filler
]) ])
]) `styleBasic` ]) `styleBasic`
@ -1093,6 +1083,24 @@ buildUI wenv model = widgetTree
, filler , filler
]) `styleBasic` ]) `styleBasic`
[bgColor (white & L.a .~ 0.5)] [bgColor (white & L.a .~ 0.5)]
-- , 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)
-- ]
-- (model ^. amountValid && model ^. recipientValid)
-- (model ^. amountValid && model ^. recipientValid)
notImplemented = NotImplemented notImplemented = NotImplemented
generateQRCodes :: Config -> IO () generateQRCodes :: Config -> IO ()
@ -1391,7 +1399,7 @@ handleEvent wenv node model evt =
case currentWallet of case currentWallet of
Nothing -> return $ ShowError "No wallet available" Nothing -> return $ ShowError "No wallet available"
Just cW -> do Just cW -> do
runNoLoggingT $ syncWallet (model ^. configuration) cW runStderrLoggingT $ syncWallet (model ^. configuration) cW
pool <- pool <-
runNoLoggingT $ runNoLoggingT $
initPool $ c_dbPath $ model ^. configuration initPool $ c_dbPath $ model ^. configuration
@ -1623,7 +1631,8 @@ scanZebra dbPath zHost zPort net sendMsg = do
if syncChk if syncChk
then sendMsg (ShowError "Sync already in progress") then sendMsg (ShowError "Sync already in progress")
else do else do
unless (chkBlock == dbBlock) $ rewindWalletData pool chkBlock unless (chkBlock == dbBlock) $
runStderrLoggingT $ rewindWalletData pool chkBlock
let sb = let sb =
if chkBlock == dbBlock if chkBlock == dbBlock
then max dbBlock b then max dbBlock b

5
src/Zenith/RPC.hs
View file

@ -892,7 +892,8 @@ scanZebra dbPath zHost zPort net = do
chkBlock <- checkIntegrity dbPath zHost zPort dbBlock 1 chkBlock <- checkIntegrity dbPath zHost zPort dbBlock 1
syncChk <- isSyncing pool syncChk <- isSyncing pool
unless syncChk $ do unless syncChk $ do
unless (chkBlock == dbBlock) $ rewindWalletData pool chkBlock unless (chkBlock == dbBlock) $
runStderrLoggingT $ rewindWalletData pool chkBlock
let sb = let sb =
if chkBlock == dbBlock if chkBlock == dbBlock
then max dbBlock b then max dbBlock b
@ -909,7 +910,7 @@ scanZebra dbPath zHost zPort net = do
return () return ()
Right _ -> do Right _ -> do
wals <- getWallets pool net wals <- getWallets pool net
runNoLoggingT $ runStderrLoggingT $
mapM_ mapM_
(syncWallet (Config dbPath zHost zPort "user" "pwd" 8080)) (syncWallet (Config dbPath zHost zPort "user" "pwd" 8080))
wals wals

4
src/Zenith/Scanner.hs
View file

@ -10,8 +10,8 @@ import Control.Monad.Logger
( NoLoggingT ( NoLoggingT
, logErrorN , logErrorN
, logInfoN , logInfoN
, runFileLoggingT
, runNoLoggingT , runNoLoggingT
, runStderrLoggingT
) )
import Data.Aeson import Data.Aeson
import Data.HexString import Data.HexString
@ -238,7 +238,7 @@ clearSync config = do
w <- getWallets pool $ zgb_net chainInfo w <- getWallets pool $ zgb_net chainInfo
liftIO $ mapM_ (updateWalletSync pool 0 . entityKey) w liftIO $ mapM_ (updateWalletSync pool 0 . entityKey) w
w' <- liftIO $ getWallets pool $ zgb_net chainInfo w' <- liftIO $ getWallets pool $ zgb_net chainInfo
r <- runNoLoggingT $ mapM (syncWallet config) w' r <- runStderrLoggingT $ mapM (syncWallet config) w'
liftIO $ print r liftIO $ print r
-- | Detect chain re-orgs -- | Detect chain re-orgs

6
test/Spec.hs
View file

@ -212,8 +212,8 @@ main = do
"localhost" "localhost"
18232 18232
TestNet TestNet
(toSqlKey 1) (toSqlKey 3)
3001331 3026170
[ ProposedNote [ ProposedNote
(ValidAddressAPI $ fromJust uaRead) (ValidAddressAPI $ fromJust uaRead)
0.005 0.005
@ -222,7 +222,7 @@ main = do
Full Full
case tx of case tx of
Left e -> assertFailure $ show e Left e -> assertFailure $ show e
Right h -> h `shouldNotBe` (hexString "deadbeef") Right h -> h `shouldBe` (hexString "deadbeef")
it "To Sapling" $ do it "To Sapling" $ do
let uaRead = let uaRead =
parseAddress parseAddress