feat!: add re-org detection and rewind

Adds new `ZcashBlock` table to database to track block information and
creates a relationship between `ZcashTransaction` records and the block
they belong to.
Database getters and setters are updated to use the block record for
confirmations, height, time data.

CHANGELOG.md

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

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
 

src/Zenith/CLI.hs

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

src/Zenith/Core.hs

@@ -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]

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,13 +204,18 @@ share
     value Int64
     UniqueOrchSpend tx accId
     deriving Show Eq
-  ZcashTransaction
-    block Int
-    txId HexStringDB
+  ZcashBlock
+    height Int
+    hash HexStringDB
     conf Int
     time Int
     network ZcashNetDB
-    UniqueTx block txId network
+    UniqueBlock height network
+    deriving Show Eq
+  ZcashTransaction
+    blockId ZcashBlockId OnDeleteCascade OnUpdateCascade
+    txId HexStringDB
+    UniqueTx blockId txId
     deriving Show Eq
   TransparentNote
     tx ZcashTransactionId
@@ -437,10 +444,10 @@ initDb dbName = do
       clearWalletTransactions pool
       clearWalletData pool
       m <-
-        try $ PS.runSqlite dbName $ runMigrationQuiet migrateAll :: IO
+        try $ PS.runSqlite dbName $ runMigrationUnsafeQuiet migrateAll :: IO
           (Either SomeException [T.Text])
       case m of
-        Left _e2 -> return $ Left "Failed to migrate data tables"
+        Left e2 -> return $ Left $ "Failed to migrate data tables" ++ show e2
         Right _ -> return $ Right True
     Right _ -> return $ Right False
 
@@ -579,14 +586,13 @@ getMaxBlock pool net = do
     PS.retryOnBusy $
     flip PS.runSqlPool pool $ do
       selectOne $ do
-        txs <- from $ table @ZcashTransaction
-        where_ (txs ^. ZcashTransactionBlock >. val 0)
-        where_ (txs ^. ZcashTransactionNetwork ==. val net)
-        orderBy [desc $ txs ^. ZcashTransactionBlock]
-        pure txs
+        bls <- from $ table @ZcashBlock
+        where_ (bls ^. ZcashBlockNetwork ==. val net)
+        orderBy [desc $ bls ^. ZcashBlockHeight]
+        pure bls
   case b of
     Nothing -> return $ -1
-    Just x -> return $ zcashTransactionBlock $ entityVal x
+    Just x -> return $ zcashBlockHeight $ entityVal x
 
 -- | Returns a list of addresses associated with the given account
 getAddresses ::
@@ -677,20 +683,33 @@ saveAddress pool w =
   runNoLoggingT $
   PS.retryOnBusy $ flip PS.runSqlPool pool $ insertUniqueEntity w
 
+-- | Save a block to the database
+saveBlock :: ConnectionPool -> ZcashBlock -> IO (Key ZcashBlock)
+saveBlock pool b =
+  runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do insert b
+
+-- | Read a block by height
+getBlock :: ConnectionPool -> Int -> IO (Maybe (Entity ZcashBlock))
+getBlock pool b =
+  runNoLoggingT $
+  PS.retryOnBusy $
+  flip PS.runSqlPool pool $ do
+    selectOne $ do
+      bl <- from $ table @ZcashBlock
+      where_ $ bl ^. ZcashBlockHeight ==. val b
+      pure bl
+
 -- | Save a transaction to the data model
 saveTransaction ::
      ConnectionPool -- ^ the database path
-  -> Int -- ^ block time
-  -> ZcashNetDB -- ^ the network
+  -> ZcashBlockId -- ^ The block the transaction is in
   -> Transaction -- ^ The transaction to save
   -> NoLoggingT IO (Key ZcashTransaction)
-saveTransaction pool t n wt =
+saveTransaction pool bi wt =
   PS.retryOnBusy $
   flip PS.runSqlPool pool $ do
     let ix = [0 ..]
-    w <-
-      insert $
-      ZcashTransaction (tx_height wt) (HexStringDB $ tx_id wt) (tx_conf wt) t n
+    w <- insert $ ZcashTransaction bi (HexStringDB $ tx_id wt)
     when (isJust $ tx_transpBundle wt) $ do
       _ <-
         insertMany_ $
@@ -776,10 +795,13 @@ getZcashTransactions pool b net =
   PS.retryOnBusy $
   flip PS.runSqlPool pool $ do
     select $ do
-      txs <- from $ table @ZcashTransaction
-      where_ (txs ^. ZcashTransactionBlock >. val b)
-      where_ (txs ^. ZcashTransactionNetwork ==. val (ZcashNetDB net))
-      orderBy [asc $ txs ^. ZcashTransactionBlock]
+      (blks :& txs) <-
+        from $ table @ZcashBlock `innerJoin` table @ZcashTransaction `on`
+        (\(blks :& txs) ->
+           blks ^. ZcashBlockId ==. txs ^. ZcashTransactionBlockId)
+      where_ (blks ^. ZcashBlockHeight >. val b)
+      where_ (blks ^. ZcashBlockNetwork ==. val (ZcashNetDB net))
+      orderBy [asc $ blks ^. ZcashBlockHeight]
       return txs
 
 -- ** QR codes
@@ -876,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)
@@ -1640,14 +1681,22 @@ upsertWalTx ::
   => ZcashTransaction
   -> ZcashAccountId
   -> SqlPersistT m (Entity WalletTransaction)
-upsertWalTx zt za =
+upsertWalTx zt za = do
+  blk <-
+    selectOne $ do
+      blks <- from $ table @ZcashBlock
+      where_ (blks ^. ZcashBlockId ==. val (zcashTransactionBlockId zt))
+      pure blks
+  case blk of
+    Nothing -> throw $ userError "Invalid block for transaction"
+    Just b ->
       upsert
         (WalletTransaction
            (zcashTransactionTxId zt)
            za
-       (zcashTransactionBlock zt)
-       (zcashTransactionConf zt)
-       (zcashTransactionTime zt))
+           (zcashBlockHeight $ entityVal b)
+           (zcashBlockConf $ entityVal b)
+           (zcashBlockTime $ entityVal b))
         []
 
 getSaplingOutIndex :: ConnectionPool -> ShieldOutputId -> IO Int
@@ -1982,6 +2031,130 @@ selectUnspentNotes pool za amt = do
              , n : snd (checkOrchard (x - walletOrchNoteValue (entityVal n)) ns))
         else (0, [n])
 
+selectUnspentNotesV2 ::
+     ConnectionPool
+  -> ZcashAccountId
+  -> Integer
+  -> Int
+  -> PrivacyPolicy
+  -> IO
+       (Either
+          TxError
+          ( [Entity WalletTrNote]
+          , [Entity WalletSapNote]
+          , [Entity WalletOrchNote]))
+selectUnspentNotesV2 pool za amt recv policy = do
+  case policy of
+    Full ->
+      case recv of
+        4 -> do
+          orchNotes <- getWalletUnspentOrchNotes pool za
+          let (a1, oList) = checkOrchard (fromIntegral amt) orchNotes
+          if a1 > 0
+            then return $
+                 Left $ PrivacyPolicyError "Not enough notes for Full privacy"
+            else return $ Right ([], [], oList)
+        3 -> do
+          sapNotes <- getWalletUnspentSapNotes pool za
+          let (a2, sList) = checkSapling (fromIntegral amt) sapNotes
+          if a2 > 0
+            then return $
+                 Left $ PrivacyPolicyError "Not enough notes for Full privacy"
+            else return $ Right ([], sList, [])
+        _anyOther ->
+          return $
+          Left $ PrivacyPolicyError "Receiver not capable of Full privacy"
+    Medium ->
+      if recv > 2
+        then do
+          orchNotes <- getWalletUnspentOrchNotes pool za
+          let (a1, oList) = checkOrchard (fromIntegral amt) orchNotes
+          if a1 > 0
+            then do
+              sapNotes <- getWalletUnspentSapNotes pool za
+              let (a2, sList) = checkSapling a1 sapNotes
+              if a2 > 0
+                then return $
+                     Left $
+                     PrivacyPolicyError "Not enough notes for Medium privacy"
+                else return $ Right ([], sList, oList)
+            else return $ Right ([], [], oList)
+        else return $
+             Left $ PrivacyPolicyError "Receiver not capable of Medium privacy"
+    Low ->
+      if recv == 0
+        then return $ Left ZHError
+        else do
+          case recv of
+            3 -> do
+              sapNotes <- getWalletUnspentSapNotes pool za
+              let (a1, sList) = checkSapling (fromIntegral amt) sapNotes
+              if a1 > 0
+                then do
+                  orchNotes <- getWalletUnspentOrchNotes pool za
+                  let (a2, oList) = checkOrchard a1 orchNotes
+                  if a2 > 0
+                    then return $
+                         Left $
+                         PrivacyPolicyError "Not enough notes for Low privacy"
+                    else return $ Right ([], sList, oList)
+                else return $ Right ([], sList, [])
+            _anyOther -> do
+              orchNotes <- getWalletUnspentOrchNotes pool za
+              let (a1, oList) = checkOrchard (fromIntegral amt) orchNotes
+              if a1 > 0
+                then do
+                  sapNotes <- getWalletUnspentSapNotes pool za
+                  let (a2, sList) = checkSapling a1 sapNotes
+                  if a2 > 0
+                    then return $
+                         Left $
+                         PrivacyPolicyError "Not enough notes for Low privacy"
+                    else return $ Right ([], sList, oList)
+                else return $ Right ([], [], oList)
+    None -> do
+      orchNotes <- getWalletUnspentOrchNotes pool za
+      let (a1, oList) = checkOrchard (fromIntegral amt) orchNotes
+      if a1 > 0
+        then do
+          sapNotes <- getWalletUnspentSapNotes pool za
+          let (a2, sList) = checkSapling a1 sapNotes
+          if a2 > 0
+            then do
+              trNotes <- getWalletUnspentTrNotes pool za
+              let (a3, tList) = checkTransparent a2 trNotes
+              if a3 > 0
+                then return $ Left InsufficientFunds
+                else return $ Right (tList, sList, oList)
+            else return $ Right ([], sList, oList)
+        else return $ Right ([], [], oList)
+  where
+    checkTransparent ::
+         Int64 -> [Entity WalletTrNote] -> (Int64, [Entity WalletTrNote])
+    checkTransparent x [] = (x, [])
+    checkTransparent x (n:ns) =
+      if walletTrNoteValue (entityVal n) < x
+        then ( fst (checkTransparent (x - walletTrNoteValue (entityVal n)) ns)
+             , n :
+               snd (checkTransparent (x - walletTrNoteValue (entityVal n)) ns))
+        else (0, [n])
+    checkSapling ::
+         Int64 -> [Entity WalletSapNote] -> (Int64, [Entity WalletSapNote])
+    checkSapling x [] = (x, [])
+    checkSapling x (n:ns) =
+      if walletSapNoteValue (entityVal n) < x
+        then ( fst (checkSapling (x - walletSapNoteValue (entityVal n)) ns)
+             , n : snd (checkSapling (x - walletSapNoteValue (entityVal n)) ns))
+        else (0, [n])
+    checkOrchard ::
+         Int64 -> [Entity WalletOrchNote] -> (Int64, [Entity WalletOrchNote])
+    checkOrchard x [] = (x, [])
+    checkOrchard x (n:ns) =
+      if walletOrchNoteValue (entityVal n) < x
+        then ( fst (checkOrchard (x - walletOrchNoteValue (entityVal n)) ns)
+             , n : snd (checkOrchard (x - walletOrchNoteValue (entityVal n)) ns))
+        else (0, [n])
+
 getWalletTxId ::
      ConnectionPool -> WalletTransactionId -> IO (Maybe (Value HexStringDB))
 getWalletTxId pool wId = do
@@ -2013,6 +2186,9 @@ saveConfs pool b c = do
       update $ \t -> do
         set t [WalletTransactionConf =. val c]
         where_ $ t ^. WalletTransactionBlock ==. val b
+      update $ \bl -> do
+        set bl [ZcashBlockConf =. val c]
+        where_ $ bl ^. ZcashBlockHeight ==. val b
 
 -- | Helper function to extract a Unified Address from the database
 readUnifiedAddressDB :: WalletAddress -> Maybe UnifiedAddress
@@ -2105,3 +2281,14 @@ finalizeOperation pool op status result = do
         , OperationResult =. val (Just result)
         ]
       where_ (ops ^. OperationId ==. val op)
+
+-- | Rewind the data store to a given block height
+rewindWalletData :: ConnectionPool -> Int -> IO ()
+rewindWalletData pool b = do
+  runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $
+    delete $ do
+      blk <- from $ table @ZcashBlock
+      where_ $ blk ^. ZcashBlockHeight >. val b
+  clearWalletTransactions pool

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
   , isValidString
   , jsonNumber
@@ -60,7 +58,6 @@ import Zenith.Utils
   , parseAddress
   , showAddress
   , validBarValue
-  , validateAddressBool
   )
 
 data AppEvent
@@ -116,7 +113,6 @@ data AppEvent
   | CheckValidAddress !T.Text
   | CheckValidDescrip !T.Text
   | SaveNewABEntry
-  | SaveABDescription !T.Text
   | UpdateABEntry !T.Text !T.Text
   | CloseUpdABEntry
   | ShowMessage !T.Text
@@ -1443,11 +1439,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
@@ -1457,6 +1454,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
@@ -1481,16 +1482,16 @@ scanZebra dbPath zHost zPort net sendMsg = do
             Left e2 -> sendMsg (ShowError $ showt e2)
             Right hb -> do
               let blockTime = getBlockTime hb
-              mapM_ (processTx zHost zPort blockTime pool (ZcashNetDB net)) $
-                bl_txs $ addTime blk blockTime
+              bi <-
+                saveBlock pool $
+                ZcashBlock
+                  (fromIntegral $ bl_height blk)
+                  (HexStringDB $ bl_hash blk)
+                  (fromIntegral $ bl_confirmations blk)
+                  blockTime
+                  (ZcashNetDB net)
+              mapM_ (processTx zHost zPort bi pool) $ bl_txs blk
               sendMsg (SyncVal step)
-    addTime :: BlockResponse -> Int -> BlockResponse
-    addTime bl t =
-      BlockResponse
-        (bl_confirmations bl)
-        (bl_height bl)
-        (fromIntegral t)
-        (bl_txs bl)
 
 sendTransaction ::
      Config

src/Zenith/Scanner.hs

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

src/Zenith/Types.hs

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

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,62 @@ main = do
           a `shouldBe`
             Just
               "ztestsapling1tgjr4zppwk4ne8xy6gdq4z2gwq7dmf5jq8z2ctpn8nlmtse0a74fa5z0m8z383gmpgqz6q6duu4"
-      {-describe "Creating Tx" $ do-}
-        {-xit "To Orchard" $ do-}
-          {-let uaRead =-}
-                {-isValidUnifiedAddress-}
-                  {-"utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax"-}
-          {-case uaRead of-}
-            {-Nothing -> assertFailure "wrong address"-}
-            {-Just ua -> do-}
-              {-tx <--}
-                {-prepareTx-}
-                  {-"zenith.db"-}
-                  {-TestNet-}
-                  {-(toSqlKey 1)-}
-                  {-2819811-}
-                  {-0.04-}
-                  {-ua-}
-                  {-"sent with Zenith, test"-}
-              {-tx `shouldBe` Right (hexString "deadbeef")-}
+      describe "Notes" $ do
+        it "Check Orchard notes" $ do
+          pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db"
+          oNotes <- getWalletUnspentOrchNotes pool (toSqlKey 1)
+          oNotes `shouldBe` []
+        it "Check Sapling notes" $ do
+          pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db"
+          oNotes <- getWalletUnspentSapNotes pool (toSqlKey 1)
+          oNotes `shouldBe` []
+        it "Check transparent notes" $ do
+          pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db"
+          oNotes <- getWalletUnspentTrNotes pool (toSqlKey 1)
+          oNotes `shouldBe` []
+      describe "Creating Tx" $ do
+        describe "Full" $ do
+          it "To Orchard" $ do
+            let uaRead =
+                  parseAddress
+                    "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax"
+            case uaRead of
+              Nothing -> assertFailure "wrong address"
+              Just ua -> do
+                pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db"
+                tx <-
+                  runFileLoggingT "zenith.log" $
+                  prepareTxV2
+                    pool
+                    "localhost"
+                    18232
+                    TestNet
+                    (toSqlKey 1)
+                    2999946
+                    0.005
+                    (fromJust uaRead)
+                    "Sending memo to orchard"
+                    Full
+                tx `shouldBe` Right (hexString "deadbeef")
+          it "To Sapling" $ do
+            let uaRead =
+                  parseAddress
+                    "ztestsapling136jp8z89v2jh6kqd5rs4dtvlxym90m43svzdwzxaplyvc5ttzppytpvx80ncllcsqzpmukxjl3y"
+            case uaRead of
+              Nothing -> assertFailure "wrong address"
+              Just ua -> do
+                pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db"
+                tx <-
+                  runFileLoggingT "zenith.log" $
+                  prepareTxV2
+                    pool
+                    "localhost"
+                    18232
+                    TestNet
+                    (toSqlKey 1)
+                    2999396
+                    0.005
+                    (fromJust uaRead)
+                    "Sending memo to orchard"
+                    Full
+                tx `shouldBe` Right (hexString "deadbeef")

zcash-haskell

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