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

RPC Server #103

Merged
pitmutt merged 129 commits from rav001 into milestone3 2024-11-21 15:30:22 +00:00
Conversation 0 Commits 129 Files changed 22 +570 -203
9 changed files with 570 additions and 203 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files
Showing only changes of commit 0e14228a0e - Show all commits

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

19
src/Zenith/CLI.hs
View file

@ -91,6 +91,7 @@ import Zenith.DB
import Zenith.Scanner (processTx, rescanZebra, updateConfs)
import Zenith.Types
( Config(..)
, HexStringDB(..)
, PhraseDB(..)
, UnifiedAddressDB(..)
, ZcashNetDB(..)
@ -765,16 +766,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

218
src/Zenith/Core.hs
View file

@ -772,7 +772,11 @@ 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)
notePlan <-
liftIO $
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
@ -780,18 +784,28 @@ prepareTxV2 pool zebraHost zebraPort zn za bh amt va memo policy = do
let noteTotal = getTotalAmount (tList, sList, oList)
tSpends <-
liftIO $
prepTSpends (getTranSK $ zcashAccountTPrivateKey $ entityVal acc) tList
prepTSpends
(getTranSK $ zcashAccountTPrivateKey $ entityVal acc)
tList
--print tSpends
sSpends <-
liftIO $
prepSSpends (getSapSK $ zcashAccountSapSpendKey $ entityVal acc) sList
prepSSpends
(getSapSK $ zcashAccountSapSpendKey $ entityVal acc)
sList
--print sSpends
oSpends <-
liftIO $
prepOSpends (getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc) oList
prepOSpends
(getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc)
oList
--print oSpends
dummy <-
liftIO $ makeOutgoing acc recipient zats (noteTotal - 5000 - zats)
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
@ -808,62 +822,204 @@ prepareTxV2 pool zebraHost zebraPort zn za bh amt va memo policy = do
Left e1 -> return $ Left Fee
Right fee -> do
let feeAmt =
fromIntegral (runGet getInt64le $ LBS.fromStrict $ toBytes fee)
(tList1, sList1, oList1) <-
liftIO $ selectUnspentNotes pool za (zats + feeAmt)
logDebugN $ T.pack $ "selected notes with fee" ++ show feeAmt
logDebugN $ T.pack $ show tList
logDebugN $ T.pack $ show sList
logDebugN $ T.pack $ show oList
outgoing <-
liftIO $ makeOutgoing acc recipient zats (noteTotal - feeAmt - zats)
logDebugN $ T.pack $ show outgoing
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)
tSpends
sSpends
oSpends
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
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
fromJust $
o_rec =<< isValidUnifiedAddress (E.encodeUtf8 internalUA)
return $
Right
[ OutgoingNote
4
(getBytes $ getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc)
(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
_ -> "")
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]

263
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,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
@ -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,22 @@ 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
-- | 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 +784,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,14 +887,23 @@ saveWalletTransaction pool za zt = do
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
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
(zcashTransactionBlock zT')
(zcashTransactionConf zT')
(zcashTransactionTime zT'))
(zcashBlockHeight $ entityVal blk)
(zcashBlockConf $ entityVal blk)
(zcashBlockTime $ entityVal blk))
[]
return $ entityKey t
@ -976,14 +996,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 +1022,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 +1035,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 +1066,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 +1092,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,14 +1670,22 @@ upsertWalTx ::
=> ZcashTransaction
-> ZcashAccountId
-> SqlPersistT m (Entity WalletTransaction)
upsertWalTx zt za =
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
(zcashTransactionBlock zt)
(zcashTransactionConf zt)
(zcashTransactionTime zt))
(zcashBlockHeight $ entityVal b)
(zcashBlockConf $ entityVal b)
(zcashBlockTime $ entityVal b))
[]
getSaplingOutIndex :: ConnectionPool -> ShieldOutputId -> IO Int
@ -1982,6 +2020,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 +2175,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

18
src/Zenith/GUI.hs
View file

@ -1481,16 +1481,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

33
src/Zenith/Scanner.hs
View file

@ -27,7 +27,9 @@ import ZcashHaskell.Types
import ZcashHaskell.Utils (getBlockTime, makeZebraCall, readZebraTransaction)
import Zenith.Core (checkBlockChain, syncWallet)
import Zenith.DB
( clearWalletData
( ZcashBlock(..)
, ZcashBlockId
, clearWalletData
, clearWalletTransactions
, getMaxBlock
, getMinBirthdayHeight
@ -35,11 +37,12 @@ import Zenith.DB
, 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 +122,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 +157,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)

7
src/Zenith/Types.hs
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)

90
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,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")

2
zcash-haskell

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