Compare commits

...

2 commits

Author SHA1 Message Date
93240325df
feat!: add re-org detection and rewind 2024-09-24 14:34:19 -05:00
0e14228a0e
feat!: add block tracking to data model
Adds new `ZcashBlock` table to database to track block information and
creates a relationship between `ZcashTransaction` records and the block
they belong to.
Database getters and setters are updated to use the block record for
confirmations, height, time data.
2024-09-23 13:55:14 -05:00
10 changed files with 664 additions and 239 deletions

View file

@ -24,6 +24,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
### Changed
- Detection of changes in database schema for automatic re-scan
- Block tracking for chain re-org detection
## [0.6.0.0-beta]

View file

@ -230,6 +230,7 @@ main = do
"gui" -> runZenithGUI myConfig
"tui" -> runZenithTUI myConfig
"rescan" -> rescanZebra zebraHost zebraPort dbFilePath
"resync" -> clearSync myConfig
_ -> printUsage
else printUsage

View file

@ -61,7 +61,7 @@ import qualified Brick.Widgets.List as L
import qualified Brick.Widgets.ProgressBar as P
import Control.Concurrent (forkIO, threadDelay)
import Control.Exception (throw, throwIO, try)
import Control.Monad (forever, void, when)
import Control.Monad (forever, unless, void, when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (runFileLoggingT, runNoLoggingT)
import Data.Aeson
@ -88,9 +88,10 @@ import ZcashHaskell.Types
import ZcashHaskell.Utils (getBlockTime, makeZebraCall)
import Zenith.Core
import Zenith.DB
import Zenith.Scanner (processTx, rescanZebra, updateConfs)
import Zenith.Scanner (checkIntegrity, processTx, rescanZebra, updateConfs)
import Zenith.Types
( Config(..)
, HexStringDB(..)
, PhraseDB(..)
, UnifiedAddressDB(..)
, ZcashNetDB(..)
@ -721,26 +722,29 @@ scanZebra dbP zHost zPort b eChan znet = do
bStatus <- liftIO $ checkBlockChain zHost zPort
pool <- runNoLoggingT $ initPool dbP
dbBlock <- getMaxBlock pool $ ZcashNetDB znet
chkBlock <- checkIntegrity dbP zHost zPort dbBlock 1
unless (chkBlock == dbBlock) $ rewindWalletData pool chkBlock
let sb =
if chkBlock == dbBlock
then max dbBlock b
else max chkBlock b
if sb > zgb_blocks bStatus || sb < 1
then do
liftIO $ BC.writeBChan eChan $ TickMsg "Invalid starting block for scan"
else do
let bList = [(sb + 1) .. (zgb_blocks bStatus)]
if not (null bList)
then do
let step =
(1.0 :: Float) / fromIntegral (zgb_blocks bStatus - (sb + 1))
mapM_ (processBlock pool step) bList
else liftIO $ BC.writeBChan eChan $ TickVal 1.0
confUp <- try $ updateConfs zHost zPort pool :: IO (Either IOError ())
case confUp of
Left _e0 ->
liftIO $
BC.writeBChan eChan $ TickMsg "Failed to update unconfirmed transactions"
Right _ -> do
let sb = max dbBlock b
if sb > zgb_blocks bStatus || sb < 1
then do
liftIO $
BC.writeBChan eChan $ TickMsg "Invalid starting block for scan"
else do
let bList = [(sb + 1) .. (zgb_blocks bStatus)]
if not (null bList)
then do
let step =
(1.0 :: Float) /
fromIntegral (zgb_blocks bStatus - (sb + 1))
mapM_ (processBlock pool step) bList
else liftIO $ BC.writeBChan eChan $ TickVal 1.0
Right _ -> return ()
where
processBlock :: ConnectionPool -> Float -> Int -> IO ()
processBlock pool step bl = do
@ -765,16 +769,16 @@ scanZebra dbP zHost zPort b eChan znet = do
Left e2 -> liftIO $ BC.writeBChan eChan $ TickMsg e2
Right hb -> do
let blockTime = getBlockTime hb
mapM_ (processTx zHost zPort blockTime pool (ZcashNetDB znet)) $
bl_txs $ addTime blk blockTime
bi <-
saveBlock pool $
ZcashBlock
(fromIntegral $ bl_height blk)
(HexStringDB $ bl_hash blk)
(fromIntegral $ bl_confirmations blk)
blockTime
(ZcashNetDB znet)
mapM_ (processTx zHost zPort bi pool) $ bl_txs blk
liftIO $ BC.writeBChan eChan $ TickVal step
addTime :: BlockResponse -> Int -> BlockResponse
addTime bl t =
BlockResponse
(bl_confirmations bl)
(bl_height bl)
(fromIntegral t)
(bl_txs bl)
appEvent :: BT.BrickEvent Name Tick -> BT.EventM Name State ()
appEvent (BT.AppEvent t) = do

View file

@ -772,98 +772,254 @@ prepareTxV2 pool zebraHost zebraPort zn za bh amt va memo policy = do
{-firstPass <- liftIO $ selectUnspentNotes pool za zats-}
--let fee = calculateTxFee firstPass $ fst recipient
--logDebugN $ T.pack $ "calculated fee " ++ show fee
(tList, sList, oList) <- liftIO $ selectUnspentNotes pool za (zats + 5000)
logDebugN "selected notes"
logDebugN $ T.pack $ show tList
logDebugN $ T.pack $ show sList
logDebugN $ T.pack $ show oList
let noteTotal = getTotalAmount (tList, sList, oList)
tSpends <-
notePlan <-
liftIO $
prepTSpends (getTranSK $ zcashAccountTPrivateKey $ entityVal acc) tList
--print tSpends
sSpends <-
liftIO $
prepSSpends (getSapSK $ zcashAccountSapSpendKey $ entityVal acc) sList
--print sSpends
oSpends <-
liftIO $
prepOSpends (getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc) oList
--print oSpends
dummy <-
liftIO $ makeOutgoing acc recipient zats (noteTotal - 5000 - zats)
logDebugN "Calculating fee"
let feeResponse =
createTransaction
(Just sT)
(Just oT)
tSpends
sSpends
oSpends
dummy
zn
(bh + 3)
False
case feeResponse of
Left e1 -> return $ Left Fee
Right fee -> do
let feeAmt =
fromIntegral (runGet getInt64le $ LBS.fromStrict $ toBytes fee)
(tList1, sList1, oList1) <-
liftIO $ selectUnspentNotes pool za (zats + feeAmt)
logDebugN $ T.pack $ "selected notes with fee" ++ show feeAmt
selectUnspentNotesV2 pool za (zats + 10000) (fst recipient) policy
case notePlan of
Right (tList, sList, oList) -> do
logDebugN "selected notes"
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
zn
(bh + 3)
True
logDebugN $ T.pack $ show tx
return tx
let noteTotal = getTotalAmount (tList, sList, oList)
tSpends <-
liftIO $
prepTSpends
(getTranSK $ zcashAccountTPrivateKey $ entityVal acc)
tList
--print tSpends
sSpends <-
liftIO $
prepSSpends
(getSapSK $ zcashAccountSapSpendKey $ entityVal acc)
sList
--print sSpends
oSpends <-
liftIO $
prepOSpends
(getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc)
oList
--print oSpends
dummy' <-
liftIO $
makeOutgoing acc recipient zats (noteTotal - 5000 - zats) policy
case dummy' of
Left e -> return $ Left e
Right dummy -> do
logDebugN "Calculating fee"
let feeResponse =
createTransaction
(Just sT)
(Just oT)
tSpends
sSpends
oSpends
dummy
zn
(bh + 3)
False
case feeResponse of
Left e1 -> return $ Left Fee
Right fee -> do
let feeAmt =
fromIntegral
(runGet getInt64le $ LBS.fromStrict $ toBytes fee)
finalNotePlan <-
liftIO $
selectUnspentNotesV2
pool
za
(zats + feeAmt)
(fst recipient)
policy
case finalNotePlan of
Right (tList1, sList1, oList1) -> do
logDebugN $
T.pack $ "selected notes with fee" ++ show feeAmt
logDebugN $ T.pack $ show tList1
logDebugN $ T.pack $ show sList1
logDebugN $ T.pack $ show oList1
tSpends1 <-
liftIO $
prepTSpends
(getTranSK $ zcashAccountTPrivateKey $ entityVal acc)
tList1
sSpends1 <-
liftIO $
prepSSpends
(getSapSK $ zcashAccountSapSpendKey $ entityVal acc)
sList1
oSpends1 <-
liftIO $
prepOSpends
(getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc)
oList1
let noteTotal1 = getTotalAmount (tList1, sList1, oList1)
outgoing' <-
liftIO $
makeOutgoing
acc
recipient
zats
(noteTotal1 - feeAmt - zats)
policy
logDebugN $ T.pack $ show outgoing'
case outgoing' of
Left e -> return $ Left e
Right outgoing -> do
let tx =
createTransaction
(Just sT)
(Just oT)
tSpends1
sSpends1
oSpends1
outgoing
zn
(bh + 3)
True
logDebugN $ T.pack $ show tx
return tx
Left e -> return $ Left e
Left e -> do
logErrorN $ T.pack $ show e
return $ Left e
where
makeOutgoing ::
Entity ZcashAccount
-> (Int, BS.ByteString)
-> Integer
-> Integer
-> IO [OutgoingNote]
makeOutgoing acc (k, recvr) zats chg = do
-> PrivacyPolicy
-> IO (Either TxError [OutgoingNote])
makeOutgoing acc (k, recvr) zats chg policy = do
chgAddr <- runNoLoggingT $ getInternalAddresses pool $ entityKey acc
let internalUA = getUA $ walletAddressUAddress $ entityVal $ head chgAddr
let chgRcvr =
fromJust $ o_rec =<< isValidUnifiedAddress (E.encodeUtf8 internalUA)
return
[ OutgoingNote
4
(getBytes $ getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc)
(getBytes chgRcvr)
(fromIntegral chg)
""
True
, OutgoingNote
(fromIntegral k)
(case k of
4 ->
getBytes $ getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc
3 ->
getBytes $ getSapSK $ zcashAccountSapSpendKey $ entityVal acc
_ -> "")
recvr
(fromIntegral zats)
(E.encodeUtf8 memo)
False
]
case k of
4 ->
case policy of
None ->
return $
Left $
PrivacyPolicyError "Recipient not allowed by privacy policy"
_anyOther -> do
let chgRcvr =
fromJust $
o_rec =<< isValidUnifiedAddress (E.encodeUtf8 internalUA)
return $
Right
[ OutgoingNote
4
(getBytes $
getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc)
(getBytes chgRcvr)
(fromIntegral chg)
""
True
, OutgoingNote
4
(getBytes $
getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc)
recvr
(fromIntegral zats)
(E.encodeUtf8 memo)
False
]
3 ->
case policy of
None ->
return $
Left $
PrivacyPolicyError "Receiver not compatible with privacy policy"
Full -> do
let chgRcvr =
fromJust $
s_rec =<< isValidUnifiedAddress (E.encodeUtf8 internalUA)
return $
Right
[ OutgoingNote
3
(getBytes $
getSapSK $ zcashAccountSapSpendKey $ entityVal acc)
(getBytes chgRcvr)
(fromIntegral chg)
""
True
, OutgoingNote
3
(getBytes $
getSapSK $ zcashAccountSapSpendKey $ entityVal acc)
recvr
(fromIntegral zats)
(E.encodeUtf8 memo)
False
]
_anyOther -> do
let chgRcvr =
fromJust $
o_rec =<< isValidUnifiedAddress (E.encodeUtf8 internalUA)
return $
Right
[ OutgoingNote
4
(getBytes $
getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc)
(getBytes chgRcvr)
(fromIntegral chg)
""
True
, OutgoingNote
3
(getBytes $
getSapSK $ zcashAccountSapSpendKey $ entityVal acc)
recvr
(fromIntegral zats)
(E.encodeUtf8 memo)
False
]
2 ->
if policy <= Low
then do
let chgRcvr =
fromJust $
t_rec =<< isValidUnifiedAddress (E.encodeUtf8 internalUA)
return $
Right
[ OutgoingNote
1
BS.empty
(toBytes $ tr_bytes chgRcvr)
(fromIntegral chg)
""
True
, OutgoingNote 2 BS.empty recvr (fromIntegral zats) "" False
]
else return $
Left $
PrivacyPolicyError
"Receiver not compatible with privacy policy"
1 ->
if policy <= Low
then do
let chgRcvr =
fromJust $
t_rec =<< isValidUnifiedAddress (E.encodeUtf8 internalUA)
return $
Right
[ OutgoingNote
1
BS.empty
(toBytes $ tr_bytes chgRcvr)
(fromIntegral chg)
""
True
, OutgoingNote 1 BS.empty recvr (fromIntegral zats) "" False
]
else return $
Left $
PrivacyPolicyError
"Receiver not compatible with privacy policy"
_anyOther -> return $ Left ZHError
getTotalAmount ::
( [Entity WalletTrNote]
, [Entity WalletSapNote]

View file

@ -18,7 +18,7 @@
module Zenith.DB where
import Control.Exception (SomeException(..), throwIO, try)
import Control.Exception (SomeException(..), throw, throwIO, try)
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Logger (NoLoggingT, runNoLoggingT)
@ -69,6 +69,7 @@ import ZcashHaskell.Types
, TransparentAddress(..)
, TransparentBundle(..)
, TransparentReceiver(..)
, TxError(..)
, UnifiedAddress(..)
, ValidAddress(..)
, ZcashNet(..)
@ -78,6 +79,7 @@ import Zenith.Types
, HexStringDB(..)
, OrchardSpendingKeyDB(..)
, PhraseDB(..)
, PrivacyPolicy(..)
, RseedDB(..)
, SaplingSpendingKeyDB(..)
, ScopeDB(..)
@ -202,13 +204,18 @@ share
value Int64
UniqueOrchSpend tx accId
deriving Show Eq
ZcashTransaction
block Int
txId HexStringDB
ZcashBlock
height Int
hash HexStringDB
conf Int
time Int
network ZcashNetDB
UniqueTx block txId network
UniqueBlock height network
deriving Show Eq
ZcashTransaction
blockId ZcashBlockId OnDeleteCascade OnUpdateCascade
txId HexStringDB
UniqueTx blockId txId
deriving Show Eq
TransparentNote
tx ZcashTransactionId
@ -437,10 +444,10 @@ initDb dbName = do
clearWalletTransactions pool
clearWalletData pool
m <-
try $ PS.runSqlite dbName $ runMigrationQuiet migrateAll :: IO
try $ PS.runSqlite dbName $ runMigrationUnsafeQuiet migrateAll :: IO
(Either SomeException [T.Text])
case m of
Left _e2 -> return $ Left "Failed to migrate data tables"
Left e2 -> return $ Left $ "Failed to migrate data tables" ++ show e2
Right _ -> return $ Right True
Right _ -> return $ Right False
@ -579,14 +586,13 @@ getMaxBlock pool net = do
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
selectOne $ do
txs <- from $ table @ZcashTransaction
where_ (txs ^. ZcashTransactionBlock >. val 0)
where_ (txs ^. ZcashTransactionNetwork ==. val net)
orderBy [desc $ txs ^. ZcashTransactionBlock]
pure txs
bls <- from $ table @ZcashBlock
where_ (bls ^. ZcashBlockNetwork ==. val net)
orderBy [desc $ bls ^. ZcashBlockHeight]
pure bls
case b of
Nothing -> return $ -1
Just x -> return $ zcashTransactionBlock $ entityVal x
Just x -> return $ zcashBlockHeight $ entityVal x
-- | Returns a list of addresses associated with the given account
getAddresses ::
@ -677,20 +683,33 @@ saveAddress pool w =
runNoLoggingT $
PS.retryOnBusy $ flip PS.runSqlPool pool $ insertUniqueEntity w
-- | Save a block to the database
saveBlock :: ConnectionPool -> ZcashBlock -> IO (Key ZcashBlock)
saveBlock pool b =
runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do insert b
-- | Read a block by height
getBlock :: ConnectionPool -> Int -> IO (Maybe (Entity ZcashBlock))
getBlock pool b =
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
selectOne $ do
bl <- from $ table @ZcashBlock
where_ $ bl ^. ZcashBlockHeight ==. val b
pure bl
-- | Save a transaction to the data model
saveTransaction ::
ConnectionPool -- ^ the database path
-> Int -- ^ block time
-> ZcashNetDB -- ^ the network
-> ZcashBlockId -- ^ The block the transaction is in
-> Transaction -- ^ The transaction to save
-> NoLoggingT IO (Key ZcashTransaction)
saveTransaction pool t n wt =
saveTransaction pool bi wt =
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
let ix = [0 ..]
w <-
insert $
ZcashTransaction (tx_height wt) (HexStringDB $ tx_id wt) (tx_conf wt) t n
w <- insert $ ZcashTransaction bi (HexStringDB $ tx_id wt)
when (isJust $ tx_transpBundle wt) $ do
_ <-
insertMany_ $
@ -776,10 +795,13 @@ getZcashTransactions pool b net =
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
select $ do
txs <- from $ table @ZcashTransaction
where_ (txs ^. ZcashTransactionBlock >. val b)
where_ (txs ^. ZcashTransactionNetwork ==. val (ZcashNetDB net))
orderBy [asc $ txs ^. ZcashTransactionBlock]
(blks :& txs) <-
from $ table @ZcashBlock `innerJoin` table @ZcashTransaction `on`
(\(blks :& txs) ->
blks ^. ZcashBlockId ==. txs ^. ZcashTransactionBlockId)
where_ (blks ^. ZcashBlockHeight >. val b)
where_ (blks ^. ZcashBlockNetwork ==. val (ZcashNetDB net))
orderBy [asc $ blks ^. ZcashBlockHeight]
return txs
-- ** QR codes
@ -876,16 +898,25 @@ saveWalletTransaction pool za zt = do
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
t <-
upsert
(WalletTransaction
(zcashTransactionTxId zT')
za
(zcashTransactionBlock zT')
(zcashTransactionConf zT')
(zcashTransactionTime zT'))
[]
return $ entityKey t
b <-
selectOne $ do
blks <- from $ table @ZcashBlock
where_ (blks ^. ZcashBlockId ==. val (zcashTransactionBlockId zT'))
pure blks
case b of
Nothing ->
throw $ userError "invalid block for saving wallet transaction"
Just blk -> do
t <-
upsert
(WalletTransaction
(zcashTransactionTxId zT')
za
(zcashBlockHeight $ entityVal blk)
(zcashBlockConf $ entityVal blk)
(zcashBlockTime $ entityVal blk))
[]
return $ entityKey t
-- | Save a @WalletSapNote@
saveWalletSapNote ::
@ -976,14 +1007,17 @@ findTransparentNotes pool b net t = do
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
select $ do
(txs :& tNotes) <-
from $ table @ZcashTransaction `innerJoin` table @TransparentNote `on`
(\(txs :& tNotes) ->
(blks :& txs :& tNotes) <-
from $ table @ZcashBlock `innerJoin` table @ZcashTransaction `on`
(\(blks :& txs) ->
blks ^. ZcashBlockId ==. txs ^. ZcashTransactionBlockId) `innerJoin`
table @TransparentNote `on`
(\(_ :& txs :& tNotes) ->
txs ^. ZcashTransactionId ==. tNotes ^. TransparentNoteTx)
where_ (txs ^. ZcashTransactionBlock >. val b)
where_ (txs ^. ZcashTransactionNetwork ==. val net)
where_ (blks ^. ZcashBlockHeight >. val b)
where_ (blks ^. ZcashBlockNetwork ==. val net)
where_ (tNotes ^. TransparentNoteScript ==. val s)
pure (txs, tNotes)
pure (blks, txs, tNotes)
mapM_
(saveWalletTrNote
pool
@ -999,10 +1033,11 @@ saveWalletTrNote ::
-> Scope
-> ZcashAccountId
-> WalletAddressId
-> (Entity ZcashTransaction, Entity TransparentNote)
-> (Entity ZcashBlock, Entity ZcashTransaction, Entity TransparentNote)
-> IO ()
saveWalletTrNote pool ch za wa (zt, tn) = do
saveWalletTrNote pool ch za wa (blk, zt, tn) = do
let zT' = entityVal zt
let b = entityVal blk
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
@ -1011,9 +1046,9 @@ saveWalletTrNote pool ch za wa (zt, tn) = do
(WalletTransaction
(zcashTransactionTxId zT')
za
(zcashTransactionBlock zT')
(zcashTransactionConf zT')
(zcashTransactionTime zT'))
(zcashBlockHeight b)
(zcashBlockConf b)
(zcashBlockTime b))
[]
insert_ $
WalletTrNote
@ -1042,12 +1077,15 @@ getShieldedOutputs pool b net =
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
select $ do
(txs :& sOutputs) <-
from $ table @ZcashTransaction `innerJoin` table @ShieldOutput `on`
(\(txs :& sOutputs) ->
(blks :& txs :& sOutputs) <-
from $ table @ZcashBlock `innerJoin` table @ZcashTransaction `on`
(\(blks :& txs) ->
blks ^. ZcashBlockId ==. txs ^. ZcashTransactionBlockId) `innerJoin`
table @ShieldOutput `on`
(\(_ :& txs :& sOutputs) ->
txs ^. ZcashTransactionId ==. sOutputs ^. ShieldOutputTx)
where_ (txs ^. ZcashTransactionBlock >=. val b)
where_ (txs ^. ZcashTransactionNetwork ==. val net)
where_ (blks ^. ZcashBlockHeight >=. val b)
where_ (blks ^. ZcashBlockNetwork ==. val net)
orderBy
[ asc $ txs ^. ZcashTransactionId
, asc $ sOutputs ^. ShieldOutputPosition
@ -1065,12 +1103,15 @@ getOrchardActions pool b net =
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
select $ do
(txs :& oActions) <-
from $ table @ZcashTransaction `innerJoin` table @OrchAction `on`
(\(txs :& oActions) ->
(blks :& txs :& oActions) <-
from $ table @ZcashBlock `innerJoin` table @ZcashTransaction `on`
(\(blks :& txs) ->
blks ^. ZcashBlockId ==. txs ^. ZcashTransactionBlockId) `innerJoin`
table @OrchAction `on`
(\(_ :& txs :& oActions) ->
txs ^. ZcashTransactionId ==. oActions ^. OrchActionTx)
where_ (txs ^. ZcashTransactionBlock >=. val b)
where_ (txs ^. ZcashTransactionNetwork ==. val net)
where_ (blks ^. ZcashBlockHeight >=. val b)
where_ (blks ^. ZcashBlockNetwork ==. val net)
orderBy
[asc $ txs ^. ZcashTransactionId, asc $ oActions ^. OrchActionPosition]
pure (txs, oActions)
@ -1640,15 +1681,23 @@ upsertWalTx ::
=> ZcashTransaction
-> ZcashAccountId
-> SqlPersistT m (Entity WalletTransaction)
upsertWalTx zt za =
upsert
(WalletTransaction
(zcashTransactionTxId zt)
za
(zcashTransactionBlock zt)
(zcashTransactionConf zt)
(zcashTransactionTime zt))
[]
upsertWalTx zt za = do
blk <-
selectOne $ do
blks <- from $ table @ZcashBlock
where_ (blks ^. ZcashBlockId ==. val (zcashTransactionBlockId zt))
pure blks
case blk of
Nothing -> throw $ userError "Invalid block for transaction"
Just b ->
upsert
(WalletTransaction
(zcashTransactionTxId zt)
za
(zcashBlockHeight $ entityVal b)
(zcashBlockConf $ entityVal b)
(zcashBlockTime $ entityVal b))
[]
getSaplingOutIndex :: ConnectionPool -> ShieldOutputId -> IO Int
getSaplingOutIndex pool i = do
@ -1982,6 +2031,130 @@ selectUnspentNotes pool za amt = do
, n : snd (checkOrchard (x - walletOrchNoteValue (entityVal n)) ns))
else (0, [n])
selectUnspentNotesV2 ::
ConnectionPool
-> ZcashAccountId
-> Integer
-> Int
-> PrivacyPolicy
-> IO
(Either
TxError
( [Entity WalletTrNote]
, [Entity WalletSapNote]
, [Entity WalletOrchNote]))
selectUnspentNotesV2 pool za amt recv policy = do
case policy of
Full ->
case recv of
4 -> do
orchNotes <- getWalletUnspentOrchNotes pool za
let (a1, oList) = checkOrchard (fromIntegral amt) orchNotes
if a1 > 0
then return $
Left $ PrivacyPolicyError "Not enough notes for Full privacy"
else return $ Right ([], [], oList)
3 -> do
sapNotes <- getWalletUnspentSapNotes pool za
let (a2, sList) = checkSapling (fromIntegral amt) sapNotes
if a2 > 0
then return $
Left $ PrivacyPolicyError "Not enough notes for Full privacy"
else return $ Right ([], sList, [])
_anyOther ->
return $
Left $ PrivacyPolicyError "Receiver not capable of Full privacy"
Medium ->
if recv > 2
then do
orchNotes <- getWalletUnspentOrchNotes pool za
let (a1, oList) = checkOrchard (fromIntegral amt) orchNotes
if a1 > 0
then do
sapNotes <- getWalletUnspentSapNotes pool za
let (a2, sList) = checkSapling a1 sapNotes
if a2 > 0
then return $
Left $
PrivacyPolicyError "Not enough notes for Medium privacy"
else return $ Right ([], sList, oList)
else return $ Right ([], [], oList)
else return $
Left $ PrivacyPolicyError "Receiver not capable of Medium privacy"
Low ->
if recv == 0
then return $ Left ZHError
else do
case recv of
3 -> do
sapNotes <- getWalletUnspentSapNotes pool za
let (a1, sList) = checkSapling (fromIntegral amt) sapNotes
if a1 > 0
then do
orchNotes <- getWalletUnspentOrchNotes pool za
let (a2, oList) = checkOrchard a1 orchNotes
if a2 > 0
then return $
Left $
PrivacyPolicyError "Not enough notes for Low privacy"
else return $ Right ([], sList, oList)
else return $ Right ([], sList, [])
_anyOther -> do
orchNotes <- getWalletUnspentOrchNotes pool za
let (a1, oList) = checkOrchard (fromIntegral amt) orchNotes
if a1 > 0
then do
sapNotes <- getWalletUnspentSapNotes pool za
let (a2, sList) = checkSapling a1 sapNotes
if a2 > 0
then return $
Left $
PrivacyPolicyError "Not enough notes for Low privacy"
else return $ Right ([], sList, oList)
else return $ Right ([], [], oList)
None -> do
orchNotes <- getWalletUnspentOrchNotes pool za
let (a1, oList) = checkOrchard (fromIntegral amt) orchNotes
if a1 > 0
then do
sapNotes <- getWalletUnspentSapNotes pool za
let (a2, sList) = checkSapling a1 sapNotes
if a2 > 0
then do
trNotes <- getWalletUnspentTrNotes pool za
let (a3, tList) = checkTransparent a2 trNotes
if a3 > 0
then return $ Left InsufficientFunds
else return $ Right (tList, sList, oList)
else return $ Right ([], sList, oList)
else return $ Right ([], [], oList)
where
checkTransparent ::
Int64 -> [Entity WalletTrNote] -> (Int64, [Entity WalletTrNote])
checkTransparent x [] = (x, [])
checkTransparent x (n:ns) =
if walletTrNoteValue (entityVal n) < x
then ( fst (checkTransparent (x - walletTrNoteValue (entityVal n)) ns)
, n :
snd (checkTransparent (x - walletTrNoteValue (entityVal n)) ns))
else (0, [n])
checkSapling ::
Int64 -> [Entity WalletSapNote] -> (Int64, [Entity WalletSapNote])
checkSapling x [] = (x, [])
checkSapling x (n:ns) =
if walletSapNoteValue (entityVal n) < x
then ( fst (checkSapling (x - walletSapNoteValue (entityVal n)) ns)
, n : snd (checkSapling (x - walletSapNoteValue (entityVal n)) ns))
else (0, [n])
checkOrchard ::
Int64 -> [Entity WalletOrchNote] -> (Int64, [Entity WalletOrchNote])
checkOrchard x [] = (x, [])
checkOrchard x (n:ns) =
if walletOrchNoteValue (entityVal n) < x
then ( fst (checkOrchard (x - walletOrchNoteValue (entityVal n)) ns)
, n : snd (checkOrchard (x - walletOrchNoteValue (entityVal n)) ns))
else (0, [n])
getWalletTxId ::
ConnectionPool -> WalletTransactionId -> IO (Maybe (Value HexStringDB))
getWalletTxId pool wId = do
@ -2013,6 +2186,9 @@ saveConfs pool b c = do
update $ \t -> do
set t [WalletTransactionConf =. val c]
where_ $ t ^. WalletTransactionBlock ==. val b
update $ \bl -> do
set bl [ZcashBlockConf =. val c]
where_ $ bl ^. ZcashBlockHeight ==. val b
-- | Helper function to extract a Unified Address from the database
readUnifiedAddressDB :: WalletAddress -> Maybe UnifiedAddress
@ -2105,3 +2281,14 @@ finalizeOperation pool op status result = do
, OperationResult =. val (Just result)
]
where_ (ops ^. OperationId ==. val op)
-- | Rewind the data store to a given block height
rewindWalletData :: ConnectionPool -> Int -> IO ()
rewindWalletData pool b = do
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $
delete $ do
blk <- from $ table @ZcashBlock
where_ $ blk ^. ZcashBlockHeight >. val b
clearWalletTransactions pool

View file

@ -10,7 +10,7 @@ import Codec.QRCode
import Codec.QRCode.JuicyPixels
import Control.Concurrent (threadDelay)
import Control.Exception (throwIO, try)
import Control.Monad (when)
import Control.Monad (unless, when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (runFileLoggingT, runNoLoggingT)
import Data.Aeson
@ -47,12 +47,10 @@ import ZcashHaskell.Utils (getBlockTime, makeZebraCall)
import Zenith.Core
import Zenith.DB
import Zenith.GUI.Theme
import Zenith.Scanner (processTx, rescanZebra, updateConfs)
import Zenith.Scanner (checkIntegrity, processTx, rescanZebra, updateConfs)
import Zenith.Types hiding (ZcashAddress(..))
import Zenith.Utils
( displayAmount
, getZenithPath
, isEmpty
, isRecipientValid
, isValidString
, jsonNumber
@ -60,7 +58,6 @@ import Zenith.Utils
, parseAddress
, showAddress
, validBarValue
, validateAddressBool
)
data AppEvent
@ -116,7 +113,6 @@ data AppEvent
| CheckValidAddress !T.Text
| CheckValidDescrip !T.Text
| SaveNewABEntry
| SaveABDescription !T.Text
| UpdateABEntry !T.Text !T.Text
| CloseUpdABEntry
| ShowMessage !T.Text
@ -1443,20 +1439,25 @@ scanZebra dbPath zHost zPort net sendMsg = do
pool <- runNoLoggingT $ initPool dbPath
b <- liftIO $ getMinBirthdayHeight pool
dbBlock <- getMaxBlock pool $ ZcashNetDB net
let sb = max dbBlock b
chkBlock <- checkIntegrity dbPath zHost zPort dbBlock 1
unless (chkBlock == dbBlock) $ rewindWalletData pool chkBlock
let sb =
if chkBlock == dbBlock
then max dbBlock b
else max chkBlock b
if sb > zgb_blocks bStatus || sb < 1
then sendMsg (ShowError "Invalid starting block for scan")
else do
let bList = [(sb + 1) .. (zgb_blocks bStatus)]
if not (null bList)
then do
let step = (1.0 :: Float) / fromIntegral (length bList)
mapM_ (processBlock pool step) bList
else sendMsg (SyncVal 1.0)
confUp <- try $ updateConfs zHost zPort pool :: IO (Either IOError ())
case confUp of
Left _e0 -> sendMsg (ShowError "Failed to update unconfirmed transactions")
Right _ -> do
if sb > zgb_blocks bStatus || sb < 1
then sendMsg (ShowError "Invalid starting block for scan")
else do
let bList = [(sb + 1) .. (zgb_blocks bStatus)]
if not (null bList)
then do
let step = (1.0 :: Float) / fromIntegral (length bList)
mapM_ (processBlock pool step) bList
else sendMsg (SyncVal 1.0)
Right _ -> return ()
where
processBlock :: ConnectionPool -> Float -> Int -> IO ()
processBlock pool step bl = do
@ -1481,16 +1482,16 @@ scanZebra dbPath zHost zPort net sendMsg = do
Left e2 -> sendMsg (ShowError $ showt e2)
Right hb -> do
let blockTime = getBlockTime hb
mapM_ (processTx zHost zPort blockTime pool (ZcashNetDB net)) $
bl_txs $ addTime blk blockTime
bi <-
saveBlock pool $
ZcashBlock
(fromIntegral $ bl_height blk)
(HexStringDB $ bl_hash blk)
(fromIntegral $ bl_confirmations blk)
blockTime
(ZcashNetDB net)
mapM_ (processTx zHost zPort bi pool) $ bl_txs blk
sendMsg (SyncVal step)
addTime :: BlockResponse -> Int -> BlockResponse
addTime bl t =
BlockResponse
(bl_confirmations bl)
(bl_height bl)
(fromIntegral t)
(bl_txs bl)
sendTransaction ::
Config

View file

@ -27,19 +27,23 @@ import ZcashHaskell.Types
import ZcashHaskell.Utils (getBlockTime, makeZebraCall, readZebraTransaction)
import Zenith.Core (checkBlockChain, syncWallet)
import Zenith.DB
( clearWalletData
( ZcashBlock(..)
, ZcashBlockId
, clearWalletData
, clearWalletTransactions
, getBlock
, getMaxBlock
, getMinBirthdayHeight
, getUnconfirmedBlocks
, getWallets
, initDb
, initPool
, saveBlock
, saveConfs
, saveTransaction
, updateWalletSync
)
import Zenith.Types (Config(..), ZcashNetDB(..))
import Zenith.Types (Config(..), HexStringDB(..), ZcashNetDB(..))
import Zenith.Utils (jsonNumber)
-- | Function to scan the Zcash blockchain through the Zebra node and populate the Zenith database
@ -119,28 +123,26 @@ processBlock host port pool pg net b = do
Left e2 -> liftIO $ throwIO $ userError e2
Right hb -> do
let blockTime = getBlockTime hb
mapM_ (processTx host port blockTime pool net) $
bl_txs $ addTime blk blockTime
bi <-
saveBlock pool $
ZcashBlock
(fromIntegral $ bl_height blk)
(HexStringDB $ bl_hash blk)
(fromIntegral $ bl_confirmations blk)
blockTime
net
mapM_ (processTx host port bi pool) $ bl_txs blk
liftIO $ tick pg
where
addTime :: BlockResponse -> Int -> BlockResponse
addTime bl t =
BlockResponse
(bl_confirmations bl)
(bl_height bl)
(fromIntegral t)
(bl_txs bl)
-- | Function to process a raw transaction
processTx ::
T.Text -- ^ Host name for `zebrad`
-> Int -- ^ Port for `zebrad`
-> Int -- ^ Block time
-> ZcashBlockId -- ^ Block ID
-> ConnectionPool -- ^ DB file path
-> ZcashNetDB -- ^ the network
-> HexString -- ^ transaction id
-> IO ()
processTx host port bt pool net t = do
processTx host port bt pool t = do
r <-
liftIO $
makeZebraCall
@ -156,7 +158,7 @@ processTx host port bt pool net t = do
Just rzt -> do
_ <-
runNoLoggingT $
saveTransaction pool bt net $
saveTransaction pool bt $
Transaction
t
(ztr_blockheight rawTx)
@ -213,3 +215,33 @@ clearSync config = do
w' <- liftIO $ getWallets pool $ zgb_net chainInfo
r <- mapM (syncWallet config) w'
liftIO $ print r
-- | Detect chain re-orgs
checkIntegrity ::
T.Text -- ^ Database path
-> T.Text -- ^ Zebra host
-> Int -- ^ Zebra port
-> Int -- ^ The block to start the check
-> Int -- ^ depth
-> IO Int
checkIntegrity dbP zHost zPort b d =
if b < 1
then return 1
else do
r <-
makeZebraCall
zHost
zPort
"getblock"
[Data.Aeson.String $ T.pack $ show b, jsonNumber 1]
case r of
Left e -> throwIO $ userError e
Right blk -> do
pool <- runNoLoggingT $ initPool dbP
dbBlk <- getBlock pool b
case dbBlk of
Nothing -> throwIO $ userError "Block mismatch, rescan needed"
Just dbBlk' ->
if bl_hash blk == getHex (zcashBlockHash $ entityVal dbBlk')
then return b
else checkIntegrity dbP zHost zPort (b - 5 * d) (d + 1)

View file

@ -199,10 +199,11 @@ $(deriveJSON defaultOptions ''ZenithStatus)
derivePersistField "ZenithStatus"
data PrivacyPolicy
= Full
| Medium
= None
| Low
| None
| Medium
| Full
deriving (Eq, Show, Read, Ord)
$(deriveJSON defaultOptions ''PrivacyPolicy)

View file

@ -1,15 +1,16 @@
{-# LANGUAGE OverloadedStrings #-}
import Control.Monad (when)
import Control.Monad.Logger (runNoLoggingT)
import Control.Monad.Logger (runFileLoggingT, runNoLoggingT)
import Data.HexString
import Data.Maybe (fromJust)
import qualified Data.Text.Encoding as E
import Database.Persist
import Database.Persist.Sqlite
import System.Directory
import Test.HUnit
import Test.Hspec
import ZcashHaskell.Orchard (isValidUnifiedAddress)
import ZcashHaskell.Orchard (isValidUnifiedAddress, parseAddress)
import ZcashHaskell.Sapling
( decodeSaplingOutputEsk
, encodeSaplingAddress
@ -172,15 +173,15 @@ main = do
"6c5d1413c63a9a88db71c3f41dc12cd60197ee742fc75b217215e7144db48bd3"
describe "Note selection for Tx" $ do
it "Value less than balance" $ do
pool <- runNoLoggingT $ initPool "zenith.db"
pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db"
res <- selectUnspentNotes pool (toSqlKey 1) 14000000
res `shouldNotBe` ([], [], [])
it "Value greater than balance" $ do
pool <- runNoLoggingT $ initPool "zenith.db"
pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db"
let res = selectUnspentNotes pool (toSqlKey 1) 84000000
res `shouldThrow` anyIOException
it "Fee calculation" $ do
pool <- runNoLoggingT $ initPool "zenith.db"
pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db"
res <- selectUnspentNotes pool (toSqlKey 1) 14000000
calculateTxFee res 3 `shouldBe` 20000
describe "Testing validation" $ do
@ -209,7 +210,7 @@ main = do
(case decodeTransparentAddress (E.encodeUtf8 a) of
Just _a3 -> True
Nothing ->
case decodeExchangeAddress (En.encodeUtf8 a) of
case decodeExchangeAddress (E.encodeUtf8 a) of
Just _a4 -> True
Nothing -> False))
it "Transparent" $ do
@ -233,21 +234,62 @@ main = do
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")-}
describe "Notes" $ do
it "Check Orchard notes" $ do
pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db"
oNotes <- getWalletUnspentOrchNotes pool (toSqlKey 1)
oNotes `shouldBe` []
it "Check Sapling notes" $ do
pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db"
oNotes <- getWalletUnspentSapNotes pool (toSqlKey 1)
oNotes `shouldBe` []
it "Check transparent notes" $ do
pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db"
oNotes <- getWalletUnspentTrNotes pool (toSqlKey 1)
oNotes `shouldBe` []
describe "Creating Tx" $ do
describe "Full" $ do
it "To Orchard" $ do
let uaRead =
parseAddress
"utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax"
case uaRead of
Nothing -> assertFailure "wrong address"
Just ua -> do
pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db"
tx <-
runFileLoggingT "zenith.log" $
prepareTxV2
pool
"localhost"
18232
TestNet
(toSqlKey 1)
2999946
0.005
(fromJust uaRead)
"Sending memo to orchard"
Full
tx `shouldBe` Right (hexString "deadbeef")
it "To Sapling" $ do
let uaRead =
parseAddress
"ztestsapling136jp8z89v2jh6kqd5rs4dtvlxym90m43svzdwzxaplyvc5ttzppytpvx80ncllcsqzpmukxjl3y"
case uaRead of
Nothing -> assertFailure "wrong address"
Just ua -> do
pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db"
tx <-
runFileLoggingT "zenith.log" $
prepareTxV2
pool
"localhost"
18232
TestNet
(toSqlKey 1)
2999396
0.005
(fromJust uaRead)
"Sending memo to orchard"
Full
tx `shouldBe` Right (hexString "deadbeef")

@ -1 +1 @@
Subproject commit 7965dc38c48da348f503a52ee10042fffc43f32c
Subproject commit 63a97b880cb32d8e008650f0efef2fdadc7d3d4a