zenith/src/Zenith/Scanner.hs

158 lines
4.6 KiB
Haskell
Raw Normal View History

{-# 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, initDb, 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 ()