src/Zenith/CLI.hs

@@ -839,7 +839,7 @@ scanZebra dbP zHost zPort b eChan znet = do
       logDebugN $
         "dbBlock: " <>
         T.pack (show dbBlock) <> " chkBlock: " <> T.pack (show chkBlock)
-      when (chkBlock /= dbBlock) $ rewindWalletData pool chkBlock
+      when (chkBlock /= dbBlock) $ liftIO $ rewindWalletData pool chkBlock
       let sb =
             if chkBlock == dbBlock
               then max dbBlock b
@@ -953,7 +953,7 @@ appEvent (BT.AppEvent t) = do
                      Just (_k, w) -> return w
               _ <-
                 liftIO $
-                runStderrLoggingT $
+                runNoLoggingT $
                 syncWallet
                   (Config
                      (s ^. dbPath)

src/Zenith/Core.hs

@@ -60,7 +60,6 @@ import ZcashHaskell.Sapling
   , genSaplingInternalAddress
   , genSaplingPaymentAddress
   , genSaplingSpendingKey
-  , getSaplingFrontier
   , getSaplingNotePosition
   , getSaplingWitness
   , updateSaplingCommitmentTree
@@ -280,64 +279,49 @@ findSaplingOutputs ::
   -> Int -- ^ the starting block
   -> ZcashNetDB -- ^ The network
   -> Entity ZcashAccount -- ^ The account to use
-  -> LoggingT IO ()
+  -> IO ()
 findSaplingOutputs config b znet za = do
   let dbPath = c_dbPath config
   let zebraHost = c_zebraHost config
   let zebraPort = c_zebraPort config
   let zn = getNet znet
-  pool <- liftIO $ runNoLoggingT $ initPool dbPath
+  pool <- runNoLoggingT $ initPool dbPath
-  tList <- liftIO $ getShieldedOutputs pool b znet
+  tList <- getShieldedOutputs pool b znet
-  trees <- liftIO $ getCommitmentTrees zebraHost zebraPort (b - 1)
+  trees <- getCommitmentTrees zebraHost zebraPort (b - 1)
-  logDebugN "getting Sapling frontier"
+  let sT = SaplingCommitmentTree $ ztiSapling trees
-  let sT = getSaplingFrontier $ SaplingCommitmentTree $ ztiSapling trees
+  decryptNotes sT zn pool tList
-  case sT of
+  sapNotes <- getWalletSapNotes pool (entityKey za)
-    Nothing ->
+  findSapSpends pool (entityKey za) sapNotes
-      liftIO $ throwIO $ userError "Failed to read Sapling commitment tree"
-    Just sT' -> do
-      logDebugN "Sapling frontier valid"
-      decryptNotes sT' zn pool tList
-      sapNotes <- liftIO $ getWalletSapNotes pool (entityKey za)
-      liftIO $ findSapSpends pool (entityKey za) sapNotes
   where
     sk :: SaplingSpendingKeyDB
     sk = zcashAccountSapSpendKey $ entityVal za
     decryptNotes ::
-         SaplingFrontier
+         SaplingCommitmentTree
       -> ZcashNet
       -> ConnectionPool
       -> [(Entity ZcashTransaction, Entity ShieldOutput)]
-      -> LoggingT IO ()
+      -> IO ()
     decryptNotes _ _ _ [] = return ()
     decryptNotes st n pool ((zt, o):txs) = do
       let updatedTree =
             updateSaplingCommitmentTree
               st
               (getHex $ shieldOutputCmu $ entityVal o)
-      logDebugN "updated frontier"
       case updatedTree of
-        Nothing ->
+        Nothing -> throwIO $ userError "Failed to update commitment tree"
-          liftIO $ throwIO $ userError "Failed to update commitment tree"
         Just uT -> do
           let noteWitness = getSaplingWitness uT
-          logDebugN "got witness"
           let notePos = getSaplingNotePosition <$> noteWitness
-          logDebugN "got position"
           case notePos of
-            Nothing ->
+            Nothing -> throwIO $ userError "Failed to obtain note position"
-              liftIO $ throwIO $ userError "Failed to obtain note position"
             Just nP -> do
               case decodeShOut External n nP o of
                 Nothing -> do
-                  logDebugN "couldn't decode external"
                   case decodeShOut Internal n nP o of
                     Nothing -> do
-                      logDebugN "couldn't decode internal"
                       decryptNotes uT n pool txs
                     Just dn1 -> do
-                      wId <-
+                      wId <- saveWalletTransaction pool (entityKey za) zt
-                        liftIO $ saveWalletTransaction pool (entityKey za) zt
-                      liftIO $
                       saveWalletSapNote
                         pool
                         wId
@@ -349,8 +333,7 @@ findSaplingOutputs config b znet za = do
                         dn1
                       decryptNotes uT n pool txs
                 Just dn0 -> do
-                  wId <- liftIO $ saveWalletTransaction pool (entityKey za) zt
+                  wId <- saveWalletTransaction pool (entityKey za) zt
-                  liftIO $
                   saveWalletSapNote
                     pool
                     wId
@@ -943,7 +926,7 @@ prepareTxV2 pool zebraHost zebraPort zn za bh pnotes policy = do
                       oSpends
                       dummy
                       zn
-                      bh
+                      (bh + 3)
                       False
               case feeResponse of
                 Left e1 -> return $ Left Fee
@@ -1002,7 +985,7 @@ prepareTxV2 pool zebraHost zebraPort zn za bh pnotes policy = do
                                   oSpends1
                                   outgoing
                                   zn
-                                  bh
+                                  (bh + 3)
                                   True
                           logDebugN $ T.pack $ show tx
                           return tx
@@ -1278,14 +1261,14 @@ prepareTxV2 pool zebraHost zebraPort zn za bh pnotes policy = do
 syncWallet ::
      Config -- ^ configuration parameters
   -> Entity ZcashWallet
-  -> LoggingT IO ()
+  -> NoLoggingT IO ()
 syncWallet config w = do
   startTime <- liftIO getCurrentTime
-  logDebugN $ T.pack $ show startTime
   let walletDb = c_dbPath config
   let znet = zcashWalletNetwork $ entityVal w
   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
@@ -1295,7 +1278,7 @@ syncWallet config w = do
     mapM (liftIO . runNoLoggingT . getInternalAddresses pool . entityKey) accs
   chainTip <- liftIO $ getMaxBlock pool znet
   logDebugN $ "chain tip: " <> T.pack (show chainTip)
-  lastBlock <- liftIO $ getLastSyncBlock pool $ entityKey w
+  let lastBlock = zcashWalletLastSync $ entityVal w
   logDebugN $ "last block: " <> T.pack (show lastBlock)
   let startBlock =
         if lastBlock > 0
@@ -1304,22 +1287,18 @@ syncWallet config w = do
   logDebugN $ "start block: " <> T.pack (show startBlock)
   mapM_ (liftIO . findTransparentNotes pool startBlock znet) addrs
   mapM_ (liftIO . findTransparentNotes pool startBlock znet) intAddrs
-  logDebugN "processed transparent notes"
   mapM_ (liftIO . findTransparentSpends pool . entityKey) accs
-  logDebugN "processed transparent spends"
+  sapNotes <-
-  mapM_
+    liftIO $
+    mapM
       (findSaplingOutputs config startBlock (zcashWalletNetwork $ entityVal w))
       accs
-  logDebugN "processed sapling outputs"
+  orchNotes <-
     liftIO $
-    mapM_
+    mapM
       (findOrchardActions config startBlock (zcashWalletNetwork $ entityVal w))
       accs
-  logDebugN "processed orchard actions"
   _ <- liftIO $ updateSaplingWitnesses pool
-  logDebugN "updated sapling witnesses"
   _ <- liftIO $ updateOrchardWitnesses pool
-  logDebugN "updated orchard witnesses"
   _ <- liftIO $ updateWalletSync pool chainTip (entityKey w)
-  logDebugN "updated wallet lastSync"
   mapM_ (liftIO . runNoLoggingT . getWalletTransactions pool) addrs

src/Zenith/DB.hs

@@ -21,13 +21,7 @@ module Zenith.DB where
 import Control.Exception (SomeException(..), throw, throwIO, try)
 import Control.Monad (unless, when)
 import Control.Monad.IO.Class (MonadIO, liftIO)
-import Control.Monad.Logger
+import Control.Monad.Logger (NoLoggingT, runNoLoggingT)
-  ( LoggingT
-  , NoLoggingT
-  , logDebugN
-  , runNoLoggingT
-  , runStderrLoggingT
-  )
 import qualified Data.ByteString as BS
 import Data.HexString
 import Data.Int
@@ -1789,25 +1783,10 @@ getSaplingCmus pool zt = do
 getMaxSaplingNote :: Pool SqlBackend -> IO ShieldOutputId
 getMaxSaplingNote pool = do
   flip PS.runSqlPool pool $ do
-    maxBlock <-
-      selectOne $ do
-        blks <- from $ table @ZcashBlock
-        where_ $ blks ^. ZcashBlockHeight >. val 0
-        orderBy [desc $ blks ^. ZcashBlockHeight]
-        pure $ blks ^. ZcashBlockHeight
-    case maxBlock of
-      Nothing -> return $ toSqlKey 0
-      Just (Value mb) -> do
     x <-
       selectOne $ do
-            (blks :& txs :& n) <-
+        n <- from $ table @ShieldOutput
-              from $ table @ZcashBlock `innerJoin` table @ZcashTransaction `on`
+        where_ (n ^. ShieldOutputId >. val (toSqlKey 0))
-              (\(blks :& txs) ->
-                 blks ^. ZcashBlockId ==. txs ^. ZcashTransactionBlockId) `innerJoin`
-              table @ShieldOutput `on`
-              (\(_ :& txs :& n) ->
-                 txs ^. ZcashTransactionId ==. n ^. ShieldOutputTx)
-            where_ (blks ^. ZcashBlockHeight <=. val (mb - 5))
         orderBy [desc $ n ^. ShieldOutputId]
         pure (n ^. ShieldOutputId)
     case x of
@@ -1857,7 +1836,6 @@ getMaxOrchardNote pool = do
       selectOne $ do
         blks <- from $ table @ZcashBlock
         where_ $ blks ^. ZcashBlockHeight >. val 0
-        orderBy [desc $ blks ^. ZcashBlockHeight]
         pure $ blks ^. ZcashBlockHeight
     case maxBlock of
       Nothing -> return $ toSqlKey 0
@@ -2074,22 +2052,22 @@ rewindWalletTransactions pool b = do
         x <- from $ table @WalletOrchNote
         where_ $ x ^. WalletOrchNoteTx `in_` valList oldKeys
         return ()
-      delete $ do
-        x <- from $ table @WalletSapSpend
-        where_ $ x ^. WalletSapSpendTx `in_` valList oldKeys
-        return ()
       delete $ do
         x <- from $ table @WalletSapNote
         where_ $ x ^. WalletSapNoteTx `in_` valList oldKeys
         return ()
       delete $ do
-        x <- from $ table @WalletTrSpend
+        x <- from $ table @WalletSapSpend
-        where_ $ x ^. WalletTrSpendTx `in_` valList oldKeys
+        where_ $ x ^. WalletSapSpendTx `in_` valList oldKeys
         return ()
       delete $ do
         x <- from $ table @WalletTrNote
         where_ $ x ^. WalletTrNoteTx `in_` valList oldKeys
         return ()
+      delete $ do
+        x <- from $ table @WalletTrSpend
+        where_ $ x ^. WalletTrSpendTx `in_` valList oldKeys
+        return ()
       delete $ do
         txs <- from $ table @WalletTransaction
         where_ $ txs ^. WalletTransactionBlock >. val b
@@ -2643,14 +2621,10 @@ completeSync pool st = do
   return ()
 
 -- | Rewind the data store to a given block height
-rewindWalletData :: ConnectionPool -> Int -> LoggingT IO ()
+rewindWalletData :: ConnectionPool -> Int -> IO ()
 rewindWalletData pool b = do
-  logDebugN "Starting transaction rewind"
+  rewindWalletTransactions pool b
-  liftIO $ clearWalletTransactions pool
+  runNoLoggingT $
-  logDebugN "Completed transaction rewind"
-  logDebugN "Starting data store rewind"
-  _ <-
-    runStderrLoggingT $
     PS.retryOnBusy $
     flip PS.runSqlPool pool $ do
       oldBlocks <-
@@ -2668,112 +2642,21 @@ rewindWalletData pool b = do
       delete $ do
         x <- from $ table @TransparentNote
         where_ $ x ^. TransparentNoteTx `in_` valList oldTxKeys
-  logDebugN "Completed TransparentNote delete"
-  _ <-
-    runStderrLoggingT $
-    PS.retryOnBusy $
-    flip PS.runSqlPool pool $ do
-      oldBlocks <-
-        select $ do
-          blk <- from $ table @ZcashBlock
-          where_ $ blk ^. ZcashBlockHeight >. val b
-          pure blk
-      let oldBlkKeys = map entityKey oldBlocks
-      oldTxs <-
-        select $ do
-          txs <- from $ table @ZcashTransaction
-          where_ $ txs ^. ZcashTransactionBlockId `in_` valList oldBlkKeys
-          pure txs
-      let oldTxKeys = map entityKey oldTxs
       delete $ do
         x <- from $ table @TransparentSpend
         where_ $ x ^. TransparentSpendTx `in_` valList oldTxKeys
-  logDebugN "Completed TransparentSpend delete"
-  _ <-
-    runStderrLoggingT $
-    PS.retryOnBusy $
-    flip PS.runSqlPool pool $ do
-      oldBlocks <-
-        select $ do
-          blk <- from $ table @ZcashBlock
-          where_ $ blk ^. ZcashBlockHeight >. val b
-          pure blk
-      let oldBlkKeys = map entityKey oldBlocks
-      oldTxs <-
-        select $ do
-          txs <- from $ table @ZcashTransaction
-          where_ $ txs ^. ZcashTransactionBlockId `in_` valList oldBlkKeys
-          pure txs
-      let oldTxKeys = map entityKey oldTxs
       delete $ do
         x <- from $ table @ShieldOutput
         where_ $ x ^. ShieldOutputTx `in_` valList oldTxKeys
-  logDebugN "Completed ShieldOutput delete"
-  _ <-
-    runStderrLoggingT $
-    PS.retryOnBusy $
-    flip PS.runSqlPool pool $ do
-      oldBlocks <-
-        select $ do
-          blk <- from $ table @ZcashBlock
-          where_ $ blk ^. ZcashBlockHeight >. val b
-          pure blk
-      let oldBlkKeys = map entityKey oldBlocks
-      oldTxs <-
-        select $ do
-          txs <- from $ table @ZcashTransaction
-          where_ $ txs ^. ZcashTransactionBlockId `in_` valList oldBlkKeys
-          pure txs
-      let oldTxKeys = map entityKey oldTxs
       delete $ do
         x <- from $ table @ShieldSpend
         where_ $ x ^. ShieldSpendTx `in_` valList oldTxKeys
-  logDebugN "Completed ShieldSpend delete"
-  _ <-
-    runStderrLoggingT $
-    PS.retryOnBusy $
-    flip PS.runSqlPool pool $ do
-      oldBlocks <-
-        select $ do
-          blk <- from $ table @ZcashBlock
-          where_ $ blk ^. ZcashBlockHeight >. val b
-          pure blk
-      let oldBlkKeys = map entityKey oldBlocks
-      oldTxs <-
-        select $ do
-          txs <- from $ table @ZcashTransaction
-          where_ $ txs ^. ZcashTransactionBlockId `in_` valList oldBlkKeys
-          pure txs
-      let oldTxKeys = map entityKey oldTxs
       delete $ do
         x <- from $ table @OrchAction
         where_ $ x ^. OrchActionTx `in_` valList oldTxKeys
-  logDebugN "Completed OrchAction delete"
-  _ <-
-    runStderrLoggingT $
-    PS.retryOnBusy $
-    flip PS.runSqlPool pool $ do
-      oldBlocks <-
-        select $ do
-          blk <- from $ table @ZcashBlock
-          where_ $ blk ^. ZcashBlockHeight >. val b
-          pure blk
-      let oldBlkKeys = map entityKey oldBlocks
-      oldTxs <-
-        select $ do
-          txs <- from $ table @ZcashTransaction
-          where_ $ txs ^. ZcashTransactionBlockId `in_` valList oldBlkKeys
-          pure txs
-      let oldTxKeys = map entityKey oldTxs
       delete $ do
         x <- from $ table @ZcashTransaction
         where_ $ x ^. ZcashTransactionId `in_` valList oldTxKeys
-  logDebugN "Completed ZcashTransaction delete"
-  _ <-
-    runStderrLoggingT $
-    PS.retryOnBusy $
-    flip PS.runSqlPool pool $ do
       delete $ do
         blk <- from $ table @ZcashBlock
         where_ $ blk ^. ZcashBlockHeight >. val b
-  logDebugN "Completed data store rewind"

src/Zenith/GUI.hs

@@ -12,7 +12,7 @@ import Control.Concurrent (threadDelay)
 import Control.Exception (throwIO, try)
 import Control.Monad (unless, when)
 import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT)
+import Control.Monad.Logger (runFileLoggingT, runNoLoggingT)
 import Data.Aeson
 import qualified Data.ByteString as BS
 import Data.HexString (toText)
@@ -997,17 +997,31 @@ buildUI wenv model = widgetTree
                           , label (displayAmount (model ^. network) 100 ) `styleBasic`
                             [width 50, textFont "Bold"]
                           , filler
+--                          , spacer
+--                          , numericField_
+--                              sendAmount
+--                              [ decimals 8
+--                              , minValue 0.0
+--                              , maxValue
+--                                  (fromIntegral (model ^. tBalance) / 100000000.0)
+--                              , validInput tBalanceValid
+--                              , onChange CheckAmount
+--                              ] `styleBasic`
+--                            [ width 150
+--                            , styleIf
+--                                (not $ model ^. tBalanceValid)
+--                                (textColor red)
+--                            ]
                           ]
                       , spacer
                       , box_
                           [alignMiddle]
                           (hstack
                               [ filler 
-                             , mainButton "Proceed" NotImplemented `nodeEnabled`
+                              , mainButton "Proceed" NotImplemented `nodeEnabled` True
-                               True
+--                               (model ^. amountValid && model ^. recipientValid)
                               , spacer 
-                             , mainButton "Cancel" CloseShield `nodeEnabled`
+                              , mainButton "Cancel" CloseShield `nodeEnabled` True
-                               True
                               , filler
                              ])
                       ]) `styleBasic`
@@ -1033,14 +1047,12 @@ buildUI wenv model = widgetTree
                       , separatorLine `styleBasic` [fgColor btnColor]
                       , spacer
                       , hstack 
-                          [ (label "Total Transparent : " `styleBasic`
+                          [ (label "Total Transparent : " `styleBasic` [ textFont "Bold" ]) 
-                             [textFont "Bold"])
                           , (label "0.00" )
                           ]
                       , spacer
                       , hstack 
-                          [ (label "Total Shielded : " `styleBasic`
+                          [ (label "Total Shielded : " `styleBasic` [ textFont "Bold" ]) 
-                             [textFont "Bold"])
                           , (label "0.00" )
                           ]
                       , spacer    
@@ -1053,8 +1065,7 @@ buildUI wenv model = widgetTree
                               [ decimals 8
                               , minValue 0.0
                               , maxValue
-                                  (fromIntegral (model ^. sBalance) /
+                                  (fromIntegral (model ^. sBalance) / 100000000.0)
-                                   100000000.0)
                               , validInput sBalanceValid
                               , onChange CheckAmount
                               ] `styleBasic`
@@ -1069,11 +1080,10 @@ buildUI wenv model = widgetTree
                           [alignMiddle]
                           (hstack
                              [ filler 
-                             , mainButton "Proceed" NotImplemented `nodeEnabled`
+                             , mainButton "Proceed" NotImplemented `nodeEnabled` True
-                               True
+--                               (model ^. amountValid && model ^. recipientValid)
                              , spacer 
-                             , mainButton "Cancel" CloseDeShield `nodeEnabled`
+                             , mainButton "Cancel" CloseDeShield `nodeEnabled` True
-                               True
                              , filler
                              ])
                       ]) `styleBasic`
@@ -1083,24 +1093,6 @@ buildUI wenv model = widgetTree
            , filler
            ]) `styleBasic`
       [bgColor (white & L.a .~ 0.5)]
-
---                          , spacer
---                          , numericField_
---                              sendAmount
---                              [ decimals 8
---                              , minValue 0.0
---                              , maxValue
---                                  (fromIntegral (model ^. tBalance) / 100000000.0)
---                              , validInput tBalanceValid
---                              , onChange CheckAmount
---                              ] `styleBasic`
---                            [ width 150
---                            , styleIf
---                                (not $ model ^. tBalanceValid)
---                                (textColor red)
---                            ]
---                               (model ^. amountValid && model ^. recipientValid)
---                               (model ^. amountValid && model ^. recipientValid)
 notImplemented = NotImplemented
 
 generateQRCodes :: Config -> IO ()
@@ -1399,7 +1391,7 @@ handleEvent wenv node model evt =
                  case currentWallet of
                    Nothing -> return $ ShowError "No wallet available"
                    Just cW -> do
-                     runStderrLoggingT $ syncWallet (model ^. configuration) cW
+                     runNoLoggingT $ syncWallet (model ^. configuration) cW
                      pool <-
                        runNoLoggingT $
                        initPool $ c_dbPath $ model ^. configuration
@@ -1631,8 +1623,7 @@ scanZebra dbPath zHost zPort net sendMsg = do
   if syncChk
     then sendMsg (ShowError "Sync already in progress")
     else do
-      unless (chkBlock == dbBlock) $
+      unless (chkBlock == dbBlock) $ rewindWalletData pool chkBlock
-        runStderrLoggingT $ rewindWalletData pool chkBlock
       let sb =
             if chkBlock == dbBlock
               then max dbBlock b

src/Zenith/RPC.hs

@@ -892,8 +892,7 @@ scanZebra dbPath zHost zPort net = do
   chkBlock <- checkIntegrity dbPath zHost zPort dbBlock 1
   syncChk <- isSyncing pool
   unless syncChk $ do
-    unless (chkBlock == dbBlock) $
+    unless (chkBlock == dbBlock) $ rewindWalletData pool chkBlock
-      runStderrLoggingT $ rewindWalletData pool chkBlock
     let sb =
           if chkBlock == dbBlock
             then max dbBlock b
@@ -910,7 +909,7 @@ scanZebra dbPath zHost zPort net = do
             return ()
           Right _ -> do
             wals <- getWallets pool net
-            runStderrLoggingT $
+            runNoLoggingT $
               mapM_
                 (syncWallet (Config dbPath zHost zPort "user" "pwd" 8080))
                 wals

src/Zenith/Scanner.hs

@@ -10,8 +10,8 @@ import Control.Monad.Logger
   ( NoLoggingT
   , logErrorN
   , logInfoN
+  , runFileLoggingT
   , runNoLoggingT
-  , runStderrLoggingT
   )
 import Data.Aeson
 import Data.HexString
@@ -238,7 +238,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 <- runStderrLoggingT $ mapM (syncWallet config) w'
+          r <- runNoLoggingT $ mapM (syncWallet config) w'
           liftIO $ print r
 
 -- | Detect chain re-orgs

test/Spec.hs

@@ -212,8 +212,8 @@ main = do
                     "localhost"
                     18232
                     TestNet
-                    (toSqlKey 3)
+                    (toSqlKey 1)
-                    3026170
+                    3001331
                     [ ProposedNote
                         (ValidAddressAPI $ fromJust uaRead)
                         0.005
@@ -222,7 +222,7 @@ main = do
                     Full
                 case tx of
                   Left e -> assertFailure $ show e
-                  Right h -> h `shouldBe` (hexString "deadbeef")
+                  Right h -> h `shouldNotBe` (hexString "deadbeef")
           it "To Sapling" $ do
             let uaRead =
                   parseAddress

zcash-haskell

@@ -1 +1 @@
-Subproject commit 662a0d1148d3f52e2683157a4c9280bb8e81b0cb
+Subproject commit 003293cc3f978c146824d0695c5c458cf2cc9bb5