rvv001 - Merge with rav001 branch

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]
 

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

@@ -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
+  pool <- liftIO $ runNoLoggingT $ initPool dbP
-  dbBlock <- getMaxBlock pool $ ZcashNetDB znet
+  dbBlock <- liftIO $ getMaxBlock pool $ ZcashNetDB znet
-  confUp <- try $ updateConfs zHost zPort pool :: IO (Either IOError ())
+  chkBlock <- liftIO $ checkIntegrity dbP zHost zPort dbBlock 1
-  case confUp of
+  logDebugN $
-    Left _e0 ->
+    "dbBlock: " <>
-      liftIO $
+    T.pack (show dbBlock) <> " chkBlock: " <> T.pack (show chkBlock)
-      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 $
+      liftIO $ BC.writeBChan eChan $ TickMsg "Invalid starting block for scan"
-            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) /
+                (1.0 :: Float) / fromIntegral (zgb_blocks bStatus - (sb + 1))
-                    fromIntegral (zgb_blocks bStatus - (sb + 1))
+          mapM_ (liftIO . processBlock pool step) bList
-              mapM_ (processBlock pool step) bList
         else liftIO $ BC.writeBChan eChan $ TickVal 1.0
+  confUp <-
+    liftIO $ try $ updateConfs zHost zPort pool :: LoggingT
+      IO
+      (Either IOError ())
+  case confUp of
+    Left _e0 ->
+      liftIO $
+      BC.writeBChan eChan $ TickMsg "Failed to update unconfirmed transactions"
+    Right _ -> return ()
   where
     processBlock :: ConnectionPool -> Float -> Int -> IO ()
     processBlock pool step bl = do
@@ -780,16 +797,16 @@ scanZebra dbP zHost zPort b eChan znet = do
             Left e2 -> liftIO $ BC.writeBChan eChan $ TickMsg e2
             Right hb -> do
               let blockTime = getBlockTime hb
-              mapM_ (processTx zHost zPort blockTime pool (ZcashNetDB znet)) $
+              bi <-
-                bl_txs $ addTime blk blockTime
+                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)

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 <-
+          dummy' <-
-        liftIO $ makeOutgoing acc recipient zats (noteTotal - 5000 - zats)
+            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)
+                        fromIntegral
-          (tList1, sList1, oList1) <-
+                          (runGet getInt64le $ LBS.fromStrict $ toBytes fee)
-            liftIO $ selectUnspentNotes pool za (zats + feeAmt)
+                  finalNotePlan <-
-          logDebugN $ T.pack $ "selected notes with fee" ++ show feeAmt
+                    liftIO $
-          logDebugN $ T.pack $ show tList
+                    selectUnspentNotesV2
-          logDebugN $ T.pack $ show sList
+                      pool
-          logDebugN $ T.pack $ show oList
+                      za
-          outgoing <-
+                      (zats + feeAmt)
-            liftIO $ makeOutgoing acc recipient zats (noteTotal - feeAmt - zats)
+                      (fst recipient)
-          logDebugN $ T.pack $ show outgoing
+                      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
+                                  tSpends1
-                  sSpends
+                                  sSpends1
-                  oSpends
+                                  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]
+      -> PrivacyPolicy
-    makeOutgoing acc (k, recvr) zats chg = do
+      -> 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)
+                    fromJust $
-      return
+                    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)
+                      4
-            (case k of
+                      (getBytes $
-               4 ->
+                       getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc)
-                 getBytes $ getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc
-               3 ->
-                 getBytes $ getSapSK $ zcashAccountSapSpendKey $ 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
+  pool <- liftIO $ runNoLoggingT $ initPool walletDb
-  accs <- runNoLoggingT $ getAccounts pool $ entityKey w
+  accs <- liftIO $ runNoLoggingT $ getAccounts pool $ entityKey w
-  addrs <- concat <$> mapM (runNoLoggingT . getAddresses pool . entityKey) accs
+  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
+    concat <$>
-  chainTip <- getMaxBlock pool znet
+    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
+  _ <- liftIO $ updateSaplingWitnesses pool
-  _ <- updateOrchardWitnesses pool
+  _ <- liftIO $ updateOrchardWitnesses pool
   _ <- liftIO $ updateWalletSync pool chainTip (entityKey w)
-  mapM_ (runNoLoggingT . getWalletTransactions pool) addrs
+  mapM_ (liftIO . runNoLoggingT . getWalletTransactions pool) addrs

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
+  ZcashBlock
-    block Int
+    height Int
-    txId HexStringDB
+    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
+        bls <- from $ table @ZcashBlock
-        where_ (txs ^. ZcashTransactionBlock >. val 0)
+        where_ (bls ^. ZcashBlockNetwork ==. val net)
-        where_ (txs ^. ZcashTransactionNetwork ==. val net)
+        orderBy [desc $ bls ^. ZcashBlockHeight]
-        orderBy [desc $ txs ^. ZcashTransactionBlock]
+        pure bls
-        pure txs
   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
+  -> ZcashBlockId -- ^ The block the transaction is in
-  -> ZcashNetDB -- ^ the network
   -> 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 <-
+    w <- insert $ ZcashTransaction bi (HexStringDB $ tx_id wt)
-      insert $
-      ZcashTransaction (tx_height wt) (HexStringDB $ tx_id wt) (tx_conf wt) t n
     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
+      (blks :& txs) <-
-      where_ (txs ^. ZcashTransactionBlock >. val b)
+        from $ table @ZcashBlock `innerJoin` table @ZcashTransaction `on`
-      where_ (txs ^. ZcashTransactionNetwork ==. val (ZcashNetDB net))
+        (\(blks :& txs) ->
-      orderBy [asc $ txs ^. ZcashTransactionBlock]
+           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')
+                 (zcashBlockHeight $ entityVal blk)
-             (zcashTransactionConf zT')
+                 (zcashBlockConf $ entityVal blk)
-             (zcashTransactionTime zT'))
+                 (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) <-
+            (blks :& txs :& tNotes) <-
-              from $ table @ZcashTransaction `innerJoin` table @TransparentNote `on`
+              from $ table @ZcashBlock `innerJoin` table @ZcashTransaction `on`
-              (\(txs :& tNotes) ->
+              (\(blks :& txs) ->
+                 blks ^. ZcashBlockId ==. txs ^. ZcashTransactionBlockId) `innerJoin`
+              table @TransparentNote `on`
+              (\(_ :& txs :& tNotes) ->
                  txs ^. ZcashTransactionId ==. tNotes ^. TransparentNoteTx)
-            where_ (txs ^. ZcashTransactionBlock >. val b)
+            where_ (blks ^. ZcashBlockHeight >. val b)
-            where_ (txs ^. ZcashTransactionNetwork ==. val net)
+            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')
+             (zcashBlockHeight b)
-             (zcashTransactionConf zT')
+             (zcashBlockConf b)
-             (zcashTransactionTime zT'))
+             (zcashBlockTime b))
           []
       insert_ $
         WalletTrNote
@@ -1042,12 +1077,15 @@ getShieldedOutputs pool b net =
   PS.retryOnBusy $
   flip PS.runSqlPool pool $ do
     select $ do
-      (txs :& sOutputs) <-
+      (blks :& txs :& sOutputs) <-
-        from $ table @ZcashTransaction `innerJoin` table @ShieldOutput `on`
+        from $ table @ZcashBlock `innerJoin` table @ZcashTransaction `on`
-        (\(txs :& sOutputs) ->
+        (\(blks :& txs) ->
+           blks ^. ZcashBlockId ==. txs ^. ZcashTransactionBlockId) `innerJoin`
+        table @ShieldOutput `on`
+        (\(_ :& txs :& sOutputs) ->
            txs ^. ZcashTransactionId ==. sOutputs ^. ShieldOutputTx)
-      where_ (txs ^. ZcashTransactionBlock >=. val b)
+      where_ (blks ^. ZcashBlockHeight >=. val b)
-      where_ (txs ^. ZcashTransactionNetwork ==. val net)
+      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) <-
+      (blks :& txs :& oActions) <-
-        from $ table @ZcashTransaction `innerJoin` table @OrchAction `on`
+        from $ table @ZcashBlock `innerJoin` table @ZcashTransaction `on`
-        (\(txs :& oActions) ->
+        (\(blks :& txs) ->
+           blks ^. ZcashBlockId ==. txs ^. ZcashTransactionBlockId) `innerJoin`
+        table @OrchAction `on`
+        (\(_ :& txs :& oActions) ->
            txs ^. ZcashTransactionId ==. oActions ^. OrchActionTx)
-      where_ (txs ^. ZcashTransactionBlock >=. val b)
+      where_ (blks ^. ZcashBlockHeight >=. val b)
-      where_ (txs ^. ZcashTransactionNetwork ==. val net)
+      where_ (blks ^. ZcashBlockNetwork ==. val net)
       orderBy
         [asc $ txs ^. ZcashTransactionId, asc $ oActions ^. OrchActionPosition]
       pure (txs, oActions)
@@ -1570,10 +1611,24 @@ getOrchardCmxs pool zt = do
 getMaxOrchardNote :: Pool SqlBackend -> IO OrchActionId
 getMaxOrchardNote pool = do
   flip PS.runSqlPool pool $ do
+    maxBlock <-
+      selectOne $ do
+        blks <- from $ table @ZcashBlock
+        where_ $ blks ^. ZcashBlockHeight >. val 0
+        pure $ blks ^. ZcashBlockHeight
+    case maxBlock of
+      Nothing -> return $ toSqlKey 0
+      Just (Value mb) -> do
         x <-
           selectOne $ do
-        n <- from $ table @OrchAction
+            (blks :& txs :& n) <-
-        where_ (n ^. OrchActionId >. val (toSqlKey 0))
+              from $ table @ZcashBlock `innerJoin` table @ZcashTransaction `on`
+              (\(blks :& txs) ->
+                 blks ^. ZcashBlockId ==. txs ^. ZcashTransactionBlockId) `innerJoin`
+              table @OrchAction `on`
+              (\(_ :& txs :& n) ->
+                 txs ^. ZcashTransactionId ==. n ^. OrchActionTx)
+            where_ (blks ^. ZcashBlockHeight <=. val (mb - 5))
             orderBy [desc $ n ^. OrchActionId]
             pure (n ^. OrchActionId)
         case x of
@@ -1640,14 +1695,22 @@ upsertWalTx ::
   => ZcashTransaction
   -> ZcashAccountId
   -> SqlPersistT m (Entity WalletTransaction)
-upsertWalTx zt za =
+upsertWalTx zt za = do
+  blk <-
+    selectOne $ do
+      blks <- from $ table @ZcashBlock
+      where_ (blks ^. ZcashBlockId ==. val (zcashTransactionBlockId zt))
+      pure blks
+  case blk of
+    Nothing -> throw $ userError "Invalid block for transaction"
+    Just b ->
       upsert
         (WalletTransaction
            (zcashTransactionTxId zt)
            za
-       (zcashTransactionBlock zt)
+           (zcashBlockHeight $ entityVal b)
-       (zcashTransactionConf zt)
+           (zcashBlockConf $ entityVal b)
-       (zcashTransactionTime zt))
+           (zcashBlockTime $ entityVal b))
         []
 
 getSaplingOutIndex :: ConnectionPool -> ShieldOutputId -> IO Int
@@ -1801,6 +1864,9 @@ clearWalletData pool = do
       delete $ do
         _ <- from $ table @ZcashTransaction
         return ()
+      delete $ do
+        _ <- from $ table @ZcashBlock
+        return ()
 
 getWalletUnspentTrNotes ::
      ConnectionPool -> ZcashAccountId -> IO [Entity WalletTrNote]
@@ -1982,6 +2048,130 @@ selectUnspentNotes pool za amt = do
              , n : snd (checkOrchard (x - walletOrchNoteValue (entityVal n)) ns))
         else (0, [n])
 
+selectUnspentNotesV2 ::
+     ConnectionPool
+  -> ZcashAccountId
+  -> Integer
+  -> Int
+  -> PrivacyPolicy
+  -> IO
+       (Either
+          TxError
+          ( [Entity WalletTrNote]
+          , [Entity WalletSapNote]
+          , [Entity WalletOrchNote]))
+selectUnspentNotesV2 pool za amt recv policy = do
+  case policy of
+    Full ->
+      case recv of
+        4 -> do
+          orchNotes <- getWalletUnspentOrchNotes pool za
+          let (a1, oList) = checkOrchard (fromIntegral amt) orchNotes
+          if a1 > 0
+            then return $
+                 Left $ PrivacyPolicyError "Not enough notes for Full privacy"
+            else return $ Right ([], [], oList)
+        3 -> do
+          sapNotes <- getWalletUnspentSapNotes pool za
+          let (a2, sList) = checkSapling (fromIntegral amt) sapNotes
+          if a2 > 0
+            then return $
+                 Left $ PrivacyPolicyError "Not enough notes for Full privacy"
+            else return $ Right ([], sList, [])
+        _anyOther ->
+          return $
+          Left $ PrivacyPolicyError "Receiver not capable of Full privacy"
+    Medium ->
+      if recv > 2
+        then do
+          orchNotes <- getWalletUnspentOrchNotes pool za
+          let (a1, oList) = checkOrchard (fromIntegral amt) orchNotes
+          if a1 > 0
+            then do
+              sapNotes <- getWalletUnspentSapNotes pool za
+              let (a2, sList) = checkSapling a1 sapNotes
+              if a2 > 0
+                then return $
+                     Left $
+                     PrivacyPolicyError "Not enough notes for Medium privacy"
+                else return $ Right ([], sList, oList)
+            else return $ Right ([], [], oList)
+        else return $
+             Left $ PrivacyPolicyError "Receiver not capable of Medium privacy"
+    Low ->
+      if recv == 0
+        then return $ Left ZHError
+        else do
+          case recv of
+            3 -> do
+              sapNotes <- getWalletUnspentSapNotes pool za
+              let (a1, sList) = checkSapling (fromIntegral amt) sapNotes
+              if a1 > 0
+                then do
+                  orchNotes <- getWalletUnspentOrchNotes pool za
+                  let (a2, oList) = checkOrchard a1 orchNotes
+                  if a2 > 0
+                    then return $
+                         Left $
+                         PrivacyPolicyError "Not enough notes for Low privacy"
+                    else return $ Right ([], sList, oList)
+                else return $ Right ([], sList, [])
+            _anyOther -> do
+              orchNotes <- getWalletUnspentOrchNotes pool za
+              let (a1, oList) = checkOrchard (fromIntegral amt) orchNotes
+              if a1 > 0
+                then do
+                  sapNotes <- getWalletUnspentSapNotes pool za
+                  let (a2, sList) = checkSapling a1 sapNotes
+                  if a2 > 0
+                    then return $
+                         Left $
+                         PrivacyPolicyError "Not enough notes for Low privacy"
+                    else return $ Right ([], sList, oList)
+                else return $ Right ([], [], oList)
+    None -> do
+      orchNotes <- getWalletUnspentOrchNotes pool za
+      let (a1, oList) = checkOrchard (fromIntegral amt) orchNotes
+      if a1 > 0
+        then do
+          sapNotes <- getWalletUnspentSapNotes pool za
+          let (a2, sList) = checkSapling a1 sapNotes
+          if a2 > 0
+            then do
+              trNotes <- getWalletUnspentTrNotes pool za
+              let (a3, tList) = checkTransparent a2 trNotes
+              if a3 > 0
+                then return $ Left InsufficientFunds
+                else return $ Right (tList, sList, oList)
+            else return $ Right ([], sList, oList)
+        else return $ Right ([], [], oList)
+  where
+    checkTransparent ::
+         Int64 -> [Entity WalletTrNote] -> (Int64, [Entity WalletTrNote])
+    checkTransparent x [] = (x, [])
+    checkTransparent x (n:ns) =
+      if walletTrNoteValue (entityVal n) < x
+        then ( fst (checkTransparent (x - walletTrNoteValue (entityVal n)) ns)
+             , n :
+               snd (checkTransparent (x - walletTrNoteValue (entityVal n)) ns))
+        else (0, [n])
+    checkSapling ::
+         Int64 -> [Entity WalletSapNote] -> (Int64, [Entity WalletSapNote])
+    checkSapling x [] = (x, [])
+    checkSapling x (n:ns) =
+      if walletSapNoteValue (entityVal n) < x
+        then ( fst (checkSapling (x - walletSapNoteValue (entityVal n)) ns)
+             , n : snd (checkSapling (x - walletSapNoteValue (entityVal n)) ns))
+        else (0, [n])
+    checkOrchard ::
+         Int64 -> [Entity WalletOrchNote] -> (Int64, [Entity WalletOrchNote])
+    checkOrchard x [] = (x, [])
+    checkOrchard x (n:ns) =
+      if walletOrchNoteValue (entityVal n) < x
+        then ( fst (checkOrchard (x - walletOrchNoteValue (entityVal n)) ns)
+             , n : snd (checkOrchard (x - walletOrchNoteValue (entityVal n)) ns))
+        else (0, [n])
+
 getWalletTxId ::
      ConnectionPool -> WalletTransactionId -> IO (Maybe (Value HexStringDB))
 getWalletTxId pool wId = do
@@ -2013,6 +2203,9 @@ saveConfs pool b c = do
       update $ \t -> do
         set t [WalletTransactionConf =. val c]
         where_ $ t ^. WalletTransactionBlock ==. val b
+      update $ \bl -> do
+        set bl [ZcashBlockConf =. val c]
+        where_ $ bl ^. ZcashBlockHeight ==. val b
 
 -- | Helper function to extract a Unified Address from the database
 readUnifiedAddressDB :: WalletAddress -> Maybe UnifiedAddress
@@ -2105,3 +2298,14 @@ finalizeOperation pool op status result = do
         , OperationResult =. val (Just result)
         ]
       where_ (ops ^. OperationId ==. val op)
+
+-- | Rewind the data store to a given block height
+rewindWalletData :: ConnectionPool -> Int -> IO ()
+rewindWalletData pool b = do
+  runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $
+    delete $ do
+      blk <- from $ table @ZcashBlock
+      where_ $ blk ^. ZcashBlockHeight >=. val b
+  clearWalletTransactions pool

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"
+                                 OrchardPool -> "Unified"
-                                 Sapling -> "Legacy Shielded"
+                                 SaplingPool -> "Legacy Shielded"
-                                 Transparent -> "Transparent"
+                                 TransparentPool -> "Transparent"
-                                 Sprout -> "Unknown") `styleBasic`
+                                 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 OrchardPool wAddr
-          generateOneQr pool Sapling wAddr
+          generateOneQr pool SaplingPool wAddr
-          generateOneQr pool Transparent 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
+        OrchardPool ->
-        Sprout -> Nothing
+          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
+          OrchardPool ->
-          Sapling ->
+            maybe "None" (getUA . walletAddressUAddress . entityVal) a
+          SaplingPool ->
             fromMaybe "None" $
             (getSaplingFromUA .
              E.encodeUtf8 . getUA . walletAddressUAddress . entityVal) =<<
             a
-          Sprout -> "None"
+          SproutPool -> "None"
-          Transparent ->
+          TransparentPool ->
             maybe "None" (encodeTransparentReceiver (model ^. network)) $
             t_rec =<<
             (isValidUnifiedAddress .
@@ -1212,7 +1210,7 @@ handleEvent wenv node model evt =
       if not (null a)
         then [ Model $ model & addresses .~ a
              , Event $ SwitchAddr $ model ^. selAddr
-             , Event $ SetPool Orchard
+             , Event $ SetPool OrchardPool
              ]
         else [Event $ NewAddress currentAccount]
     LoadAccs a ->
@@ -1250,6 +1248,7 @@ handleEvent wenv node model evt =
                  case currentWallet of
                    Nothing -> return $ ShowError "No wallet available"
                    Just cW -> do
+                     runFileLoggingT "zenith.log" $
                        syncWallet (model ^. configuration) cW
                      pool <-
                        runNoLoggingT $
@@ -1472,11 +1471,12 @@ scanZebra dbPath zHost zPort net sendMsg = do
   pool <- runNoLoggingT $ initPool dbPath
   b <- liftIO $ getMinBirthdayHeight pool
   dbBlock <- getMaxBlock pool $ ZcashNetDB net
-  let sb = max dbBlock b
+  chkBlock <- checkIntegrity dbPath zHost zPort dbBlock 1
-  confUp <- try $ updateConfs zHost zPort pool :: IO (Either IOError ())
+  unless (chkBlock == dbBlock) $ rewindWalletData pool chkBlock
-  case confUp of
+  let sb =
-    Left _e0 -> sendMsg (ShowError "Failed to update unconfirmed transactions")
+        if chkBlock == dbBlock
-    Right _ -> do
+          then max dbBlock b
+          else max chkBlock b
   if sb > zgb_blocks bStatus || sb < 1
     then sendMsg (ShowError "Invalid starting block for scan")
     else do
@@ -1486,6 +1486,10 @@ scanZebra dbPath zHost zPort net sendMsg = do
           let step = (1.0 :: Float) / fromIntegral (length bList)
           mapM_ (processBlock pool step) bList
         else sendMsg (SyncVal 1.0)
+  confUp <- try $ updateConfs zHost zPort pool :: IO (Either IOError ())
+  case confUp of
+    Left _e0 -> sendMsg (ShowError "Failed to update unconfirmed transactions")
+    Right _ -> return ()
   where
     processBlock :: ConnectionPool -> Float -> Int -> IO ()
     processBlock pool step bl = do
@@ -1510,16 +1514,16 @@ scanZebra dbPath zHost zPort net sendMsg = do
             Left e2 -> sendMsg (ShowError $ showt e2)
             Right hb -> do
               let blockTime = getBlockTime hb
-              mapM_ (processTx zHost zPort blockTime pool (ZcashNetDB net)) $
+              bi <-
-                bl_txs $ addTime blk blockTime
+                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

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
+      {-pool2 <- runNoLoggingT $ initPool dbFilePath-}
-      pool3 <- 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) $
+          bi <-
-            bl_txs $ addTime blk blockTime
+            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)

src/Zenith/Types.hs

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

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
+  | tReg = Just TransparentPool
-  | sReg && chkS = Just Zenith.Types.Sapling
+  | sReg && chkS = Just SaplingPool
-  | uReg && chk = Just Orchard
+  | uReg && chk = Just OrchardPool
   | otherwise = Nothing
   where
     transparentRegex = "^t1[a-zA-Z0-9]{33}$" :: String
@@ -221,4 +221,3 @@ padWithZero n s
 isEmpty :: [a] -> Bool
 isEmpty [] = True
 isEmpty _ = False
-

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."

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-}
+      describe "Notes" $ do
-        {-xit "To Orchard" $ do-}
+        it "Check Orchard notes" $ do
-          {-let uaRead =-}
+          pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db"
-                {-isValidUnifiedAddress-}
+          oNotes <- getWalletUnspentOrchNotes pool (toSqlKey 1)
-                  {-"utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax"-}
+          oNotes `shouldBe` []
-          {-case uaRead of-}
+        it "Check Sapling notes" $ do
-            {-Nothing -> assertFailure "wrong address"-}
+          pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db"
-            {-Just ua -> do-}
+          oNotes <- getWalletUnspentSapNotes pool (toSqlKey 4)
-              {-tx <--}
+          oNotes `shouldBe` []
-                {-prepareTx-}
+        it "Check transparent notes" $ do
-                  {-"zenith.db"-}
+          pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db"
-                  {-TestNet-}
+          oNotes <- getWalletUnspentTrNotes pool (toSqlKey 1)
-                  {-(toSqlKey 1)-}
+          oNotes `shouldBe` []
-                  {-2819811-}
+      describe "Creating Tx" $ do
-                  {-0.04-}
+        describe "Full" $ do
-                  {-ua-}
+          it "To Orchard" $ do
-                  {-"sent with Zenith, test"-}
+            let uaRead =
-              {-tx `shouldBe` Right (hexString "deadbeef")-}
+                  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")