Milestone 3: RPC server, ZIP-320 #104
11 changed files with 861 additions and 332 deletions
|
|
@ -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]
|
||||
|
||||
|
|
|
|||
|
|
@ -230,6 +230,7 @@ main = do
|
|||
"gui" -> runZenithGUI myConfig
|
||||
"tui" -> runZenithTUI myConfig
|
||||
"rescan" -> rescanZebra zebraHost zebraPort dbFilePath
|
||||
"resync" -> clearSync myConfig
|
||||
_ -> printUsage
|
||||
else printUsage
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ())
|
||||
case confUp of
|
||||
Left _e0 ->
|
||||
liftIO $
|
||||
BC.writeBChan eChan $ TickMsg "Failed to update unconfirmed transactions"
|
||||
Right _ -> do
|
||||
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"
|
||||
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
|
||||
(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 _ -> 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)
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
@ -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
|
||||
|
|
|
|||
326
src/Zenith/DB.hs
326
src/Zenith/DB.hs
|
|
@ -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,14 +898,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 +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,10 +1611,24 @@ getOrchardCmxs pool zt = do
|
|||
getMaxOrchardNote :: Pool SqlBackend -> IO OrchActionId
|
||||
getMaxOrchardNote pool = do
|
||||
flip PS.runSqlPool pool $ do
|
||||
maxBlock <-
|
||||
selectOne $ do
|
||||
blks <- from $ table @ZcashBlock
|
||||
where_ $ blks ^. ZcashBlockHeight >. val 0
|
||||
pure $ blks ^. ZcashBlockHeight
|
||||
case maxBlock of
|
||||
Nothing -> return $ toSqlKey 0
|
||||
Just (Value mb) -> do
|
||||
x <-
|
||||
selectOne $ do
|
||||
n <- from $ table @OrchAction
|
||||
where_ (n ^. OrchActionId >. val (toSqlKey 0))
|
||||
(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
|
||||
|
|
@ -1640,14 +1695,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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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,6 +1248,7 @@ handleEvent wenv node model evt =
|
|||
case currentWallet of
|
||||
Nothing -> return $ ShowError "No wallet available"
|
||||
Just cW -> do
|
||||
runFileLoggingT "zenith.log" $
|
||||
syncWallet (model ^. configuration) cW
|
||||
pool <-
|
||||
runNoLoggingT $
|
||||
|
|
@ -1472,11 +1471,12 @@ 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
|
||||
confUp <- try $ updateConfs zHost zPort pool :: IO (Either IOError ())
|
||||
case confUp of
|
||||
Left _e0 -> sendMsg (ShowError "Failed to update unconfirmed transactions")
|
||||
Right _ -> do
|
||||
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
|
||||
|
|
@ -1486,6 +1486,10 @@ scanZebra dbPath zHost zPort net sendMsg = 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 _ -> 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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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,10 +199,10 @@ $(deriveJSON defaultOptions ''ZenithStatus)
|
|||
derivePersistField "ZenithStatus"
|
||||
|
||||
data PrivacyPolicy
|
||||
= Full
|
||||
| Medium
|
||||
= None
|
||||
| Low
|
||||
| None
|
||||
| Medium
|
||||
| Full
|
||||
deriving (Eq, Show, Read, Ord)
|
||||
|
||||
$(deriveJSON defaultOptions ''PrivacyPolicy)
|
||||
|
|
@ -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 []
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -221,4 +221,3 @@ padWithZero n s
|
|||
isEmpty :: [a] -> Bool
|
||||
isEmpty [] = True
|
||||
isEmpty _ = False
|
||||
|
||||
|
|
|
|||
|
|
@ -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
143
test/Spec.hs
|
|
@ -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")
|
||||
|
|
|
|||
Loading…
Reference in a new issue