Milestone 3: RPC server, ZIP-320 #104
8 changed files with 263 additions and 115 deletions
|
@ -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)
|
||||||
|
|
|
@ -60,6 +60,7 @@ import ZcashHaskell.Sapling
|
||||||
, genSaplingInternalAddress
|
, genSaplingInternalAddress
|
||||||
, genSaplingPaymentAddress
|
, genSaplingPaymentAddress
|
||||||
, genSaplingSpendingKey
|
, genSaplingSpendingKey
|
||||||
|
, getSaplingFrontier
|
||||||
, getSaplingNotePosition
|
, getSaplingNotePosition
|
||||||
, getSaplingWitness
|
, getSaplingWitness
|
||||||
, updateSaplingCommitmentTree
|
, updateSaplingCommitmentTree
|
||||||
|
@ -279,70 +280,86 @@ 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 <-
|
||||||
saveWalletSapNote
|
liftIO $ saveWalletTransaction pool (entityKey za) zt
|
||||||
pool
|
liftIO $
|
||||||
wId
|
saveWalletSapNote
|
||||||
nP
|
pool
|
||||||
(fromJust noteWitness)
|
wId
|
||||||
True
|
nP
|
||||||
(entityKey za)
|
(fromJust noteWitness)
|
||||||
(entityKey o)
|
True
|
||||||
dn1
|
(entityKey za)
|
||||||
|
(entityKey o)
|
||||||
|
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
|
||||||
saveWalletSapNote
|
liftIO $
|
||||||
pool
|
saveWalletSapNote
|
||||||
wId
|
pool
|
||||||
nP
|
wId
|
||||||
(fromJust noteWitness)
|
nP
|
||||||
False
|
(fromJust noteWitness)
|
||||||
(entityKey za)
|
False
|
||||||
(entityKey o)
|
(entityKey za)
|
||||||
dn0
|
(entityKey o)
|
||||||
|
dn0
|
||||||
decryptNotes uT n pool txs
|
decryptNotes uT n pool txs
|
||||||
decodeShOut ::
|
decodeShOut ::
|
||||||
Scope
|
Scope
|
||||||
|
@ -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
|
logDebugN "processed sapling outputs"
|
||||||
orchNotes <-
|
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
|
||||||
|
|
151
src/Zenith/DB.hs
151
src/Zenith/DB.hs
|
@ -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,15 +1789,30 @@ 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
|
||||||
x <-
|
maxBlock <-
|
||||||
selectOne $ do
|
selectOne $ do
|
||||||
n <- from $ table @ShieldOutput
|
blks <- from $ table @ZcashBlock
|
||||||
where_ (n ^. ShieldOutputId >. val (toSqlKey 0))
|
where_ $ blks ^. ZcashBlockHeight >. val 0
|
||||||
orderBy [desc $ n ^. ShieldOutputId]
|
orderBy [desc $ blks ^. ZcashBlockHeight]
|
||||||
pure (n ^. ShieldOutputId)
|
pure $ blks ^. ZcashBlockHeight
|
||||||
case x of
|
case maxBlock of
|
||||||
Nothing -> return $ toSqlKey 0
|
Nothing -> return $ toSqlKey 0
|
||||||
Just (Value y) -> return y
|
Just (Value mb) -> do
|
||||||
|
x <-
|
||||||
|
selectOne $ do
|
||||||
|
(blks :& txs :& n) <-
|
||||||
|
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]
|
||||||
|
pure (n ^. ShieldOutputId)
|
||||||
|
case x of
|
||||||
|
Nothing -> return $ toSqlKey 0
|
||||||
|
Just (Value y) -> return y
|
||||||
|
|
||||||
updateSapNoteRecord ::
|
updateSapNoteRecord ::
|
||||||
Pool SqlBackend
|
Pool SqlBackend
|
||||||
|
@ -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"
|
||||||
|
|
|
@ -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)
|
||||||
|
@ -975,7 +975,7 @@ buildUI wenv model = widgetTree
|
||||||
, filler
|
, filler
|
||||||
]
|
]
|
||||||
shieldOverlay =
|
shieldOverlay =
|
||||||
box
|
box
|
||||||
(vstack
|
(vstack
|
||||||
[ filler
|
[ filler
|
||||||
, hstack
|
, hstack
|
||||||
|
@ -988,41 +988,27 @@ buildUI wenv model = widgetTree
|
||||||
(label "Shield Zcash" `styleBasic`
|
(label "Shield Zcash" `styleBasic`
|
||||||
[textFont "Bold", textSize 12])
|
[textFont "Bold", textSize 12])
|
||||||
, separatorLine `styleBasic` [fgColor btnColor]
|
, separatorLine `styleBasic` [fgColor btnColor]
|
||||||
, spacer
|
, spacer
|
||||||
, hstack
|
, hstack
|
||||||
[ filler
|
[ filler
|
||||||
, label ("Amount : " ) `styleBasic`
|
, label ("Amount : ") `styleBasic`
|
||||||
[width 50, textFont "Bold"]
|
[width 50, textFont "Bold"]
|
||||||
, spacer
|
, spacer
|
||||||
, 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`
|
||||||
, filler
|
True
|
||||||
|
, filler
|
||||||
])
|
])
|
||||||
]) `styleBasic`
|
]) `styleBasic`
|
||||||
[radius 4, border 2 btnColor, bgColor white, padding 4]
|
[radius 4, border 2 btnColor, bgColor white, padding 4]
|
||||||
|
@ -1046,16 +1032,18 @@ buildUI wenv model = widgetTree
|
||||||
[textFont "Bold", textSize 12])
|
[textFont "Bold", textSize 12])
|
||||||
, separatorLine `styleBasic` [fgColor btnColor]
|
, separatorLine `styleBasic` [fgColor btnColor]
|
||||||
, spacer
|
, spacer
|
||||||
, hstack
|
, hstack
|
||||||
[ (label "Total Transparent : " `styleBasic` [ textFont "Bold" ])
|
[ (label "Total Transparent : " `styleBasic`
|
||||||
, (label "0.00" )
|
[textFont "Bold"])
|
||||||
|
, (label "0.00")
|
||||||
]
|
]
|
||||||
, spacer
|
, spacer
|
||||||
, hstack
|
, hstack
|
||||||
[ (label "Total Shielded : " `styleBasic` [ textFont "Bold" ])
|
[ (label "Total Shielded : " `styleBasic`
|
||||||
, (label "0.00" )
|
[textFont "Bold"])
|
||||||
|
, (label "0.00")
|
||||||
]
|
]
|
||||||
, spacer
|
, spacer
|
||||||
, hstack
|
, hstack
|
||||||
[ label "Amount:" `styleBasic`
|
[ label "Amount:" `styleBasic`
|
||||||
[width 50, textFont "Bold"]
|
[width 50, textFont "Bold"]
|
||||||
|
@ -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`
|
||||||
|
@ -1079,11 +1068,12 @@ buildUI wenv model = widgetTree
|
||||||
, 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" 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
|
||||||
|
@ -1482,9 +1490,9 @@ handleEvent wenv node model evt =
|
||||||
model & msgAB ?~ "Function not implemented..." & menuPopup .~ False
|
model & msgAB ?~ "Function not implemented..." & menuPopup .~ False
|
||||||
]
|
]
|
||||||
CloseMsgAB -> [Model $ model & msgAB .~ Nothing & inError .~ False]
|
CloseMsgAB -> [Model $ model & msgAB .~ Nothing & inError .~ False]
|
||||||
ShowShield -> [ Model $ model & shieldZec .~ True & menuPopup .~ False ]
|
ShowShield -> [Model $ model & shieldZec .~ True & menuPopup .~ False]
|
||||||
CloseShield -> [Model $ model & shieldZec .~ False]
|
CloseShield -> [Model $ model & shieldZec .~ False]
|
||||||
ShowDeShield -> [ Model $ model & deShieldZec .~ True & menuPopup .~ False ]
|
ShowDeShield -> [Model $ model & deShieldZec .~ True & menuPopup .~ False]
|
||||||
CloseDeShield -> [Model $ model & deShieldZec .~ False]
|
CloseDeShield -> [Model $ model & deShieldZec .~ False]
|
||||||
LoadAbList a -> [Model $ model & abaddressList .~ a]
|
LoadAbList a -> [Model $ model & abaddressList .~ a]
|
||||||
UpdateABDescrip d a ->
|
UpdateABDescrip d a ->
|
||||||
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -1 +1 @@
|
||||||
Subproject commit 396f15140a00fd9a00f06c89910f76a22354e8d8
|
Subproject commit 662a0d1148d3f52e2683157a4c9280bb8e81b0cb
|
Loading…
Reference in a new issue