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

rvv001 - Merge with rav001 branch

Browse source
This commit is contained in:
Rene V. Vergara A. 2024-09-29 20:22:29 -04:00
commit 6255ea3142
11 changed files with 861 additions and 332 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
CHANGELOG.md
View file

@ -24,6 +24,8 @@ 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
- Refactored `ZcashPool`
## [0.6.0.0-beta]

1
app/Main.hs
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

81
src/Zenith/CLI.hs
View file

@ -62,9 +62,14 @@ 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 Control.Monad.Logger
( LoggingT
, logDebugN
, runFileLoggingT
, runNoLoggingT
)
import Data.Aeson
import Data.HexString (HexString(..), toText)
import Data.Maybe
@ -89,9 +94,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(..)
@ -731,31 +737,42 @@ abMBarAttr :: A.AttrName
abMBarAttr = A.attrName "menubar"
scanZebra ::
T.Text -> T.Text -> Int -> Int -> BC.BChan Tick -> ZcashNet -> IO ()
T.Text
-> T.Text
-> Int
-> Int
-> BC.BChan Tick
-> ZcashNet
-> LoggingT IO ()
scanZebra dbP zHost zPort b eChan znet = do
bStatus <- liftIO $ checkBlockChain zHost zPort
pool <- runNoLoggingT $ initPool dbP
dbBlock <- getMaxBlock pool $ ZcashNetDB znet
confUp <- try $ updateConfs zHost zPort pool :: IO (Either IOError ())
pool <- liftIO $ runNoLoggingT $ initPool dbP
dbBlock <- liftIO $ getMaxBlock pool $ ZcashNetDB znet
chkBlock <- liftIO $ checkIntegrity dbP zHost zPort dbBlock 1
logDebugN $
"dbBlock: " <>
T.pack (show dbBlock) <> " chkBlock: " <> T.pack (show chkBlock)
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_ (liftIO . processBlock pool step) bList
else liftIO $ BC.writeBChan eChan $ TickVal 1.0
confUp <-
liftIO $ try $ updateConfs zHost zPort pool :: LoggingT
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
@ -780,16 +797,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
@ -834,6 +851,7 @@ appEvent (BT.AppEvent t) = do
Just (_k, w) -> return w
_ <-
liftIO $
runFileLoggingT "zenith.log" $
syncWallet
(Config
(s ^. dbPath)
@ -870,6 +888,7 @@ appEvent (BT.AppEvent t) = do
_ <-
liftIO $
forkIO $
runFileLoggingT "zenith.log" $
scanZebra
(s ^. dbPath)
(s ^. zebraHost)

342
src/Zenith/Core.hs
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]
@ -951,22 +1107,30 @@ prepareTxV2 pool zebraHost zebraPort zn za bh amt va memo policy = do
syncWallet ::
Config -- ^ configuration parameters
-> Entity ZcashWallet
-> IO ()
-> LoggingT IO ()
syncWallet config w = do
startTime <- liftIO getCurrentTime
let walletDb = c_dbPath config
let znet = zcashWalletNetwork $ entityVal w
pool <- runNoLoggingT $ initPool walletDb
accs <- runNoLoggingT $ getAccounts pool $ entityKey w
addrs <- concat <$> mapM (runNoLoggingT . getAddresses pool . entityKey) accs
pool <- liftIO $ runNoLoggingT $ initPool walletDb
accs <- liftIO $ runNoLoggingT $ getAccounts pool $ entityKey w
logDebugN $ "Accounts: " <> T.pack (show accs)
addrs <-
concat <$>
mapM (liftIO . runNoLoggingT . getAddresses pool . entityKey) accs
logDebugN $ "addrs: " <> T.pack (show addrs)
intAddrs <-
concat <$> mapM (runNoLoggingT . getInternalAddresses pool . entityKey) accs
chainTip <- getMaxBlock pool znet
concat <$>
mapM (liftIO . runNoLoggingT . getInternalAddresses pool . entityKey) accs
chainTip <- liftIO $ getMaxBlock pool znet
logDebugN $ "chain tip: " <> T.pack (show chainTip)
let lastBlock = zcashWalletLastSync $ entityVal w
logDebugN $ "last block: " <> T.pack (show lastBlock)
let startBlock =
if lastBlock > 0
then lastBlock
else zcashWalletBirthdayHeight $ entityVal w
logDebugN $ "start block: " <> T.pack (show startBlock)
mapM_ (liftIO . findTransparentNotes pool startBlock znet) addrs
mapM_ (liftIO . findTransparentNotes pool startBlock znet) intAddrs
mapM_ (liftIO . findTransparentSpends pool . entityKey) accs
@ -980,7 +1144,7 @@ syncWallet config w = do
mapM
(findOrchardActions config startBlock (zcashWalletNetwork $ entityVal w))
accs
_ <- updateSaplingWitnesses pool
_ <- updateOrchardWitnesses pool
_ <- liftIO $ updateSaplingWitnesses pool
_ <- liftIO $ updateOrchardWitnesses pool
_ <- liftIO $ updateWalletSync pool chainTip (entityKey w)
mapM_ (runNoLoggingT . getWalletTransactions pool) addrs
mapM_ (liftIO . runNoLoggingT . getWalletTransactions pool) addrs

360
src/Zenith/DB.hs
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,23 +204,28 @@ 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
tx ZcashTransactionId OnDeleteCascade OnUpdateCascade
value Int64
script BS.ByteString
position Int
UniqueTNPos tx position
deriving Show Eq
TransparentSpend
tx ZcashTransactionId
tx ZcashTransactionId OnDeleteCascade OnUpdateCascade
outPointHash HexStringDB
outPointIndex Word64
script BS.ByteString
@ -227,7 +234,7 @@ share
UniqueTSPos tx position
deriving Show Eq
OrchAction
tx ZcashTransactionId
tx ZcashTransactionId OnDeleteCascade OnUpdateCascade
nf HexStringDB
rk HexStringDB
cmx HexStringDB
@ -240,7 +247,7 @@ share
UniqueOAPos tx position
deriving Show Eq
ShieldOutput
tx ZcashTransactionId
tx ZcashTransactionId OnDeleteCascade OnUpdateCascade
cv HexStringDB
cmu HexStringDB
ephKey HexStringDB
@ -251,7 +258,7 @@ share
UniqueSOPos tx position
deriving Show Eq
ShieldSpend
tx ZcashTransactionId
tx ZcashTransactionId OnDeleteCascade OnUpdateCascade
cv HexStringDB
anchor HexStringDB
nullifier HexStringDB
@ -340,7 +347,7 @@ trToZcashNoteAPI pool n = do
return $
ZcashNoteAPI
(getHex $ walletTransactionTxId $ entityVal t') -- tx ID
Zenith.Types.Transparent -- pool
Zenith.Types.TransparentPool -- pool
(fromIntegral (walletTrNoteValue (entityVal n)) / 100000000.0) -- zec
(walletTrNoteValue $ entityVal n) -- zats
"" -- memo
@ -361,7 +368,7 @@ sapToZcashNoteAPI pool n = do
return $
ZcashNoteAPI
(getHex $ walletTransactionTxId $ entityVal t') -- tx ID
Zenith.Types.Sapling -- pool
Zenith.Types.SaplingPool -- pool
(fromIntegral (walletSapNoteValue (entityVal n)) / 100000000.0) -- zec
(walletSapNoteValue $ entityVal n) -- zats
(walletSapNoteMemo $ entityVal n) -- memo
@ -382,7 +389,7 @@ orchToZcashNoteAPI pool n = do
return $
ZcashNoteAPI
(getHex $ walletTransactionTxId $ entityVal t') -- tx ID
Orchard
OrchardPool
(fromIntegral (walletOrchNoteValue (entityVal n)) / 100000000.0) -- zec
(walletOrchNoteValue $ entityVal n) -- zats
(walletOrchNoteMemo $ entityVal n) -- memo
@ -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)
@ -1570,15 +1611,29 @@ getOrchardCmxs pool zt = do
getMaxOrchardNote :: Pool SqlBackend -> IO OrchActionId
getMaxOrchardNote pool = do
flip PS.runSqlPool pool $ do
x <-
maxBlock <-
selectOne $ do
n <- from $ table @OrchAction
where_ (n ^. OrchActionId >. val (toSqlKey 0))
orderBy [desc $ n ^. OrchActionId]
pure (n ^. OrchActionId)
case x of
blks <- from $ table @ZcashBlock
where_ $ blks ^. ZcashBlockHeight >. val 0
pure $ blks ^. ZcashBlockHeight
case maxBlock of
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 @OrchAction `on`
(\(_ :& txs :& n) ->
txs ^. ZcashTransactionId ==. n ^. OrchActionTx)
where_ (blks ^. ZcashBlockHeight <=. val (mb - 5))
orderBy [desc $ n ^. OrchActionId]
pure (n ^. OrchActionId)
case x of
Nothing -> return $ toSqlKey 0
Just (Value y) -> return y
updateOrchNoteRecord ::
Pool SqlBackend
@ -1640,15 +1695,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
@ -1801,6 +1864,9 @@ clearWalletData pool = do
delete $ do
_ <- from $ table @ZcashTransaction
return ()
delete $ do
_ <- from $ table @ZcashBlock
return ()
getWalletUnspentTrNotes ::
ConnectionPool -> ZcashAccountId -> IO [Entity WalletTrNote]
@ -1982,6 +2048,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 +2203,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 +2298,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

117
src/Zenith/GUI.hs
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
, isRecipientValidGUI
, isZecAddressValid
@ -62,7 +60,6 @@ import Zenith.Utils
, parseAddress
, showAddress
, validBarValue
, validateAddressBool
)
data AppEvent
@ -118,7 +115,6 @@ data AppEvent
| CheckValidAddress !T.Text
| CheckValidDescrip !T.Text
| SaveNewABEntry
| SaveABDescription !T.Text
| UpdateABEntry !T.Text !T.Text
| CloseUpdABEntry
| ShowMessage !T.Text
@ -421,43 +417,43 @@ buildUI wenv model = widgetTree
[ vstack
[ tooltip "Unified" $
box_
[onClick (SetPool Orchard)]
[onClick (SetPool OrchardPool)]
(remixIcon remixShieldCheckFill `styleBasic`
[ textSize 14
, padding 4
, styleIf
(model ^. selPool == Orchard)
(model ^. selPool == OrchardPool)
(bgColor btnColor)
, styleIf
(model ^. selPool == Orchard)
(model ^. selPool == OrchardPool)
(textColor white)
])
, filler
, tooltip "Legacy Shielded" $
box_
[onClick (SetPool Sapling)]
[onClick (SetPool SaplingPool)]
(remixIcon remixShieldLine `styleBasic`
[ textSize 14
, padding 4
, styleIf
(model ^. selPool == Sapling)
(model ^. selPool == SaplingPool)
(bgColor btnColor)
, styleIf
(model ^. selPool == Sapling)
(model ^. selPool == SaplingPool)
(textColor white)
])
, filler
, tooltip "Transparent" $
box_
[onClick (SetPool Transparent)]
[onClick (SetPool TransparentPool)]
(remixIcon remixEyeLine `styleBasic`
[ textSize 14
, padding 4
, styleIf
(model ^. selPool == Transparent)
(model ^. selPool == TransparentPool)
(bgColor btnColor)
, styleIf
(model ^. selPool == Transparent)
(model ^. selPool == TransparentPool)
(textColor white)
])
] `styleBasic`
@ -470,10 +466,10 @@ buildUI wenv model = widgetTree
(hstack
[ label
(case model ^. selPool of
Orchard -> "Unified"
Sapling -> "Legacy Shielded"
Transparent -> "Transparent"
Sprout -> "Unknown") `styleBasic`
OrchardPool -> "Unified"
SaplingPool -> "Legacy Shielded"
TransparentPool -> "Transparent"
SproutPool -> "Unknown") `styleBasic`
[textColor white]
, remixIcon remixFileCopyFill `styleBasic`
[textSize 14, padding 4, textColor white]
@ -974,9 +970,9 @@ generateQRCodes config = do
if not (null s)
then return ()
else do
generateOneQr pool Orchard wAddr
generateOneQr pool Sapling wAddr
generateOneQr pool Transparent wAddr
generateOneQr pool OrchardPool wAddr
generateOneQr pool SaplingPool wAddr
generateOneQr pool TransparentPool wAddr
generateOneQr ::
ConnectionPool -> ZcashPool -> Entity WalletAddress -> IO ()
generateOneQr p zp wAddr =
@ -1011,7 +1007,7 @@ generateQRCodes config = do
dispAddr :: ZcashPool -> WalletAddress -> Maybe T.Text
dispAddr zp w =
case zp of
Transparent ->
TransparentPool ->
T.append "zcash:" .
encodeTransparentReceiver
(maybe
@ -1023,11 +1019,12 @@ generateQRCodes config = do
(t_rec =<<
(isValidUnifiedAddress . E.encodeUtf8 . getUA . walletAddressUAddress)
w)
Sapling ->
SaplingPool ->
T.append "zcash:" <$>
(getSaplingFromUA . E.encodeUtf8 . getUA . walletAddressUAddress) w
Orchard -> Just $ (T.append "zcash:" . getUA . walletAddressUAddress) w
Sprout -> Nothing
OrchardPool ->
Just $ (T.append "zcash:" . getUA . walletAddressUAddress) w
SproutPool -> Nothing
handleEvent ::
WidgetEnv AppModel AppEvent
@ -1141,7 +1138,7 @@ handleEvent wenv node model evt =
Just wAddr -> getUserTx dbPool $ entityKey wAddr
]
SwitchQr q -> [Model $ model & qrCodeWidget .~ q]
SwitchAddr i -> [Model $ model & selAddr .~ i, Event $ SetPool Orchard]
SwitchAddr i -> [Model $ model & selAddr .~ i, Event $ SetPool OrchardPool]
SwitchAcc i ->
[ Model $ model & selAcc .~ i
, Task $
@ -1159,7 +1156,7 @@ handleEvent wenv node model evt =
b <- getBalance dbPool $ entityKey acc
u <- getUnconfirmedBalance dbPool $ entityKey acc
return (b, u)
, Event $ SetPool Orchard
, Event $ SetPool OrchardPool
]
SwitchWal i ->
[ Model $ model & selWallet .~ i & selAcc .~ 0 & selAddr .~ 0
@ -1182,14 +1179,15 @@ handleEvent wenv node model evt =
, setClipboardData $
ClipboardText $
case model ^. selPool of
Orchard -> maybe "None" (getUA . walletAddressUAddress . entityVal) a
Sapling ->
OrchardPool ->
maybe "None" (getUA . walletAddressUAddress . entityVal) a
SaplingPool ->
fromMaybe "None" $
(getSaplingFromUA .
E.encodeUtf8 . getUA . walletAddressUAddress . entityVal) =<<
a
Sprout -> "None"
Transparent ->
SproutPool -> "None"
TransparentPool ->
maybe "None" (encodeTransparentReceiver (model ^. network)) $
t_rec =<<
(isValidUnifiedAddress .
@ -1212,7 +1210,7 @@ handleEvent wenv node model evt =
if not (null a)
then [ Model $ model & addresses .~ a
, Event $ SwitchAddr $ model ^. selAddr
, Event $ SetPool Orchard
, Event $ SetPool OrchardPool
]
else [Event $ NewAddress currentAccount]
LoadAccs a ->
@ -1250,7 +1248,8 @@ handleEvent wenv node model evt =
case currentWallet of
Nothing -> return $ ShowError "No wallet available"
Just cW -> do
syncWallet (model ^. configuration) cW
runFileLoggingT "zenith.log" $
syncWallet (model ^. configuration) cW
pool <-
runNoLoggingT $
initPool $ c_dbPath $ model ^. configuration
@ -1472,20 +1471,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
@ -1510,16 +1514,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
@ -1611,7 +1615,8 @@ runZenithGUI config = do
else return []
qr <-
if not (null addrList)
then getQrCode pool Orchard $ entityKey $ head addrList
then getQrCode pool OrchardPool $
entityKey $ head addrList
else return Nothing
bal <-
if not (null accList)
@ -1640,7 +1645,7 @@ runZenithGUI config = do
(if unconfBal == 0
then Nothing
else Just unconfBal)
Orchard
OrchardPool
qr
False
False

78
src/Zenith/Scanner.hs
View file

@ -6,7 +6,13 @@ import Control.Concurrent.Async (concurrently_, withAsync)
import Control.Exception (throwIO, try)
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (NoLoggingT, logErrorN, logInfoN, runNoLoggingT)
import Control.Monad.Logger
( NoLoggingT
, logErrorN
, logInfoN
, runFileLoggingT
, runNoLoggingT
)
import Data.Aeson
import Data.HexString
import qualified Data.Text as T
@ -27,19 +33,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
@ -57,8 +67,8 @@ rescanZebra host port dbFilePath = do
Right bStatus -> do
let znet = ZcashNetDB $ zgb_net bStatus
pool1 <- runNoLoggingT $ initPool dbFilePath
pool2 <- runNoLoggingT $ initPool dbFilePath
pool3 <- runNoLoggingT $ initPool dbFilePath
{-pool2 <- runNoLoggingT $ initPool dbFilePath-}
{-pool3 <- runNoLoggingT $ initPool dbFilePath-}
clearWalletTransactions pool1
clearWalletData pool1
dbBlock <- getMaxBlock pool1 znet
@ -119,28 +129,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 +164,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)
@ -211,5 +219,35 @@ clearSync config = do
w <- getWallets pool $ zgb_net chainInfo
liftIO $ mapM_ (updateWalletSync pool 0 . entityKey) w
w' <- liftIO $ getWallets pool $ zgb_net chainInfo
r <- mapM (syncWallet config) w'
r <- runFileLoggingT "zenith.log" $ 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)

37
src/Zenith/Types.hs
View file

@ -104,10 +104,10 @@ data Config = Config
} deriving (Eq, Prelude.Show)
data ZcashPool
= Transparent
| Sprout
| Sapling
| Orchard
= TransparentPool
| SproutPool
| SaplingPool
| OrchardPool
deriving (Show, Read, Eq)
derivePersistField "ZcashPool"
@ -115,18 +115,18 @@ derivePersistField "ZcashPool"
instance ToJSON ZcashPool where
toJSON zp =
case zp of
Transparent -> Data.Aeson.String "p2pkh"
Sprout -> Data.Aeson.String "sprout"
Sapling -> Data.Aeson.String "sapling"
Orchard -> Data.Aeson.String "orchard"
TransparentPool -> Data.Aeson.String "p2pkh"
SproutPool -> Data.Aeson.String "sprout"
SaplingPool -> Data.Aeson.String "sapling"
OrchardPool -> Data.Aeson.String "orchard"
instance FromJSON ZcashPool where
parseJSON =
withText "ZcashPool" $ \case
"p2pkh" -> return Transparent
"sprout" -> return Sprout
"sapling" -> return Sapling
"orchard" -> return Orchard
"p2pkh" -> return TransparentPool
"sprout" -> return SproutPool
"sapling" -> return SaplingPool
"orchard" -> return OrchardPool
_ -> fail "Not a known Zcash pool"
newtype ZenithUuid = ZenithUuid
@ -199,12 +199,12 @@ $(deriveJSON defaultOptions ''ZenithStatus)
derivePersistField "ZenithStatus"
data PrivacyPolicy
= Full
| Medium
= None
| Low
| None
| Medium
| Full
deriving (Eq, Show, Read, Ord)
$(deriveJSON defaultOptions ''PrivacyPolicy)
-- ** `zebrad`
@ -298,7 +298,8 @@ instance FromJSON AddressGroup where
Nothing -> return []
Just x -> do
x' <- x .:? "addresses"
return $ maybe [] (map (ZcashAddress s1 [Transparent] Nothing)) x'
return $
maybe [] (map (ZcashAddress s1 [TransparentPool] Nothing)) x'
processSapling k s2 =
case k of
Nothing -> return []
@ -306,7 +307,7 @@ instance FromJSON AddressGroup where
where processOneSapling sx =
withObject "Sapling" $ \oS -> do
oS' <- oS .: "addresses"
return $ map (ZcashAddress sx [Sapling] Nothing) oS'
return $ map (ZcashAddress sx [SaplingPool] Nothing) oS'
processUnified u =
case u of
Nothing -> return []

25
src/Zenith/Utils.hs
View file

@ -3,13 +3,13 @@
module Zenith.Utils where
import Data.Aeson
import Data.Char (isAlphaNum, isSpace)
import Data.Functor (void)
import Data.Maybe
import Data.Ord (clamp)
import Data.Scientific (Scientific(..), scientific)
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import Data.Char (isAlphaNum, isSpace)
import System.Directory
import System.Process (createProcess_, shell)
import Text.Regex.Posix
@ -74,9 +74,9 @@ getAddresses ag = agtransparent ag <> agsapling ag <> agunified ag
-- | Helper function to validate potential Zcash addresses
validateAddress :: T.Text -> Maybe ZcashPool
validateAddress txt --(tReg || sReg && isJust chk) || (uReg && isJust chk)
| tReg = Just Zenith.Types.Transparent
| sReg && chkS = Just Zenith.Types.Sapling
| uReg && chk = Just Orchard
| tReg = Just TransparentPool
| sReg && chkS = Just SaplingPool
| uReg && chk = Just OrchardPool
| otherwise = Nothing
where
transparentRegex = "^t1[a-zA-Z0-9]{33}$" :: String
@ -197,16 +197,16 @@ parseAddress a znet =
Nothing -> Nothing
isValidContent :: String -> Bool
isValidContent [] = False -- an empty string is invalid
isValidContent [] = False -- an empty string is invalid
isValidContent (x:xs)
| not (isAlphaNum x ) = False -- string must start with an alphanumeric character
| otherwise = allValidChars xs -- process the rest of the string
| not (isAlphaNum x) = False -- string must start with an alphanumeric character
| otherwise = allValidChars xs -- process the rest of the string
where
allValidChars :: String -> Bool
allValidChars [] = True -- if we got here, string is valid
allValidChars [] = True -- if we got here, string is valid
allValidChars (y:ys)
| isAlphaNum y || isSpace y = allValidChars ys -- char is valid, continue
| otherwise = False -- found an invalid character, return false
| otherwise = False -- found an invalid character, return false
isValidString :: T.Text -> Bool
isValidString c = do
@ -215,10 +215,9 @@ isValidString c = do
padWithZero :: Int -> String -> String
padWithZero n s
| (length s) >= n = s
| otherwise = padWithZero n ("0" ++ s)
| (length s) >= n = s
| otherwise = padWithZero n ("0" ++ s)
isEmpty :: [a] -> Bool
isEmpty [] = True
isEmpty _ = False
isEmpty _ = False

7
src/Zenith/Zcashd.hs
View file

@ -123,9 +123,10 @@ sendTx user pwd fromAddy toAddy amount memo = do
if source fromAddy /= ImportedWatchOnly
then do
let privacyPolicy
| valAdd == Just Transparent = "AllowRevealedRecipients"
| valAdd == Just TransparentPool = "AllowRevealedRecipients"
| isNothing (account fromAddy) &&
elem Transparent (pool fromAddy) = "AllowRevealedSenders"
elem TransparentPool (pool fromAddy) =
"AllowRevealedSenders"
| otherwise = "AllowRevealedAmounts"
let pd =
case memo of
@ -301,7 +302,7 @@ sendWithUri user pwd fromAddy uri repTo = do
let addType = validateAddress $ T.pack parsedAddress
case addType of
Nothing -> putStrLn " Invalid address"
Just Transparent -> do
Just TransparentPool -> do
putStrLn $ " Address is valid: " ++ parsedAddress
case (readMaybe parsedAmount :: Maybe Double) of
Nothing -> putStrLn " Invalid amount."

143
test/Spec.hs
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,115 @@ 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 4)
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)
3001230
0.005
(fromJust uaRead)
"Sending memo to orchard"
Full
case tx of
Left e -> assertFailure $ show e
Right h -> h `shouldNotBe` (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 4)
3001230
0.005
(fromJust uaRead)
"Sending memo to sapling"
Full
case tx of
Left e -> assertFailure $ show e
Right h -> h `shouldNotBe` (hexString "deadbeef")
describe "Medium" $ do
xit "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)
3000789
0.005
(fromJust uaRead)
"Sending memo to orchard"
Medium
case tx of
Left e -> assertFailure $ show e
Right h -> h `shouldNotBe` (hexString "deadbeef")
xit "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)
3000789
0.005
(fromJust uaRead)
"Sending memo to orchard"
Medium
case tx of
Left e -> assertFailure $ show e
Right h -> h `shouldNotBe` (hexString "deadbeef")