zenith/src/Zenith/Scanner.hs

{-# LANGUAGE OverloadedStrings #-}

module Zenith.Scanner where

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 Data.Aeson
import Data.HexString
import qualified Data.Text as T
import Data.Time (getCurrentTime)
import Database.Persist.Sqlite
import System.Console.AsciiProgress
import ZcashHaskell.Types
  ( BlockResponse(..)
  , RawZebraTx(..)
  , Transaction(..)
  , ZcashNet(..)
  , ZebraGetBlockChainInfo(..)
  , ZebraTxResponse(..)
  , fromRawOBundle
  , fromRawSBundle
  , fromRawTBundle
  )
import ZcashHaskell.Utils (getBlockTime, makeZebraCall, readZebraTransaction)
import Zenith.Core (checkBlockChain, syncWallet)
import Zenith.DB
  ( clearWalletData
  , clearWalletTransactions
  , getMaxBlock
  , getMinBirthdayHeight
  , getUnconfirmedBlocks
  , getWallets
  , initDb
  , initPool
  , saveConfs
  , saveTransaction
  , updateWalletSync
  )
import Zenith.Types (Config(..), ZcashNetDB(..))
import Zenith.Utils (jsonNumber)

-- | Function to scan the Zcash blockchain through the Zebra node and populate the Zenith database
rescanZebra ::
     T.Text -- ^ Host
  -> Int -- ^ Port
  -> T.Text -- ^ Path to database file
  -> IO ()
rescanZebra host port dbFilePath = do
  bc <-
    try $ checkBlockChain host port :: IO
      (Either IOError ZebraGetBlockChainInfo)
  case bc of
    Left e -> print e
    Right bStatus -> do
      let znet = ZcashNetDB $ zgb_net bStatus
      pool1 <- runNoLoggingT $ initPool dbFilePath
      pool2 <- runNoLoggingT $ initPool dbFilePath
      pool3 <- runNoLoggingT $ initPool dbFilePath
      clearWalletTransactions pool1
      clearWalletData pool1
      dbBlock <- getMaxBlock pool1 znet
      b <- liftIO $ getMinBirthdayHeight pool1
      let sb = max dbBlock b
      if sb > zgb_blocks bStatus || sb < 1
        then liftIO $ throwIO $ userError "Invalid starting block for scan"
        else do
          print $
            "Scanning from " ++ show sb ++ " to " ++ show (zgb_blocks bStatus)
          let bList = [sb .. (zgb_blocks bStatus)]
          {-
          let batch = length bList `div` 3
          let bl1 = take batch bList
          let bl2 = take batch $ drop batch bList
          let bl3 = drop (2 * batch) bList
          -}
          _ <-
            displayConsoleRegions $ do
              pg1 <- newProgressBar def {pgTotal = fromIntegral $ length bList}
              {-pg2 <- newProgressBar def {pgTotal = fromIntegral $ length bl2}-}
              {-pg3 <- newProgressBar def {pgTotal = fromIntegral $ length bl3}-}
              mapM_ (processBlock host port pool1 pg1 znet) bList
              {-`concurrently_`-}
                {-mapM_ (processBlock host port pool2 pg2 znet) bl2 `concurrently_`-}
                {-mapM_ (processBlock host port pool3 pg3 znet) bl3-}
              print "Please wait..."
          print "Rescan complete"

-- | Function to process a raw block and extract the transaction information
processBlock ::
     T.Text -- ^ Host name for `zebrad`
  -> Int -- ^ Port for `zebrad`
  -> ConnectionPool -- ^ DB file path
  -> ProgressBar -- ^ Progress bar
  -> ZcashNetDB -- ^ the network
  -> Int -- ^ The block number to process
  -> IO ()
processBlock host port pool pg net b = do
  r <-
    liftIO $
    makeZebraCall
      host
      port
      "getblock"
      [Data.Aeson.String $ T.pack $ show b, jsonNumber 1]
  case r of
    Left e -> liftIO $ throwIO $ userError e
    Right blk -> do
      r2 <-
        liftIO $
        makeZebraCall
          host
          port
          "getblock"
          [Data.Aeson.String $ T.pack $ show b, jsonNumber 0]
      case r2 of
        Left e2 -> liftIO $ throwIO $ userError e2
        Right hb -> do
          let blockTime = getBlockTime hb
          mapM_ (processTx host port blockTime pool net) $
            bl_txs $ addTime blk blockTime
          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
  -> ConnectionPool -- ^ DB file path
  -> ZcashNetDB -- ^ the network
  -> HexString -- ^ transaction id
  -> IO ()
processTx host port bt pool net t = do
  r <-
    liftIO $
    makeZebraCall
      host
      port
      "getrawtransaction"
      [Data.Aeson.String $ toText t, jsonNumber 1]
  case r of
    Left e -> liftIO $ throwIO $ userError e
    Right rawTx -> do
      case readZebraTransaction (ztr_hex rawTx) of
        Nothing -> return ()
        Just rzt -> do
          _ <-
            runNoLoggingT $
            saveTransaction pool bt net $
            Transaction
              t
              (ztr_blockheight rawTx)
              (ztr_conf rawTx)
              (fromIntegral $ zt_expiry rzt)
              (fromRawTBundle $ zt_tBundle rzt)
              (fromRawSBundle $ zt_sBundle rzt)
              (fromRawOBundle $ zt_oBundle rzt)
          return ()

-- | Function to update unconfirmed transactions
updateConfs ::
     T.Text -- ^ Host name for `zebrad`
  -> Int -- ^ Port for `zebrad`
  -> ConnectionPool
  -> IO ()
updateConfs host port pool = do
  targetBlocks <- getUnconfirmedBlocks pool
  mapM_ updateTx targetBlocks
  where
    updateTx :: Int -> IO ()
    updateTx b = do
      r <-
        makeZebraCall
          host
          port
          "getblock"
          [Data.Aeson.String $ T.pack $ show b, jsonNumber 1]
      case r of
        Left e -> throwIO $ userError e
        Right blk -> do
          saveConfs pool b $ fromInteger $ bl_confirmations blk

clearSync :: Config -> IO ()
clearSync config = do
  let zHost = c_zebraHost config
  let zPort = c_zebraPort config
  let dbPath = c_dbPath config
  pool <- runNoLoggingT $ initPool dbPath
  bc <-
    try $ checkBlockChain zHost zPort :: IO
      (Either IOError ZebraGetBlockChainInfo)
  case bc of
    Left e1 -> throwIO e1
    Right chainInfo -> do
      x <- initDb dbPath
      case x of
        Left e2 -> throwIO $ userError e2
        Right x' -> do
          when x' $ rescanZebra zHost zPort dbPath
          _ <- clearWalletTransactions pool
          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'
          liftIO $ print r