diff --git a/CHANGELOG.md b/CHANGELOG.md index 896f51a..fa43828 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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] diff --git a/app/Main.hs b/app/Main.hs index 2547ab8..f3d4b4c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -230,6 +230,7 @@ main = do "gui" -> runZenithGUI myConfig "tui" -> runZenithTUI myConfig "rescan" -> rescanZebra zebraHost zebraPort dbFilePath + "resync" -> clearSync myConfig _ -> printUsage else printUsage diff --git a/src/Zenith/CLI.hs b/src/Zenith/CLI.hs index de5086e..1c963f4 100644 --- a/src/Zenith/CLI.hs +++ b/src/Zenith/CLI.hs @@ -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) diff --git a/src/Zenith/Core.hs b/src/Zenith/Core.hs index abf064b..fcfed56 100644 --- a/src/Zenith/Core.hs +++ b/src/Zenith/Core.hs @@ -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 diff --git a/src/Zenith/DB.hs b/src/Zenith/DB.hs index b2b8db6..38a4b8a 100644 --- a/src/Zenith/DB.hs +++ b/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,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 diff --git a/src/Zenith/GUI.hs b/src/Zenith/GUI.hs index 3a6e4b5..17713e3 100644 --- a/src/Zenith/GUI.hs +++ b/src/Zenith/GUI.hs @@ -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 diff --git a/src/Zenith/Scanner.hs b/src/Zenith/Scanner.hs index 61b890e..7642d86 100644 --- a/src/Zenith/Scanner.hs +++ b/src/Zenith/Scanner.hs @@ -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) diff --git a/src/Zenith/Types.hs b/src/Zenith/Types.hs index 4250283..0a3d58d 100644 --- a/src/Zenith/Types.hs +++ b/src/Zenith/Types.hs @@ -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 [] diff --git a/src/Zenith/Utils.hs b/src/Zenith/Utils.hs index e23a0ab..ad700ce 100644 --- a/src/Zenith/Utils.hs +++ b/src/Zenith/Utils.hs @@ -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 diff --git a/src/Zenith/Zcashd.hs b/src/Zenith/Zcashd.hs index bc4c2d2..8d402b9 100644 --- a/src/Zenith/Zcashd.hs +++ b/src/Zenith/Zcashd.hs @@ -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." diff --git a/test/Spec.hs b/test/Spec.hs index 9b4995c..96523c0 100644 --- a/test/Spec.hs +++ b/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")