zenith/src/Zenith/Scanner.hs

{-# LANGUAGE OverloadedStrings #-}

module Zenith.Scanner where

import Control.Exception (throwIO, try)
import qualified Control.Monad.Catch as CM (try)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger
  ( LoggingT
  , NoLoggingT
  , logErrorN
  , logInfoN
  , runNoLoggingT
  )
import Data.Aeson
import Data.HexString
import Data.Maybe
import qualified Data.Text as T
import Data.Time (getCurrentTime)
import Database.Persist.Sqlite
import GHC.Utils.Monad (concatMapM)
import Lens.Micro ((&), (.~), (^.), set)
import System.Console.AsciiProgress
import ZcashHaskell.Types
  ( BlockResponse(..)
  , RawZebraTx(..)
  , Transaction(..)
  , ZebraGetBlockChainInfo(..)
  , ZebraTxResponse(..)
  , fromRawOBundle
  , fromRawSBundle
  , fromRawTBundle
  )
import ZcashHaskell.Utils (getBlockTime, makeZebraCall, readZebraTransaction)
import Zenith.Core (checkBlockChain)
import Zenith.DB
  ( getMaxBlock
  , getUnconfirmedBlocks
  , initDb
  , saveConfs
  , saveTransaction
  )
import Zenith.Utils (jsonNumber)

-- | Function to scan the Zcash blockchain through the Zebra node and populate the Zenith database
scanZebra ::
     Int -- ^ Starting block
  -> T.Text -- ^ Host
  -> Int -- ^ Port
  -> T.Text -- ^ Path to database file
  -> NoLoggingT IO ()
scanZebra b host port dbFilePath = do
  _ <- liftIO $ initDb dbFilePath
  startTime <- liftIO getCurrentTime
  logInfoN $ "Started sync: " <> T.pack (show startTime)
  bc <-
    liftIO $ try $ checkBlockChain host port :: NoLoggingT
      IO
      (Either IOError ZebraGetBlockChainInfo)
  case bc of
    Left e -> logErrorN $ T.pack (show e)
    Right bStatus -> do
      let dbInfo =
            mkSqliteConnectionInfo dbFilePath & extraPragmas .~
            ["read_uncommited = true"]
      pool <- createSqlitePoolFromInfo dbInfo 5
      dbBlock <- getMaxBlock pool
      let sb = max dbBlock b
      if sb > zgb_blocks bStatus || sb < 1
        then liftIO $ throwIO $ userError "Invalid starting block for scan"
        else do
          liftIO $
            print $
            "Scanning from " ++
            show (sb + 1) ++ " to " ++ show (zgb_blocks bStatus)
          let bList = [(sb + 1) .. (zgb_blocks bStatus)]
          displayConsoleRegions $ do
            pg <-
              liftIO $
              newProgressBar def {pgTotal = fromIntegral $ length bList}
            txList <-
              CM.try $ mapM_ (processBlock host port pool pg) bList :: NoLoggingT
                IO
                (Either IOError ())
            case txList of
              Left e1 -> logErrorN $ T.pack (show e1)
              Right txList' -> logInfoN "Finished scan"

-- | 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
  -> Int -- ^ The block number to process
  -> NoLoggingT IO ()
processBlock host port pool pg 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) $
            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
  -> HexString -- ^ transaction id
  -> NoLoggingT IO ()
processTx host port bt pool 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
          _ <-
            saveTransaction pool bt $
            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