|
| 1 | +module Cardano.DbTool.LsmDebug |
| 2 | + ( LsmDebugParams (..) |
| 3 | + , runLsmDebug |
| 4 | + ) where |
| 5 | + |
| 6 | +import Cardano.DbSync.Config |
| 7 | +import Cardano.DbSync.Config.Cardano |
| 8 | +import Cardano.DbSync.Config.Types (LedgerBackend (..), LedgerStateDir (..)) |
| 9 | +import Cardano.DbSync.Error |
| 10 | +import Cardano.DbSync.Ledger.State (listLedgerStateFilesOrdered, loadLedgerStateFromFile, |
| 11 | + mkHandleFromValues) |
| 12 | +import Cardano.DbSync.Ledger.Types (CardanoLedgerState (..), LedgerStateFile (..)) |
| 13 | + |
| 14 | +import Cardano.Crypto.Hash.Class (hashFromTextAsHex) |
| 15 | +import Cardano.Ledger.BaseTypes (TxIx (..)) |
| 16 | +import Cardano.Ledger.Crypto (StandardCrypto) |
| 17 | +import Cardano.Ledger.SafeHash (unsafeMakeSafeHash) |
| 18 | +import Cardano.Ledger.TxIn (TxId (..), TxIn (..)) |
| 19 | + |
| 20 | +import Control.Exception (SomeException, evaluate, try) |
| 21 | +import Control.Monad.Trans.Except (runExceptT) |
| 22 | +import Control.ResourceRegistry (withRegistry) |
| 23 | +import Control.Tracer (nullTracer) |
| 24 | + |
| 25 | +import Data.ByteString (ByteString) |
| 26 | +import qualified Data.ByteString as BS |
| 27 | +import Data.Proxy (Proxy (..)) |
| 28 | +import Data.String (fromString) |
| 29 | +import Data.Text (Text) |
| 30 | +import qualified Data.Text as Text |
| 31 | +import qualified Data.Vector as V |
| 32 | +import Data.Word (Word16) |
| 33 | +import qualified Database.LSMTree as LSM |
| 34 | +import Numeric (showHex) |
| 35 | +import qualified Data.Primitive.ByteArray as PBA |
| 36 | +import qualified Data.Vector.Primitive as VP |
| 37 | + |
| 38 | +import Ouroboros.Consensus.Cardano.Block (CardanoBlock) |
| 39 | +import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState) |
| 40 | +import Ouroboros.Consensus.Ledger.Tables.Utils (emptyLedgerTables) |
| 41 | +import Ouroboros.Consensus.Storage.LedgerDB.V2.LSM |
| 42 | + (SomeHasFSAndBlockIO (..), TxInBytes (..), TxOutBytes (..), |
| 43 | + fromTxOutBytes, stdMkBlockIOFS, toTxInBytes) |
| 44 | + |
| 45 | +import System.FilePath (dropExtension, takeFileName, (</>)) |
| 46 | +import System.FS.API (mkFsPath) |
| 47 | + |
| 48 | +import Prelude |
| 49 | + |
| 50 | +data LsmDebugParams = LsmDebugParams |
| 51 | + { ldpConfigFile :: !ConfigFile |
| 52 | + , ldpLedgerStateDir :: !LedgerStateDir |
| 53 | + , ldpTxHash :: !Text |
| 54 | + , ldpTxIndex :: !Word16 |
| 55 | + , ldpSnapshot :: !(Maybe Text) |
| 56 | + } |
| 57 | + |
| 58 | +runLsmDebug :: LsmDebugParams -> IO () |
| 59 | +runLsmDebug params = do |
| 60 | + enc <- readSyncNodeConfig (ldpConfigFile params) |
| 61 | + genCfg <- runOrThrowIO $ runExceptT $ readCardanoGenesisConfig enc |
| 62 | + let cfg = mkTopLevelConfig genCfg |
| 63 | + lsmDir = unLedgerStateDir (ldpLedgerStateDir params) </> "lsm" |
| 64 | + ledgerFiles <- listLedgerStateFilesOrdered (ldpLedgerStateDir params) |
| 65 | + case ledgerFiles of |
| 66 | + [] -> putStrLn "No ledger state files found" |
| 67 | + (lf : _) -> do |
| 68 | + putStrLn $ "Using ledger state file: " <> lsfFilePath lf |
| 69 | + -- Load era context from the state file (empty InMemory handle for era context only) |
| 70 | + eState <- loadLedgerStateFromFile |
| 71 | + (\_ _ -> mkHandleFromValues emptyLedgerTables) |
| 72 | + Nothing |
| 73 | + (LedgerBackendLSM Nothing) |
| 74 | + nullTracer cfg False |
| 75 | + (lsfOriginPoint lf) |
| 76 | + lf |
| 77 | + case eState of |
| 78 | + Left err -> putStrLn $ "Failed to load ledger state: " <> Text.unpack err |
| 79 | + Right cls -> do |
| 80 | + let snapshotName = case ldpSnapshot params of |
| 81 | + Just s -> Text.unpack s |
| 82 | + Nothing -> dropExtension $ takeFileName $ lsfFilePath lf |
| 83 | + lookupEntry lsmDir snapshotName (clsState cls) params |
| 84 | + |
| 85 | +lookupEntry |
| 86 | + :: FilePath |
| 87 | + -> String |
| 88 | + -> ExtLedgerState CardanoBlock EmptyMK |
| 89 | + -> LsmDebugParams |
| 90 | + -> IO () |
| 91 | +lookupEntry lsmDir snapshotName st params = do |
| 92 | + txIn <- parseTxIn (ldpTxHash params) (ldpTxIndex params) |
| 93 | + let key = toTxInBytes (Proxy @(ExtLedgerState CardanoBlock)) txIn |
| 94 | + putStrLn $ "Looking up TxIn in snapshot: " <> snapshotName |
| 95 | + withRegistry $ \reg -> do |
| 96 | + (_, SomeHasFSAndBlockIO hasFS blockIO) <- stdMkBlockIOFS lsmDir reg |
| 97 | + (_, session) <- allocate reg |
| 98 | + (\_ -> LSM.openSession nullTracer hasFS blockIO 0 (mkFsPath [])) |
| 99 | + LSM.closeSession |
| 100 | + (_, table) <- allocate reg |
| 101 | + (\_ -> LSM.openTableFromSnapshot |
| 102 | + session |
| 103 | + (fromString snapshotName) |
| 104 | + (LSM.SnapshotLabel "UTxO table")) |
| 105 | + LSM.closeTable |
| 106 | + results <- LSM.lookups table (V.singleton key) |
| 107 | + case V.head results of |
| 108 | + LSM.NotFound -> |
| 109 | + putStrLn "TxIn not found in this snapshot" |
| 110 | + LSM.Found txOutBytes -> do |
| 111 | + putStrLn $ "Found! Raw bytes (hex): " <> toHex (toBS txOutBytes) |
| 112 | + result <- try (evaluate (fromTxOutBytes st key txOutBytes)) |
| 113 | + :: IO (Either SomeException (TxOut (ExtLedgerState CardanoBlock))) |
| 114 | + case result of |
| 115 | + Left err -> putStrLn $ "Decode FAILED: " <> show err |
| 116 | + Right _ -> putStrLn "Decode OK" |
| 117 | + LSM.FoundWithBlob{} -> |
| 118 | + putStrLn "Unexpected blob entry" |
| 119 | + |
| 120 | +parseTxIn :: Text -> Word16 -> IO (TxIn StandardCrypto) |
| 121 | +parseTxIn hashHex idx = |
| 122 | + case hashFromTextAsHex (Text.unpack hashHex) of |
| 123 | + Nothing -> fail $ "Invalid tx hash: " <> Text.unpack hashHex |
| 124 | + Just h -> pure $ TxIn (TxId (unsafeMakeSafeHash h)) (TxIx (fromIntegral idx)) |
| 125 | + |
| 126 | +toBS :: TxOutBytes -> ByteString |
| 127 | +toBS (TxOutBytes (LSM.RawBytes (VP.Vector off len barr))) = |
| 128 | + BS.pack [PBA.indexByteArray barr (off + i) | i <- [0 .. len - 1]] |
| 129 | + |
| 130 | +toHex :: ByteString -> String |
| 131 | +toHex = BS.foldr' (\b acc -> pad (showHex b "") <> acc) "" |
| 132 | + where |
| 133 | + pad s = replicate (2 - length s) '0' <> s |
0 commit comments