Add Logging to sync

src/Zenith/CLI.hs

@@ -63,7 +63,12 @@ import Control.Concurrent (forkIO, threadDelay)
 import Control.Exception (throw, throwIO, try)
 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
@@ -717,17 +722,22 @@ abMBarAttr :: A.AttrName
 abMBarAttr = A.attrName "menubar"
 
 scanZebra ::
-     T.Text -> T.Text -> Int -> Int -> BC.BChan Tick -> ZcashNet -> IO ()
+     T.Text
+  -> T.Text
+  -> Int
+  -> Int
+  -> BC.BChan Tick
+  -> ZcashNet
+  -> LoggingT IO ()
 scanZebra dbP zHost zPort b eChan znet = do
   bStatus <- liftIO $ checkBlockChain zHost zPort
-  pool <- runNoLoggingT $ initPool dbP
-  dbBlock <- getMaxBlock pool $ ZcashNetDB znet
-  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
+  pool <- liftIO $ runNoLoggingT $ initPool dbP
+  dbBlock <- liftIO $ getMaxBlock pool $ ZcashNetDB znet
+  chkBlock <- liftIO $ checkIntegrity dbP zHost zPort dbBlock 1
+  logDebugN $
+    "dbBlock: " <>
+    T.pack (show dbBlock) <> " chkBlock: " <> T.pack (show chkBlock)
+  let sb = max dbBlock b
   if sb > zgb_blocks bStatus || sb < 1
     then do
       liftIO $ BC.writeBChan eChan $ TickMsg "Invalid starting block for scan"
@@ -737,9 +747,12 @@ scanZebra dbP zHost zPort b eChan znet = do
         then do
           let step =
                 (1.0 :: Float) / fromIntegral (zgb_blocks bStatus - (sb + 1))
-          mapM_ (processBlock pool step) bList
+          mapM_ (liftIO . processBlock pool step) bList
         else liftIO $ BC.writeBChan eChan $ TickVal 1.0
-  confUp <- try $ updateConfs zHost zPort pool :: IO (Either IOError ())
+  confUp <-
+    liftIO $ try $ updateConfs zHost zPort pool :: LoggingT
+      IO
+      (Either IOError ())
   case confUp of
     Left _e0 ->
       liftIO $
@@ -823,6 +836,7 @@ appEvent (BT.AppEvent t) = do
                      Just (_k, w) -> return w
               _ <-
                 liftIO $
+                runFileLoggingT "zenith.log" $
                 syncWallet
                   (Config
                      (s ^. dbPath)
@@ -859,6 +873,7 @@ appEvent (BT.AppEvent t) = do
                   _ <-
                     liftIO $
                     forkIO $
+                    runFileLoggingT "zenith.log" $
                     scanZebra
                       (s ^. dbPath)
                       (s ^. zebraHost)

src/Zenith/Core.hs

@@ -1107,22 +1107,30 @@ prepareTxV2 pool zebraHost zebraPort zn za bh amt va memo policy = do
 syncWallet ::
      Config -- ^ configuration parameters
   -> Entity ZcashWallet
-  -> IO ()
+  -> LoggingT IO ()
 syncWallet config w = do
   startTime <- liftIO getCurrentTime
   let walletDb = c_dbPath config
   let znet = zcashWalletNetwork $ entityVal w
-  pool <- runNoLoggingT $ initPool walletDb
-  accs <- runNoLoggingT $ getAccounts pool $ entityKey w
-  addrs <- concat <$> mapM (runNoLoggingT . getAddresses pool . entityKey) accs
+  pool <- liftIO $ runNoLoggingT $ initPool walletDb
+  accs <- liftIO $ runNoLoggingT $ getAccounts pool $ entityKey w
+  logDebugN $ "Accounts: " <> T.pack (show accs)
+  addrs <-
+    concat <$>
+    mapM (liftIO . runNoLoggingT . getAddresses pool . entityKey) accs
+  logDebugN $ "addrs: " <> T.pack (show addrs)
   intAddrs <-
-    concat <$> mapM (runNoLoggingT . getInternalAddresses pool . entityKey) accs
-  chainTip <- getMaxBlock pool znet
+    concat <$>
+    mapM (liftIO . runNoLoggingT . getInternalAddresses pool . entityKey) accs
+  chainTip <- liftIO $ getMaxBlock pool znet
+  logDebugN $ "chain tip: " <> T.pack (show chainTip)
   let lastBlock = zcashWalletLastSync $ entityVal w
+  logDebugN $ "last block: " <> T.pack (show lastBlock)
   let startBlock =
         if lastBlock > 0
           then lastBlock
           else zcashWalletBirthdayHeight $ entityVal w
+  logDebugN $ "start block: " <> T.pack (show startBlock)
   mapM_ (liftIO . findTransparentNotes pool startBlock znet) addrs
   mapM_ (liftIO . findTransparentNotes pool startBlock znet) intAddrs
   mapM_ (liftIO . findTransparentSpends pool . entityKey) accs
@@ -1136,7 +1144,7 @@ syncWallet config w = do
     mapM
       (findOrchardActions config startBlock (zcashWalletNetwork $ entityVal w))
       accs
-  _ <- updateSaplingWitnesses pool
-  _ <- updateOrchardWitnesses pool
+  _ <- liftIO $ updateSaplingWitnesses pool
+  _ <- liftIO $ updateOrchardWitnesses pool
   _ <- liftIO $ updateWalletSync pool chainTip (entityKey w)
-  mapM_ (runNoLoggingT . getWalletTransactions pool) addrs
+  mapM_ (liftIO . runNoLoggingT . getWalletTransactions pool) addrs

src/Zenith/DB.hs

@@ -218,14 +218,14 @@ share
     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
@@ -234,7 +234,7 @@ share
     UniqueTSPos tx position
     deriving Show Eq
   OrchAction
-    tx ZcashTransactionId
+    tx ZcashTransactionId OnDeleteCascade OnUpdateCascade
     nf HexStringDB
     rk HexStringDB
     cmx HexStringDB
@@ -247,7 +247,7 @@ share
     UniqueOAPos tx position
     deriving Show Eq
   ShieldOutput
-    tx ZcashTransactionId
+    tx ZcashTransactionId OnDeleteCascade OnUpdateCascade
     cv HexStringDB
     cmu HexStringDB
     ephKey HexStringDB
@@ -258,7 +258,7 @@ share
     UniqueSOPos tx position
     deriving Show Eq
   ShieldSpend
-    tx ZcashTransactionId
+    tx ZcashTransactionId OnDeleteCascade OnUpdateCascade
     cv HexStringDB
     anchor HexStringDB
     nullifier HexStringDB
@@ -1611,10 +1611,24 @@ getOrchardCmxs pool zt = do
 getMaxOrchardNote :: Pool SqlBackend -> IO OrchActionId
 getMaxOrchardNote pool = do
   flip PS.runSqlPool pool $ do
+    maxBlock <-
+      selectOne $ do
+        blks <- from $ table @ZcashBlock
+        where_ $ blks ^. ZcashBlockHeight >. val 0
+        pure $ blks ^. ZcashBlockHeight
+    case maxBlock of
+      Nothing -> return $ toSqlKey 0
+      Just (Value mb) -> do
         x <-
           selectOne $ do
-        n <- from $ table @OrchAction
-        where_ (n ^. OrchActionId >. val (toSqlKey 0))
+            (blks :& txs :& n) <-
+              from $ table @ZcashBlock `innerJoin` table @ZcashTransaction `on`
+              (\(blks :& txs) ->
+                 blks ^. ZcashBlockId ==. txs ^. ZcashTransactionBlockId) `innerJoin`
+              table @OrchAction `on`
+              (\(_ :& txs :& n) ->
+                 txs ^. ZcashTransactionId ==. n ^. OrchActionTx)
+            where_ (blks ^. ZcashBlockHeight <=. val (mb - 5))
             orderBy [desc $ n ^. OrchActionId]
             pure (n ^. OrchActionId)
         case x of
@@ -1850,6 +1864,9 @@ clearWalletData pool = do
       delete $ do
         _ <- from $ table @ZcashTransaction
         return ()
+      delete $ do
+        _ <- from $ table @ZcashBlock
+        return ()
 
 getWalletUnspentTrNotes ::
      ConnectionPool -> ZcashAccountId -> IO [Entity WalletTrNote]
@@ -2290,5 +2307,5 @@ rewindWalletData pool b = do
     flip PS.runSqlPool pool $
     delete $ do
       blk <- from $ table @ZcashBlock
-      where_ $ blk ^. ZcashBlockHeight >. val b
+      where_ $ blk ^. ZcashBlockHeight >=. val b
   clearWalletTransactions pool

src/Zenith/GUI.hs

@@ -1220,6 +1220,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 $

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
@@ -61,8 +67,8 @@ rescanZebra host port dbFilePath = do
     Right bStatus -> do
       let znet = ZcashNetDB $ zgb_net bStatus
       pool1 <- runNoLoggingT $ initPool dbFilePath
-      pool2 <- runNoLoggingT $ initPool dbFilePath
-      pool3 <- runNoLoggingT $ initPool dbFilePath
+      {-pool2 <- runNoLoggingT $ initPool dbFilePath-}
+      {-pool3 <- runNoLoggingT $ initPool dbFilePath-}
       clearWalletTransactions pool1
       clearWalletData pool1
       dbBlock <- getMaxBlock pool1 znet
@@ -213,7 +219,7 @@ 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

test/Spec.hs

@@ -241,7 +241,7 @@ main = do
           oNotes `shouldBe` []
         it "Check Sapling notes" $ do
           pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db"
-          oNotes <- getWalletUnspentSapNotes pool (toSqlKey 1)
+          oNotes <- getWalletUnspentSapNotes pool (toSqlKey 4)
           oNotes `shouldBe` []
         it "Check transparent notes" $ do
           pool <- runNoLoggingT $ initPool "/home/rav/Zenith/zenith.db"
@@ -265,16 +265,43 @@ main = do
                     18232
                     TestNet
                     (toSqlKey 1)
-                    2999946
+                    3001230
                     0.005
                     (fromJust uaRead)
                     "Sending memo to orchard"
                     Full
-                tx `shouldBe` Right (hexString "deadbeef")
+                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
@@ -287,9 +314,35 @@ main = do
                     18232
                     TestNet
                     (toSqlKey 1)
-                    2999396
+                    3000789
                     0.005
                     (fromJust uaRead)
                     "Sending memo to orchard"
-                    Full
-                tx `shouldBe` Right (hexString "deadbeef")
+                    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")

zcash-haskell

@@ -1 +1 @@
-Subproject commit 63a97b880cb32d8e008650f0efef2fdadc7d3d4a
+Subproject commit 12296026a0ebb9a5afe0904b251c5d31080eab18