From 72db710e10a37f7a4b1d33267f79d0e088e0c642 Mon Sep 17 00:00:00 2001 From: Cmdv Date: Thu, 9 Jan 2025 13:23:04 +0000 Subject: [PATCH 1/2] Remove old code due to hard fork Dec 2024 --- cardano-chain-gen/cardano-chain-gen.cabal | 21 -- cardano-chain-gen/test/Main.hs | 4 - .../test/Test/Cardano/Db/Mock/Unit/Alonzo.hs | 112 ------- .../test/Test/Cardano/Db/Mock/Unit/Babbage.hs | 206 ------------ cardano-db-sync/app/cardano-db-sync.hs | 194 +---------- cardano-db-sync/cardano-db-sync.cabal | 5 - cardano-db-sync/src/Cardano/DbSync/Default.hs | 2 - .../src/Cardano/DbSync/Fix/ConsumedBy.hs | 59 ---- .../src/Cardano/DbSync/Fix/EpochStake.hs | 75 ----- .../src/Cardano/DbSync/Fix/PlutusDataBytes.hs | 315 ------------------ .../src/Cardano/DbSync/Fix/PlutusScripts.hs | 181 ---------- cardano-db-sync/src/Cardano/DbSync/Sync.hs | 254 +------------- cardano-db/cardano-db.cabal | 3 - cardano-db/src/Cardano/Db/Version/V13_0.hs | 6 - .../src/Cardano/Db/Version/V13_0/Query.hs | 195 ----------- .../src/Cardano/Db/Version/V13_0/Schema.hs | 109 ------ 16 files changed, 10 insertions(+), 1731 deletions(-) delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo.hs delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage.hs delete mode 100644 cardano-db-sync/src/Cardano/DbSync/Fix/ConsumedBy.hs delete mode 100644 cardano-db-sync/src/Cardano/DbSync/Fix/EpochStake.hs delete mode 100644 cardano-db-sync/src/Cardano/DbSync/Fix/PlutusDataBytes.hs delete mode 100644 cardano-db-sync/src/Cardano/DbSync/Fix/PlutusScripts.hs delete mode 100644 cardano-db/src/Cardano/Db/Version/V13_0.hs delete mode 100644 cardano-db/src/Cardano/Db/Version/V13_0/Query.hs delete mode 100644 cardano-db/src/Cardano/Db/Version/V13_0/Schema.hs diff --git a/cardano-chain-gen/cardano-chain-gen.cabal b/cardano-chain-gen/cardano-chain-gen.cabal index d23a3fe34..1b3997b34 100644 --- a/cardano-chain-gen/cardano-chain-gen.cabal +++ b/cardano-chain-gen/cardano-chain-gen.cabal @@ -130,27 +130,6 @@ test-suite cardano-chain-gen other-modules: Test.Cardano.Db.Mock.Config Test.Cardano.Db.Mock.Examples Test.Cardano.Db.Mock.Property.Property - Test.Cardano.Db.Mock.Unit.Alonzo - Test.Cardano.Db.Mock.Unit.Alonzo.Config - Test.Cardano.Db.Mock.Unit.Alonzo.Plutus - Test.Cardano.Db.Mock.Unit.Alonzo.PoolAndSmash - Test.Cardano.Db.Mock.Unit.Alonzo.Reward - Test.Cardano.Db.Mock.Unit.Alonzo.Simple - Test.Cardano.Db.Mock.Unit.Alonzo.Stake - Test.Cardano.Db.Mock.Unit.Alonzo.Tx - Test.Cardano.Db.Mock.Unit.Babbage - Test.Cardano.Db.Mock.Unit.Babbage.CommandLineArg.ConfigFile - Test.Cardano.Db.Mock.Unit.Babbage.CommandLineArg.EpochDisabled - Test.Cardano.Db.Mock.Unit.Babbage.Config.MigrateConsumedPruneTxOut - Test.Cardano.Db.Mock.Unit.Babbage.Config.Parse - Test.Cardano.Db.Mock.Unit.Babbage.InlineAndReference - Test.Cardano.Db.Mock.Unit.Babbage.Other - Test.Cardano.Db.Mock.Unit.Babbage.Plutus - Test.Cardano.Db.Mock.Unit.Babbage.Reward - Test.Cardano.Db.Mock.Unit.Babbage.Rollback - Test.Cardano.Db.Mock.Unit.Babbage.Simple - Test.Cardano.Db.Mock.Unit.Babbage.Stake - Test.Cardano.Db.Mock.Unit.Babbage.Tx Test.Cardano.Db.Mock.Unit.Conway Test.Cardano.Db.Mock.Unit.Conway.CommandLineArg.ConfigFile Test.Cardano.Db.Mock.Unit.Conway.CommandLineArg.EpochDisabled diff --git a/cardano-chain-gen/test/Main.hs b/cardano-chain-gen/test/Main.hs index 9a9e4ffda..034615d02 100644 --- a/cardano-chain-gen/test/Main.hs +++ b/cardano-chain-gen/test/Main.hs @@ -7,8 +7,6 @@ import System.Directory (getCurrentDirectory) import System.Environment (lookupEnv, setEnv) import System.FilePath (()) import qualified Test.Cardano.Db.Mock.Property.Property as Property -import qualified Test.Cardano.Db.Mock.Unit.Alonzo as Alonzo -import qualified Test.Cardano.Db.Mock.Unit.Babbage as Babbage import qualified Test.Cardano.Db.Mock.Unit.Conway as Conway import Test.Tasty import Test.Tasty.QuickCheck (testProperty) @@ -30,8 +28,6 @@ tests iom = do testGroup "cardano-chain-gen" [ Conway.unitTests iom knownMigrationsPlain - , Babbage.unitTests iom knownMigrationsPlain - , Alonzo.unitTests iom knownMigrationsPlain , testProperty "QSM" $ Property.prop_empty_blocks iom knownMigrationsPlain ] where diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo.hs deleted file mode 100644 index 7010d2024..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} - -module Test.Cardano.Db.Mock.Unit.Alonzo ( - unitTests, -) where - -import Cardano.Mock.ChainSync.Server (IOManager) -import Data.Text (Text) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (Assertion, testCase) - -import qualified Test.Cardano.Db.Mock.Unit.Alonzo.Config as AlzConfig -import qualified Test.Cardano.Db.Mock.Unit.Alonzo.Plutus as AlzPlutus -import qualified Test.Cardano.Db.Mock.Unit.Alonzo.PoolAndSmash as AlzPnS -import qualified Test.Cardano.Db.Mock.Unit.Alonzo.Reward as AlzReward -import qualified Test.Cardano.Db.Mock.Unit.Alonzo.Simple as AlzSimple -import qualified Test.Cardano.Db.Mock.Unit.Alonzo.Stake as AlzStake -import qualified Test.Cardano.Db.Mock.Unit.Alonzo.Tx as AlzTx - -{- HLINT ignore "Reduce duplication" -} - -unitTests :: IOManager -> [(Text, Text)] -> TestTree -unitTests iom knownMigrations = - testGroup - "Alonzo unit tests" - [ testGroup - "config" - [ testCase "default insert config" AlzConfig.defaultInsertConfig - , testCase "insert config" AlzConfig.insertConfig - ] - , testGroup - "simple" - [ test "simple forge blocks" AlzSimple.forgeBlocks - , test "sync one block" AlzSimple.addSimple - , test "restart db-sync" AlzSimple.restartDBSync - , test "sync small chain" AlzSimple.addSimpleChain - ] - , testGroup - "blocks with txs" - [ test "simple tx" AlzTx.addSimpleTx - , test "consume utxo same block" AlzTx.consumeSameBlock - ] - , testGroup - "stake addresses" - [ test "(de)registrations" AlzStake.registrationTx - , test "(de)registrations in same block" AlzStake.registrationsSameBlock - , test "(de)registrations in same tx" AlzStake.registrationsSameTx - , test "stake address pointers" AlzStake.stakeAddressPtr - , test "stake address pointers deregistration" AlzStake.stakeAddressPtrDereg - , test "stake address pointers. Use before registering." AlzStake.stakeAddressPtrUseBefore - ] - , testGroup - "rewards" - [ test "rewards simple" AlzReward.simpleRewards - , test "rewards with deregistration" AlzReward.rewardsDeregistration - , test "rewards with reregistration. Fixed in Babbage." AlzReward.rewardsReregistration - , test "Mir Cert" AlzReward.mirReward - , test "Mir rollback" AlzReward.mirRewardRollback - , test "Mir Cert deregistration" AlzReward.mirRewardDereg - , -- , test "test rewards empty last part of epoch" rewardsEmptyChainLast - -- , test "test delta rewards" rewardsDelta -- See the same test on Babbage for the reason it was disabled. - test "rollback on epoch boundary" AlzReward.rollbackBoundary - , test "single MIR Cert multiple outputs" AlzReward.singleMIRCertMultiOut - ] - , testGroup - "stake distribution" - [ test "stake distribution from genesis" AlzStake.stakeDistGenesis - , test "2000 delegations" AlzStake.delegations2000 - , test "2001 delegations" AlzStake.delegations2001 - , test "8000 delegations" AlzStake.delegations8000 - , test "many delegations" AlzStake.delegationsMany - , test "many delegations, sparse chain" AlzStake.delegationsManyNotDense - ] - , testGroup - "plutus spend scripts" - [ test "simple script lock" AlzPlutus.simpleScript - , test "unlock script in same block" AlzPlutus.unlockScriptSameBlock - , test "failed script" AlzPlutus.failedScript - , test "failed script in same block" AlzPlutus.failedScriptSameBlock - , test "multiple scripts unlocked" AlzPlutus.multipleScripts - , test "multiple scripts unlocked same block" AlzPlutus.multipleScriptsSameBlock - , test "multiple scripts failed" AlzPlutus.multipleScriptsFailed - , test "multiple scripts failed same block" AlzPlutus.multipleScriptsFailedSameBlock - ] - , testGroup - "plutus cert scripts" - [ test "stake scripts" AlzPlutus.registrationScriptTx - , test "stake scripts deregistration" AlzPlutus.deregistrationScriptTx - , test "multiple stake scripts deregistration" AlzPlutus.deregistrationsScriptTxs - , test "multiple stake scripts deregistration in same tx" AlzPlutus.deregistrationsScriptTx - , test "multiple stake scripts deregistration in same tx missing redeemer 1" AlzPlutus.deregistrationsScriptTx' - , test "multiple stake scripts deregistration in same tx missing redeemer 2" AlzPlutus.deregistrationsScriptTx'' - ] - , testGroup - "MultiAssets plutus scripts" - [ test "mint simple multi asset" AlzPlutus.mintMultiAsset - , test "mint many multi assets" AlzPlutus.mintMultiAssets - , test "swap many multi assets" AlzPlutus.swapMultiAssets - ] - , testGroup - "pools and smash" - [ test "pool registration" AlzPnS.poolReg - , test "query pool that's not registered" AlzPnS.nonexistantPoolQuery - , test "pool deregistration" AlzPnS.poolDeReg - , test "pool multiple deregistration" AlzPnS.poolDeRegMany - , test "delist pool" AlzPnS.poolDelist - ] - ] - where - test :: String -> (IOManager -> [(Text, Text)] -> Assertion) -> TestTree - test str action = testCase str (action iom knownMigrations) diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage.hs deleted file mode 100644 index 07281e32c..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage.hs +++ /dev/null @@ -1,206 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module Test.Cardano.Db.Mock.Unit.Babbage ( - unitTests, -) where - -import Cardano.Mock.ChainSync.Server (IOManager) -import Data.Text (Text) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (Assertion, testCase) - -import qualified Test.Cardano.Db.Mock.Unit.Babbage.CommandLineArg.ConfigFile as ConfigFile -import qualified Test.Cardano.Db.Mock.Unit.Babbage.CommandLineArg.EpochDisabled as EpochDisabled -import qualified Test.Cardano.Db.Mock.Unit.Babbage.Config.MigrateConsumedPruneTxOut as MigrateConsumedPruneTxOut -import qualified Test.Cardano.Db.Mock.Unit.Babbage.Config.Parse as Config -import qualified Test.Cardano.Db.Mock.Unit.Babbage.InlineAndReference as BabInlineRef -import qualified Test.Cardano.Db.Mock.Unit.Babbage.Other as BabOther -import qualified Test.Cardano.Db.Mock.Unit.Babbage.Plutus as BabPlutus -import qualified Test.Cardano.Db.Mock.Unit.Babbage.Reward as BabReward -import qualified Test.Cardano.Db.Mock.Unit.Babbage.Rollback as BabRollback -import qualified Test.Cardano.Db.Mock.Unit.Babbage.Simple as BabSimple -import qualified Test.Cardano.Db.Mock.Unit.Babbage.Stake as BabStake -import qualified Test.Cardano.Db.Mock.Unit.Babbage.Tx as BabTx -import Test.Cardano.Db.Mock.Validate (expectFailSilent) - -unitTests :: IOManager -> [(Text, Text)] -> TestTree -unitTests iom knownMigrations = - testGroup - "Babbage unit tests" - [ testGroup - "config" - [ testCase "default insert config" Config.defaultInsertConfig - , testCase "insert config" Config.insertConfig - , testGroup - "tx-out" - [ test "basic prune" MigrateConsumedPruneTxOut.basicPrune - , test "basic prune with address table" MigrateConsumedPruneTxOut.basicPruneWithAddress - , test "prune with simple rollback" MigrateConsumedPruneTxOut.pruneWithSimpleRollback - , test "prune with full tx rollback" MigrateConsumedPruneTxOut.pruneWithFullTxRollback - , test "pruning should keep some tx" MigrateConsumedPruneTxOut.pruningShouldKeepSomeTx - , test "prune and rollback one block" MigrateConsumedPruneTxOut.pruneAndRollBackOneBlock - , test "no pruning and rollback" MigrateConsumedPruneTxOut.noPruneAndRollBack - , test "prune same block" MigrateConsumedPruneTxOut.pruneSameBlock - , test "no pruning same block" MigrateConsumedPruneTxOut.noPruneSameBlock - , expectFailSilent "restart with new consumed set to false" $ MigrateConsumedPruneTxOut.migrateAndPruneRestart iom knownMigrations - , expectFailSilent "set prune flag, restart missing prune flag" $ MigrateConsumedPruneTxOut.pruneRestartMissingFlag iom knownMigrations - , expectFailSilent "set bootstrap flag, restart missing bootstrap flag" $ MigrateConsumedPruneTxOut.bootstrapRestartMissingFlag iom knownMigrations - ] - , testGroup - "tx-out using Address table" - [ test "basic prune with address table" MigrateConsumedPruneTxOut.basicPruneWithAddress - , test "prune with simple rollback with address table" MigrateConsumedPruneTxOut.pruneWithSimpleRollbackWithAddress - , test "prune with full tx rollback with address table" MigrateConsumedPruneTxOut.pruneWithFullTxRollbackWithAddress - , test "pruning should keep some tx with address table" MigrateConsumedPruneTxOut.pruningShouldKeepSomeTxWithAddress - , test "prune and rollback one block with address table" MigrateConsumedPruneTxOut.pruneAndRollBackOneBlockWithAddress - , test "no pruning and rollback with address table" MigrateConsumedPruneTxOut.noPruneAndRollBackWithAddress - , test "prune same block with address table" MigrateConsumedPruneTxOut.pruneSameBlockWithAddress - , test "no pruning same block with address table" MigrateConsumedPruneTxOut.noPruneSameBlockWithAddress - , expectFailSilent "restart with new consumed set to false, with address table" $ MigrateConsumedPruneTxOut.migrateAndPruneRestartWithAddress iom knownMigrations - , expectFailSilent "set prune flag, restart missing prune flag, with address table" $ MigrateConsumedPruneTxOut.pruneRestartMissingFlagWithAddress iom knownMigrations - , expectFailSilent "set bootstrap flag, restart missing bootstrap flag, with address table" $ MigrateConsumedPruneTxOut.bootstrapRestartMissingFlagWithAddress iom knownMigrations - ] - ] - , testGroup - "simple" - [ test "simple forge blocks" BabSimple.forgeBlocks - , test "sync one block" BabSimple.addSimple - , test "sync small chain" BabSimple.addSimpleChain - , test "restart db-sync" BabSimple.restartDBSync - , test "node restart" BabSimple.nodeRestart - , test "node restart boundary" BabSimple.nodeRestartBoundary - ] - , testGroup - "Command Line Arguments" - [ testGroup - "config" - [ expectFailSilent "fails if incorrect config file given" $ ConfigFile.checkConfigFileArg iom knownMigrations - ] - , testGroup - "disable-epoch" - [ test "Epoch doesn't update when disabled" EpochDisabled.checkEpochDisabledArg - , test "Epoch updates when enabled" EpochDisabled.checkEpochEnabled - ] - ] - , testGroup - "rollbacks" - [ test "simple rollback" BabRollback.simpleRollback - , test "sync bigger chain" BabRollback.bigChain - , test "rollback while db-sync is off" BabRollback.restartAndRollback - , -- , test "rollback further" rollbackFurther disabled - test "big rollbacks executed lazily" BabRollback.lazyRollback - , test "lazy rollback on restart" BabRollback.lazyRollbackRestart - , test "rollback while rollbacking" BabRollback.doubleRollback - , test "rollback stake address cache" BabRollback.stakeAddressRollback - , test "rollback change order of txs" BabRollback.rollbackChangeTxOrder - , test "rollback full tx" BabRollback.rollbackFullTx - ] - , testGroup - "different configs" - [ test "genesis config without pool" BabOther.configNoPools - , test "genesis config without stakes" BabOther.configNoStakes - ] - , testGroup - "blocks with txs" - [ test "simple tx" BabTx.addSimpleTx - , test "simple tx in Shelley era" BabTx.addSimpleTxShelley - , test "consume utxo same block" BabTx.consumeSameBlock - ] - , testGroup - "stake addresses" - [ test "(de)registrations" BabStake.registrationTx - , test "(de)registrations in same block" BabStake.registrationsSameBlock - , test "(de)registrations in same tx" BabStake.registrationsSameTx - , test "stake address pointers" BabStake.stakeAddressPtr - , test "stake address pointers deregistration" BabStake.stakeAddressPtrDereg - , test "stake address pointers. Use before registering." BabStake.stakeAddressPtrUseBefore - ] - , testGroup - "stake distribution" - [ test "stake distribution from genesis" BabStake.stakeDistGenesis - , test "2000 delegations" BabStake.delegations2000 - , test "2001 delegations" BabStake.delegations2001 - , test "8000 delegations" BabStake.delegations8000 - , test "many delegations" BabStake.delegationsMany - , test "many delegations, sparse chain" BabStake.delegationsManyNotDense - ] - , testGroup - "rewards" - [ test "rewards simple" BabReward.simpleRewards - , test "shelley rewards from multiple sources" BabReward.rewardsShelley - , test "rewards with deregistration" BabReward.rewardsDeregistration - , test "rewards with reregistration. Fixed in Babbage." BabReward.rewardsReregistration - , test "Mir Cert" BabReward.mirReward - , -- , test "Mir rollback" mirRewardRollback - test "Mir Cert Shelley" BabReward.mirRewardShelley - , test "Mir Cert deregistration" BabReward.mirRewardDereg - , -- , test "test rewards empty last part of epoch" rewardsEmptyChainLast - -- , test "test delta rewards" rewardsDelta -- We disable the test. See in the test for more. - test "rollback on epoch boundary" BabReward.rollbackBoundary - , test "single MIR Cert multiple outputs" BabReward.singleMIRCertMultiOut - ] - , testGroup - "plutus spend scripts" - [ test "simple script lock" BabPlutus.simpleScript - , test "unlock script in same block" BabPlutus.unlockScriptSameBlock - , test "failed script" BabPlutus.failedScript - , test "failed script fees" BabPlutus.failedScriptFees - , test "failed script in same block" BabPlutus.failedScriptSameBlock - , test "multiple scripts unlocked" BabPlutus.multipleScripts - , test "multiple scripts unlocked rollback" BabPlutus.multipleScriptsRollback - , test "multiple scripts unlocked same block" BabPlutus.multipleScriptsSameBlock - , test "multiple scripts failed" BabPlutus.multipleScriptsFailed - , test "multiple scripts failed same block" BabPlutus.multipleScriptsFailedSameBlock - ] - , testGroup - "plutus cert scripts" - [ test "stake scripts" BabPlutus.registrationScriptTx - , test "stake scripts deregistration" BabPlutus.deregistrationScriptTx - , test "multiple stake scripts deregistration" BabPlutus.deregistrationsScriptTxs - , test "multiple stake scripts deregistration in same tx" BabPlutus.deregistrationsScriptTx - , test "multiple stake scripts deregistration in same tx missing redeemer 1" BabPlutus.deregistrationsScriptTx' - , test "multiple stake scripts deregistration in same tx missing redeemer 2" BabPlutus.deregistrationsScriptTx'' - ] - , testGroup - "MultiAssets plutus scripts" - [ test "mint simple multi asset" BabPlutus.mintMultiAsset - , test "mint many multi assets" BabPlutus.mintMultiAssets - , test "swap many multi assets" BabPlutus.swapMultiAssets - ] - , testGroup - "pools and smash" - [ test "pool registration" BabOther.poolReg - , test "query pool that's not registered" BabOther.nonexistantPoolQuery - , test "pool deregistration" BabOther.poolDeReg - , test "pool multiple deregistration" BabOther.poolDeRegMany - , test "delist pool" BabOther.poolDelist - ] - , testGroup - "Babbage inline and reference" - [ test "spend inline datum" BabInlineRef.unlockDatumOutput - , test "spend inline datum same block" BabInlineRef.unlockDatumOutputSameBlock - , test "inline datum with non canonical CBOR" BabInlineRef.inlineDatumCBOR - , test "spend reference script" BabInlineRef.spendRefScript - , test "spend reference script same block" BabInlineRef.spendRefScriptSameBlock - , test "spend collateral output of invalid tx" BabInlineRef.spendCollateralOutput - , test "spend collateral output of invalid tx rollback" BabInlineRef.spendCollateralOutputRollback - , test "spend collateral output of invalid tx same block" BabInlineRef.spendCollateralOutputSameBlock - , test "reference input to output which is not spent" BabInlineRef.referenceInputUnspend - , test "supply and run script which is both reference and in witnesses" BabInlineRef.supplyScriptsTwoWays - , test "supply and run script which is both reference and in witnesses same block" BabInlineRef.supplyScriptsTwoWaysSameBlock - , test "reference script as minting" BabInlineRef.referenceMintingScript - , test "reference script as delegation" BabInlineRef.referenceDelegation - ] - , testGroup - "Hard Fork" - [ test "fork from Alonzo to Babbage fixed epoch" BabOther.forkFixedEpoch - , test "fork from Alonzo to Babbage and rollback" BabOther.rollbackFork - -- TODO fix this test. - -- , test "fork from Alonzo to Babbage using proposal" forkWithProposal - ] - ] - where - test :: String -> (IOManager -> [(Text, Text)] -> Assertion) -> TestTree - test str action = testCase str (action iom knownMigrations) diff --git a/cardano-db-sync/app/cardano-db-sync.hs b/cardano-db-sync/app/cardano-db-sync.hs index 7e6e0162a..62f7d1bf6 100644 --- a/cardano-db-sync/app/cardano-db-sync.hs +++ b/cardano-db-sync/app/cardano-db-sync.hs @@ -18,6 +18,9 @@ import Paths_cardano_db_sync (version) import System.Info (arch, compilerName, compilerVersion, os) import Prelude (error) +--------------------------------------------------------------------------------------------------- +-- Main entry point into the app +--------------------------------------------------------------------------------------------------- main :: IO () main = do cmd <- Opt.execParser opts @@ -55,12 +58,13 @@ main = do <> "For more details view https://github.com/IntersectMBO/cardano-db-sync/blob" <> "/master/doc/syncing-and-rollbacks.md#ledger-state" --- ------------------------------------------------------------------------------------------------- - +--------------------------------------------------------------------------------------------------- +-- Command Line Configurations +--------------------------------------------------------------------------------------------------- opts :: ParserInfo SyncCommand opts = Opt.info - (pDeprecated <*> pCommandLine <**> Opt.helper) + (pCommandLine <**> Opt.helper) ( Opt.fullDesc <> Opt.progDesc "Cardano PostgreSQL sync node." ) @@ -73,27 +77,6 @@ pCommandLine = , CmdRun <$> pRunDbSyncNode ] -pDeprecated :: Parser (a -> a) -pDeprecated = - pDisableOfflineData - <*> pHasLedger - <*> pShouldUseLedger - <*> pKeepTxMetadata - <*> pHasShelley - <*> pHasMultiAssets - <*> pHasMetadata - <*> pHasPlutusExtra - <*> pHasGov - <*> pHasOffChainPoolData - <*> pForceTxIn - <*> pDisableAllMode - <*> pFullMode - <*> pOnlyUTxO - <*> pOnlyGov - <*> pMigrateConsumed - <*> pPruneTxOut - <*> pBootstrap - pRunDbSyncNode :: Parser SyncNodeParams pRunDbSyncNode = do SyncNodeParams @@ -244,169 +227,6 @@ pVersionCommand = ) ] --- * Deprecated flags -pDisableOfflineData :: Parser (a -> a) -pDisableOfflineData = - Opt.abortOption - (Opt.InfoMsg "Error: disable-offline-data has been deprecated, please use disable-offchain-pool-data instead") - ( Opt.long "disable-offline-data" - <> Opt.help "disable-offline-data is deprecated" - <> Opt.hidden - ) - -pHasLedger :: Parser (a -> a) -pHasLedger = - Opt.abortOption - (Opt.InfoMsg "Error: disable-ledger has been deprecated, please configure ledger in db-sync-config.json instead") - ( Opt.long "disable-ledger" - <> Opt.help "disable-ledger is deprecated" - <> Opt.hidden - ) - -pShouldUseLedger :: Parser (a -> a) -pShouldUseLedger = - Opt.abortOption - (Opt.InfoMsg "Error: dont-use-ledger has been deprecated, please configure ledger in db-sync-config.json instead") - ( Opt.long "dont-use-ledger" - <> Opt.help "dont-use-ledger is deprecated" - <> Opt.hidden - ) - -pKeepTxMetadata :: Parser (a -> a) -pKeepTxMetadata = - Opt.abortOption - (Opt.InfoMsg "Error: keep-tx-metadata has been deprecated, please configure ledger in db-sync-config.json instead") - ( Opt.long "keep-tx-metadata" - <> Opt.help "keep-tx-metadata is deprecated" - <> Opt.hidden - ) - -pHasShelley :: Parser (a -> a) -pHasShelley = - Opt.abortOption - (Opt.InfoMsg "Error: disable-shelley has been deprecated, please configure shelley in db-sync-config.json instead") - ( Opt.long "disable-shelley" - <> Opt.help "disable-shelley is deprecated" - <> Opt.hidden - ) - -pHasMultiAssets :: Parser (a -> a) -pHasMultiAssets = - Opt.abortOption - (Opt.InfoMsg "Error: disable-multiassets has been deprecated, please configure multi-assets in db-sync-config.json instead") - ( Opt.long "disable-multiassets" - <> Opt.help "disable-multiassets is deprecated" - <> Opt.hidden - ) - -pHasMetadata :: Parser (a -> a) -pHasMetadata = - Opt.abortOption - (Opt.InfoMsg "Error: disable-metadata has been deprecated, please configure metadata in db-sync-config.json instead") - ( Opt.long "disable-metadata" - <> Opt.help "disable-metadata is deprecated" - <> Opt.hidden - ) - -pHasPlutusExtra :: Parser (a -> a) -pHasPlutusExtra = - Opt.abortOption - (Opt.InfoMsg "Error: disable-plutus-extra has been deprecated, please configure plutus in db-sync-config.json instead") - ( Opt.long "disable-metadata" - <> Opt.help "disable-metadata is deprecated" - <> Opt.hidden - ) - -pHasGov :: Parser (a -> a) -pHasGov = - Opt.abortOption - (Opt.InfoMsg "Error: disable-gov has been deprecated, please configure governance in db-sync-config.json instead") - ( Opt.long "disable-gov" - <> Opt.help "disable-gov is deprecated" - <> Opt.hidden - ) - -pHasOffChainPoolData :: Parser (a -> a) -pHasOffChainPoolData = - Opt.abortOption - (Opt.InfoMsg "Error: disable-offchain-pool-data has been deprecated, please configure offchain pool data in db-sync-config.json instead") - ( Opt.long "disable-offchain-pool-data" - <> Opt.help "disable-gov is deprecated" - <> Opt.hidden - ) - -pForceTxIn :: Parser (a -> a) -pForceTxIn = - Opt.abortOption - (Opt.InfoMsg "Error: force-tx-in has been deprecated, please configure tx-out in db-sync-config.json instead") - ( Opt.long "force-tx-in" - <> Opt.help "force-tx-in is deprecated" - <> Opt.hidden - ) - -pDisableAllMode :: Parser (a -> a) -pDisableAllMode = - Opt.abortOption - (Opt.InfoMsg "Error: disable-all has been deprecated, please configure db-sync-config.json instead") - ( Opt.long "disable-all" - <> Opt.help "disable-all is deprecated" - <> Opt.hidden - ) - -pFullMode :: Parser (a -> a) -pFullMode = - Opt.abortOption - (Opt.InfoMsg "Error: full has been deprecated, please configure db-sync-config.json instead") - ( Opt.long "full" - <> Opt.help "full is deprecated" - <> Opt.hidden - ) - -pOnlyUTxO :: Parser (a -> a) -pOnlyUTxO = - Opt.abortOption - (Opt.InfoMsg "Error: only-utxo has been deprecated, please configure db-sync-config.json instead") - ( Opt.long "only-utxo" - <> Opt.help "only-utxo is deprecated" - <> Opt.hidden - ) - -pOnlyGov :: Parser (a -> a) -pOnlyGov = - Opt.abortOption - (Opt.InfoMsg "Error: only-gov has been deprecated, please configure db-sync-config.json instead") - ( Opt.long "only-gov" - <> Opt.help "only-gov is deprecated" - <> Opt.hidden - ) - -pMigrateConsumed :: Parser (a -> a) -pMigrateConsumed = - Opt.abortOption - (Opt.InfoMsg "Error: consumed-tx-out has been deprecated, please configure tx-out in db-sync-config.json instead") - ( Opt.long "consumed-tx-out" - <> Opt.help "consumed-tx-out is deprecated" - <> Opt.hidden - ) - -pPruneTxOut :: Parser (a -> a) -pPruneTxOut = - Opt.abortOption - (Opt.InfoMsg "Error: prune-tx-out has been deprecated, please configure tx-out in db-sync-config.json instead") - ( Opt.long "prune-tx-out" - <> Opt.help "prune-tx-out is deprecated" - <> Opt.hidden - ) - -pBootstrap :: Parser (a -> a) -pBootstrap = - Opt.abortOption - (Opt.InfoMsg "Error: bootstrap-tx-out has been deprecated, please configure tx-out in db-sync-config.json instead") - ( Opt.long "bootstrap-tx-out" - <> Opt.help "bootstrap-tx-out is deprecated" - <> Opt.hidden - ) - command' :: String -> String -> Parser a -> Opt.Mod Opt.CommandFields a command' c descr p = Opt.command c $ diff --git a/cardano-db-sync/cardano-db-sync.cabal b/cardano-db-sync/cardano-db-sync.cabal index f0394f472..fa7c3b04c 100644 --- a/cardano-db-sync/cardano-db-sync.cabal +++ b/cardano-db-sync/cardano-db-sync.cabal @@ -119,11 +119,6 @@ library Cardano.DbSync.Rollback - Cardano.DbSync.Fix.ConsumedBy - Cardano.DbSync.Fix.EpochStake - Cardano.DbSync.Fix.PlutusDataBytes - Cardano.DbSync.Fix.PlutusScripts - -- OffChain Cardano.DbSync.OffChain Cardano.DbSync.OffChain.FetchQueue diff --git a/cardano-db-sync/src/Cardano/DbSync/Default.hs b/cardano-db-sync/src/Cardano/DbSync/Default.hs index 010ee9fcc..1703a584d 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Default.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Default.hs @@ -24,7 +24,6 @@ import Cardano.DbSync.Era.Universal.Epoch (hasEpochStartEvent, hasNewEpochEvent) import Cardano.DbSync.Era.Universal.Insert.Certificate (mkAdaPots) import Cardano.DbSync.Era.Universal.Insert.LedgerEvent (insertNewEpochLedgerEvents) import Cardano.DbSync.Error -import Cardano.DbSync.Fix.EpochStake import Cardano.DbSync.Ledger.State (applyBlockAndSnapshot, defaultApplyResult) import Cardano.DbSync.Ledger.Types (ApplyResult (..)) import Cardano.DbSync.LocalStateQuery @@ -83,7 +82,6 @@ applyAndInsertBlockMaybe syncEnv tracer cblk = do , ". Time to restore consistency." ] rollbackFromBlockNo syncEnv (blockNo cblk) - void $ migrateStakeDistr syncEnv (apOldLedger applyRes) insertBlock syncEnv cblk applyRes True tookSnapshot liftIO $ setConsistentLevel syncEnv Consistent Right blockId | Just (adaPots, slotNo, epochNo) <- getAdaPots applyRes -> do diff --git a/cardano-db-sync/src/Cardano/DbSync/Fix/ConsumedBy.hs b/cardano-db-sync/src/Cardano/DbSync/Fix/ConsumedBy.hs deleted file mode 100644 index e340706e5..000000000 --- a/cardano-db-sync/src/Cardano/DbSync/Fix/ConsumedBy.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Cardano.DbSync.Fix.ConsumedBy (FixEntry, fixConsumedBy, fixEntriesConsumed) where - -import Cardano.BM.Trace (Trace, logWarning) -import qualified Cardano.Chain.Block as Byron hiding (blockHash) -import qualified Cardano.Chain.UTxO as Byron -import qualified Cardano.Crypto as Crypto (serializeCborHash) -import qualified Cardano.Db as DB -import Cardano.DbSync.Api (getTrace, getTxOutTableType) -import Cardano.DbSync.Api.Types (SyncEnv) -import Cardano.DbSync.Era.Byron.Insert -import Cardano.DbSync.Era.Byron.Util (blockPayload, unTxHash) -import Cardano.DbSync.Era.Util -import Cardano.DbSync.Error -import Cardano.DbSync.Types -import Cardano.Prelude hiding (length, (.)) -import Database.Persist.SqlBackend.Internal -import Ouroboros.Consensus.Byron.Ledger (ByronBlock (..)) -import Ouroboros.Consensus.Cardano.Block (HardForkBlock (..)) - -type FixEntry = (DB.TxOutIdW, DB.TxId) - --- | Nothing when the syncing must stop. -fixConsumedBy :: SqlBackend -> SyncEnv -> CardanoBlock -> IO (Maybe [FixEntry]) -fixConsumedBy backend syncEnv cblk = case cblk of - BlockByron blk -> fixBlock backend syncEnv blk - _ -> pure Nothing - -fixBlock :: SqlBackend -> SyncEnv -> ByronBlock -> IO (Maybe [FixEntry]) -fixBlock backend syncEnv bblk = case byronBlockRaw bblk of - Byron.ABOBBoundary _ -> pure $ Just [] - Byron.ABOBBlock blk -> do - mEntries <- runReaderT (runExceptT $ mapM (fixTx syncEnv) (blockPayload blk)) backend - case mEntries of - Right newEntries -> pure $ Just $ concat newEntries - Left err -> do - liftIO $ - logWarning (getTrace syncEnv) $ - mconcat - [ "While fixing block " - , textShow bblk - , ", encountered error " - , textShow err - ] - pure Nothing - -fixTx :: MonadIO m => SyncEnv -> Byron.TxAux -> ExceptT SyncNodeError (ReaderT SqlBackend m) [FixEntry] -fixTx syncEnv tx = do - txId <- liftLookupFail "resolving tx" $ DB.queryTxId txHash - resolvedInputs <- mapM (resolveTxInputs txOutTableType) (toList $ Byron.txInputs (Byron.taTx tx)) - pure (prepUpdate txId <$> resolvedInputs) - where - txOutTableType = getTxOutTableType syncEnv - txHash = unTxHash $ Crypto.serializeCborHash (Byron.taTx tx) - prepUpdate txId (_, _, txOutId, _) = (txOutId, txId) - -fixEntriesConsumed :: SqlBackend -> Trace IO Text -> [FixEntry] -> IO () -fixEntriesConsumed backend tracer = DB.runDbIohkLogging backend tracer . DB.updateListTxOutConsumedByTxId diff --git a/cardano-db-sync/src/Cardano/DbSync/Fix/EpochStake.hs b/cardano-db-sync/src/Cardano/DbSync/Fix/EpochStake.hs deleted file mode 100644 index 625bcf018..000000000 --- a/cardano-db-sync/src/Cardano/DbSync/Fix/EpochStake.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - -module Cardano.DbSync.Fix.EpochStake where - -import Cardano.BM.Trace (logInfo, logWarning) -import qualified Cardano.Db as DB -import Cardano.DbSync.Api -import Cardano.DbSync.Api.Types -import Cardano.DbSync.Era.Shelley.Generic.StakeDist hiding (getStakeSlice) -import Cardano.DbSync.Era.Universal.Epoch -import Cardano.DbSync.Error -import Cardano.DbSync.Ledger.State -import Cardano.DbSync.Ledger.Types -import Cardano.Prelude -import Control.Monad.Trans.Control -import qualified Data.Map.Strict as Map -import qualified Data.Strict.Maybe as Strict -import Database.Persist.Sql (SqlBackend) - -migrateStakeDistr :: - (MonadIO m, MonadBaseControl IO m) => - SyncEnv -> - Strict.Maybe CardanoLedgerState -> - ExceptT SyncNodeError (ReaderT SqlBackend m) Bool -migrateStakeDistr env mcls = - case (envLedgerEnv env, mcls) of - (HasLedger lenv, Strict.Just cls) -> do - ems <- lift DB.queryAllExtraMigrations - runWhen (not $ DB.isStakeDistrComplete ems) $ do - liftIO $ logInfo trce "Starting Stake Distribution migration on table epoch_stake" - let stakeSlice = getStakeSlice lenv cls True - case stakeSlice of - NoSlices -> - liftIO $ logInsert 0 - Slice (StakeSlice _epochNo distr) isFinal -> do - liftIO $ logInsert (Map.size distr) - insertStakeSlice env stakeSlice - (mminEpoch, mmaxEpoch) <- lift DB.queryMinMaxEpochStake - liftIO $ logMinMax mminEpoch mmaxEpoch - case (mminEpoch, mmaxEpoch) of - (Just minEpoch, Just maxEpoch) -> do - when (maxEpoch > 0) $ - lift $ - DB.insertEpochStakeProgress (mkProgress True <$> [minEpoch .. (maxEpoch - 1)]) - lift $ DB.insertEpochStakeProgress [mkProgress isFinal maxEpoch] - _ -> pure () - lift $ DB.insertExtraMigration DB.StakeDistrEnded - _ -> pure False - where - trce = getTrace env - mkProgress isCompleted e = - DB.EpochStakeProgress - { DB.epochStakeProgressEpochNo = e - , DB.epochStakeProgressCompleted = isCompleted - } - - logInsert :: Int -> IO () - logInsert n - | n == 0 = logInfo trce "No missing epoch_stake found" - | n > 100000 = logWarning trce $ "Found " <> textShow n <> " epoch_stake. This may take a while" - | otherwise = logInfo trce $ "Found " <> textShow n <> " epoch_stake" - - logMinMax mmin mmax = - logInfo trce $ - mconcat - [ "Min epoch_stake at " - , textShow mmin - , " and max at " - , textShow mmax - ] - - runWhen :: Monad m => Bool -> m () -> m Bool - runWhen a action = do - if a then action >> pure True else pure False diff --git a/cardano-db-sync/src/Cardano/DbSync/Fix/PlutusDataBytes.hs b/cardano-db-sync/src/Cardano/DbSync/Fix/PlutusDataBytes.hs deleted file mode 100644 index 29e189867..000000000 --- a/cardano-db-sync/src/Cardano/DbSync/Fix/PlutusDataBytes.hs +++ /dev/null @@ -1,315 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - -module Cardano.DbSync.Fix.PlutusDataBytes where - -import Cardano.BM.Trace (Trace, logInfo, logWarning) -import qualified Cardano.Db.Version.V13_0 as DB_V_13_0 -import Cardano.DbSync.Api -import Cardano.DbSync.Era.Shelley.Generic.Block -import Cardano.DbSync.Era.Shelley.Generic.Tx.Alonzo -import Cardano.DbSync.Era.Shelley.Generic.Tx.Types -import Cardano.DbSync.Error (bsBase16Encode) -import Cardano.DbSync.Types -import qualified Cardano.Ledger.Alonzo.Tx as Alonzo -import qualified Cardano.Ledger.Alonzo.TxWits as Alonzo -import qualified Cardano.Ledger.Babbage.TxBody as Babbage -import Cardano.Ledger.Babbage.TxOut -import qualified Cardano.Ledger.Core as Core -import qualified Cardano.Ledger.Era as Ledger -import qualified Cardano.Ledger.Plutus.Data as Alonzo -import qualified Cardano.Ledger.Plutus.Data as Plutus -import Cardano.Prelude (mapMaybe, textShow) -import Cardano.Slotting.Slot (SlotNo (..)) -import Control.Monad (filterM, when) -import Control.Monad.Extra (mapMaybeM) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad.Trans.Reader (ReaderT) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Short as SBS -import Data.Either.Extra (mapLeft) -import Data.Foldable (toList) -import Data.Int (Int64) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Word (Word64) -import Database.Persist (Entity (..)) -import Database.Persist.Sql (SqlBackend) -import GHC.Records (HasField (getField)) -import Lens.Micro -import Ouroboros.Consensus.Cardano.Block hiding (CardanoBlock) - -data FixData = FixData - { fdDatum :: [FixPlutusInfo] - , fdRedeemerData :: [FixPlutusInfo] - } - -data FixPlutusInfo = FixPlutusInfo - { fpHash :: ByteString - , fpPrevPoint :: CardanoPoint - } - deriving (Show) - -nullData :: FixData -> Bool -nullData fd = null (fdDatum fd) && null (fdRedeemerData fd) - -sizeFixData :: FixData -> Int -sizeFixData fd = length (fdDatum fd) + length (fdRedeemerData fd) - -spanFDOnNextPoint :: FixData -> Maybe (CardanoPoint, FixData, FixData) -spanFDOnNextPoint fd = case (getNextPointList (fdDatum fd), getNextPointList (fdRedeemerData fd)) of - (Nothing, Nothing) -> Nothing - (Just p, Nothing) -> Just $ spanOnPoint fd p - (Nothing, Just p) -> Just $ spanOnPoint fd p - (Just p, Just p') -> Just $ spanOnPoint fd (min p p') - -spanOnPoint :: FixData -> CardanoPoint -> (CardanoPoint, FixData, FixData) -spanOnPoint fd point = - (point, FixData datum rdmData, FixData datumRest rdmDataRest) - where - (datum, datumRest) = span ((point ==) . fpPrevPoint) (fdDatum fd) - (rdmData, rdmDataRest) = span ((point ==) . fpPrevPoint) (fdRedeemerData fd) - -getNextPointList :: [FixPlutusInfo] -> Maybe CardanoPoint -getNextPointList fds = case fds of - [] -> Nothing - fd : _ -> Just $ fpPrevPoint fd - -getWrongPlutusData :: - (MonadBaseControl IO m, MonadIO m) => - Trace IO Text -> - ReaderT SqlBackend m FixData -getWrongPlutusData tracer = do - liftIO $ - logInfo tracer $ - mconcat - [ "Starting the fixing Plutus Data bytes procedure. This may take a couple hours on mainnet if there are wrong values." - , " You can skip it using --skip-plutus-data-fix." - , " It will fix Datum and RedeemerData with wrong bytes. See more in Issue #1214 and #1278." - , " This procedure makes resyncing unnecessary." - ] - datumList <- - findWrongPlutusData - tracer - "Datum" - DB_V_13_0.queryDatumCount - DB_V_13_0.queryDatumPage - (fmap f . DB_V_13_0.querydatumInfo . entityKey) - (DB_V_13_0.datumHash . entityVal) - (Just . getDatumBytes) - (mapLeft Just . hashPlutusData . getDatumBytes) - redeemerDataList <- - findWrongPlutusData - tracer - "RedeemerData" - DB_V_13_0.queryRedeemerDataCount - DB_V_13_0.queryRedeemerDataPage - (fmap f . DB_V_13_0.queryRedeemerDataInfo . entityKey) - (DB_V_13_0.redeemerDataHash . entityVal) - (Just . getRedeemerDataBytes) - (mapLeft Just . hashPlutusData . getRedeemerDataBytes) - pure $ FixData datumList redeemerDataList - where - f queryRes = do - (prevBlockHsh, mPrevSlotNo) <- queryRes - prevSlotNo <- mPrevSlotNo - prevPoint <- convertToPoint (SlotNo prevSlotNo) prevBlockHsh - Just prevPoint - - getDatumBytes = DB_V_13_0.datumBytes . entityVal - getRedeemerDataBytes = DB_V_13_0.redeemerDataBytes . entityVal - - hashPlutusData a = - dataHashToBytes . Alonzo.hashBinaryData @StandardAlonzo - <$> Alonzo.makeBinaryData (SBS.toShort a) - -findWrongPlutusData :: - forall a m. - (MonadBaseControl IO m, MonadIO m) => - Trace IO Text -> - Text -> - m Word64 -> -- query count - (Int64 -> Int64 -> m [a]) -> -- query a page - (a -> m (Maybe CardanoPoint)) -> -- get previous block point - (a -> ByteString) -> -- get the hash - (a -> Maybe ByteString) -> -- get the stored bytes - (a -> Either (Maybe String) ByteString) -> -- hash the stored bytes - m [FixPlutusInfo] -findWrongPlutusData tracer tableName qCount qPage qGetInfo getHash getBytes hashBytes = do - liftIO $ - logInfo tracer $ - mconcat - ["Trying to find ", tableName, " with wrong bytes"] - count <- qCount - liftIO $ - logInfo tracer $ - mconcat - ["There are ", textShow count, " ", tableName, ". Need to scan them all."] - datums <- findRec False 0 [] - liftIO $ - logInfo tracer $ - Text.concat - [ "Found " - , textShow (length datums) - , " " - , tableName - , " with mismatch between bytes and hash." - ] - pure datums - where - showBytes = maybe "" bsBase16Encode - - findRec :: Bool -> Int64 -> [[FixPlutusInfo]] -> m [FixPlutusInfo] - findRec printedSome offset acc = do - when (mod offset (10 * limit) == 0 && offset > 0) $ - liftIO $ - logInfo tracer $ - mconcat ["Checked ", textShow offset, " ", tableName] - ls <- qPage offset limit - ls' <- filterM checkValidBytes ls - ls'' <- mapMaybeM convertToFixPlutusInfo ls' - newPrintedSome <- - if null ls' || printedSome - then pure printedSome - else do - liftIO $ - logInfo tracer $ - Text.concat - [ "Found some wrong values already. The oldest ones are (hash, bytes): " - , textShow $ (\a -> (bsBase16Encode $ getHash a, showBytes $ getBytes a)) <$> take 5 ls' - ] - pure True - let !newAcc = ls'' : acc - if fromIntegral (length ls) < limit - then pure $ reverse $ mconcat newAcc - else findRec newPrintedSome (offset + limit) newAcc - - checkValidBytes :: a -> m Bool - checkValidBytes a = case hashBytes a of - Left Nothing -> pure False - Left (Just msg) -> do - liftIO $ - logWarning tracer $ - Text.concat ["Invalid Binary Data for hash ", textShow actualHash, ": ", Text.pack msg] - pure False - Right hashedBytes -> pure $ hashedBytes /= actualHash - where - actualHash = getHash a - - convertToFixPlutusInfo :: a -> m (Maybe FixPlutusInfo) - convertToFixPlutusInfo a = do - mPoint <- qGetInfo a - case mPoint of - Nothing -> pure Nothing - Just prevPoint -> - pure $ - Just $ - FixPlutusInfo - { fpHash = getHash a - , fpPrevPoint = prevPoint - } - - limit = 100_000 - -fixPlutusData :: MonadIO m => Trace IO Text -> CardanoBlock -> FixData -> ReaderT SqlBackend m () -fixPlutusData tracer cblk fds = do - mapM_ (fixData True) $ fdDatum fds - mapM_ (fixData False) $ fdRedeemerData fds - where - fixData :: MonadIO m => Bool -> FixPlutusInfo -> ReaderT SqlBackend m () - fixData isDatum fd = do - case Map.lookup (fpHash fd) correctBytesMap of - Nothing -> pure () - Just correctBytes | isDatum -> do - mDatumId <- DB_V_13_0.queryDatum $ fpHash fd - case mDatumId of - Just datumId -> - DB_V_13_0.upateDatumBytes datumId correctBytes - Nothing -> - liftIO $ - logWarning tracer $ - mconcat - ["Datum", " not found in block"] - Just correctBytes -> do - mRedeemerDataId <- DB_V_13_0.queryRedeemerData $ fpHash fd - case mRedeemerDataId of - Just redeemerDataId -> - DB_V_13_0.upateRedeemerDataBytes redeemerDataId correctBytes - Nothing -> - liftIO $ - logWarning tracer $ - mconcat - ["RedeemerData", " not found in block"] - - correctBytesMap = Map.union (scrapDatumsBlock cblk) (scrapRedeemerDataBlock cblk) - -scrapDatumsBlock :: CardanoBlock -> Map ByteString ByteString -scrapDatumsBlock cblk = case cblk of - BlockConway _blk -> mempty -- This bug existed in a version that didn't support Conway or later eras - BlockBabbage blk -> Map.unions $ scrapDatumsTxBabbage . snd <$> getTxs blk - BlockAlonzo blk -> Map.unions $ scrapDatumsTxAlonzo . snd <$> getTxs blk - BlockByron _ -> error "No Datums in Byron" - BlockShelley _ -> error "No Datums in Shelley" - BlockAllegra _ -> error "No Datums in Allegra" - BlockMary _ -> error "No Datums in Mary" - -scrapDatumsTxBabbage :: Core.Tx StandardBabbage -> Map ByteString ByteString -scrapDatumsTxBabbage tx = - Map.fromList $ - fmap mkTuple $ - witnessData <> outputData <> collOutputData - where - mkTuple pd = (dataHashToBytes $ txDataHash pd, txDataBytes pd) - witnessData = txDataWitness tx - txBody = getField @"body" tx - outputData = mapMaybe getDatumOutput $ toList $ Babbage.outputs' txBody - collOutputData = mapMaybe getDatumOutput $ toList $ Babbage.collateralReturn' txBody - - getDatumOutput :: BabbageTxOut StandardBabbage -> Maybe PlutusData - getDatumOutput txOut = case txOut ^. datumTxOutL of - Plutus.Datum binaryData -> - let plutusData = Alonzo.binaryDataToData binaryData - in Just $ mkTxData (Alonzo.hashData plutusData, plutusData) - _ -> Nothing - -scrapDatumsTxAlonzo :: Core.Tx StandardAlonzo -> Map ByteString ByteString -scrapDatumsTxAlonzo tx = - Map.fromList $ fmap mkTuple witnessData - where - mkTuple pd = (dataHashToBytes $ txDataHash pd, txDataBytes pd) - witnessData = txDataWitness tx - -scrapRedeemerDataBlock :: CardanoBlock -> Map ByteString ByteString -scrapRedeemerDataBlock cblk = case cblk of - BlockConway _blk -> mempty - BlockBabbage blk -> Map.unions $ scrapRedeemerDataTx . snd <$> getTxs blk - BlockAlonzo blk -> Map.unions $ scrapRedeemerDataTx . snd <$> getTxs blk - BlockByron _ -> error "No RedeemerData in Byron" - BlockShelley _ -> error "No RedeemerData in Shelley" - BlockAllegra _ -> error "No RedeemerData in Allegra" - BlockMary _ -> error "No RedeemerData in Mary" - -scrapRedeemerDataTx :: - forall era. - ( Ledger.EraCrypto era ~ StandardCrypto - , Alonzo.AlonzoEraTxWits era - , Core.EraTx era - ) => - Core.Tx era -> - Map ByteString ByteString -scrapRedeemerDataTx tx = - Map.fromList $ mkTuple . fst <$> Map.elems (Alonzo.unRedeemers (tx ^. (Core.witsTxL . Alonzo.rdmrsTxWitsL))) - where - mkTuple dt = mkTuple' $ mkTxData (Alonzo.hashData dt, dt) - mkTuple' pd = (dataHashToBytes $ txDataHash pd, txDataBytes pd) diff --git a/cardano-db-sync/src/Cardano/DbSync/Fix/PlutusScripts.hs b/cardano-db-sync/src/Cardano/DbSync/Fix/PlutusScripts.hs deleted file mode 100644 index 31c0724fa..000000000 --- a/cardano-db-sync/src/Cardano/DbSync/Fix/PlutusScripts.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module Cardano.DbSync.Fix.PlutusScripts where - -import Cardano.Prelude (mapMaybe) - -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad.Trans.Reader (ReaderT) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Short as SBS -import Data.Foldable (toList) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Text (Text) -import Lens.Micro - -import Cardano.Slotting.Slot (SlotNo (..)) - -import Cardano.Ledger.Alonzo.Scripts -import qualified Cardano.Ledger.Babbage.TxBody as Babbage -import Cardano.Ledger.BaseTypes (strictMaybeToMaybe) -import qualified Cardano.Ledger.Core as Ledger - --- import Cardano.Ledger.Plutus.Language - -import Cardano.Db (ScriptType (..), maybeToEither) -import qualified Cardano.Db.Version.V13_0 as DB_V_13_0 - -import Cardano.BM.Trace (Trace, logInfo, logWarning) - -import Cardano.DbSync.Api -import qualified Cardano.DbSync.Era.Shelley.Generic as Generic -import Cardano.DbSync.Era.Shelley.Generic.Block -import Cardano.DbSync.Era.Shelley.Generic.Tx.Alonzo -import qualified Cardano.DbSync.Era.Shelley.Generic.Tx.Babbage as Babbage -import Cardano.DbSync.Era.Shelley.Generic.Tx.Types -import Cardano.DbSync.Types - -import Database.Persist (Entity (..)) -import Database.Persist.Sql (SqlBackend) - -import Ouroboros.Consensus.Cardano.Block (HardForkBlock (BlockAllegra, BlockAlonzo, BlockBabbage, BlockByron, BlockMary, BlockShelley)) -import Ouroboros.Consensus.Shelley.Eras - -import Cardano.DbSync.Fix.PlutusDataBytes -import Cardano.Ledger.Babbage.TxOut -import Cardano.Ledger.Plutus.Language (Plutus (..)) - -newtype FixPlutusScripts = FixPlutusScripts {scriptsInfo :: [FixPlutusInfo]} - -nullPlutusScripts :: FixPlutusScripts -> Bool -nullPlutusScripts = null . scriptsInfo - -sizeFixPlutusScripts :: FixPlutusScripts -> Int -sizeFixPlutusScripts = length . scriptsInfo - -spanFPSOnNextPoint :: FixPlutusScripts -> Maybe (CardanoPoint, FixPlutusScripts, FixPlutusScripts) -spanFPSOnNextPoint fps = do - point <- getNextPointList $ scriptsInfo fps - Just $ spanFPSOnPoint fps point - -spanFPSOnPoint :: FixPlutusScripts -> CardanoPoint -> (CardanoPoint, FixPlutusScripts, FixPlutusScripts) -spanFPSOnPoint fps point = - (point, FixPlutusScripts atPoint, FixPlutusScripts rest) - where - (atPoint, rest) = span ((point ==) . fpPrevPoint) (scriptsInfo fps) - -getWrongPlutusScripts :: - (MonadBaseControl IO m, MonadIO m) => - Trace IO Text -> - ReaderT SqlBackend m FixPlutusScripts -getWrongPlutusScripts tracer = do - liftIO $ - logInfo tracer $ - mconcat - [ "Starting the fixing Plutus Script procedure. This may take a couple minutes on mainnet if there are wrong values." - , " You can skip it using --skip-plutus-script-fix." - , " It will fix Script with wrong bytes. See more in Issue #1214 and #1348." - , " This procedure makes resyncing unnecessary." - ] - FixPlutusScripts <$> findWrongPlutusScripts tracer - -findWrongPlutusScripts :: - forall m. - (MonadBaseControl IO m, MonadIO m) => - Trace IO Text -> - ReaderT SqlBackend m [FixPlutusInfo] -findWrongPlutusScripts tracer = - findWrongPlutusData - tracer - "Script" - DB_V_13_0.queryScriptCount - DB_V_13_0.queryScriptPage - (fmap f . DB_V_13_0.queryScriptInfo . entityKey) - (DB_V_13_0.scriptHash . entityVal) - (DB_V_13_0.scriptBytes . entityVal) - (hashPlutusScript . entityVal) - where - f queryRes = do - (prevBlockHsh, mPrevSlotNo) <- queryRes - prevSlotNo <- mPrevSlotNo - prevPoint <- convertToPoint (SlotNo prevSlotNo) prevBlockHsh - Just prevPoint - - hashPlutusScript :: DB_V_13_0.Script -> Either (Maybe String) ByteString - hashPlutusScript dbScript = do - bytes <- maybeToEither (Just "No bytes found for plutus script") id $ DB_V_13_0.scriptBytes dbScript - case DB_V_13_0.scriptType dbScript of - PlutusV1 -> do - -- The bug only affected Alonzo script - let script :: AlonzoScript StandardAlonzo = PlutusScript (AlonzoPlutusV1 (Plutus $ PlutusBinary $ SBS.toShort bytes)) - let hsh :: Ledger.ScriptHash StandardCrypto = Ledger.hashScript @StandardAlonzo script - Right $ Generic.unScriptHash hsh - PlutusV2 -> Left Nothing - PlutusV3 -> Left Nothing - _ -> Left $ Just "Non plutus script found where it shouldn't." - -fixPlutusScripts :: MonadIO m => Trace IO Text -> CardanoBlock -> FixPlutusScripts -> ReaderT SqlBackend m () -fixPlutusScripts tracer cblk fpss = do - mapM_ fixData $ scriptsInfo fpss - where - fixData :: MonadIO m => FixPlutusInfo -> ReaderT SqlBackend m () - fixData fpi = do - case Map.lookup (fpHash fpi) correctBytesMap of - Nothing -> pure () - Just correctBytes -> do - mScriptId <- DB_V_13_0.queryScript $ fpHash fpi - case mScriptId of - Just scriptId -> - DB_V_13_0.updateScriptBytes scriptId correctBytes - Nothing -> - liftIO $ - logWarning tracer $ - mconcat - ["Script", " not found in block"] - - correctBytesMap = scrapScriptBlock cblk - -scrapScriptBlock :: CardanoBlock -> Map ByteString ByteString -scrapScriptBlock cblk = case cblk of - BlockBabbage blk -> Map.unions $ scrapScriptTxBabbage . snd <$> getTxs blk - BlockAlonzo blk -> Map.unions $ scrapScriptTxAlonzo . snd <$> getTxs blk - BlockByron _ -> error "No Plutus Scripts in Byron" - BlockShelley _ -> error "No Plutus Scripts in Shelley" - BlockAllegra _ -> error "No Plutus Scripts in Allegra" - BlockMary _ -> error "No Plutus Scripts in Mary" - _ -> mempty -- This bug existed in a version that didn't support Conway or later eras - -scrapScriptTxBabbage :: Ledger.Tx StandardBabbage -> Map ByteString ByteString -scrapScriptTxBabbage tx = Map.union txMap txOutMap - where - txMap = Map.fromList $ mapMaybe getTxScript $ getScripts tx - txOutMap = - Map.fromList $ - mapMaybe getOutputScript $ - toList $ - Babbage.outputs' $ - tx ^. Ledger.bodyTxL - - getOutputScript :: Ledger.TxOut StandardBabbage -> Maybe (ByteString, ByteString) - getOutputScript txOut = do - script :: AlonzoScript StandardBabbage <- strictMaybeToMaybe $ txOut ^. referenceScriptTxOutL - getTxScript $ Babbage.fromScript script - -scrapScriptTxAlonzo :: Ledger.Tx StandardAlonzo -> Map ByteString ByteString -scrapScriptTxAlonzo tx = Map.fromList $ mapMaybe getTxScript $ getScripts tx - -getTxScript :: Generic.TxScript -> Maybe (ByteString, ByteString) -getTxScript txScript = - if txScriptType txScript `elem` [PlutusV1, PlutusV2] - then do - cbor <- txScriptCBOR txScript - Just (txScriptHash txScript, cbor) - else Nothing diff --git a/cardano-db-sync/src/Cardano/DbSync/Sync.hs b/cardano-db-sync/src/Cardano/DbSync/Sync.hs index 656f81b4e..de827a39d 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Sync.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Sync.hs @@ -1,7 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -25,18 +24,14 @@ module Cardano.DbSync.Sync ( ) where import Cardano.BM.Data.Tracer (ToLogObject (..), ToObject) -import Cardano.BM.Trace (Trace, appendName, logInfo, logWarning) +import Cardano.BM.Trace (Trace, appendName, logInfo) import qualified Cardano.BM.Trace as Logging import Cardano.Client.Subscription (subscribe) -import Cardano.Db (runDbIohkLogging) import Cardano.DbSync.Api -import Cardano.DbSync.Api.Types (ConsistentLevel (..), FixesRan (..), LedgerEnv (..), SyncEnv (..), SyncOptions (..), envLedgerEnv, envNetworkMagic, envOptions) +import Cardano.DbSync.Api.Types (ConsistentLevel (..), LedgerEnv (..), SyncEnv (..), envLedgerEnv, envNetworkMagic, envOptions) import Cardano.DbSync.Config import Cardano.DbSync.Database import Cardano.DbSync.DbAction -import Cardano.DbSync.Fix.ConsumedBy -import Cardano.DbSync.Fix.PlutusDataBytes -import Cardano.DbSync.Fix.PlutusScripts import Cardano.DbSync.LocalStateQuery import Cardano.DbSync.Metrics import Cardano.DbSync.Tracing.ToObjectOrphans () @@ -50,7 +45,6 @@ import qualified Data.ByteString.Lazy as BSL import Data.Functor.Contravariant (contramap) import qualified Data.List as List import qualified Data.Text as Text -import Database.Persist.Postgresql (SqlBackend) import Network.Mux (MuxTrace, WithMuxBearer) import Network.Mux.Types (MuxMode (..)) import Network.TypedProtocol.Pipelined (N (..), Nat (Succ, Zero)) @@ -75,7 +69,6 @@ import Ouroboros.Network.Block ( genesisPoint, getTipBlockNo, ) -import Ouroboros.Network.Driver (runPeer) import Ouroboros.Network.Driver.Simple (runPipelinedPeer) import Ouroboros.Network.Mux (MiniProtocolCb (..), RunMiniProtocol (..), RunMiniProtocolWithMinimalCtx, mkMiniProtocolCbFromPeer) import Ouroboros.Network.NodeToClient ( @@ -96,8 +89,6 @@ import Ouroboros.Network.NodeToClient ( networkErrorPolicies, ) import qualified Ouroboros.Network.NodeToClient.Version as Network -import Ouroboros.Network.Protocol.ChainSync.Client (ChainSyncClient) -import qualified Ouroboros.Network.Protocol.ChainSync.Client as Client import Ouroboros.Network.Protocol.ChainSync.ClientPipelined ( ChainSyncClientPipelined (..), ClientPipelinedStIdle (..), @@ -206,78 +197,11 @@ dbSyncProtocols syncEnv metricsSetters tc codecConfig version bversion = tracer :: Trace IO Text tracer = getTrace syncEnv - backend :: SqlBackend - backend = envBackend syncEnv - - initAction channel = do - consumedFixed <- getIsConsumedFixed syncEnv - case consumedFixed of - Nothing -> oldActionFixes channel - Just wrongEntriesSize | wrongEntriesSize == 0 -> do - logInfo tracer "Found no wrong consumed_by_tx_id entries" - oldActionFixes channel - Just wrongEntriesSize -> do - logInfo tracer $ - mconcat ["Found ", textShow wrongEntriesSize, " consumed_by_tx_id wrong entries"] - fixedEntries <- - runPeer - localChainSyncTracer - (cChainSyncCodec codecs) - channel - ( Client.chainSyncClientPeer $ - chainSyncClientFixConsumed backend syncEnv wrongEntriesSize - ) - logInfo tracer $ - mconcat ["Fixed ", textShow fixedEntries, " consumed_by_tx_id wrong entries"] - pure False - - oldActionFixes channel = do - fr <- getIsSyncFixed syncEnv - let skipFix = soptSkipFix $ envOptions syncEnv - let onlyFix = soptOnlyFix $ envOptions syncEnv - if noneFixed fr && (onlyFix || not skipFix) - then do - fd <- runDbIohkLogging backend tracer $ getWrongPlutusData tracer - unless (nullData fd) $ - void $ - runPeer - localChainSyncTracer - (cChainSyncCodec codecs) - channel - ( Client.chainSyncClientPeer $ - chainSyncClientFixData backend tracer fd - ) - if onlyFix - then do - setIsFixed syncEnv DataFixRan - else setIsFixedAndMigrate syncEnv DataFixRan - pure False - else - if isDataFixed fr && (onlyFix || not skipFix) - then do - ls <- runDbIohkLogging backend tracer $ getWrongPlutusScripts tracer - unless (nullPlutusScripts ls) $ - void $ - runPeer - localChainSyncTracer - (cChainSyncCodec codecs) - channel - ( Client.chainSyncClientPeer $ - chainSyncClientFixScripts backend tracer ls - ) - when onlyFix $ panic "All Good! This error is only thrown to exit db-sync" - setIsFixed syncEnv AllFixRan - pure False - else do - when skipFix $ setIsFixedAndMigrate syncEnv AllFixRan - pure True - localChainSyncPtcl :: RunMiniProtocolWithMinimalCtx 'InitiatorMode LocalAddress BSL.ByteString IO () Void localChainSyncPtcl = InitiatorProtocolOnly $ MiniProtocolCb $ \_ctx channel -> liftIO . logException tracer "ChainSyncWithBlocksPtcl: " $ do - isInitComplete <- runAndSetDone tc $ initAction channel - when isInitComplete $ do + when True $ do logInfo tracer "Starting ChainSync client" setConsistentLevel syncEnv Unchecked @@ -461,175 +385,3 @@ drainThePipe n0 client = go n0 { recvMsgRollForward = \_hdr _tip -> pure $ go n' , recvMsgRollBackward = \_pt _tip -> pure $ go n' } - -chainSyncClientFixConsumed :: - SqlBackend -> SyncEnv -> Word64 -> ChainSyncClient CardanoBlock (Point CardanoBlock) (Tip CardanoBlock) IO Integer -chainSyncClientFixConsumed backend syncEnv wrongTotalSize = Client.ChainSyncClient $ do - liftIO $ logInfo tracer "Starting chainsync to fix consumed_by_tx_id Byron entries. See issue https://github.com/IntersectMBO/cardano-db-sync/issues/1821. This makes resyncing unnecessary." - pure $ Client.SendMsgFindIntersect [genesisPoint] clientStIntersect - where - tracer = getTrace syncEnv - clientStIntersect = - Client.ClientStIntersect - { Client.recvMsgIntersectFound = \_blk _tip -> - Client.ChainSyncClient $ - pure $ - Client.SendMsgRequestNext (pure ()) (clientStNext (0, (0, []))) - , Client.recvMsgIntersectNotFound = \_tip -> - panic "Failed to find intersection with genesis." - } - - clientStNext :: (Integer, (Integer, [[FixEntry]])) -> Client.ClientStNext CardanoBlock (Point CardanoBlock) (Tip CardanoBlock) IO Integer - clientStNext (sizeFixedTotal, (sizeFixEntries, fixEntries)) = - Client.ClientStNext - { Client.recvMsgRollForward = \blk _tip -> Client.ChainSyncClient $ do - mNewEntries <- fixConsumedBy backend syncEnv blk - case mNewEntries of - Nothing -> do - fixAccumulatedEntries fixEntries - pure $ Client.SendMsgDone (sizeFixedTotal + sizeFixEntries) - Just newEntries -> do - let sizeNewEntries = fromIntegral (length newEntries) - (sizeNewFixed, sizeUnfixed, unfixedEntries) <- - fixAccumulatedEntriesMaybe (sizeFixEntries + sizeNewEntries, newEntries : fixEntries) - let sizeNewFixedTotal = sizeFixedTotal + sizeNewFixed - logSize sizeFixedTotal sizeNewFixedTotal - pure $ Client.SendMsgRequestNext (pure ()) (clientStNext (sizeNewFixedTotal, (sizeUnfixed, unfixedEntries))) - , Client.recvMsgRollBackward = \_point _tip -> - Client.ChainSyncClient $ - pure $ - Client.SendMsgRequestNext (pure ()) (clientStNext (sizeFixedTotal, (sizeFixEntries, fixEntries))) - } - - fixAccumulatedEntries = fixEntriesConsumed backend tracer . concat . reverse - - fixAccumulatedEntriesMaybe :: (Integer, [[FixEntry]]) -> IO (Integer, Integer, [[FixEntry]]) - fixAccumulatedEntriesMaybe (n, entries) - | n >= 10_000 = fixAccumulatedEntries entries >> pure (n, 0, []) - | otherwise = pure (0, n, entries) - - logSize :: Integer -> Integer -> IO () - logSize lastSize newSize = do - when (newSize `div` 200_000 > lastSize `div` 200_000) $ - logInfo tracer $ - mconcat ["Fixed ", textShow newSize, "/", textShow wrongTotalSize, " entries"] - -chainSyncClientFixData :: - SqlBackend -> Trace IO Text -> FixData -> ChainSyncClient CardanoBlock (Point CardanoBlock) (Tip CardanoBlock) IO () -chainSyncClientFixData backend tracer fixData = Client.ChainSyncClient $ do - liftIO $ logInfo tracer "Starting chainsync to fix Plutus Data. This will update database values in tables datum and redeemer_data." - clientStIdle True (sizeFixData fixData) fixData - where - updateSizeAndLog :: Int -> Int -> IO Int - updateSizeAndLog lastSize currentSize = do - let diffSize = lastSize - currentSize - if lastSize >= currentSize && diffSize >= 200_000 - then do - liftIO $ logInfo tracer $ mconcat ["Fixed ", textShow (sizeFixData fixData - currentSize), " Plutus Data"] - pure currentSize - else pure lastSize - - clientStIdle :: Bool -> Int -> FixData -> IO (Client.ClientStIdle CardanoBlock (Point CardanoBlock) (Tip CardanoBlock) IO ()) - clientStIdle shouldLog lastSize fds = do - case spanFDOnNextPoint fds of - Nothing -> do - liftIO $ logInfo tracer "Finished chainsync to fix Plutus Data." - pure $ Client.SendMsgDone () - Just (point, fdOnPoint, fdRest) -> do - when shouldLog $ - liftIO $ - logInfo tracer $ - mconcat ["Starting fixing Plutus Data ", textShow point] - newLastSize <- liftIO $ updateSizeAndLog lastSize (sizeFixData fds) - let clientStIntersect = - Client.ClientStIntersect - { Client.recvMsgIntersectFound = \_pnt _tip -> - Client.ChainSyncClient $ - pure $ - Client.SendMsgRequestNext (pure ()) (clientStNext newLastSize fdOnPoint fdRest) - , Client.recvMsgIntersectNotFound = \tip -> Client.ChainSyncClient $ do - liftIO $ - logWarning tracer $ - mconcat - [ "Node can't find block " - , textShow point - , ". It's probably behind, at " - , textShow tip - , ". Sleeping for 3 mins and retrying.." - ] - liftIO $ threadDelay $ 180 * 1_000_000 - pure $ Client.SendMsgFindIntersect [point] clientStIntersect - } - pure $ Client.SendMsgFindIntersect [point] clientStIntersect - - clientStNext :: Int -> FixData -> FixData -> Client.ClientStNext CardanoBlock (Point CardanoBlock) (Tip CardanoBlock) IO () - clientStNext lastSize fdOnPoint fdRest = - Client.ClientStNext - { Client.recvMsgRollForward = \blk _tip -> Client.ChainSyncClient $ do - runDbIohkLogging backend tracer $ fixPlutusData tracer blk fdOnPoint - clientStIdle False lastSize fdRest - , Client.recvMsgRollBackward = \_point _tip -> - Client.ChainSyncClient $ - pure $ - Client.SendMsgRequestNext (pure ()) (clientStNext lastSize fdOnPoint fdRest) - } - -chainSyncClientFixScripts :: - SqlBackend -> Trace IO Text -> FixPlutusScripts -> ChainSyncClient CardanoBlock (Point CardanoBlock) (Tip CardanoBlock) IO () -chainSyncClientFixScripts backend tracer fps = Client.ChainSyncClient $ do - liftIO $ logInfo tracer "Starting chainsync to fix Plutus Scripts. This will update database values in tables script." - clientStIdle True (sizeFixPlutusScripts fps) fps - where - updateSizeAndLog :: Int -> Int -> IO Int - updateSizeAndLog lastSize currentSize = do - let diffSize = lastSize - currentSize - if lastSize >= currentSize && diffSize >= 200_000 - then do - liftIO $ logInfo tracer $ mconcat ["Fixed ", textShow (sizeFixPlutusScripts fps - currentSize), " Plutus Scripts"] - pure currentSize - else pure lastSize - - clientStIdle :: Bool -> Int -> FixPlutusScripts -> IO (Client.ClientStIdle CardanoBlock (Point CardanoBlock) (Tip CardanoBlock) IO ()) - clientStIdle shouldLog lastSize fps' = do - case spanFPSOnNextPoint fps' of - Nothing -> do - liftIO $ logInfo tracer "Finished chainsync to fix Plutus Scripts." - pure $ Client.SendMsgDone () - Just (point, fpsOnPoint, fpsRest) -> do - when shouldLog $ - liftIO $ - logInfo tracer $ - mconcat ["Starting fixing Plutus Scripts ", textShow point] - newLastSize <- liftIO $ updateSizeAndLog lastSize (sizeFixPlutusScripts fps') - let clientStIntersect = - Client.ClientStIntersect - { Client.recvMsgIntersectFound = \_pnt _tip -> - Client.ChainSyncClient $ - pure $ - Client.SendMsgRequestNext (pure ()) (clientStNext newLastSize fpsOnPoint fpsRest) - , Client.recvMsgIntersectNotFound = \tip -> Client.ChainSyncClient $ do - liftIO $ - logWarning tracer $ - mconcat - [ "Node can't find block " - , textShow point - , ". It's probably behind, at " - , textShow tip - , ". Sleeping for 3 mins and retrying.." - ] - liftIO $ threadDelay $ 180 * 1_000_000 - pure $ Client.SendMsgFindIntersect [point] clientStIntersect - } - pure $ Client.SendMsgFindIntersect [point] clientStIntersect - - clientStNext :: Int -> FixPlutusScripts -> FixPlutusScripts -> Client.ClientStNext CardanoBlock (Point CardanoBlock) (Tip CardanoBlock) IO () - clientStNext lastSize fpsOnPoint fpsRest = - Client.ClientStNext - { Client.recvMsgRollForward = \blk _tip -> Client.ChainSyncClient $ do - runDbIohkLogging backend tracer $ fixPlutusScripts tracer blk fpsOnPoint - clientStIdle False lastSize fpsRest - , Client.recvMsgRollBackward = \_point _tip -> - Client.ChainSyncClient $ - pure $ - Client.SendMsgRequestNext (pure ()) (clientStNext lastSize fpsOnPoint fpsRest) - } diff --git a/cardano-db/cardano-db.cabal b/cardano-db/cardano-db.cabal index d2288a07b..cd33daf14 100644 --- a/cardano-db/cardano-db.cabal +++ b/cardano-db/cardano-db.cabal @@ -32,7 +32,6 @@ library exposed-modules: Cardano.Db Cardano.Db.Schema.Core.TxOut Cardano.Db.Schema.Variant.TxOut - Cardano.Db.Version.V13_0 other-modules: Cardano.Db.Error Cardano.Db.Git.RevFromGit @@ -58,8 +57,6 @@ library Cardano.Db.Schema.Orphans Cardano.Db.Schema.Types Cardano.Db.Types - Cardano.Db.Version.V13_0.Query - Cardano.Db.Version.V13_0.Schema build-depends: aeson , base >= 4.14 && < 5 diff --git a/cardano-db/src/Cardano/Db/Version/V13_0.hs b/cardano-db/src/Cardano/Db/Version/V13_0.hs deleted file mode 100644 index b3b6e7969..000000000 --- a/cardano-db/src/Cardano/Db/Version/V13_0.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Cardano.Db.Version.V13_0 ( - module X, -) where - -import Cardano.Db.Version.V13_0.Query as X -import Cardano.Db.Version.V13_0.Schema as X diff --git a/cardano-db/src/Cardano/Db/Version/V13_0/Query.hs b/cardano-db/src/Cardano/Db/Version/V13_0/Query.hs deleted file mode 100644 index 8463e72fd..000000000 --- a/cardano-db/src/Cardano/Db/Version/V13_0/Query.hs +++ /dev/null @@ -1,195 +0,0 @@ -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module Cardano.Db.Version.V13_0.Query ( - queryDatum, - queryDatumPage, - queryDatumCount, - querydatumInfo, - queryRedeemerData, - queryRedeemerDataPage, - queryRedeemerDataCount, - queryRedeemerDataInfo, - queryScript, - queryScriptPage, - queryScriptCount, - queryScriptInfo, - upateDatumBytes, - upateRedeemerDataBytes, - updateScriptBytes, -) where - -import Cardano.Db.Types (ScriptType (..)) -import Cardano.Db.Version.V13_0.Schema -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Reader (ReaderT) -import Data.ByteString.Char8 (ByteString) -import Data.Int (Int64) -import Data.Maybe (listToMaybe) -import Data.Word (Word64) -import Database.Esqueleto.Experimental ( - Entity (..), - SqlBackend, - Value, - asc, - countRows, - from, - innerJoin, - just, - limit, - offset, - on, - orderBy, - select, - table, - unValue, - val, - where_, - (==.), - (^.), - (||.), - type (:&) ((:&)), - ) -import Database.Persist ((=.)) -import Database.Persist.Class - -{- HLINT ignore "Fuse on/on" -} - -queryDatum :: MonadIO m => ByteString -> ReaderT SqlBackend m (Maybe DatumId) -queryDatum hsh = do - xs <- select $ do - datum <- from $ table @Datum - where_ (datum ^. DatumHash ==. val hsh) - pure (datum ^. DatumId) - pure $ unValue <$> listToMaybe xs - -queryDatumPage :: MonadIO m => Int64 -> Int64 -> ReaderT SqlBackend m [Entity Datum] -queryDatumPage ofs lmt = - select $ do - datum <- from $ table @Datum - orderBy [asc (datum ^. DatumId)] - limit lmt - offset ofs - pure datum - -queryDatumCount :: MonadIO m => ReaderT SqlBackend m Word64 -queryDatumCount = do - xs <- select $ do - _ <- from $ table @Datum - pure countRows - pure $ maybe 0 unValue (listToMaybe xs) - -querydatumInfo :: MonadIO m => DatumId -> ReaderT SqlBackend m (Maybe (ByteString, Maybe Word64)) -querydatumInfo datumId = do - res <- select $ do - (_blk :& _tx :& datum :& prevBlock) <- - from - $ table @Block - `innerJoin` table @Tx - `on` (\(blk :& tx) -> tx ^. TxBlockId ==. blk ^. BlockId) - `innerJoin` table @Datum - `on` (\(_blk :& tx :& datum) -> datum ^. DatumTxId ==. tx ^. TxId) - `innerJoin` table @Block - `on` (\(blk :& _tx :& _datum :& prevBlk) -> blk ^. BlockPreviousId ==. just (prevBlk ^. BlockId)) - where_ (datum ^. DatumId ==. val datumId) - pure (prevBlock ^. BlockHash, prevBlock ^. BlockSlotNo) - pure $ unValue2 <$> listToMaybe res - -queryRedeemerData :: MonadIO m => ByteString -> ReaderT SqlBackend m (Maybe RedeemerDataId) -queryRedeemerData hsh = do - xs <- select $ do - rdmrDt <- from $ table @RedeemerData - where_ (rdmrDt ^. RedeemerDataHash ==. val hsh) - pure (rdmrDt ^. RedeemerDataId) - pure $ unValue <$> listToMaybe xs - -queryRedeemerDataPage :: MonadIO m => Int64 -> Int64 -> ReaderT SqlBackend m [Entity RedeemerData] -queryRedeemerDataPage ofs lmt = - select $ do - redeemerData <- from $ table @RedeemerData - orderBy [asc (redeemerData ^. RedeemerDataId)] - limit lmt - offset ofs - pure redeemerData - -queryRedeemerDataCount :: MonadIO m => ReaderT SqlBackend m Word64 -queryRedeemerDataCount = do - xs <- select $ do - _ <- from $ table @RedeemerData - pure countRows - pure $ maybe 0 unValue (listToMaybe xs) - -queryRedeemerDataInfo :: MonadIO m => RedeemerDataId -> ReaderT SqlBackend m (Maybe (ByteString, Maybe Word64)) -queryRedeemerDataInfo rdmDataId = do - res <- select $ do - (_blk :& _tx :& rdmData :& prevBlock) <- - from - $ table @Block - `innerJoin` table @Tx - `on` (\(blk :& tx) -> tx ^. TxBlockId ==. blk ^. BlockId) - `innerJoin` table @RedeemerData - `on` (\(_blk :& tx :& rdmData) -> rdmData ^. RedeemerDataTxId ==. tx ^. TxId) - `innerJoin` table @Block - `on` (\(blk :& _tx :& _rdmData :& prevBlk) -> blk ^. BlockPreviousId ==. just (prevBlk ^. BlockId)) - where_ (rdmData ^. RedeemerDataId ==. val rdmDataId) - pure (prevBlock ^. BlockHash, prevBlock ^. BlockSlotNo) - pure $ unValue2 <$> listToMaybe res - -queryScriptCount :: MonadIO m => ReaderT SqlBackend m Word64 -queryScriptCount = do - xs <- select $ do - scr <- from $ table @Script - where_ (scr ^. ScriptType ==. val PlutusV1 ||. scr ^. ScriptType ==. val PlutusV2) - pure countRows - pure $ maybe 0 unValue (listToMaybe xs) - -queryScript :: MonadIO m => ByteString -> ReaderT SqlBackend m (Maybe ScriptId) -queryScript hsh = do - xs <- select $ do - scr <- from $ table @Script - where_ (scr ^. ScriptType ==. val PlutusV1 ||. scr ^. ScriptType ==. val PlutusV2) - where_ (scr ^. ScriptHash ==. val hsh) - pure (scr ^. ScriptId) - pure $ unValue <$> listToMaybe xs - -queryScriptPage :: MonadIO m => Int64 -> Int64 -> ReaderT SqlBackend m [Entity Script] -queryScriptPage ofs lmt = - select $ do - scr <- from $ table @Script - where_ (scr ^. ScriptType ==. val PlutusV1 ||. scr ^. ScriptType ==. val PlutusV2) - orderBy [asc (scr ^. ScriptId)] - limit lmt - offset ofs - pure scr - -queryScriptInfo :: MonadIO m => ScriptId -> ReaderT SqlBackend m (Maybe (ByteString, Maybe Word64)) -queryScriptInfo scriptId = do - res <- select $ do - (_blk :& _tx :& scr :& prevBlock) <- - from - $ table @Block - `innerJoin` table @Tx - `on` (\(blk :& tx) -> tx ^. TxBlockId ==. blk ^. BlockId) - `innerJoin` table @Script - `on` (\(_blk :& tx :& scr) -> scr ^. ScriptTxId ==. tx ^. TxId) - `innerJoin` table @Block - `on` (\(blk :& _tx :& _scr :& prevBlk) -> blk ^. BlockPreviousId ==. just (prevBlk ^. BlockId)) - where_ (scr ^. ScriptType ==. val PlutusV1 ||. scr ^. ScriptType ==. val PlutusV2) - where_ (scr ^. ScriptId ==. val scriptId) - pure (prevBlock ^. BlockHash, prevBlock ^. BlockSlotNo) - pure $ unValue2 <$> listToMaybe res - -upateDatumBytes :: MonadIO m => DatumId -> ByteString -> ReaderT SqlBackend m () -upateDatumBytes datumId bytes = update datumId [DatumBytes =. bytes] - -upateRedeemerDataBytes :: MonadIO m => RedeemerDataId -> ByteString -> ReaderT SqlBackend m () -upateRedeemerDataBytes rdmDataId bytes = update rdmDataId [RedeemerDataBytes =. bytes] - -updateScriptBytes :: MonadIO m => ScriptId -> ByteString -> ReaderT SqlBackend m () -updateScriptBytes scriptId bytes = update scriptId [ScriptBytes =. Just bytes] - -unValue2 :: (Value a, Value b) -> (a, b) -unValue2 (a, b) = (unValue a, unValue b) diff --git a/cardano-db/src/Cardano/Db/Version/V13_0/Schema.hs b/cardano-db/src/Cardano/Db/Version/V13_0/Schema.hs deleted file mode 100644 index d0efe77b6..000000000 --- a/cardano-db/src/Cardano/Db/Version/V13_0/Schema.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module Cardano.Db.Version.V13_0.Schema where - -import Cardano.Db.Schema.Orphans () -import Cardano.Db.Types (DbLovelace, DbWord64, ScriptType) -import Data.ByteString.Char8 (ByteString) -import Data.Int (Int64) -import Data.Text (Text) -import Data.Time.Clock (UTCTime) -import Data.Word (Word16, Word64) -import Database.Persist.Documentation (deriveShowFields) -import Database.Persist.TH - -share - [ mkPersist sqlSettings - , mkEntityDefList "entityDefs" - , deriveShowFields - ] - [persistLowerCase| - - Block - hash ByteString sqltype=hash32type - epochNo Word64 Maybe sqltype=word31type - slotNo Word64 Maybe sqltype=word63type - epochSlotNo Word64 Maybe sqltype=word31type - blockNo Word64 Maybe sqltype=word31type - previousId BlockId Maybe OnDeleteCascade - slotLeaderId SlotLeaderId noreference - size Word64 sqltype=word31type - time UTCTime sqltype=timestamp - txCount Word64 - protoMajor Word16 sqltype=word31type - protoMinor Word16 sqltype=word31type - -- Shelley specific - vrfKey Text Maybe - opCert ByteString Maybe sqltype=hash32type - opCertCounter Word64 Maybe sqltype=word63type - UniqueBlock hash - - SlotLeader - hash ByteString sqltype=hash28type - poolHashId PoolHashId Maybe noreference -- This will be non-null when a block is mined by a pool. - description Text -- Description of the Slots leader. - UniqueSlotLeader hash - - PoolHash - hashRaw ByteString sqltype=hash28type - view Text - UniquePoolHash hashRaw - - Tx - hash ByteString sqltype=hash32type - blockId BlockId OnDeleteCascade -- This type is the primary key for the 'block' table. - blockIndex Word64 sqltype=word31type -- The index of this transaction within the block. - outSum DbLovelace sqltype=lovelace - fee DbLovelace sqltype=lovelace - deposit Int64 -- Needs to allow negaitve values. - size Word64 sqltype=word31type - - -- New for Allega - invalidBefore DbWord64 Maybe sqltype=word64type - invalidHereafter DbWord64 Maybe sqltype=word64type - - -- New for Alonzo - validContract Bool -- False if the contract is invalid, True otherwise. - scriptSize Word64 sqltype=word31type - UniqueTx hash - - Datum - hash ByteString sqltype=hash32type - txId TxId OnDeleteCascade - value Text Maybe sqltype=jsonb - bytes ByteString sqltype=bytea - UniqueDatum hash - - RedeemerData - hash ByteString sqltype=hash32type - txId TxId OnDeleteCascade - value Text Maybe sqltype=jsonb - bytes ByteString sqltype=bytea - UniqueRedeemerData hash - - Script - txId TxId noreference - hash ByteString sqltype=hash28type - type ScriptType sqltype=scripttype - json Text Maybe sqltype=jsonb - bytes ByteString Maybe sqltype=bytea - serialisedSize Word64 Maybe sqltype=word31type - UniqueScript hash - - |] From 06edd1039172f2f8f66c564b7f6fcf35792cfcfa Mon Sep 17 00:00:00 2001 From: Cmdv Date: Fri, 10 Jan 2025 14:42:32 +0000 Subject: [PATCH 2/2] remove migration fix related code --- cardano-chain-gen/cardano-chain-gen.cabal | 12 +- .../src/Cardano/Mock/Forging/Tx/Babbage.hs | 2 +- cardano-chain-gen/src/Cardano/Mock/Query.hs | 4 +- cardano-chain-gen/test/Main.hs | 4 + .../test/Test/Cardano/Db/Mock/Config.hs | 6 - .../test/Test/Cardano/Db/Mock/Unit/Alonzo.hs | 43 ++ .../Cardano/Db/Mock/Unit/Alonzo/Plutus.hs | 467 ---------------- .../Db/Mock/Unit/Alonzo/PoolAndSmash.hs | 273 ---------- .../Cardano/Db/Mock/Unit/Alonzo/Reward.hs | 486 ----------------- .../Test/Cardano/Db/Mock/Unit/Alonzo/Stake.hs | 340 ------------ .../test/Test/Cardano/Db/Mock/Unit/Babbage.hs | 55 ++ .../Unit/Babbage/CommandLineArg/ConfigFile.hs | 20 - .../Babbage/CommandLineArg/EpochDisabled.hs | 50 -- .../Config/MigrateConsumedPruneTxOut.hs | 413 -------------- .../Db/Mock/Unit/Babbage/Config/Parse.hs | 41 -- .../Mock/Unit/Babbage/InlineAndReference.hs | 434 --------------- .../Cardano/Db/Mock/Unit/Babbage/Other.hs | 392 -------------- .../Cardano/Db/Mock/Unit/Babbage/Plutus.hs | 508 ------------------ .../Cardano/Db/Mock/Unit/Babbage/Rollback.hs | 257 --------- .../Cardano/Db/Mock/Unit/Babbage/Stake.hs | 340 ------------ cardano-db-sync/app/cardano-db-sync.hs | 25 +- cardano-db-sync/src/Cardano/DbSync.hs | 8 +- cardano-db-sync/src/Cardano/DbSync/Api.hs | 35 +- .../src/Cardano/DbSync/Api/Types.hs | 6 - .../src/Cardano/DbSync/Config/Types.hs | 2 - cardano-db-sync/src/Cardano/DbSync/Sync.hs | 48 +- cardano-db-sync/test/Cardano/DbSync/Gen.hs | 2 - cardano-db-tool/app/cardano-db-tool.hs | 22 +- cardano-db/src/Cardano/Db/Migration.hs | 7 +- 29 files changed, 146 insertions(+), 4156 deletions(-) create mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo.hs delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Plutus.hs delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/PoolAndSmash.hs delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Reward.hs delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Stake.hs create mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage.hs delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/CommandLineArg/ConfigFile.hs delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/CommandLineArg/EpochDisabled.hs delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Config/MigrateConsumedPruneTxOut.hs delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Config/Parse.hs delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/InlineAndReference.hs delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Other.hs delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Plutus.hs delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Rollback.hs delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Stake.hs diff --git a/cardano-chain-gen/cardano-chain-gen.cabal b/cardano-chain-gen/cardano-chain-gen.cabal index 1b3997b34..36a56c253 100644 --- a/cardano-chain-gen/cardano-chain-gen.cabal +++ b/cardano-chain-gen/cardano-chain-gen.cabal @@ -130,12 +130,21 @@ test-suite cardano-chain-gen other-modules: Test.Cardano.Db.Mock.Config Test.Cardano.Db.Mock.Examples Test.Cardano.Db.Mock.Property.Property + Test.Cardano.Db.Mock.UnifiedApi + Test.Cardano.Db.Mock.Unit.Alonzo + Test.Cardano.Db.Mock.Unit.Alonzo.Config + Test.Cardano.Db.Mock.Unit.Alonzo.Simple + Test.Cardano.Db.Mock.Unit.Alonzo.Tx + Test.Cardano.Db.Mock.Unit.Babbage + Test.Cardano.Db.Mock.Unit.Babbage.Reward + Test.Cardano.Db.Mock.Unit.Babbage.Simple + Test.Cardano.Db.Mock.Unit.Babbage.Tx Test.Cardano.Db.Mock.Unit.Conway Test.Cardano.Db.Mock.Unit.Conway.CommandLineArg.ConfigFile Test.Cardano.Db.Mock.Unit.Conway.CommandLineArg.EpochDisabled Test.Cardano.Db.Mock.Unit.Conway.Config.JsonbInSchema - Test.Cardano.Db.Mock.Unit.Conway.Config.Parse Test.Cardano.Db.Mock.Unit.Conway.Config.MigrateConsumedPruneTxOut + Test.Cardano.Db.Mock.Unit.Conway.Config.Parse Test.Cardano.Db.Mock.Unit.Conway.Governance Test.Cardano.Db.Mock.Unit.Conway.InlineAndReference Test.Cardano.Db.Mock.Unit.Conway.Other @@ -145,7 +154,6 @@ test-suite cardano-chain-gen Test.Cardano.Db.Mock.Unit.Conway.Simple Test.Cardano.Db.Mock.Unit.Conway.Stake Test.Cardano.Db.Mock.Unit.Conway.Tx - Test.Cardano.Db.Mock.UnifiedApi Test.Cardano.Db.Mock.Validate build-depends: aeson diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Babbage.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Babbage.hs index f3dcd1156..af2a8d068 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Babbage.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Babbage.hs @@ -462,7 +462,7 @@ mkUTxOBabbage :: AlonzoTx StandardBabbage -> [(TxIn StandardCrypto, BabbageTxOut mkUTxOBabbage = mkUTxOAlonzo mkUTxOCollBabbage :: - (BabbageEraTxBody era) => + BabbageEraTxBody era => AlonzoTx era -> [(TxIn (EraCrypto era), TxOut era)] mkUTxOCollBabbage tx = Map.toList $ unUTxO $ collOuts $ getField @"body" tx diff --git a/cardano-chain-gen/src/Cardano/Mock/Query.hs b/cardano-chain-gen/src/Cardano/Mock/Query.hs index 46c645408..1d82cde64 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Query.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Query.hs @@ -199,7 +199,9 @@ queryVoteCounts txHash idx = do `innerJoin` table @Db.Tx `on` (\(vote :& tx) -> vote ^. Db.VotingProcedureTxId ==. tx ^. Db.TxId) where_ $ - vote ^. Db.VotingProcedureVote ==. val v + vote + ^. Db.VotingProcedureVote + ==. val v &&. tx ^. Db.TxHash ==. val txHash &&. vote ^. Db.VotingProcedureIndex ==. val idx pure countRows diff --git a/cardano-chain-gen/test/Main.hs b/cardano-chain-gen/test/Main.hs index 034615d02..9a9e4ffda 100644 --- a/cardano-chain-gen/test/Main.hs +++ b/cardano-chain-gen/test/Main.hs @@ -7,6 +7,8 @@ import System.Directory (getCurrentDirectory) import System.Environment (lookupEnv, setEnv) import System.FilePath (()) import qualified Test.Cardano.Db.Mock.Property.Property as Property +import qualified Test.Cardano.Db.Mock.Unit.Alonzo as Alonzo +import qualified Test.Cardano.Db.Mock.Unit.Babbage as Babbage import qualified Test.Cardano.Db.Mock.Unit.Conway as Conway import Test.Tasty import Test.Tasty.QuickCheck (testProperty) @@ -28,6 +30,8 @@ tests iom = do testGroup "cardano-chain-gen" [ Conway.unitTests iom knownMigrationsPlain + , Babbage.unitTests iom knownMigrationsPlain + , Alonzo.unitTests iom knownMigrationsPlain , testProperty "QSM" $ Property.prop_empty_blocks iom knownMigrationsPlain ] where diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs index e9414732a..759a7c5fc 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs @@ -122,8 +122,6 @@ data CommandLineArgs = CommandLineArgs , claEpochDisabled :: Bool , claHasCache :: Bool , claHasLedger :: Bool - , claSkipFix :: Bool - , claOnlyFix :: Bool , claForceIndexes :: Bool , claHasMultiAssets :: Bool , claHasMetadata :: Bool @@ -286,8 +284,6 @@ mkSyncNodeParams staticDir mutableDir CommandLineArgs {..} = do , enpPGPassSource = DB.PGPassCached pgconfig , enpEpochDisabled = claEpochDisabled , enpHasCache = claHasCache - , enpSkipFix = claSkipFix - , enpOnlyFix = claOnlyFix , enpForceIndexes = claForceIndexes , enpHasInOut = True , enpSnEveryFollowing = 35 @@ -361,8 +357,6 @@ initCommandLineArgs = , claEpochDisabled = True , claHasCache = True , claHasLedger = True - , claSkipFix = True - , claOnlyFix = False , claForceIndexes = False , claHasMultiAssets = True , claHasMetadata = True diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo.hs new file mode 100644 index 000000000..21413ffe6 --- /dev/null +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test.Cardano.Db.Mock.Unit.Alonzo ( + unitTests, +) where + +import Cardano.Mock.ChainSync.Server (IOManager) +import Data.Text (Text) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, testCase) + +import qualified Test.Cardano.Db.Mock.Unit.Alonzo.Config as AlzConfig +import qualified Test.Cardano.Db.Mock.Unit.Alonzo.Simple as AlzSimple +import qualified Test.Cardano.Db.Mock.Unit.Alonzo.Tx as AlzTx + +{- HLINT ignore "Reduce duplication" -} + +unitTests :: IOManager -> [(Text, Text)] -> TestTree +unitTests iom knownMigrations = + testGroup + "Alonzo unit tests" + [ testGroup + "config" + [ testCase "default insert config" AlzConfig.defaultInsertConfig + , testCase "insert config" AlzConfig.insertConfig + ] + , testGroup + "simple" + [ test "simple forge blocks" AlzSimple.forgeBlocks + , test "sync one block" AlzSimple.addSimple + , test "restart db-sync" AlzSimple.restartDBSync + , test "sync small chain" AlzSimple.addSimpleChain + ] + , testGroup + "blocks with txs" + [ test "simple tx" AlzTx.addSimpleTx + , test "consume utxo same block" AlzTx.consumeSameBlock + ] + ] + where + test :: String -> (IOManager -> [(Text, Text)] -> Assertion) -> TestTree + test str action = testCase str (action iom knownMigrations) diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Plutus.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Plutus.hs deleted file mode 100644 index c066fc90c..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Plutus.hs +++ /dev/null @@ -1,467 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeApplications #-} - -#if __GLASGOW_HASKELL__ >= 908 -{-# OPTIONS_GHC -Wno-x-partial #-} -#endif - -module Test.Cardano.Db.Mock.Unit.Alonzo.Plutus ( - -- plutus spend scripts - simpleScript, - unlockScriptSameBlock, - failedScript, - failedScriptSameBlock, - multipleScripts, - multipleScriptsSameBlock, - multipleScriptsFailed, - multipleScriptsFailedSameBlock, - -- plutus cert scripts - registrationScriptTx, - deregistrationScriptTx, - deregistrationsScriptTxs, - deregistrationsScriptTx, - deregistrationsScriptTx', - deregistrationsScriptTx'', - -- plutus multiAsset scripts - mintMultiAsset, - mintMultiAssets, - swapMultiAssets, -) where - -import qualified Cardano.Crypto.Hash as Crypto -import Cardano.Db (TxOutTableType (..)) -import qualified Cardano.Db as DB -import qualified Cardano.Db.Schema.Core.TxOut as C -import qualified Cardano.Db.Schema.Variant.TxOut as V -import Cardano.DbSync.Era.Shelley.Generic.Util (renderAddress) -import Cardano.Ledger.Coin -import Cardano.Ledger.Mary.Value (MaryValue (..), MultiAsset (..), PolicyID (..)) -import Cardano.Ledger.Plutus.Data (hashData) -import Cardano.Ledger.SafeHash (extractHash) -import Cardano.Ledger.Shelley.TxCert -import Cardano.Mock.ChainSync.Server (IOManager) -import Cardano.Mock.Forging.Interpreter (withAlonzoLedgerState) -import qualified Cardano.Mock.Forging.Tx.Alonzo as Alonzo -import Cardano.Mock.Forging.Tx.Alonzo.ScriptsExamples ( - alwaysMintScriptAddr, - alwaysMintScriptHash, - alwaysSucceedsScriptAddr, - alwaysSucceedsScriptHash, - assetNames, - plutusDataList, - ) -import Cardano.Mock.Forging.Types ( - MockBlock (..), - NodeId (..), - StakeIndex (..), - TxEra (..), - UTxOIndex (..), - ) -import Control.Monad (void) -import qualified Data.Map as Map -import Data.Text (Text) -import Ouroboros.Consensus.Cardano.Block (StandardAlonzo) -import Test.Cardano.Db.Mock.Config (alonzoConfigDir, startDBSync, withFullConfig, withFullConfigAndDropDB) -import Test.Cardano.Db.Mock.UnifiedApi ( - fillUntilNextEpoch, - forgeNextAndSubmit, - registerAllStakeCreds, - withAlonzoFindLeaderAndSubmit, - withAlonzoFindLeaderAndSubmitTx, - ) -import Test.Cardano.Db.Mock.Validate ( - assertAlonzoCounts, - assertBlockNoBackoff, - assertEqQuery, - assertScriptCert, - ) -import Test.Tasty.HUnit (Assertion) - ----------------------------------------------------------------------------------------------------------- --- Plutus Spend Scripts ----------------------------------------------------------------------------------------------------------- -simpleScript :: IOManager -> [(Text, Text)] -> Assertion -simpleScript = - withFullConfigAndDropDB alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - a <- fillUntilNextEpoch interpreter mockServer - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkLockByScriptTx (UTxOIndex 0) [True] 20000 20000 - - assertBlockNoBackoff dbSync (fromIntegral $ length a + 2) - assertEqQuery dbSync (fmap getOutFields <$> DB.queryScriptOutputs TxOutCore) [expectedFields] "Unexpected script outputs" - where - testLabel = "simpleScript-alonzo" - getOutFields txOutW = case txOutW of - DB.CTxOutW txOut -> - ( C.txOutAddress txOut - , C.txOutAddressHasScript txOut - , C.txOutValue txOut - , C.txOutDataHash txOut - ) - DB.VTxOutW txout mAddress -> case mAddress of - Just address -> - ( V.addressAddress address - , V.addressHasScript address - , V.txOutValue txout - , V.txOutDataHash txout - ) - Nothing -> error "AlonzoSimpleScript: expected an address" - expectedFields = - ( renderAddress alwaysSucceedsScriptAddr - , True - , DB.DbLovelace 20000 - , Just $ Crypto.hashToBytes (extractHash $ hashData @StandardAlonzo plutusDataList) - ) - -_unlockScript :: IOManager -> [(Text, Text)] -> Assertion -_unlockScript = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - -- We don't use withAlonzoFindLeaderAndSubmitTx here, because we want access to the tx. - tx0 <- withAlonzoLedgerState interpreter $ Alonzo.mkLockByScriptTx (UTxOIndex 0) [True] 20000 20000 - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx0] (NodeId 1) - - let utxo0 = head (Alonzo.mkUTxOAlonzo tx0) - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) True 10000 500 - - assertBlockNoBackoff dbSync 3 - assertAlonzoCounts dbSync (1, 1, 1, 1, 1, 1, 0, 0) - where - testLabel = "unlockScript-alonzo" - -unlockScriptSameBlock :: IOManager -> [(Text, Text)] -> Assertion -unlockScriptSameBlock = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Alonzo.mkLockByScriptTx (UTxOIndex 0) [True] 20000 20000 st - let utxo0 = head (Alonzo.mkUTxOAlonzo tx0) - tx1 <- Alonzo.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) True 10000 500 st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 2 - assertAlonzoCounts dbSync (1, 1, 1, 1, 1, 1, 0, 0) - where - testLabel = "unlockScriptSameBlock-alonzo" - -failedScript :: IOManager -> [(Text, Text)] -> Assertion -failedScript = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - tx0 <- withAlonzoLedgerState interpreter $ Alonzo.mkLockByScriptTx (UTxOIndex 0) [False] 20000 20000 - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx0] (NodeId 1) - - let utxo0 = head (Alonzo.mkUTxOAlonzo tx0) - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) False 10000 500 - - assertBlockNoBackoff dbSync 2 - assertAlonzoCounts dbSync (0, 0, 0, 0, 1, 0, 1, 1) - where - testLabel = "failedScript-alonzo" - -failedScriptSameBlock :: IOManager -> [(Text, Text)] -> Assertion -failedScriptSameBlock = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Alonzo.mkLockByScriptTx (UTxOIndex 0) [False] 20000 20000 st - let utxo0 = head (Alonzo.mkUTxOAlonzo tx0) - tx1 <- Alonzo.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) False 10000 500 st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 2 - assertAlonzoCounts dbSync (0, 0, 0, 0, 1, 0, 1, 1) - where - testLabel = "failedScriptSameBlock-alonzo" - -multipleScripts :: IOManager -> [(Text, Text)] -> Assertion -multipleScripts = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - tx0 <- withAlonzoLedgerState interpreter $ Alonzo.mkLockByScriptTx (UTxOIndex 0) [True, False, True] 20000 20000 - let utxo = Alonzo.mkUTxOAlonzo tx0 - pair1 = head utxo - pair2 = utxo !! 2 - tx1 <- - withAlonzoLedgerState interpreter $ - Alonzo.mkUnlockScriptTx [UTxOPair pair1, UTxOPair pair2] (UTxOIndex 1) (UTxOIndex 2) True 10000 500 - - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx0] (NodeId 1) - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx1] (NodeId 1) - - assertBlockNoBackoff dbSync 2 - assertAlonzoCounts dbSync (1, 2, 1, 1, 3, 2, 0, 0) - where - testLabel = "multipleScripts-alonzo" - -multipleScriptsSameBlock :: IOManager -> [(Text, Text)] -> Assertion -multipleScriptsSameBlock = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Alonzo.mkLockByScriptTx (UTxOIndex 0) [True, False, True] 20000 20000 st - let utxo = Alonzo.mkUTxOAlonzo tx0 - pair1 = head utxo - pair2 = utxo !! 2 - tx1 <- Alonzo.mkUnlockScriptTx [UTxOPair pair1, UTxOPair pair2] (UTxOIndex 1) (UTxOIndex 2) True 10000 500 st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertAlonzoCounts dbSync (1, 2, 1, 1, 3, 2, 0, 0) - where - testLabel = "multipleScriptsSameBlock-alonzo" - -multipleScriptsFailed :: IOManager -> [(Text, Text)] -> Assertion -multipleScriptsFailed = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - tx0 <- withAlonzoLedgerState interpreter $ Alonzo.mkLockByScriptTx (UTxOIndex 0) [True, False, True] 20000 20000 - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx0] (NodeId 1) - - let utxos = Alonzo.mkUTxOAlonzo tx0 - tx1 <- - withAlonzoLedgerState interpreter $ - Alonzo.mkUnlockScriptTx (UTxOPair <$> [head utxos, utxos !! 1, utxos !! 2]) (UTxOIndex 1) (UTxOIndex 2) False 10000 500 - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx1] (NodeId 1) - - assertBlockNoBackoff dbSync 2 - assertAlonzoCounts dbSync (0, 0, 0, 0, 3, 0, 1, 1) - where - testLabel = "multipleScriptsFailed-alonzo" - -multipleScriptsFailedSameBlock :: IOManager -> [(Text, Text)] -> Assertion -multipleScriptsFailedSameBlock = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Alonzo.mkLockByScriptTx (UTxOIndex 0) [True, False, True] 20000 20000 st - - let utxos = tail $ Alonzo.mkUTxOAlonzo tx0 - tx1 <- Alonzo.mkUnlockScriptTx (UTxOPair <$> [head utxos, utxos !! 1, utxos !! 2]) (UTxOIndex 1) (UTxOIndex 2) False 10000 500 st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertAlonzoCounts dbSync (0, 0, 0, 0, 3, 0, 1, 1) - where - testLabel = "multipleScriptsFailedSameBlock-alonzo" - ----------------------------------------------------------------------------------------------------------- --- Plutus Cert Scripts ----------------------------------------------------------------------------------------------------------- - -registrationScriptTx :: IOManager -> [(Text, Text)] -> Assertion -registrationScriptTx = - withFullConfigAndDropDB alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] - assertBlockNoBackoff dbSync 1 - assertScriptCert dbSync (0, 0, 0, 1) - where - testLabel = "registrationScriptTx-alonzo" - -deregistrationScriptTx :: IOManager -> [(Text, Text)] -> Assertion -deregistrationScriptTx = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Alonzo.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx1 <- Alonzo.mkScriptDCertTx [(StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert)] True st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertScriptCert dbSync (1, 0, 0, 1) - where - testLabel = "deregistrationScriptTx-alonzo" - -deregistrationsScriptTxs :: IOManager -> [(Text, Text)] -> Assertion -deregistrationsScriptTxs = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Alonzo.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx1 <- Alonzo.mkScriptDCertTx [(StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert)] True st - tx2 <- Alonzo.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx3 <- Alonzo.mkScriptDCertTx [(StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert)] True st - pure [tx0, tx1, Alonzo.addValidityInterval 1000 tx2, Alonzo.addValidityInterval 2000 tx3] - - assertBlockNoBackoff dbSync 1 - assertScriptCert dbSync (2, 0, 0, 1) - assertAlonzoCounts dbSync (1, 2, 1, 0, 0, 0, 0, 0) - where - testLabel = "deregistrationsScriptTxs-alonzo" - -deregistrationsScriptTx :: IOManager -> [(Text, Text)] -> Assertion -deregistrationsScriptTx = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Alonzo.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx1 <- - Alonzo.mkScriptDCertTx - [ (StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert) - , (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyRegCert) - , (StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert) - ] - True - st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertScriptCert dbSync (2, 0, 0, 1) - assertAlonzoCounts dbSync (1, 2, 1, 0, 0, 0, 0, 0) - where - testLabel = "deregistrationsScriptTx-alonzo" - --- Like previous but missing a redeemer. This is a known ledger issue -deregistrationsScriptTx' :: IOManager -> [(Text, Text)] -> Assertion -deregistrationsScriptTx' = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Alonzo.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx1 <- - Alonzo.mkScriptDCertTx - [ (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyUnRegCert) - , (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyRegCert) - , (StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert) - ] - True - st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - -- TODO: This is a bug! The first field should be 2. However the deregistrations - -- are missing the redeemers - assertScriptCert dbSync (0, 0, 0, 1) - assertAlonzoCounts dbSync (1, 1, 1, 0, 0, 0, 0, 0) - where - testLabel = "deregistrationsScriptTx'-alonzo" - --- Like previous but missing the other redeemer. This is a known ledger issue -deregistrationsScriptTx'' :: IOManager -> [(Text, Text)] -> Assertion -deregistrationsScriptTx'' = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Alonzo.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx1 <- - Alonzo.mkScriptDCertTx - [ (StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert) - , (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyRegCert) - , (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyUnRegCert) - ] - True - st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertScriptCert dbSync (2, 0, 0, 1) - assertAlonzoCounts dbSync (1, 1, 1, 0, 0, 0, 0, 0) - where - testLabel = "deregistrationsScriptTx''-alonzo" - ----------------------------------------------------------------------------------------------------------- --- Plutus MultiAsset Scripts ----------------------------------------------------------------------------------------------------------- - -mintMultiAsset :: IOManager -> [(Text, Text)] -> Assertion -mintMultiAsset = - withFullConfigAndDropDB alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \st -> do - let val0 = MultiAsset $ Map.singleton (PolicyID alwaysMintScriptHash) (Map.singleton (head assetNames) 1) - Alonzo.mkMAssetsScriptTx [UTxOIndex 0] (UTxOIndex 1) [(UTxOAddressNew 0, MaryValue (Coin 10000) mempty)] val0 True 100 st - - assertBlockNoBackoff dbSync 1 - assertAlonzoCounts dbSync (1, 1, 1, 1, 0, 0, 0, 0) - where - testLabel = "mintMultiAsset-alonzo" - -mintMultiAssets :: IOManager -> [(Text, Text)] -> Assertion -mintMultiAssets = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - let assets0 = Map.fromList [(head assetNames, 10), (assetNames !! 1, 4)] - let policy0 = PolicyID alwaysMintScriptHash - let policy1 = PolicyID alwaysSucceedsScriptHash - let val1 = MultiAsset $ Map.fromList [(policy0, assets0), (policy1, assets0)] - tx0 <- Alonzo.mkMAssetsScriptTx [UTxOIndex 0] (UTxOIndex 1) [(UTxOAddressNew 0, MaryValue (Coin 10000) mempty)] val1 True 100 st - tx1 <- Alonzo.mkMAssetsScriptTx [UTxOIndex 2] (UTxOIndex 3) [(UTxOAddressNew 0, MaryValue (Coin 10000) mempty)] val1 True 200 st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertAlonzoCounts dbSync (2, 4, 1, 2, 0, 0, 0, 0) - where - testLabel = "mintMultiAssets-alonzo" - -swapMultiAssets :: IOManager -> [(Text, Text)] -> Assertion -swapMultiAssets = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - let assetsMinted0 = Map.fromList [(head assetNames, 10), (assetNames !! 1, 4)] - let policy0 = PolicyID alwaysMintScriptHash - let policy1 = PolicyID alwaysSucceedsScriptHash - let mintValue0 = MultiAsset $ Map.fromList [(policy0, assetsMinted0), (policy1, assetsMinted0)] - let assets0 = Map.fromList [(head assetNames, 5), (assetNames !! 1, 2)] - let outValue0 = MaryValue (Coin 20) $ MultiAsset $ Map.fromList [(policy0, assets0), (policy1, assets0)] - - tx0 <- - Alonzo.mkMAssetsScriptTx - [UTxOIndex 0] - (UTxOIndex 1) - [(UTxOAddress alwaysSucceedsScriptAddr, outValue0), (UTxOAddress alwaysMintScriptAddr, outValue0)] - mintValue0 - True - 100 - st - - let utxos = Alonzo.mkUTxOAlonzo tx0 - tx1 <- - Alonzo.mkMAssetsScriptTx - [UTxOPair (head utxos), UTxOPair (utxos !! 1), UTxOIndex 2] - (UTxOIndex 3) - [ (UTxOAddress alwaysSucceedsScriptAddr, outValue0) - , (UTxOAddress alwaysMintScriptAddr, outValue0) - , (UTxOAddressNew 0, outValue0) - , (UTxOAddressNew 0, outValue0) - ] - mintValue0 - True - 200 - st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertAlonzoCounts dbSync (2, 6, 1, 2, 4, 2, 0, 0) - where - testLabel = "swapMultiAssets-alonzo" diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/PoolAndSmash.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/PoolAndSmash.hs deleted file mode 100644 index 42cc82004..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/PoolAndSmash.hs +++ /dev/null @@ -1,273 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} - -module Test.Cardano.Db.Mock.Unit.Alonzo.PoolAndSmash ( - poolReg, - nonexistantPoolQuery, - poolDeReg, - poolDeRegMany, - poolDelist, -) where - -import Cardano.DbSync.Era.Shelley.Generic.Util (unKeyHashRaw) -import Cardano.Ledger.BaseTypes (EpochNo) -import Cardano.Ledger.Credential (StakeCredential) -import Cardano.Ledger.Keys (KeyHash, KeyRole (StakePool)) -import Cardano.Ledger.Shelley.TxCert -import Cardano.Mock.ChainSync.Server (IOManager) -import qualified Cardano.Mock.Forging.Tx.Alonzo as Alonzo -import Cardano.Mock.Forging.Tx.Generic (resolvePool) -import Cardano.Mock.Forging.Types (PoolIndex (..), StakeIndex (..)) -import Cardano.SMASH.Server.PoolDataLayer (PoolDataLayer (..), dbToServantPoolId) -import Cardano.SMASH.Server.Types (DBFail (RecordDoesNotExist)) -import Cardano.Slotting.Slot (EpochNo (..)) -import Control.Monad (void) -import Data.Text (Text) -import Ouroboros.Consensus.Cardano.Block (StandardAlonzo, StandardCrypto) -import Test.Cardano.Db.Mock.Config ( - alonzoConfigDir, - getPoolLayer, - startDBSync, - withFullConfig, - withFullConfigAndDropDB, - ) -import Test.Cardano.Db.Mock.UnifiedApi ( - fillUntilNextEpoch, - forgeNextFindLeaderAndSubmit, - getAlonzoLedgerState, - withAlonzoFindLeaderAndSubmit, - withAlonzoFindLeaderAndSubmitTx, - ) -import Test.Cardano.Db.Mock.Validate ( - addPoolCounters, - assertBlockNoBackoff, - assertPoolCounters, - assertPoolLayerCounters, - poolCountersQuery, - runQuery, - ) -import Test.Tasty.HUnit (Assertion, assertEqual) - -poolReg :: IOManager -> [(Text, Text)] -> Assertion -poolReg = - withFullConfigAndDropDB alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 1 - initCounter <- runQuery dbSync poolCountersQuery - assertEqual "Unexpected init pool counter" (3, 0, 3, 2, 0, 0) initCounter - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkDCertPoolTx - [ - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Alonzo.consPoolParamsTwoOwners - ) - ] - - assertBlockNoBackoff dbSync 2 - assertPoolCounters dbSync (addPoolCounters (1, 1, 1, 2, 0, 1) initCounter) - st <- getAlonzoLedgerState interpreter - assertPoolLayerCounters dbSync (0, 0) [(PoolIndexNew 0, (Right False, False, True))] st - where - testLabel = "poolReg-alonzo" - --- Issue https://github.com/IntersectMBO/cardano-db-sync/issues/997 -nonexistantPoolQuery :: IOManager -> [(Text, Text)] -> Assertion -nonexistantPoolQuery = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 1 - - st <- getAlonzoLedgerState interpreter - assertPoolLayerCounters dbSync (0, 0) [(PoolIndexNew 0, (Left RecordDoesNotExist, False, False))] st - where - testLabel = "nonexistantPoolQuery-alonzo" - -poolDeReg :: IOManager -> [(Text, Text)] -> Assertion -poolDeReg = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 1 - initCounter <- runQuery dbSync poolCountersQuery - assertEqual "Unexpected init pool counter" (3, 0, 3, 2, 0, 0) initCounter - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkDCertPoolTx - [ - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Alonzo.consPoolParamsTwoOwners - ) - , ([], PoolIndexNew 0, \_ poolId -> ShelleyTxCertPool $ RetirePool poolId (EpochNo 1)) - ] - - assertBlockNoBackoff dbSync 2 - assertPoolCounters dbSync (addPoolCounters (1, 1, 1, 2, 1, 1) initCounter) - - st <- getAlonzoLedgerState interpreter - -- Not retired yet, because epoch has not changed - assertPoolLayerCounters dbSync (0, 0) [(PoolIndexNew 0, (Right False, False, True))] st - - -- change epoch - a <- fillUntilNextEpoch interpreter mockServer - - assertBlockNoBackoff dbSync (fromIntegral $ length a + 2) - -- these counters are the same - assertPoolCounters dbSync (addPoolCounters (1, 1, 1, 2, 1, 1) initCounter) - - -- the pool is now retired, since the epoch changed. - assertPoolLayerCounters dbSync (1, 0) [(PoolIndexNew 0, (Right True, False, False))] st - where - testLabel = "poolDeReg-alonzo" - -poolDeRegMany :: IOManager -> [(Text, Text)] -> Assertion -poolDeRegMany = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 1 - initCounter <- runQuery dbSync poolCountersQuery - assertEqual "Unexpected init pool counter" (3, 0, 3, 2, 0, 0) initCounter - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkDCertPoolTx - [ -- register - - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Alonzo.consPoolParamsTwoOwners - ) - , -- de register - ([], PoolIndexNew 0, mkPoolDereg (EpochNo 4)) - , -- register - - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Alonzo.consPoolParamsTwoOwners - ) - , -- register with different owner and reward address - - ( [StakeIndexNew 2, StakeIndexNew 1, StakeIndexNew 0] - , PoolIndexNew 0 - , Alonzo.consPoolParamsTwoOwners - ) - ] - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- - Alonzo.mkDCertPoolTx - [ -- register - - ( [StakeIndexNew 2, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Alonzo.consPoolParamsTwoOwners - ) - ] - st - - tx1 <- - Alonzo.mkDCertPoolTx - [ -- deregister - ([] :: [StakeIndex], PoolIndexNew 0, mkPoolDereg (EpochNo 4)) - , -- register - - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Alonzo.consPoolParamsTwoOwners - ) - , -- deregister - ([] :: [StakeIndex], PoolIndexNew 0, mkPoolDereg (EpochNo 1)) - ] - st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 3 - -- TODO fix PoolOwner and PoolRelay unique key - assertPoolCounters dbSync (addPoolCounters (1, 5, 5, 10, 3, 5) initCounter) - - st <- getAlonzoLedgerState interpreter - -- Not retired yet, because epoch has not changed - assertPoolLayerCounters dbSync (0, 0) [(PoolIndexNew 0, (Right False, False, True))] st - - -- change epoch - a <- fillUntilNextEpoch interpreter mockServer - - assertBlockNoBackoff dbSync (fromIntegral $ length a + 3) - -- these counters are the same - assertPoolCounters dbSync (addPoolCounters (1, 5, 5, 10, 3, 5) initCounter) - - -- from all these certificates only the latest matters. So it will retire - -- on epoch 0 - assertPoolLayerCounters dbSync (1, 0) [(PoolIndexNew 0, (Right True, False, False))] st - where - testLabel = "poolDeRegMany-alonzo" - mkPoolDereg :: - EpochNo -> - [StakeCredential StandardCrypto] -> - KeyHash 'StakePool StandardCrypto -> - ShelleyTxCert StandardAlonzo - mkPoolDereg epochNo _creds keyHash = ShelleyTxCertPool $ RetirePool keyHash epochNo - -poolDelist :: IOManager -> [(Text, Text)] -> Assertion -poolDelist = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 1 - initCounter <- runQuery dbSync poolCountersQuery - assertEqual "Unexpected init pool counter" (3, 0, 3, 2, 0, 0) initCounter - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkDCertPoolTx - [ - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Alonzo.consPoolParamsTwoOwners - ) - ] - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 3 - st <- getAlonzoLedgerState interpreter - assertPoolLayerCounters dbSync (0, 0) [(PoolIndexNew 0, (Right False, False, True))] st - - let poolKeyHash = resolvePool (PoolIndexNew 0) st - let poolId = dbToServantPoolId $ unKeyHashRaw poolKeyHash - poolLayer <- getPoolLayer dbSync - void $ dlAddDelistedPool poolLayer poolId - - -- This is not async, so we don't need to do exponential backoff - -- delisted not retired - assertPoolLayerCounters dbSync (0, 1) [(PoolIndexNew 0, (Right False, True, True))] st - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkDCertPoolTx - [([], PoolIndexNew 0, \_ poolHash -> ShelleyTxCertPool $ RetirePool poolHash (EpochNo 1))] - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 5 - -- delisted and pending retirement - assertPoolLayerCounters dbSync (0, 1) [(PoolIndexNew 0, (Right False, True, True))] st - - a <- fillUntilNextEpoch interpreter mockServer - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync (fromIntegral $ 5 + length a + 1) - -- delisted and retired - assertPoolLayerCounters dbSync (1, 1) [(PoolIndexNew 0, (Right True, True, False))] st - where - testLabel = "poolDelist-alonzo" diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Reward.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Reward.hs deleted file mode 100644 index 9f8067e04..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Reward.hs +++ /dev/null @@ -1,486 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Cardano.Db.Mock.Unit.Alonzo.Reward ( - simpleRewards, - rewardsDeregistration, - rewardsReregistration, - mirReward, - mirRewardRollback, - mirRewardDereg, - rollbackBoundary, - singleMIRCertMultiOut, -) where - -import Cardano.Ledger.Coin (Coin (Coin), DeltaCoin (DeltaCoin)) -import Cardano.Ledger.Keys (KeyHash (KeyHash)) -import Cardano.Ledger.Shelley.TxBody (Withdrawals (Withdrawals)) -import Cardano.Ledger.Shelley.TxCert -import Cardano.Mock.ChainSync.Server (IOManager, addBlock, rollback) -import qualified Cardano.Mock.Forging.Tx.Alonzo as Alonzo -import Cardano.Mock.Forging.Tx.Alonzo.Scenarios (delegateAndSendBlocks) -import Cardano.Mock.Forging.Tx.Generic (resolvePool, resolveStakeCreds) -import Cardano.Mock.Forging.Types ( - PoolIndex (PoolIndex, PoolIndexId), - StakeIndex ( - StakeIndex, - StakeIndexNew, - StakeIndexPoolLeader, - StakeIndexPoolMember - ), - UTxOIndex (UTxOAddressNewWithStake, UTxOIndex), - ) -import Control.Concurrent.Class.MonadSTM.Strict (MonadSTM (atomically)) -import Control.Monad (forM_, void) -import qualified Data.Map as Map -import Data.Text (Text) -import Ouroboros.Network.Block (blockPoint) -import Test.Cardano.Db.Mock.Config ( - alonzoConfigDir, - startDBSync, - stopDBSync, - withFullConfig, - withFullConfigAndDropDB, - ) -import Test.Cardano.Db.Mock.UnifiedApi ( - fillEpochPercentage, - fillEpochs, - fillUntilNextEpoch, - forgeAndSubmitBlocks, - getAlonzoLedgerState, - registerAllStakeCreds, - skipUntilNextEpoch, - withAlonzoFindLeaderAndSubmit, - withAlonzoFindLeaderAndSubmitTx, - ) -import Test.Cardano.Db.Mock.Validate (assertBlockNoBackoff, assertRewardCount, assertRewardCounts, assertRewardRestCount) -import Test.Tasty.HUnit (Assertion) - -simpleRewards :: IOManager -> [(Text, Text)] -> Assertion -simpleRewards = - withFullConfigAndDropDB alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - -- Pools are not registered yet, this takes 2 epochs. So fees of this tx - -- should not create any rewards. - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 2) (UTxOIndex 1) 10000 10000 - - a <- fillEpochs interpreter mockServer 3 - assertBlockNoBackoff dbSync (fromIntegral $ 2 + length a) - - -- The pool leaders take leader rewards with value 0 - assertRewardCount dbSync 3 - - st <- getAlonzoLedgerState interpreter - -- False indicates that we provide the full expected list of addresses with rewards. - assertRewardCounts - dbSync - st - False - (Just 3) - [ (StakeIndexPoolLeader (PoolIndex 0), (1, 0, 0, 0, 0)) - , (StakeIndexPoolLeader (PoolIndex 1), (1, 0, 0, 0, 0)) - , (StakeIndexPoolLeader (PoolIndex 2), (1, 0, 0, 0, 0)) - ] - - -- Now that pools are registered, we add a tx to fill the fees pot. - -- Rewards will be distributed. - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 2) (UTxOIndex 1) 10000 10000 - - b <- fillEpochs interpreter mockServer 2 - - assertBlockNoBackoff dbSync (fromIntegral $ 1 + length a + 2 + length b) - assertRewardCount dbSync 14 - assertRewardCounts - dbSync - st - True - (Just 5) - -- 2 pool leaders also delegate to pools. - [ (StakeIndexPoolLeader (PoolIndexId $ KeyHash "9f1b441b9b781b3c3abb43b25679dc17dbaaf116dddca1ad09dc1de0"), (1, 0, 0, 0, 0)) - , (StakeIndexPoolLeader (PoolIndexId $ KeyHash "5af582399de8c226391bfd21424f34d0b053419c4d93975802b7d107"), (1, 1, 0, 0, 0)) - , (StakeIndexPoolLeader (PoolIndexId $ KeyHash "58eef2925db2789f76ea057c51069e52c5e0a44550f853c6cdf620f8"), (1, 1, 0, 0, 0)) - , (StakeIndexPoolMember 0 (PoolIndex 0), (0, 1, 0, 0, 0)) - , (StakeIndexPoolMember 0 (PoolIndex 1), (0, 1, 0, 0, 0)) - ] - where - testLabel = "simpleRewards-alonzo" - -rewardsDeregistration :: IOManager -> [(Text, Text)] -> Assertion -rewardsDeregistration = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkDepositTxPools (UTxOIndex 1) 20000 - - -- first move to treasury from reserves - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \_ -> - Alonzo.mkDCertTx [ShelleyTxCertMir $ MIRCert ReservesMIR (SendToOppositePotMIR (Coin 100000))] (Withdrawals mempty) - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - -- register the stake address and delegate to a pool - let poolId = resolvePool (PoolIndex 0) st - tx1 <- - Alonzo.mkSimpleDCertTx - [ (StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert) - , (StakeIndexNew 1, \stCred -> ShelleyTxCertDelegCert $ ShelleyDelegCert stCred poolId) - ] - st - -- send some funds to the address so - tx2 <- Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOAddressNewWithStake 0 (StakeIndexNew 1)) 100000 5000 st - Right [tx1, tx2] - - a <- fillEpochs interpreter mockServer 3 - assertBlockNoBackoff dbSync (fromIntegral $ 3 + length a) - - st <- getAlonzoLedgerState interpreter - - -- Now that pools are registered, we add a tx to fill the fees pot. - -- Rewards will be distributed. - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 - - b <- fillEpochs interpreter mockServer 2 - - assertBlockNoBackoff dbSync (fromIntegral $ 4 + length a + length b) - assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0, 1, 0, 0, 0))] - - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 1) (UTxOIndex 0) 10000 10000 - - c <- fillEpochs interpreter mockServer 2 - - assertBlockNoBackoff dbSync (fromIntegral $ 5 + length a + length b + length c) - assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0, 2, 0, 0, 0))] - - d <- fillEpochs interpreter mockServer 1 - e <- fillEpochPercentage interpreter mockServer 85 - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert)] - - f <- fillUntilNextEpoch interpreter mockServer - - assertBlockNoBackoff dbSync (fromIntegral $ 6 + length (a <> b <> c <> d <> e <> f)) - -- stays at 2, since it's deregistered. - assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0, 2, 0, 0, 0))] - - g <- fillEpochs interpreter mockServer 2 - assertBlockNoBackoff dbSync (fromIntegral $ 6 + length (a <> b <> c <> d <> e <> f <> g)) - assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0, 2, 0, 0, 0))] - where - testLabel = "rewardsDeregistration-alonzo" - --- This is a fix of the reward issue fix in Babbage described in the Babbage specs --- If a stake address is deregistered during the reward computation initialisation, --- and is registered later it doesn't receive rewards before Babbage. It does receive --- on Babbage. See the same test on Alonzo. -rewardsReregistration :: IOManager -> [(Text, Text)] -> Assertion -rewardsReregistration = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkDepositTxPools (UTxOIndex 1) 20000 - - -- first move to treasury from reserves - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \_ -> - Alonzo.mkDCertTx [ShelleyTxCertMir $ MIRCert ReservesMIR (SendToOppositePotMIR (Coin 100000))] (Withdrawals mempty) - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - -- register the stake address and delegate to a pool - let poolId = resolvePool (PoolIndex 0) st - tx1 <- - Alonzo.mkSimpleDCertTx - [ (StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert) - , (StakeIndexNew 1, \stCred -> ShelleyTxCertDelegCert $ ShelleyDelegCert stCred poolId) - ] - st - -- send some funds to the address so - tx2 <- Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOAddressNewWithStake 0 (StakeIndexNew 1)) 100000 5000 st - Right [tx1, tx2] - - a <- fillEpochs interpreter mockServer 3 - assertBlockNoBackoff dbSync (fromIntegral $ 3 + length a) - - st <- getAlonzoLedgerState interpreter - - -- Now that pools are registered, we add a tx to fill the fees pot. - -- Rewards will be distributed. - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 - - b <- fillEpochs interpreter mockServer 2 - - assertBlockNoBackoff dbSync (fromIntegral $ 4 + length a + length b) - assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0, 1, 0, 0, 0))] - - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 1) (UTxOIndex 0) 10000 10000 - - b' <- fillEpochs interpreter mockServer 1 - c <- fillEpochPercentage interpreter mockServer 10 - -- deregister before the 40% of the epoch - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert)] - d <- fillEpochPercentage interpreter mockServer 60 - -- register after 40% and before epoch boundary. - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] - e <- fillUntilNextEpoch interpreter mockServer - assertBlockNoBackoff dbSync (fromIntegral $ 7 + length (a <> b <> b' <> c <> d <> e)) - -- This is 2 in Babbage - assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0, 1, 0, 0, 0))] - where - testLabel = "rewardsReregistration-Alonzo" - -mirReward :: IOManager -> [(Text, Text)] -> Assertion -mirReward = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - -- first move to treasury from reserves - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \_ -> - Alonzo.mkDCertTx [ShelleyTxCertMir $ MIRCert ReservesMIR (SendToOppositePotMIR (Coin 100000))] (Withdrawals mempty) - - void $ fillEpochPercentage interpreter mockServer 50 - - -- mir from treasury - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx1 <- - Alonzo.mkSimpleDCertTx - [ - ( StakeIndex 1 - , \cred -> ShelleyTxCertMir $ MIRCert TreasuryMIR (StakeAddressesMIR (Map.singleton cred (DeltaCoin 100))) - ) - ] - st - tx2 <- - Alonzo.mkSimpleDCertTx - [ - ( StakeIndex 1 - , \cred -> ShelleyTxCertMir $ MIRCert ReservesMIR (StakeAddressesMIR (Map.singleton cred (DeltaCoin 200))) - ) - ] - st - tx3 <- - Alonzo.mkSimpleDCertTx - [ - ( StakeIndex 1 - , \cred -> ShelleyTxCertMir $ MIRCert TreasuryMIR (StakeAddressesMIR (Map.singleton cred (DeltaCoin 300))) - ) - ] - st - pure [tx1, tx2, tx3] - - void $ fillUntilNextEpoch interpreter mockServer - - st <- getAlonzoLedgerState interpreter - -- 2 mir rewards from treasury are sumed - assertRewardCounts dbSync st True Nothing [(StakeIndex 1, (0, 0, 1, 1, 0))] - where - testLabel = "mirReward-alonzo" - -mirRewardRollback :: IOManager -> [(Text, Text)] -> Assertion -mirRewardRollback = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - -- first move to treasury from reserves - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \_ -> - Alonzo.mkDCertTx [ShelleyTxCertMir $ MIRCert ReservesMIR (SendToOppositePotMIR (Coin 100000))] (Withdrawals mempty) - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] - - a <- fillUntilNextEpoch interpreter mockServer - b <- fillEpochPercentage interpreter mockServer 5 - -- mir from treasury - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkSimpleDCertTx - [ - ( StakeIndexNew 1 - , \cred -> ShelleyTxCertMir $ MIRCert TreasuryMIR (StakeAddressesMIR (Map.singleton cred (DeltaCoin 1000))) - ) - ] - c <- fillEpochPercentage interpreter mockServer 50 - d <- fillUntilNextEpoch interpreter mockServer - - st <- getAlonzoLedgerState interpreter - assertBlockNoBackoff dbSync (fromIntegral $ 4 + length (a <> b <> c <> d)) - assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0, 0, 0, 1, 0))] - - atomically $ rollback mockServer (blockPoint $ last c) - assertBlockNoBackoff dbSync (fromIntegral $ 4 + length (a <> b <> c <> d)) - assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0, 0, 0, 1, 0))] - stopDBSync dbSync - startDBSync dbSync - assertBlockNoBackoff dbSync (fromIntegral $ 4 + length (a <> b <> c <> d)) - assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0, 0, 0, 1, 0))] - - forM_ d $ atomically . addBlock mockServer - e <- fillEpochPercentage interpreter mockServer 5 - assertBlockNoBackoff dbSync (fromIntegral $ 4 + length (a <> b <> c <> d <> e)) - assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0, 0, 0, 1, 0))] - where - testLabel = "mirRewardRollback-alonzo" - -mirRewardDereg :: IOManager -> [(Text, Text)] -> Assertion -mirRewardDereg = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - -- first move to treasury from reserves - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \_ -> - Alonzo.mkDCertTx [ShelleyTxCertMir $ MIRCert ReservesMIR (SendToOppositePotMIR (Coin 100000))] (Withdrawals mempty) - - a <- fillUntilNextEpoch interpreter mockServer - - -- mir from treasury - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx1 <- - Alonzo.mkSimpleDCertTx - [ - ( StakeIndex 1 - , \cred -> ShelleyTxCertMir $ MIRCert TreasuryMIR (StakeAddressesMIR (Map.singleton cred (DeltaCoin 100))) - ) - ] - st - tx2 <- - Alonzo.mkSimpleDCertTx - [ - ( StakeIndex 1 - , \cred -> ShelleyTxCertMir $ MIRCert ReservesMIR (StakeAddressesMIR (Map.singleton cred (DeltaCoin 200))) - ) - ] - st - tx3 <- - Alonzo.mkSimpleDCertTx - [ - ( StakeIndex 1 - , \cred -> ShelleyTxCertMir $ MIRCert TreasuryMIR (StakeAddressesMIR (Map.singleton cred (DeltaCoin 300))) - ) - ] - st - pure [tx1, tx2, tx3] - - b <- fillEpochPercentage interpreter mockServer 20 - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkSimpleDCertTx [(StakeIndex 1, ShelleyTxCertDelegCert . ShelleyUnRegCert)] - - assertBlockNoBackoff dbSync (fromIntegral $ 4 + length (a <> b)) - -- deregistration means empty rewards - st <- getAlonzoLedgerState interpreter - assertRewardCounts dbSync st False Nothing [] - where - testLabel = "mirRewardDereg-alonzo" - -_rewardsEmptyChainLast :: IOManager -> [(Text, Text)] -> Assertion -_rewardsEmptyChainLast = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - a <- fillEpochs interpreter mockServer 3 - assertRewardCount dbSync 3 - - -- Now that pools are registered, we add a tx to fill the fees pot. - -- Rewards will be distributed. - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 - - b <- fillUntilNextEpoch interpreter mockServer - assertRewardCount dbSync 6 - - c <- fillEpochPercentage interpreter mockServer 68 - - -- Skip a percentage of the epoch epoch - void $ skipUntilNextEpoch interpreter mockServer [] - d <- fillUntilNextEpoch interpreter mockServer - assertBlockNoBackoff dbSync (fromIntegral $ 1 + length a + 1 + length b + length c + 1 + length d) - assertRewardCount dbSync 17 - where - testLabel = "rewardsEmptyChainLast-alonzo" - -_rewardsDelta :: IOManager -> [(Text, Text)] -> Assertion -_rewardsDelta = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - -- These delegation push the computation of the 3 leader - -- rewards toward the 8k/f slot, so it can be delayed even more - -- with the missing blocks and create the delta reward. - -- This trick may break at some point in the future. - a <- delegateAndSendBlocks 1000 interpreter - forM_ a $ atomically . addBlock mockServer - void $ registerAllStakeCreds interpreter mockServer - b <- fillEpochs interpreter mockServer 3 - assertRewardCount dbSync 3 - - c <- fillUntilNextEpoch interpreter mockServer - assertRewardCount dbSync 6 - - d <- fillEpochPercentage interpreter mockServer 68 - assertRewardCount dbSync 6 - - -- Skip a percentage of the epoch epoch - void $ skipUntilNextEpoch interpreter mockServer [] - assertBlockNoBackoff dbSync (fromIntegral $ 1 + length a + length b + length c + 1 + length d) - -- These are delta rewards aka rewards that were added at the epoch boundary, because the reward - -- update was not complete on time, due to missing blocks. - assertRewardCount dbSync 9 - where - testLabel = "rewardsDelta-alonzo" - -rollbackBoundary :: IOManager -> [(Text, Text)] -> Assertion -rollbackBoundary = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - a <- fillEpochs interpreter mockServer 2 - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 - - blks <- forgeAndSubmitBlocks interpreter mockServer 50 - blks' <- fillUntilNextEpoch interpreter mockServer - - assertRewardCount dbSync 3 - atomically $ rollback mockServer (blockPoint $ last blks) - assertBlockNoBackoff dbSync (2 + length a + length blks + length blks') - forM_ blks' $ atomically . addBlock mockServer - assertBlockNoBackoff dbSync (2 + length a + length blks + length blks') - assertRewardCount dbSync 3 - blks'' <- fillUntilNextEpoch interpreter mockServer - assertBlockNoBackoff dbSync (2 + length a + length blks + length blks' + length blks'') - where - testLabel = "rollbackBoundary-alonzo" - -singleMIRCertMultiOut :: IOManager -> [(Text, Text)] -> Assertion -singleMIRCertMultiOut = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \_ -> - Alonzo.mkDCertTx [ShelleyTxCertMir $ MIRCert ReservesMIR (SendToOppositePotMIR (Coin 100000))] (Withdrawals mempty) - - a <- fillUntilNextEpoch interpreter mockServer - - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \state -> do - stakeAddr0 <- resolveStakeCreds (StakeIndex 0) state - stakeAddr1 <- resolveStakeCreds (StakeIndex 1) state - let saMIR = StakeAddressesMIR (Map.fromList [(stakeAddr0, DeltaCoin 10), (stakeAddr1, DeltaCoin 20)]) - Alonzo.mkDCertTx [ShelleyTxCertMir $ MIRCert ReservesMIR saMIR, ShelleyTxCertMir $ MIRCert TreasuryMIR saMIR] (Withdrawals mempty) - - b <- fillUntilNextEpoch interpreter mockServer - - assertBlockNoBackoff dbSync (2 + length a + length b) - assertRewardRestCount dbSync 4 - where - testLabel = "singleMIRCertMultiOut-alonzo" diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Stake.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Stake.hs deleted file mode 100644 index 3f5fdd0c4..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Stake.hs +++ /dev/null @@ -1,340 +0,0 @@ -module Test.Cardano.Db.Mock.Unit.Alonzo.Stake ( - -- stake addresses - registrationTx, - registrationsSameBlock, - registrationsSameTx, - stakeAddressPtr, - stakeAddressPtrDereg, - stakeAddressPtrUseBefore, - -- stake distribution - stakeDistGenesis, - delegations2000, - delegations2001, - delegations8000, - delegationsMany, - delegationsManyNotDense, -) where - -import qualified Cardano.Db as DB -import Cardano.Ledger.BaseTypes (CertIx (CertIx), TxIx (TxIx)) -import Cardano.Ledger.Credential -import Cardano.Ledger.Shelley.TxCert -import Cardano.Mock.ChainSync.Server (IOManager, addBlock) -import qualified Cardano.Mock.Forging.Tx.Alonzo as Alonzo -import Cardano.Mock.Forging.Tx.Alonzo.Scenarios (delegateAndSendBlocks) -import Cardano.Mock.Forging.Types (StakeIndex (..), UTxOIndex (..)) -import Control.Concurrent.Class.MonadSTM.Strict (MonadSTM (atomically)) -import Control.Monad (forM_, replicateM_, void) -import Data.Text (Text) -import Ouroboros.Network.Block (blockSlot) -import Test.Cardano.Db.Mock.Config (alonzoConfigDir, startDBSync, withFullConfig, withFullConfigAndDropDB) -import Test.Cardano.Db.Mock.UnifiedApi ( - fillEpochs, - fillUntilNextEpoch, - forgeAndSubmitBlocks, - forgeNextFindLeaderAndSubmit, - forgeNextSkipSlotsFindLeaderAndSubmit, - getAlonzoLedgerState, - withAlonzoFindLeaderAndSubmit, - withAlonzoFindLeaderAndSubmitTx, - ) -import Test.Cardano.Db.Mock.Validate ( - assertAddrValues, - assertBlockNoBackoff, - assertBlockNoBackoffTimes, - assertCertCounts, - assertEpochStake, - assertEpochStakeEpoch, - ) -import Test.Tasty.HUnit (Assertion) - ----------------------------------------------------------------------------------------------------------- --- Stake Addresses ----------------------------------------------------------------------------------------------------------- - -registrationTx :: IOManager -> [(Text, Text)] -> Assertion -registrationTx = - withFullConfigAndDropDB alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert)] - - -- We add interval or else the txs would have the same id - void $ - withAlonzoFindLeaderAndSubmitTx - interpreter - mockServer - ( fmap (Alonzo.addValidityInterval 1000) - . Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] - ) - - void $ - withAlonzoFindLeaderAndSubmitTx - interpreter - mockServer - ( fmap (Alonzo.addValidityInterval 2000) - . Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert)] - ) - - assertBlockNoBackoff dbSync 4 - assertCertCounts dbSync (2, 2, 0, 0) - where - testLabel = "registrationTx-alonzo" - -registrationsSameBlock :: IOManager -> [(Text, Text)] -> Assertion -registrationsSameBlock = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx1 <- Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert)] st - tx2 <- Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx3 <- Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert)] st - Right [tx0, tx1, Alonzo.addValidityInterval 1000 tx2, Alonzo.addValidityInterval 2000 tx3] - - assertBlockNoBackoff dbSync 1 - assertCertCounts dbSync (2, 2, 0, 0) - where - testLabel = "registrationsSameBlock-alonzo" - -registrationsSameTx :: IOManager -> [(Text, Text)] -> Assertion -registrationsSameTx = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkSimpleDCertTx - [ (StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert) - , (StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert) - , (StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert) - , (StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert) - ] - - assertBlockNoBackoff dbSync 1 - assertCertCounts dbSync (2, 2, 0, 0) - where - testLabel = "registrationsSameTx-alonzo" - -stakeAddressPtr :: IOManager -> [(Text, Text)] -> Assertion -stakeAddressPtr = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - blk <- - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] - - let ptr = Ptr (blockSlot blk) (TxIx 0) (CertIx 0) - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOAddressNewWithPtr 0 ptr) 20000 20000 - - assertBlockNoBackoff dbSync 2 - assertCertCounts dbSync (1, 0, 0, 0) - where - testLabel = "stakeAddressPtr-alonzo" - -stakeAddressPtrDereg :: IOManager -> [(Text, Text)] -> Assertion -stakeAddressPtrDereg = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - blk <- - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkSimpleDCertTx [(StakeIndexNew 0, ShelleyTxCertDelegCert . ShelleyRegCert)] - - let ptr0 = Ptr (blockSlot blk) (TxIx 0) (CertIx 0) - - blk' <- withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOAddressNewWithPtr 0 ptr0) 20000 20000 st - tx1 <- - Alonzo.mkSimpleDCertTx - [ (StakeIndexNew 0, ShelleyTxCertDelegCert . ShelleyUnRegCert) - , (StakeIndexNew 0, ShelleyTxCertDelegCert . ShelleyRegCert) - ] - st - pure [tx0, tx1] - - let ptr1 = Ptr (blockSlot blk') (TxIx 1) (CertIx 1) - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Alonzo.mkPaymentTx (UTxOIndex 1) (UTxOAddressNewWithPtr 0 ptr1) 20000 20000 st - tx1 <- Alonzo.mkPaymentTx (UTxOIndex 2) (UTxOAddressNewWithPtr 0 ptr0) 20000 20000 st - pure [tx0, tx1] - - st <- getAlonzoLedgerState interpreter - assertBlockNoBackoff dbSync 3 - assertCertCounts dbSync (2, 1, 0, 0) - -- The 2 addresses have the same payment credentials and they reference the same - -- stake credentials, however they have - assertAddrValues dbSync (UTxOAddressNewWithPtr 0 ptr0) (DB.DbLovelace 40000) st - assertAddrValues dbSync (UTxOAddressNewWithPtr 0 ptr1) (DB.DbLovelace 20000) st - where - testLabel = "stakeAddressPtrDereg-alonzo" - -stakeAddressPtrUseBefore :: IOManager -> [(Text, Text)] -> Assertion -stakeAddressPtrUseBefore = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - -- first use this stake credential - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkPaymentTx (UTxOIndex 1) (UTxOAddressNewWithStake 0 (StakeIndexNew 1)) 10000 500 - - -- and then register it - blk <- - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] - - let ptr = Ptr (blockSlot blk) (TxIx 0) (CertIx 0) - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOAddressNewWithPtr 0 ptr) 20000 20000 - - assertBlockNoBackoff dbSync 3 - assertCertCounts dbSync (1, 0, 0, 0) - where - testLabel = "stakeAddressPtrUseBefore-alonzo" - ----------------------------------------------------------------------------------------------------------- --- Stake Distribution ----------------------------------------------------------------------------------------------------------- - -stakeDistGenesis :: IOManager -> [(Text, Text)] -> Assertion -stakeDistGenesis = - withFullConfigAndDropDB alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - a <- fillUntilNextEpoch interpreter mockServer - assertBlockNoBackoff dbSync (fromIntegral $ length a) - -- There are 5 delegations in genesis - assertEpochStake dbSync 5 - where - testLabel = "stakeDistGenesis-alonzo" - -delegations2000 :: IOManager -> [(Text, Text)] -> Assertion -delegations2000 = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - a <- delegateAndSendBlocks 1995 interpreter - forM_ a $ atomically . addBlock mockServer - b <- fillUntilNextEpoch interpreter mockServer - c <- forgeAndSubmitBlocks interpreter mockServer 10 - - assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c) - -- There are exactly 2000 entries on the second epoch, 5 from genesis and 1995 manually added - assertEpochStakeEpoch dbSync 2 2000 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c + 1) - assertEpochStakeEpoch dbSync 2 2000 - where - testLabel = "delegations2000-alonzo" - -delegations2001 :: IOManager -> [(Text, Text)] -> Assertion -delegations2001 = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - a <- delegateAndSendBlocks 1996 interpreter - forM_ a $ atomically . addBlock mockServer - b <- fillUntilNextEpoch interpreter mockServer - c <- forgeAndSubmitBlocks interpreter mockServer 9 - - assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c) - assertEpochStakeEpoch dbSync 2 0 - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c + 1) - assertEpochStakeEpoch dbSync 2 2000 - -- The remaining entry is inserted on the next block. - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c + 2) - assertEpochStakeEpoch dbSync 2 2001 - where - testLabel = "delegations2001-alonzo" - -delegations8000 :: IOManager -> [(Text, Text)] -> Assertion -delegations8000 = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - a <- delegateAndSendBlocks 7995 interpreter - forM_ a $ atomically . addBlock mockServer - b <- fillEpochs interpreter mockServer 2 - c <- forgeAndSubmitBlocks interpreter mockServer 10 - - assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c) - assertEpochStakeEpoch dbSync 3 2000 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertEpochStakeEpoch dbSync 3 4000 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertEpochStakeEpoch dbSync 3 6000 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertEpochStakeEpoch dbSync 3 8000 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertEpochStakeEpoch dbSync 3 8000 - where - testLabel = "delegations8000-alonzo" - -delegationsMany :: IOManager -> [(Text, Text)] -> Assertion -delegationsMany = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - a <- delegateAndSendBlocks 40000 interpreter - forM_ a $ atomically . addBlock mockServer - b <- fillEpochs interpreter mockServer 4 - c <- forgeAndSubmitBlocks interpreter mockServer 10 - - -- too long. We cannot use default delays - assertBlockNoBackoffTimes (repeat 10) dbSync (fromIntegral $ length a + length b + length c) - -- The slice size here is - -- 1 + div (delegationsLen * 5) expectedBlocks = 2001 - -- instead of 2000, because there are many delegations - assertEpochStakeEpoch dbSync 7 2001 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertEpochStakeEpoch dbSync 7 4002 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertEpochStakeEpoch dbSync 7 6003 - where - testLabel = "delegationsMany-alonzo" - -delegationsManyNotDense :: IOManager -> [(Text, Text)] -> Assertion -delegationsManyNotDense = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - a <- delegateAndSendBlocks 40000 interpreter - forM_ a $ atomically . addBlock mockServer - b <- fillEpochs interpreter mockServer 4 - c <- forgeAndSubmitBlocks interpreter mockServer 10 - - -- too long. We cannot use default delays - assertBlockNoBackoffTimes (repeat 10) dbSync (fromIntegral $ length a + length b + length c) - -- The slice size here is - -- 1 + div (delegationsLen * 5) expectedBlocks = 2001 - -- instead of 2000, because there are many delegations - assertEpochStakeEpoch dbSync 7 2001 - - -- Blocks come on average every 5 slots. If we skip 15 slots before each block, - -- we are expected to get only 1/4 of the expected blocks. The adjusted slices - -- should still be long enough to cover everything. - replicateM_ 40 $ - forgeNextSkipSlotsFindLeaderAndSubmit interpreter mockServer 15 [] - - -- Even if the chain is sparse, all distributions are inserted. - assertEpochStakeEpoch dbSync 7 40005 - where - testLabel = "delegationsManyNotDense-alonzo" diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage.hs new file mode 100644 index 000000000..01ed125ca --- /dev/null +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Test.Cardano.Db.Mock.Unit.Babbage ( + unitTests, +) where + +import Cardano.Mock.ChainSync.Server (IOManager) +import Data.Text (Text) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, testCase) + +import qualified Test.Cardano.Db.Mock.Unit.Babbage.Reward as BabReward +import qualified Test.Cardano.Db.Mock.Unit.Babbage.Simple as BabSimple +import qualified Test.Cardano.Db.Mock.Unit.Babbage.Tx as BabTx + +unitTests :: IOManager -> [(Text, Text)] -> TestTree +unitTests iom knownMigrations = + testGroup + "Babbage unit tests" + [ testGroup + "simple" + [ test "simple forge blocks" BabSimple.forgeBlocks + , test "sync one block" BabSimple.addSimple + , test "sync small chain" BabSimple.addSimpleChain + , test "restart db-sync" BabSimple.restartDBSync + , test "node restart" BabSimple.nodeRestart + , test "node restart boundary" BabSimple.nodeRestartBoundary + ] + , testGroup + "blocks with txs" + [ test "simple tx" BabTx.addSimpleTx + , test "simple tx in Shelley era" BabTx.addSimpleTxShelley + , test "consume utxo same block" BabTx.consumeSameBlock + ] + , testGroup + "rewards" + [ test "rewards simple" BabReward.simpleRewards + , test "shelley rewards from multiple sources" BabReward.rewardsShelley + , test "rewards with deregistration" BabReward.rewardsDeregistration + , test "rewards with reregistration. Fixed in Babbage." BabReward.rewardsReregistration + , test "Mir Cert" BabReward.mirReward + , -- , test "Mir rollback" mirRewardRollback + test "Mir Cert Shelley" BabReward.mirRewardShelley + , test "Mir Cert deregistration" BabReward.mirRewardDereg + , -- , test "test rewards empty last part of epoch" rewardsEmptyChainLast + -- , test "test delta rewards" rewardsDelta -- We disable the test. See in the test for more. + test "rollback on epoch boundary" BabReward.rollbackBoundary + , test "single MIR Cert multiple outputs" BabReward.singleMIRCertMultiOut + ] + ] + where + test :: String -> (IOManager -> [(Text, Text)] -> Assertion) -> TestTree + test str action = testCase str (action iom knownMigrations) diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/CommandLineArg/ConfigFile.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/CommandLineArg/ConfigFile.hs deleted file mode 100644 index 601d74f79..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/CommandLineArg/ConfigFile.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Test.Cardano.Db.Mock.Unit.Babbage.CommandLineArg.ConfigFile ( - checkConfigFileArg, -) -where - -import Cardano.Mock.ChainSync.Server (IOManager) -import Data.Text (Text) -import Test.Cardano.Db.Mock.Config (CommandLineArgs (..), babbageConfigDir, initCommandLineArgs, withCustomConfig) -import Test.Cardano.Db.Mock.Validate (checkStillRuns) -import Test.Tasty.HUnit (Assertion) - --- this test fails as incorrect configuration file given -checkConfigFileArg :: IOManager -> [(Text, Text)] -> Assertion -checkConfigFileArg = - withCustomConfig commandLineConfigArgs Nothing babbageConfigDir testLabel $ \_ _ dbSyncEnv -> do - -- poll dbSync to see if it's running, which it shouldn't - checkStillRuns dbSyncEnv - where - testLabel = "CLAcheckConfigFileArg" - commandLineConfigArgs = initCommandLineArgs {claConfigFilename = "does-not-exist"} diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/CommandLineArg/EpochDisabled.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/CommandLineArg/EpochDisabled.hs deleted file mode 100644 index adba8272f..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/CommandLineArg/EpochDisabled.hs +++ /dev/null @@ -1,50 +0,0 @@ -module Test.Cardano.Db.Mock.Unit.Babbage.CommandLineArg.EpochDisabled ( - checkEpochDisabledArg, - checkEpochEnabled, -) -where - -import qualified Cardano.Db as DB -import Cardano.Mock.ChainSync.Server (IOManager) -import qualified Cardano.Mock.Forging.Tx.Babbage as Babbage -import Cardano.Mock.Forging.Types (UTxOIndex (..)) -import Control.Monad (void) -import Data.Text (Text) -import Test.Cardano.Db.Mock.Config (CommandLineArgs (..), babbageConfigDir, initCommandLineArgs, startDBSync, withCustomConfig, withCustomConfigAndDropDB) -import Test.Cardano.Db.Mock.UnifiedApi (forgeAndSubmitBlocks, withBabbageFindLeaderAndSubmitTx) -import Test.Cardano.Db.Mock.Validate (assertBlockNoBackoff, assertEqQuery) -import Test.Tasty.HUnit (Assertion) - -mkCommandLineArgs :: Bool -> CommandLineArgs -mkCommandLineArgs epochDisabled = initCommandLineArgs {claEpochDisabled = epochDisabled} - --- this test fails as incorrect configuration file given -checkEpochDisabledArg :: IOManager -> [(Text, Text)] -> Assertion -checkEpochDisabledArg = - withCustomConfigAndDropDB (mkCommandLineArgs True) Nothing babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do - startDBSync dbSyncEnv - b1 <- forgeAndSubmitBlocks interpreter mockServer 50 - -- add 2 blocks with tx - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ Babbage.mkPaymentTx (UTxOIndex 1) (UTxOIndex 0) 10000 10000 - b2 <- forgeAndSubmitBlocks interpreter mockServer 60 - - assertBlockNoBackoff dbSyncEnv (fromIntegral $ length (b1 <> b2) + 2) - assertEqQuery dbSyncEnv DB.queryEpochCount 0 "new epoch didn't prune tx_out column that are null" - where - testLabel = "CLAcheckEpochDisabledArg " - -checkEpochEnabled :: IOManager -> [(Text, Text)] -> Assertion -checkEpochEnabled = - withCustomConfig (mkCommandLineArgs False) Nothing babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do - startDBSync dbSyncEnv - b1 <- forgeAndSubmitBlocks interpreter mockServer 50 - -- add 2 blocks with tx - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ Babbage.mkPaymentTx (UTxOIndex 1) (UTxOIndex 0) 10000 10000 - b2 <- forgeAndSubmitBlocks interpreter mockServer 60 - - assertBlockNoBackoff dbSyncEnv (fromIntegral $ length (b1 <> b2) + 2) - assertEqQuery dbSyncEnv DB.queryEpochCount 1 "new epoch didn't prune tx_out column that are null" - where - testLabel = "CLAcheckEpochDisabledArg " diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Config/MigrateConsumedPruneTxOut.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Config/MigrateConsumedPruneTxOut.hs deleted file mode 100644 index 6f385c06f..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Config/MigrateConsumedPruneTxOut.hs +++ /dev/null @@ -1,413 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -#if __GLASGOW_HASKELL__ >= 908 -{-# OPTIONS_GHC -Wno-x-partial #-} -#endif - -module Test.Cardano.Db.Mock.Unit.Babbage.Config.MigrateConsumedPruneTxOut ( - basicPrune, - basicPruneWithAddress, - pruneWithSimpleRollback, - pruneWithSimpleRollbackWithAddress, - pruneWithFullTxRollback, - pruneWithFullTxRollbackWithAddress, - pruningShouldKeepSomeTx, - pruningShouldKeepSomeTxWithAddress, - pruneAndRollBackOneBlock, - pruneAndRollBackOneBlockWithAddress, - noPruneAndRollBack, - noPruneAndRollBackWithAddress, - pruneSameBlock, - pruneSameBlockWithAddress, - noPruneSameBlock, - noPruneSameBlockWithAddress, - migrateAndPruneRestart, - migrateAndPruneRestartWithAddress, - pruneRestartMissingFlag, - pruneRestartMissingFlagWithAddress, - bootstrapRestartMissingFlag, - bootstrapRestartMissingFlagWithAddress, -) where - -import Cardano.Db (TxOutTableType (..)) -import qualified Cardano.Db as DB -import Cardano.Mock.ChainSync.Server (IOManager, addBlock) -import Cardano.Mock.Forging.Interpreter (forgeNext) -import qualified Cardano.Mock.Forging.Tx.Babbage as Babbage -import Cardano.Mock.Forging.Types (UTxOIndex (..)) -import Control.Concurrent (threadDelay) -import Control.Concurrent.Class.MonadSTM.Strict (atomically) -import Control.Monad (void) -import Data.Text (Text) -import Ouroboros.Consensus.Block (blockPoint) -import Test.Cardano.Db.Mock.Config ( - babbageConfigDir, - configBootstrap, - configConsume, - configPrune, - configPruneForceTxIn, - initCommandLineArgs, - replaceConfigFile, - startDBSync, - stopDBSync, - txOutTableTypeFromConfig, - withCustomConfigAndDropDB, - ) -import Test.Cardano.Db.Mock.Examples (mockBlock0, mockBlock1) -import Test.Cardano.Db.Mock.UnifiedApi ( - forgeAndSubmitBlocks, - forgeNextFindLeaderAndSubmit, - getBabbageLedgerState, - rollbackTo, - withBabbageFindLeaderAndSubmit, - withBabbageFindLeaderAndSubmitTx, - ) -import Test.Cardano.Db.Mock.Validate (assertBlockNoBackoff, assertEqQuery, assertTxCount, assertTxInCount, assertTxOutCount, assertUnspentTx, checkStillRuns) -import Test.Tasty.HUnit (Assertion) - ------------------------------------------------------------------------------- --- Tests ------------------------------------------------------------------------------- -basicPrune :: IOManager -> [(Text, Text)] -> Assertion -basicPrune = peformBasicPrune False - -basicPruneWithAddress :: IOManager -> [(Text, Text)] -> Assertion -basicPruneWithAddress = peformBasicPrune True - -peformBasicPrune :: Bool -> IOManager -> [(Text, Text)] -> Assertion -peformBasicPrune useTxOutAddress = do - withCustomConfigAndDropDB cmdLineArgs (Just $ configPruneForceTxIn useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do - let txOutTableType = txOutTableTypeFromConfig dbSyncEnv - startDBSync dbSyncEnv - -- add 50 block - b1 <- forgeAndSubmitBlocks interpreter mockServer 50 - -- add 2 blocks with tx - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ Babbage.mkPaymentTx (UTxOIndex 1) (UTxOIndex 0) 10000 10000 - assertBlockNoBackoff dbSyncEnv (fromIntegral $ length b1 + 2) - -- check tx-out count before any pruning has happened - assertEqQuery dbSyncEnv (DB.queryTxOutCount txOutTableType) 14 "new epoch didn't prune tx_out column that are null" - -- add other blocks to instantiate the pruning - b2 <- forgeAndSubmitBlocks interpreter mockServer 48 - assertBlockNoBackoff dbSyncEnv (fromIntegral $ length (b1 <> b2) + 2) - - -- check that the tx_out has been pruned - assertEqQuery dbSyncEnv (DB.queryTxOutCount txOutTableType) 12 "the pruning didn't work correctly as the tx-out count is incorrect" - -- check Unspent tx match after pruning - assertUnspentTx dbSyncEnv - where - cmdLineArgs = initCommandLineArgs - testLabel = "configPrune" - -pruneWithSimpleRollback :: IOManager -> [(Text, Text)] -> Assertion -pruneWithSimpleRollback = peformPruneWithSimpleRollback False - -pruneWithSimpleRollbackWithAddress :: IOManager -> [(Text, Text)] -> Assertion -pruneWithSimpleRollbackWithAddress = peformPruneWithSimpleRollback True - -peformPruneWithSimpleRollback :: Bool -> IOManager -> [(Text, Text)] -> Assertion -peformPruneWithSimpleRollback useTxOutAddress = do - withCustomConfigAndDropDB cmdLineArgs (Just $ configPruneForceTxIn useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do - let txOutTableType = txOutTableTypeFromConfig dbSyncEnv - blk0 <- forgeNext interpreter mockBlock0 - blk1 <- forgeNext interpreter mockBlock1 - atomically $ addBlock mockServer blk0 - startDBSync dbSyncEnv - atomically $ addBlock mockServer blk1 - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ Babbage.mkPaymentTx (UTxOIndex 1) (UTxOIndex 0) 10000 10000 - assertEqQuery dbSyncEnv (DB.queryTxOutCount txOutTableType) 14 "" - b1 <- forgeAndSubmitBlocks interpreter mockServer 96 - assertBlockNoBackoff dbSyncEnv (fullBlockSize b1) - assertEqQuery dbSyncEnv (DB.queryTxOutCount txOutTableType) 12 "the txOut count is incorrect" - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId count after prune" - assertUnspentTx dbSyncEnv - - rollbackTo interpreter mockServer (blockPoint blk1) - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId cout after rollback" - assertBlockNoBackoff dbSyncEnv $ fullBlockSize b1 - where - fullBlockSize b = fromIntegral $ length b + 4 - cmdLineArgs = initCommandLineArgs - testLabel = "configPruneSimpleRollback" - -pruneWithFullTxRollback :: IOManager -> [(Text, Text)] -> Assertion -pruneWithFullTxRollback = performPruneWithFullTxRollback False - -pruneWithFullTxRollbackWithAddress :: IOManager -> [(Text, Text)] -> Assertion -pruneWithFullTxRollbackWithAddress = performPruneWithFullTxRollback True - -performPruneWithFullTxRollback :: Bool -> IOManager -> [(Text, Text)] -> Assertion -performPruneWithFullTxRollback useTxOutAddress = do - withCustomConfigAndDropDB cmdLineArgs (Just $ configPruneForceTxIn useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do - let txOutTableType = txOutTableTypeFromConfig dbSyncEnv - startDBSync dbSyncEnv - blk0 <- forgeNextFindLeaderAndSubmit interpreter mockServer [] - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkFullTx 0 100 st - tx1 <- Babbage.mkFullTx 1 200 st - pure [tx0, tx1] - assertBlockNoBackoff dbSyncEnv 2 - assertTxCount dbSyncEnv 13 - assertUnspentTx dbSyncEnv - assertEqQuery dbSyncEnv (DB.queryTxOutCount txOutTableType) 14 "new epoch didn't prune tx_out column that are null" - rollbackTo interpreter mockServer $ blockPoint blk0 - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkFullTx 0 100 st - tx1 <- Babbage.mkFullTx 1 200 st - tx2 <- Babbage.mkFullTx 2 200 st - pure [tx1, tx2, tx0] - assertBlockNoBackoff dbSyncEnv 2 - assertTxCount dbSyncEnv 14 - assertEqQuery dbSyncEnv (DB.queryTxOutCount txOutTableType) 16 "new epoch didn't prune tx_out column that are null" - assertUnspentTx dbSyncEnv - where - cmdLineArgs = initCommandLineArgs - testLabel = "configPruneOnFullRollback" - --- The tx in the last, 2 x securityParam worth of blocks should not be pruned. --- In these tests, 2 x securityParam = 20 blocks. -pruningShouldKeepSomeTx :: IOManager -> [(Text, Text)] -> Assertion -pruningShouldKeepSomeTx = performPruningShouldKeepSomeTx False - -pruningShouldKeepSomeTxWithAddress :: IOManager -> [(Text, Text)] -> Assertion -pruningShouldKeepSomeTxWithAddress = performPruningShouldKeepSomeTx True - -performPruningShouldKeepSomeTx :: Bool -> IOManager -> [(Text, Text)] -> Assertion -performPruningShouldKeepSomeTx useTxOutAddress = do - withCustomConfigAndDropDB cmdLineArgs (Just $ configPrune useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do - startDBSync dbSyncEnv - let txOutTableType = txOutTableTypeFromConfig dbSyncEnv - b1 <- forgeAndSubmitBlocks interpreter mockServer 80 - -- these two blocs + tx will fall withing the last 20 blocks so should not be pruned - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ Babbage.mkPaymentTx (UTxOIndex 2) (UTxOIndex 3) 10000 10000 - b2 <- forgeAndSubmitBlocks interpreter mockServer 18 - assertBlockNoBackoff dbSyncEnv (fromIntegral $ length (b1 <> b2) + 2) - -- the two marked TxOutConsumedByTxId should not be pruned - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount TxOutCore) 2 "Unexpected TxOutConsumedByTxId count after prune" - -- add more blocks to instantiate another prune - b3 <- forgeAndSubmitBlocks interpreter mockServer 110 - assertBlockNoBackoff dbSyncEnv (fromIntegral $ length (b1 <> b2 <> b3) + 2) - -- the prune should have removed all - assertTxInCount dbSyncEnv 0 - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId count after prune" - where - cmdLineArgs = initCommandLineArgs - testLabel = "configPruneCorrectAmount" - --- prune with rollback -pruneAndRollBackOneBlock :: IOManager -> [(Text, Text)] -> Assertion -pruneAndRollBackOneBlock = performPruneAndRollBackOneBlock False - -pruneAndRollBackOneBlockWithAddress :: IOManager -> [(Text, Text)] -> Assertion -pruneAndRollBackOneBlockWithAddress = performPruneAndRollBackOneBlock True - -performPruneAndRollBackOneBlock :: Bool -> IOManager -> [(Text, Text)] -> Assertion -performPruneAndRollBackOneBlock useTxOutAddress = do - withCustomConfigAndDropDB cmdLineArgs (Just $ configPruneForceTxIn useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do - startDBSync dbSyncEnv - let txOutTableType = txOutTableTypeFromConfig dbSyncEnv - void $ forgeAndSubmitBlocks interpreter mockServer 98 - -- add 2 blocks with tx - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 - -- add an empty block then fill it with a tx so we can use blk100 as point to rollback - blk100 <- forgeNextFindLeaderAndSubmit interpreter mockServer [] - st <- getBabbageLedgerState interpreter - let Right tx1 = Babbage.mkPaymentTx (UTxOIndex 2) (UTxOIndex 3) 10000 500 st - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \_st -> - Right [tx1] - assertBlockNoBackoff dbSyncEnv 101 - -- the 2 tx have been marked but not pruned as they are withing the last 20 blocks - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 2 "Unexpected TxOutConsumedByTxId count before rollback" - rollbackTo interpreter mockServer $ blockPoint blk100 - -- add an empty block - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSyncEnv 101 - -- there should only be 1 tx marked now as the other was deleted in rollback - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 1 "Unexpected TxOutConsumedByTxId count after rollback" - -- cause another prune - void $ forgeAndSubmitBlocks interpreter mockServer 102 - assertBlockNoBackoff dbSyncEnv 203 - -- everything should be pruned - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId count after rollback" - where - cmdLineArgs = initCommandLineArgs - testLabel = "configPruneAndRollBack" - --- consume with rollback -noPruneAndRollBack :: IOManager -> [(Text, Text)] -> Assertion -noPruneAndRollBack = performNoPruneAndRollBack False - -noPruneAndRollBackWithAddress :: IOManager -> [(Text, Text)] -> Assertion -noPruneAndRollBackWithAddress = performNoPruneAndRollBack True - -performNoPruneAndRollBack :: Bool -> IOManager -> [(Text, Text)] -> Assertion -performNoPruneAndRollBack useTxOutAddress = do - withCustomConfigAndDropDB cmdLineArgs (Just $ configConsume useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do - startDBSync dbSyncEnv - let txOutTableType = txOutTableTypeFromConfig dbSyncEnv - void $ forgeAndSubmitBlocks interpreter mockServer 98 - -- add 2 blocks with tx - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 - -- add an empty block then fill it with a tx so we can use blk100 as point to rollback - blk100 <- forgeNextFindLeaderAndSubmit interpreter mockServer [] - st <- getBabbageLedgerState interpreter - let Right tx1 = Babbage.mkPaymentTx (UTxOIndex 2) (UTxOIndex 3) 10000 500 st - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \_st -> - Right [tx1] - assertBlockNoBackoff dbSyncEnv 101 - -- the 2 tx have been marked but not pruned as they are withing the last 20 blocks - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 2 "Unexpected TxOutConsumedByTxId count before rollback" - rollbackTo interpreter mockServer $ blockPoint blk100 - -- add an empty block - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSyncEnv 101 - -- there should only be 1 tx marked now as the other was deleted in rollback - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 1 "Unexpected TxOutConsumedByTxId count after rollback" - -- cause another prune - void $ forgeAndSubmitBlocks interpreter mockServer 102 - assertBlockNoBackoff dbSyncEnv 203 - -- everything should be pruned - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 1 "Unexpected TxOutConsumedByTxId count after rollback" - where - cmdLineArgs = initCommandLineArgs - testLabel = "configPruneAndRollBack" - -pruneSameBlock :: IOManager -> [(Text, Text)] -> Assertion -pruneSameBlock = performPruneSameBlock False - -pruneSameBlockWithAddress :: IOManager -> [(Text, Text)] -> Assertion -pruneSameBlockWithAddress = performPruneSameBlock True - -performPruneSameBlock :: Bool -> IOManager -> [(Text, Text)] -> Assertion -performPruneSameBlock useTxOutAddress = - withCustomConfigAndDropDB cmdLineArgs (Just $ configPruneForceTxIn useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do - startDBSync dbSyncEnv - let txOutTableType = txOutTableTypeFromConfig dbSyncEnv - void $ forgeAndSubmitBlocks interpreter mockServer 76 - blk77 <- forgeNextFindLeaderAndSubmit interpreter mockServer [] - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 20000 20000 st - let utxo0 = head (Babbage.mkUTxOBabbage tx0) - tx1 <- Babbage.mkPaymentTx (UTxOPair utxo0) (UTxOIndex 2) 10000 500 st - pure [tx0, tx1] - assertBlockNoBackoff dbSyncEnv 78 - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 2 "Unexpected TxOutConsumedByTxId before rollback" - void $ forgeAndSubmitBlocks interpreter mockServer 22 - assertBlockNoBackoff dbSyncEnv 100 - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId after prune" - rollbackTo interpreter mockServer (blockPoint blk77) - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSyncEnv 78 - assertTxInCount dbSyncEnv 0 - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId after rollback" - where - cmdLineArgs = initCommandLineArgs - testLabel = "configPruneSameBlock" - -noPruneSameBlock :: IOManager -> [(Text, Text)] -> Assertion -noPruneSameBlock = performNoPruneSameBlock False - -noPruneSameBlockWithAddress :: IOManager -> [(Text, Text)] -> Assertion -noPruneSameBlockWithAddress = performNoPruneSameBlock True - -performNoPruneSameBlock :: Bool -> IOManager -> [(Text, Text)] -> Assertion -performNoPruneSameBlock useTxOutAddress = - withCustomConfigAndDropDB cmdLineArgs (Just $ configConsume useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do - startDBSync dbSyncEnv - let txOutTableType = txOutTableTypeFromConfig dbSyncEnv - void $ forgeAndSubmitBlocks interpreter mockServer 96 - blk97 <- forgeNextFindLeaderAndSubmit interpreter mockServer [] - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 20000 20000 st - let utxo0 = head (Babbage.mkUTxOBabbage tx0) - tx1 <- Babbage.mkPaymentTx (UTxOPair utxo0) (UTxOIndex 2) 10000 500 st - pure [tx0, tx1] - void $ forgeAndSubmitBlocks interpreter mockServer 2 - assertBlockNoBackoff dbSyncEnv 100 - rollbackTo interpreter mockServer (blockPoint blk97) - assertBlockNoBackoff dbSyncEnv 100 - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSyncEnv 98 - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId after rollback" - where - cmdLineArgs = initCommandLineArgs - testLabel = "configNoPruneSameBlock" - -migrateAndPruneRestart :: IOManager -> [(Text, Text)] -> Assertion -migrateAndPruneRestart = performMigrateAndPruneRestart False - -migrateAndPruneRestartWithAddress :: IOManager -> [(Text, Text)] -> Assertion -migrateAndPruneRestartWithAddress = performMigrateAndPruneRestart True - -performMigrateAndPruneRestart :: Bool -> IOManager -> [(Text, Text)] -> Assertion -performMigrateAndPruneRestart useTxOutAddress = do - withCustomConfigAndDropDB cmdLineArgs (Just $ configConsume useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do - startDBSync dbSyncEnv - void $ forgeAndSubmitBlocks interpreter mockServer 50 - assertBlockNoBackoff dbSyncEnv 50 - -- stop - stopDBSync dbSyncEnv - -- update the syncParams to include new params - newEnv <- replaceConfigFile "test-db-sync-config.json" dbSyncEnv - startDBSync newEnv - -- there is a slight delay before flag is checked - threadDelay 6000000 - -- checkStillRuns uses `poll` due to this being inside Async and passes along our thrown exception - checkStillRuns dbSyncEnv - where - cmdLineArgs = initCommandLineArgs - testLabel = "configMigrateAndPruneRestart" - -pruneRestartMissingFlag :: IOManager -> [(Text, Text)] -> Assertion -pruneRestartMissingFlag = performPruneRestartMissingFlag False - -pruneRestartMissingFlagWithAddress :: IOManager -> [(Text, Text)] -> Assertion -pruneRestartMissingFlagWithAddress = performPruneRestartMissingFlag True - -performPruneRestartMissingFlag :: Bool -> IOManager -> [(Text, Text)] -> Assertion -performPruneRestartMissingFlag useTxOutAddress = do - withCustomConfigAndDropDB cmdLineArgs (Just $ configPruneForceTxIn useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do - startDBSync dbSyncEnv - void $ forgeAndSubmitBlocks interpreter mockServer 50 - assertBlockNoBackoff dbSyncEnv 50 - -- stop - stopDBSync dbSyncEnv - -- update the syncParams to include new params - newEnv <- replaceConfigFile "test-db-sync-config.json" dbSyncEnv - startDBSync newEnv - -- there is a slight delay before flag is checked - threadDelay 6000000 - -- checkStillRuns uses `poll` due to this being inside Async and passes along our thrown exception - checkStillRuns dbSyncEnv - where - cmdLineArgs = initCommandLineArgs - testLabel = "configPruneRestartMissingFlag" - -bootstrapRestartMissingFlag :: IOManager -> [(Text, Text)] -> Assertion -bootstrapRestartMissingFlag = performBootstrapRestartMissingFlag False - -bootstrapRestartMissingFlagWithAddress :: IOManager -> [(Text, Text)] -> Assertion -bootstrapRestartMissingFlagWithAddress = performBootstrapRestartMissingFlag True - -performBootstrapRestartMissingFlag :: Bool -> IOManager -> [(Text, Text)] -> Assertion -performBootstrapRestartMissingFlag useTxOutAddress = do - withCustomConfigAndDropDB cmdLineArgs (Just $ configBootstrap useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do - startDBSync dbSyncEnv - void $ forgeAndSubmitBlocks interpreter mockServer 50 - assertBlockNoBackoff dbSyncEnv 50 - assertTxOutCount dbSyncEnv 0 - -- stop - stopDBSync dbSyncEnv - -- update the syncParams to include new params - newEnv <- replaceConfigFile "test-db-sync-config.json" dbSyncEnv - startDBSync newEnv - -- there is a slight delay before flag is checked - threadDelay 6000000 - -- checkStillRuns uses `poll` due to this being inside Async and passes along our thrown exception - checkStillRuns dbSyncEnv - where - cmdLineArgs = initCommandLineArgs - testLabel = "configBootstrapRestartMissingFlag" diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Config/Parse.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Config/Parse.hs deleted file mode 100644 index 3c75ffcf8..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Config/Parse.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Test.Cardano.Db.Mock.Unit.Babbage.Config.Parse ( - defaultInsertConfig, - insertConfig, -) where - -import Cardano.DbSync.Config -import Cardano.DbSync.Config.Types -import Cardano.Prelude -import Data.Default.Class (Default (..)) -import Test.Cardano.Db.Mock.Config -import Test.Tasty.HUnit (Assertion (), (@?=)) -import Prelude () - -defaultInsertConfig :: Assertion -defaultInsertConfig = do - cfg <- mkSyncNodeConfig babbageConfigDir initCommandLineArgs - dncInsertOptions cfg @?= def - -insertConfig :: Assertion -insertConfig = do - cfg <- mkSyncNodeConfig configDir initCommandLineArgs - let expected = - SyncInsertOptions - { sioTxCBOR = TxCBORConfig False - , sioTxOut = TxOutDisable - , sioLedger = LedgerDisable - , sioShelley = ShelleyDisable - , sioRewards = RewardsConfig True - , sioMultiAsset = MultiAssetDisable - , sioMetadata = MetadataDisable - , sioPlutus = PlutusDisable - , sioGovernance = GovernanceConfig False - , sioOffchainPoolData = OffchainPoolDataConfig False - , sioPoolStats = PoolStatsConfig False - , sioJsonType = JsonTypeDisable - , sioRemoveJsonbFromSchema = RemoveJsonbFromSchemaConfig False - } - - dncInsertOptions cfg @?= expected - where - configDir = "config-babbage-insert-options" diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/InlineAndReference.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/InlineAndReference.hs deleted file mode 100644 index f114e9d88..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/InlineAndReference.hs +++ /dev/null @@ -1,434 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -#if __GLASGOW_HASKELL__ >= 908 -{-# OPTIONS_GHC -Wno-x-partial #-} -#endif - -module Test.Cardano.Db.Mock.Unit.Babbage.InlineAndReference ( - unlockDatumOutput, - unlockDatumOutputSameBlock, - inlineDatumCBOR, - spendRefScript, - spendRefScriptSameBlock, - spendCollateralOutput, - spendCollateralOutputRollback, - spendCollateralOutputSameBlock, - referenceInputUnspend, - supplyScriptsTwoWays, - supplyScriptsTwoWaysSameBlock, - referenceMintingScript, - referenceDelegation, -) where - -import Cardano.Ledger.Coin -import Cardano.Ledger.Mary.Value (MaryValue (..), MultiAsset (..), PolicyID (..)) -import Cardano.Mock.ChainSync.Server (IOManager) -import Cardano.Mock.Forging.Interpreter (withBabbageLedgerState) -import Cardano.Mock.Forging.Tx.Alonzo.ScriptsExamples ( - alwaysSucceedsScriptAddr, - alwaysSucceedsScriptHash, - assetNames, - plutusDataEncLen, - ) -import qualified Cardano.Mock.Forging.Tx.Babbage as Babbage -import Cardano.Mock.Forging.Types ( - MockBlock (..), - NodeId (..), - TxEra (..), - UTxOIndex (..), - ) -import Control.Monad (void) -import qualified Data.ByteString.Short as SBS -import qualified Data.Map as Map -import Data.Text (Text) -import Ouroboros.Network.Block (blockPoint) -import Test.Cardano.Db.Mock.Config (babbageConfigDir, startDBSync, withFullConfig, withFullConfigAndDropDB) -import Test.Cardano.Db.Mock.UnifiedApi ( - forgeNextAndSubmit, - forgeNextFindLeaderAndSubmit, - registerAllStakeCreds, - rollbackTo, - withBabbageFindLeaderAndSubmitTx, - ) -import Test.Cardano.Db.Mock.Validate (assertBabbageCounts, assertBlockNoBackoff, assertDatumCBOR) -import Test.Tasty.HUnit (Assertion) - -unlockDatumOutput :: IOManager -> [(Text, Text)] -> Assertion -unlockDatumOutput = - withFullConfigAndDropDB babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - -- We don't use withBabbageFindLeaderAndSubmitTx here, because we want access to the tx. - tx0 <- - withBabbageLedgerState interpreter $ - Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutInline True Babbage.InlineDatum Babbage.NoReferenceScript] 20000 20000 - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx0] (NodeId 1) - - let utxo0 = head (Babbage.mkUTxOBabbage tx0) - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkUnlockScriptTxBabbage [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) [UTxOPair utxo0] False True 10000 500 - - assertBlockNoBackoff dbSync 3 - assertBabbageCounts dbSync (1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 0) - where - testLabel = "unlockDatumOutput" - -unlockDatumOutputSameBlock :: IOManager -> [(Text, Text)] -> Assertion -unlockDatumOutputSameBlock = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - -- We try to make this test as crazy as possible, by keeping inputs and outputs in the same blocks, using unnecessary reference - -- inputs and adding unnnecessary fields to the collateral output. - txs' <- withBabbageLedgerState interpreter $ \st -> do - tx0 <- - Babbage.mkLockByScriptTx - (UTxOIndex 0) - [Babbage.TxOutInline True Babbage.InlineDatum Babbage.NoReferenceScript, Babbage.TxOutInline True Babbage.NotInlineDatum (Babbage.ReferenceScript False)] - 20000 - 20000 - st - let utxo0 = head (Babbage.mkUTxOBabbage tx0) - tx1 <- - Babbage.mkUnlockScriptTxBabbage - [UTxOPair utxo0] - (UTxOIndex 1) - (UTxOIndex 2) - [UTxOPair utxo0, UTxOIndex 2] - True - True - 10000 - 500 - st - pure [tx0, tx1] - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock (TxBabbage <$> txs') (NodeId 1) - - assertBlockNoBackoff dbSync 2 - assertBabbageCounts dbSync (2, 1, 1, 1, 2, 1, 0, 0, 1, 2, 1, 1, 1) - where - testLabel = "unlockDatumOutputSameBlock" - -inlineDatumCBOR :: IOManager -> [(Text, Text)] -> Assertion -inlineDatumCBOR = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - -- We don't use withBabbageFindLeaderAndSubmitTx here, because we want access to the tx. - tx0 <- - withBabbageLedgerState interpreter $ - Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutInline True (Babbage.InlineDatumCBOR plutusDataEncLen) Babbage.NoReferenceScript] 20000 20000 - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx0] (NodeId 1) - - assertBlockNoBackoff dbSync 2 - assertDatumCBOR dbSync $ SBS.fromShort plutusDataEncLen - where - testLabel = "inlineDatumCBOR" - -spendRefScript :: IOManager -> [(Text, Text)] -> Assertion -spendRefScript = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - -- We don't use withBabbageFindLeaderAndSubmitTx here, because we want access to the tx. - tx0 <- - withBabbageLedgerState interpreter $ - Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutInline True Babbage.NotInlineDatum (Babbage.ReferenceScript True)] 20000 20000 - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx0] (NodeId 1) - - let utxo0 = head (Babbage.mkUTxOBabbage tx0) - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkUnlockScriptTxBabbage [UTxOPair utxo0] (UTxOIndex 1) (UTxOAddress alwaysSucceedsScriptAddr) [UTxOPair utxo0] False True 10000 500 - - assertBlockNoBackoff dbSync 3 - assertBabbageCounts dbSync (1, 1, 1, 1, 2, 1, 0, 0, 1, 1, 1, 0, 1) - where - testLabel = "spendRefScript" - -spendRefScriptSameBlock :: IOManager -> [(Text, Text)] -> Assertion -spendRefScriptSameBlock = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - txs' <- withBabbageLedgerState interpreter $ \st -> do - tx0 <- - Babbage.mkLockByScriptTx - (UTxOIndex 0) - [ Babbage.TxOutInline True Babbage.NotInlineDatum (Babbage.ReferenceScript True) - , Babbage.TxOutInline True Babbage.NotInlineDatum (Babbage.ReferenceScript False) - ] - 20000 - 20000 - st - let utxo0 = head (Babbage.mkUTxOBabbage tx0) - tx1 <- - Babbage.mkUnlockScriptTxBabbage - [UTxOPair utxo0] - (UTxOIndex 1) - (UTxOIndex 2) - [UTxOPair utxo0, UTxOIndex 2] - True - True - 10000 - 500 - st - pure [tx0, tx1] - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock (TxBabbage <$> txs') (NodeId 1) - - assertBlockNoBackoff dbSync 2 - assertBabbageCounts dbSync (2, 1, 1, 1, 2, 1, 0, 0, 1, 2, 1, 0, 2) - where - testLabel = "spendRefScriptSameBlock" - -spendCollateralOutput :: IOManager -> [(Text, Text)] -> Assertion -spendCollateralOutput = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - tx0 <- - withBabbageLedgerState interpreter $ - Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutNoInline False] 20000 20000 - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [TxBabbage tx0] - - -- tx fails so its collateral output become actual output. - let utxo0 = head (Babbage.mkUTxOBabbage tx0) - tx1 <- - withBabbageLedgerState interpreter $ - Babbage.mkUnlockScriptTxBabbage [UTxOInput (fst utxo0)] (UTxOIndex 1) (UTxOIndex 2) [UTxOPair utxo0] True False 10000 500 - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [TxBabbage tx1] - assertBlockNoBackoff dbSync 3 - - let utxo1 = head (Babbage.mkUTxOCollBabbage tx1) - tx2 <- - withBabbageLedgerState interpreter $ - Babbage.mkUnlockScriptTxBabbage [UTxOPair utxo1] (UTxOIndex 3) (UTxOIndex 1) [UTxOPair utxo1] False True 10000 500 - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [TxBabbage tx2] - - assertBlockNoBackoff dbSync 4 - assertBabbageCounts dbSync (1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 1, 1) - where - testLabel = "spendCollateralOutput" - -spendCollateralOutputRollback :: IOManager -> [(Text, Text)] -> Assertion -spendCollateralOutputRollback = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - blk0 <- registerAllStakeCreds interpreter mockServer - action interpreter mockServer dbSync 0 - rollbackTo interpreter mockServer (blockPoint blk0) - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - action interpreter mockServer dbSync 1 - where - testLabel = "spendCollateralOutputRollback" - action interpreter mockServer dbSync n = do - tx0 <- - withBabbageLedgerState interpreter $ - Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutNoInline False] 20000 20000 - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [TxBabbage tx0] - - -- tx fails so its collateral output become actual output. - let utxo0 = head (Babbage.mkUTxOBabbage tx0) - tx1 <- - withBabbageLedgerState interpreter $ - Babbage.mkUnlockScriptTxBabbage [UTxOInput (fst utxo0)] (UTxOIndex 1) (UTxOIndex 2) [UTxOPair utxo0] True False 10000 500 - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [TxBabbage tx1] - assertBlockNoBackoff dbSync $ n + 3 - - let utxo1 = head (Babbage.mkUTxOCollBabbage tx1) - tx2 <- - withBabbageLedgerState interpreter $ - Babbage.mkUnlockScriptTxBabbage [UTxOPair utxo1] (UTxOIndex 3) (UTxOIndex 1) [UTxOPair utxo1] False True 10000 500 - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [TxBabbage tx2] - - assertBlockNoBackoff dbSync $ n + 4 - assertBabbageCounts dbSync (1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 1, 1) - -spendCollateralOutputSameBlock :: IOManager -> [(Text, Text)] -> Assertion -spendCollateralOutputSameBlock = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - txs' <- withBabbageLedgerState interpreter $ \st -> do - tx0 <- Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutNoInline False] 20000 20000 st - - -- tx fails so its collateral output become actual output. - let utxo0 = head (Babbage.mkUTxOBabbage tx0) - tx1 <- Babbage.mkUnlockScriptTxBabbage [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) [UTxOPair utxo0] True False 10000 500 st - let utxo1 = head (Babbage.mkUTxOCollBabbage tx1) - tx2 <- Babbage.mkUnlockScriptTxBabbage [UTxOPair utxo1] (UTxOIndex 3) (UTxOIndex 4) [UTxOPair utxo1] False True 10000 500 st - pure [tx0, tx1, tx2] - void $ forgeNextFindLeaderAndSubmit interpreter mockServer (TxBabbage <$> txs') - - assertBlockNoBackoff dbSync 2 - assertBabbageCounts dbSync (1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 1, 1) - where - testLabel = "spendCollateralOutputSameBlock" - -referenceInputUnspend :: IOManager -> [(Text, Text)] -> Assertion -referenceInputUnspend = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - txs' <- withBabbageLedgerState interpreter $ \st -> do - tx0 <- - Babbage.mkLockByScriptTx - (UTxOIndex 0) - [ Babbage.TxOutInline True Babbage.InlineDatum (Babbage.ReferenceScript True) - , Babbage.TxOutInline True Babbage.InlineDatum (Babbage.ReferenceScript True) - ] - 20000 - 20000 - st - - let (utxo0 : utxo1 : _) = Babbage.mkUTxOBabbage tx0 - -- use a reference to an input which is not spend. - tx1 <- Babbage.mkUnlockScriptTxBabbage [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) [UTxOPair utxo1] False True 10000 500 st - pure [tx0, tx1] - void $ forgeNextFindLeaderAndSubmit interpreter mockServer (TxBabbage <$> txs') - - assertBlockNoBackoff dbSync 2 - assertBabbageCounts dbSync (1, 1, 1, 1, 2, 1, 0, 0, 1, 1, 1, 2, 2) - where - testLabel = "referenceInputUnspend" - -supplyScriptsTwoWays :: IOManager -> [(Text, Text)] -> Assertion -supplyScriptsTwoWays = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - tx0 <- - withBabbageLedgerState interpreter $ - Babbage.mkLockByScriptTx - (UTxOIndex 0) - [ Babbage.TxOutInline True Babbage.InlineDatum (Babbage.ReferenceScript True) - , Babbage.TxOutNoInline True - ] - 20000 - 20000 - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [TxBabbage tx0] - - let (utxo0 : utxo1 : _) = Babbage.mkUTxOBabbage tx0 - -- use a reference to an input which is not spend. - tx1 <- - withBabbageLedgerState interpreter $ - Babbage.mkUnlockScriptTxBabbage [UTxOPair utxo0, UTxOPair utxo1] (UTxOIndex 1) (UTxOIndex 2) [UTxOPair utxo0] False True 10000 500 - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [TxBabbage tx1] - - assertBlockNoBackoff dbSync 3 - assertBabbageCounts dbSync (1, 2, 1, 1, 2, 2, 0, 0, 1, 1, 1, 1, 1) - where - testLabel = "supplyScriptsTwoWays" - -supplyScriptsTwoWaysSameBlock :: IOManager -> [(Text, Text)] -> Assertion -supplyScriptsTwoWaysSameBlock = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - txs' <- withBabbageLedgerState interpreter $ \st -> do - -- one script referenced and one for the witnesses - tx0 <- - Babbage.mkLockByScriptTx - (UTxOIndex 0) - [ Babbage.TxOutInline True Babbage.InlineDatum (Babbage.ReferenceScript True) - , Babbage.TxOutNoInline True - ] - 20000 - 20000 - st - - let (utxo0 : utxo1 : _) = Babbage.mkUTxOBabbage tx0 - -- use a reference to an input which is not spend. - tx1 <- Babbage.mkUnlockScriptTxBabbage [UTxOPair utxo0, UTxOPair utxo1] (UTxOIndex 1) (UTxOIndex 2) [UTxOPair utxo0] False True 10000 500 st - pure [tx0, tx1] - void $ forgeNextFindLeaderAndSubmit interpreter mockServer (TxBabbage <$> txs') - - assertBlockNoBackoff dbSync 2 - assertBabbageCounts dbSync (1, 2, 1, 1, 2, 2, 0, 0, 1, 1, 1, 1, 1) - where - testLabel = "supplyScriptsTwoWaysSameBlock" - -referenceMintingScript :: IOManager -> [(Text, Text)] -> Assertion -referenceMintingScript = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - txs' <- withBabbageLedgerState interpreter $ \st -> do - -- one script referenced and one for the witnesses - tx0 <- - Babbage.mkLockByScriptTx - (UTxOIndex 0) - [Babbage.TxOutInline True Babbage.InlineDatum (Babbage.ReferenceScript True)] - 20000 - 20000 - st - - let utxo0 = head $ Babbage.mkUTxOBabbage tx0 - -- use a reference to an output which has a minting script. - let val0 = MultiAsset $ Map.singleton (PolicyID alwaysSucceedsScriptHash) (Map.singleton (head assetNames) 1) - tx1 <- - Babbage.mkMAssetsScriptTx - [UTxOIndex 0] - (UTxOIndex 1) - [(UTxOAddressNew 0, MaryValue (Coin 10000) mempty)] - [UTxOPair utxo0] - val0 - True - 100 - st - pure [tx0, tx1] - void $ forgeNextFindLeaderAndSubmit interpreter mockServer (TxBabbage <$> txs') - - assertBlockNoBackoff dbSync 2 - assertBabbageCounts dbSync (1, 1, 1, 1, 1, 0, 0, 0, 1, 1, 0, 1, 1) - where - testLabel = "referenceMintingScript" - -referenceDelegation :: IOManager -> [(Text, Text)] -> Assertion -referenceDelegation = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - txs' <- withBabbageLedgerState interpreter $ \st -> do - -- one script referenced and one for the witnesses - tx0 <- - Babbage.mkLockByScriptTx - (UTxOIndex 0) - [Babbage.TxOutInline True Babbage.InlineDatum (Babbage.ReferenceScript True)] - 20000 - 20000 - st - - let utxo0 = head $ Babbage.mkUTxOBabbage tx0 - -- use a reference to an output which has a minting script. - let val0 = MultiAsset $ Map.singleton (PolicyID alwaysSucceedsScriptHash) (Map.singleton (head assetNames) 1) - tx1 <- - Babbage.mkMAssetsScriptTx - [UTxOIndex 0] - (UTxOIndex 1) - [(UTxOAddressNew 0, MaryValue (Coin 10000) mempty)] - [UTxOPair utxo0] - val0 - True - 100 - st - pure [tx0, tx1] - void $ forgeNextFindLeaderAndSubmit interpreter mockServer (TxBabbage <$> txs') - - assertBlockNoBackoff dbSync 2 - assertBabbageCounts dbSync (1, 1, 1, 1, 1, 0, 0, 0, 1, 1, 0, 1, 1) - where - testLabel = "referenceDelegation" diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Other.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Other.hs deleted file mode 100644 index 7c179557e..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Other.hs +++ /dev/null @@ -1,392 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module Test.Cardano.Db.Mock.Unit.Babbage.Other ( - -- different configs - configNoPools, - configNoStakes, - -- pools and smash - poolReg, - nonexistantPoolQuery, - poolDeReg, - poolDeRegMany, - poolDelist, - -- hard fork - forkFixedEpoch, - rollbackFork, -) where - -import Cardano.DbSync.Era.Shelley.Generic.Util (unKeyHashRaw) -import Cardano.Ledger.BaseTypes (EpochNo) -import Cardano.Ledger.Credential (StakeCredential) -import Cardano.Ledger.Keys (KeyHash, KeyRole (StakePool)) -import Cardano.Ledger.Shelley.TxCert -import Cardano.Mock.ChainSync.Server (IOManager, addBlock, rollback) -import Cardano.Mock.Forging.Interpreter (forgeNext) -import qualified Cardano.Mock.Forging.Tx.Alonzo as Alonzo -import qualified Cardano.Mock.Forging.Tx.Babbage as Babbage -import Cardano.Mock.Forging.Tx.Generic (resolvePool) -import Cardano.Mock.Forging.Types ( - ForgingError (..), - PoolIndex (..), - StakeIndex (..), - UTxOIndex (..), - ) -import Cardano.SMASH.Server.PoolDataLayer (PoolDataLayer (..), dbToServantPoolId) -import Cardano.SMASH.Server.Types (DBFail (..)) -import Cardano.Slotting.Slot (EpochNo (..)) -import Control.Concurrent (threadDelay) -import Control.Concurrent.Class.MonadSTM.Strict (MonadSTM (atomically)) -import Control.Exception (try) -import Control.Monad (forM_, void) -import Data.Text (Text) -import Ouroboros.Consensus.Cardano.Block (StandardBabbage, StandardCrypto) -import Ouroboros.Network.Block (blockPoint) -import Test.Cardano.Db.Mock.Config (babbageConfigDir, getPoolLayer, startDBSync, stopDBSync, withFullConfig, withFullConfigAndDropDB) -import Test.Cardano.Db.Mock.Examples (mockBlock0) -import Test.Cardano.Db.Mock.UnifiedApi ( - fillEpochPercentage, - fillEpochs, - fillUntilNextEpoch, - forgeNextFindLeaderAndSubmit, - getBabbageLedgerState, - withAlonzoFindLeaderAndSubmitTx, - withBabbageFindLeaderAndSubmit, - withBabbageFindLeaderAndSubmitTx, - ) -import Test.Cardano.Db.Mock.Validate ( - addPoolCounters, - assertBlockNoBackoff, - assertBlocksCount, - assertPoolCounters, - assertPoolLayerCounters, - assertTxCount, - checkStillRuns, - poolCountersQuery, - runQuery, - ) -import Test.Tasty.HUnit (Assertion, assertEqual, assertFailure) - -{- HLINT ignore "Use underscore" -} - ----------------------------------------------------------------------------------------------------------- --- Different Configs ----------------------------------------------------------------------------------------------------------- - -configNoPools :: IOManager -> [(Text, Text)] -> Assertion -configNoPools = - withFullConfig "config2" testLabel $ \_ _ dbSync -> do - startDBSync dbSync - assertBlocksCount dbSync 2 - assertTxCount dbSync 6 - stopDBSync dbSync - startDBSync dbSync - -- Nothing changes, so polling assertions doesn't help here - -- We have to pause and check if anything crashed. - threadDelay 3_000_000 - checkStillRuns dbSync - assertBlocksCount dbSync 2 -- 2 genesis blocks - assertTxCount dbSync 6 - where - testLabel = "configNoPools" - -configNoStakes :: IOManager -> [(Text, Text)] -> Assertion -configNoStakes = - withFullConfig "config3" testLabel $ \interpreter _ dbSync -> do - startDBSync dbSync - assertBlocksCount dbSync 2 - assertTxCount dbSync 7 - stopDBSync dbSync - startDBSync dbSync - -- Nothing changes, so polling assertions don't help here - -- We have to pause and check if anything crashed. - threadDelay 3_000_000 - checkStillRuns dbSync - assertBlocksCount dbSync 2 - assertTxCount dbSync 7 - -- A pool with no stakes can't create a block. - eblk <- try $ forgeNext interpreter mockBlock0 - case eblk of - Right _ -> assertFailure "should fail" - Left WentTooFar {} -> pure () - -- TODO add an option to disable fingerprint validation for tests like this. - Left (EmptyFingerprint _ _) -> pure () - Left err -> assertFailure $ "got " <> show err <> " instead of WentTooFar" - where - testLabel = "configNoStakes" - ----------------------------------------------------------------------------------------------------------- --- Pools and Smash ----------------------------------------------------------------------------------------------------------- - -poolReg :: IOManager -> [(Text, Text)] -> Assertion -poolReg = - withFullConfigAndDropDB babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 1 - initCounter <- runQuery dbSync poolCountersQuery - assertEqual "Unexpected init pool counter" (3, 0, 3, 2, 0, 0) initCounter - - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkDCertPoolTx - [ - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Babbage.consPoolParamsTwoOwners - ) - ] - - assertBlockNoBackoff dbSync 2 - assertPoolCounters dbSync (addPoolCounters (1, 1, 1, 2, 0, 1) initCounter) - st <- getBabbageLedgerState interpreter - assertPoolLayerCounters dbSync (0, 0) [(PoolIndexNew 0, (Right False, False, True))] st - where - testLabel = "poolReg" - --- Issue https://github.com/IntersectMBO/cardano-db-sync/issues/997 -nonexistantPoolQuery :: IOManager -> [(Text, Text)] -> Assertion -nonexistantPoolQuery = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 1 - - st <- getBabbageLedgerState interpreter - assertPoolLayerCounters dbSync (0, 0) [(PoolIndexNew 0, (Left RecordDoesNotExist, False, False))] st - where - testLabel = "nonexistantPoolQuery" - -poolDeReg :: IOManager -> [(Text, Text)] -> Assertion -poolDeReg = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 1 - initCounter <- runQuery dbSync poolCountersQuery - assertEqual "Unexpected init pool counter" (3, 0, 3, 2, 0, 0) initCounter - - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkDCertPoolTx - [ - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Babbage.consPoolParamsTwoOwners - ) - , ([], PoolIndexNew 0, \_ poolId -> ShelleyTxCertPool $ RetirePool poolId (EpochNo 1)) - ] - - assertBlockNoBackoff dbSync 2 - assertPoolCounters dbSync (addPoolCounters (1, 1, 1, 2, 1, 1) initCounter) - - st <- getBabbageLedgerState interpreter - -- Not retired yet, because epoch has not changed - assertPoolLayerCounters dbSync (0, 0) [(PoolIndexNew 0, (Right False, False, True))] st - - -- change epoch - a <- fillUntilNextEpoch interpreter mockServer - - assertBlockNoBackoff dbSync (fromIntegral $ length a + 2) - -- these counters are the same - assertPoolCounters dbSync (addPoolCounters (1, 1, 1, 2, 1, 1) initCounter) - - -- the pool is now retired, since the epoch changed. - assertPoolLayerCounters dbSync (1, 0) [(PoolIndexNew 0, (Right True, False, False))] st - where - testLabel = "poolDeReg" - -poolDeRegMany :: IOManager -> [(Text, Text)] -> Assertion -poolDeRegMany = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 1 - initCounter <- runQuery dbSync poolCountersQuery - assertEqual "Unexpected init pool counter" (3, 0, 3, 2, 0, 0) initCounter - - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkDCertPoolTx - [ -- register - - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Babbage.consPoolParamsTwoOwners - ) - , -- de register - ([], PoolIndexNew 0, mkPoolDereg (EpochNo 4)) - , -- register - - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Babbage.consPoolParamsTwoOwners - ) - , -- register with different owner and reward address - - ( [StakeIndexNew 2, StakeIndexNew 1, StakeIndexNew 0] - , PoolIndexNew 0 - , Babbage.consPoolParamsTwoOwners - ) - ] - - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- - Babbage.mkDCertPoolTx - [ -- register - - ( [StakeIndexNew 2, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Babbage.consPoolParamsTwoOwners - ) - ] - st - - tx1 <- - Babbage.mkDCertPoolTx - [ -- deregister - ([] :: [StakeIndex], PoolIndexNew 0, mkPoolDereg (EpochNo 4)) - , -- register - - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Babbage.consPoolParamsTwoOwners - ) - , -- deregister - ([] :: [StakeIndex], PoolIndexNew 0, mkPoolDereg (EpochNo 1)) - ] - st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 3 - -- TODO fix PoolOwner and PoolRelay unique key - assertPoolCounters dbSync (addPoolCounters (1, 5, 5, 10, 3, 5) initCounter) - - st <- getBabbageLedgerState interpreter - -- Not retired yet, because epoch has not changed - assertPoolLayerCounters dbSync (0, 0) [(PoolIndexNew 0, (Right False, False, True))] st - - -- change epoch - a <- fillUntilNextEpoch interpreter mockServer - - assertBlockNoBackoff dbSync (fromIntegral $ length a + 3) - -- these counters are the same - assertPoolCounters dbSync (addPoolCounters (1, 5, 5, 10, 3, 5) initCounter) - - -- from all these certificates only the latest matters. So it will retire - -- on epoch 0 - assertPoolLayerCounters dbSync (1, 0) [(PoolIndexNew 0, (Right True, False, False))] st - where - testLabel = "poolDeRegMany" - mkPoolDereg :: - EpochNo -> - [StakeCredential StandardCrypto] -> - KeyHash 'StakePool StandardCrypto -> - ShelleyTxCert StandardBabbage - mkPoolDereg epochNo _creds keyHash = ShelleyTxCertPool $ RetirePool keyHash epochNo - -poolDelist :: IOManager -> [(Text, Text)] -> Assertion -poolDelist = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 1 - initCounter <- runQuery dbSync poolCountersQuery - assertEqual "Unexpected init pool counter" (3, 0, 3, 2, 0, 0) initCounter - - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkDCertPoolTx - [ - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Babbage.consPoolParamsTwoOwners - ) - ] - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 3 - st <- getBabbageLedgerState interpreter - assertPoolLayerCounters dbSync (0, 0) [(PoolIndexNew 0, (Right False, False, True))] st - - let poolKeyHash = resolvePool (PoolIndexNew 0) st - let poolId = dbToServantPoolId $ unKeyHashRaw poolKeyHash - poolLayer <- getPoolLayer dbSync - void $ dlAddDelistedPool poolLayer poolId - - -- This is not async, so we don't need to do exponential backoff - -- delisted not retired - assertPoolLayerCounters dbSync (0, 1) [(PoolIndexNew 0, (Right False, True, True))] st - - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkDCertPoolTx - [([], PoolIndexNew 0, \_ poolHash -> ShelleyTxCertPool $ RetirePool poolHash (EpochNo 1))] - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 5 - -- delisted and pending retirement - assertPoolLayerCounters dbSync (0, 1) [(PoolIndexNew 0, (Right False, True, True))] st - - a <- fillUntilNextEpoch interpreter mockServer - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync (fromIntegral $ 5 + length a + 1) - -- delisted and retired - assertPoolLayerCounters dbSync (1, 1) [(PoolIndexNew 0, (Right True, True, False))] st - where - testLabel = "poolDelist" - ----------------------------------------------------------------------------------------------------------- --- Hard Fork ----------------------------------------------------------------------------------------------------------- - -forkFixedEpoch :: IOManager -> [(Text, Text)] -> Assertion -forkFixedEpoch = - withFullConfigAndDropDB "config-hf-epoch1" testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 500 - - a <- fillEpochs interpreter mockServer 2 - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 500 - - b <- fillUntilNextEpoch interpreter mockServer - - assertBlockNoBackoff dbSync $ 2 + length (a <> b) - where - testLabel = "forkFixedEpoch" - -rollbackFork :: IOManager -> [(Text, Text)] -> Assertion -rollbackFork = - withFullConfig "config-hf-epoch1" testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 500 - a <- fillUntilNextEpoch interpreter mockServer - b <- fillEpochPercentage interpreter mockServer 85 - c <- fillUntilNextEpoch interpreter mockServer - blk <- - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 500 - - assertBlockNoBackoff dbSync $ 2 + length (a <> b <> c) - atomically $ rollback mockServer (blockPoint $ last b) - - forM_ (c <> [blk]) $ atomically . addBlock mockServer - - assertBlockNoBackoff dbSync $ 2 + length (a <> b <> c) - where - testLabel = "rollbackFork" diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Plutus.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Plutus.hs deleted file mode 100644 index 2135f8056..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Plutus.hs +++ /dev/null @@ -1,508 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeApplications #-} - -#if __GLASGOW_HASKELL__ >= 908 -{-# OPTIONS_GHC -Wno-x-partial #-} -#endif - -module Test.Cardano.Db.Mock.Unit.Babbage.Plutus ( - -- plutus spend scripts - simpleScript, - unlockScriptSameBlock, - failedScript, - failedScriptFees, - failedScriptSameBlock, - multipleScripts, - multipleScriptsRollback, - multipleScriptsSameBlock, - multipleScriptsFailed, - multipleScriptsFailedSameBlock, - -- plutus cert scripts - registrationScriptTx, - deregistrationsScriptTx, - deregistrationScriptTx, - deregistrationsScriptTxs, - deregistrationsScriptTx', - deregistrationsScriptTx'', - -- plutus MultiAsset scripts - mintMultiAsset, - mintMultiAssets, - swapMultiAssets, -) where - -import qualified Cardano.Crypto.Hash as Crypto -import qualified Cardano.Db as DB -import qualified Cardano.Db.Schema.Core.TxOut as C -import qualified Cardano.Db.Schema.Variant.TxOut as V -import Cardano.DbSync.Era.Shelley.Generic.Util (renderAddress) -import Cardano.Ledger.Coin -import Cardano.Ledger.Mary.Value (MaryValue (..), MultiAsset (..), PolicyID (..)) -import Cardano.Ledger.Plutus.Data (hashData) -import Cardano.Ledger.SafeHash (extractHash) -import Cardano.Ledger.Shelley.TxCert -import Cardano.Mock.ChainSync.Server (IOManager) -import Cardano.Mock.Forging.Interpreter (withBabbageLedgerState) -import Cardano.Mock.Forging.Tx.Alonzo.ScriptsExamples ( - alwaysMintScriptAddr, - alwaysMintScriptHash, - alwaysSucceedsScriptAddr, - alwaysSucceedsScriptHash, - assetNames, - plutusDataList, - ) -import qualified Cardano.Mock.Forging.Tx.Babbage as Babbage -import Cardano.Mock.Forging.Types ( - MockBlock (..), - NodeId (..), - StakeIndex (..), - TxEra (..), - UTxOIndex (..), - ) -import Control.Monad (void) -import qualified Data.Map as Map -import Data.Text (Text) -import Ouroboros.Consensus.Cardano.Block (StandardBabbage) -import Ouroboros.Network.Block (genesisPoint) -import Test.Cardano.Db.Mock.Config (babbageConfigDir, startDBSync, txOutTableTypeFromConfig, withFullConfig, withFullConfigAndDropDB) -import Test.Cardano.Db.Mock.UnifiedApi ( - fillUntilNextEpoch, - forgeNextAndSubmit, - forgeNextFindLeaderAndSubmit, - registerAllStakeCreds, - rollbackTo, - withBabbageFindLeaderAndSubmit, - withBabbageFindLeaderAndSubmitTx, - ) -import Test.Cardano.Db.Mock.Validate ( - assertAlonzoCounts, - assertBlockNoBackoff, - assertEqQuery, - assertNonZeroFeesContract, - assertScriptCert, - ) -import Test.Tasty.HUnit (Assertion) - ----------------------------------------------------------------------------------------------------------- --- Plutus Spend Scripts ----------------------------------------------------------------------------------------------------------- - -simpleScript :: IOManager -> [(Text, Text)] -> Assertion -simpleScript = - withFullConfigAndDropDB babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - let txOutTableType = txOutTableTypeFromConfig dbSync - void $ registerAllStakeCreds interpreter mockServer - - a <- fillUntilNextEpoch interpreter mockServer - - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutNoInline True] 20000 20000 - - assertBlockNoBackoff dbSync (fromIntegral $ length a + 2) - assertEqQuery dbSync (fmap getOutFields <$> DB.queryScriptOutputs txOutTableType) [expectedFields] "Unexpected script outputs" - where - testLabel = "simpleScript" - getOutFields txOutW = - case txOutW of - DB.CTxOutW txOut -> - ( C.txOutAddress txOut - , C.txOutAddressHasScript txOut - , C.txOutValue txOut - , C.txOutDataHash txOut - ) - DB.VTxOutW txOut mAddress -> case mAddress of - Just address -> - ( V.addressAddress address - , V.addressHasScript address - , V.txOutValue txOut - , V.txOutDataHash txOut - ) - Nothing -> error "BabbageSimpleScript: expected an address" - - expectedFields = - ( renderAddress alwaysSucceedsScriptAddr - , True - , DB.DbLovelace 20000 - , Just $ Crypto.hashToBytes (extractHash $ hashData @StandardBabbage plutusDataList) - ) - -unlockScriptSameBlock :: IOManager -> [(Text, Text)] -> Assertion -unlockScriptSameBlock = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutNoInline True] 20000 20000 st - let utxo0 = head (Babbage.mkUTxOBabbage tx0) - tx1 <- Babbage.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) True 10000 500 st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 2 - assertAlonzoCounts dbSync (1, 1, 1, 1, 1, 1, 0, 0) - where - testLabel = "unlockScriptSameBlock" - -failedScript :: IOManager -> [(Text, Text)] -> Assertion -failedScript = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - tx0 <- withBabbageLedgerState interpreter $ Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutNoInline False] 20000 20000 - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx0] (NodeId 1) - - let utxo0 = head (Babbage.mkUTxOBabbage tx0) - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) False 10000 500 - - assertBlockNoBackoff dbSync 2 - assertAlonzoCounts dbSync (0, 0, 0, 0, 1, 0, 1, 1) - where - testLabel = "failedScript" - -failedScriptFees :: IOManager -> [(Text, Text)] -> Assertion -failedScriptFees = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - tx0 <- withBabbageLedgerState interpreter $ Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutNoInline False] 20000 20000 - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx0] (NodeId 1) - - let utxo0 = head (Babbage.mkUTxOBabbage tx0) - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) False 10000 500 - - assertBlockNoBackoff dbSync 2 - assertAlonzoCounts dbSync (0, 0, 0, 0, 1, 0, 1, 1) - assertNonZeroFeesContract dbSync - where - testLabel = "failedScriptFees" - -failedScriptSameBlock :: IOManager -> [(Text, Text)] -> Assertion -failedScriptSameBlock = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutNoInline False] 20000 20000 st - let utxo0 = head (Babbage.mkUTxOBabbage tx0) - tx1 <- Babbage.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) False 10000 500 st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 2 - assertAlonzoCounts dbSync (0, 0, 0, 0, 1, 0, 1, 1) - where - testLabel = "failedScriptSameBlock" - -multipleScripts :: IOManager -> [(Text, Text)] -> Assertion -multipleScripts = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - tx0 <- withBabbageLedgerState interpreter $ Babbage.mkLockByScriptTx (UTxOIndex 0) (Babbage.TxOutNoInline <$> [True, False, True]) 20000 20000 - let utxo = Babbage.mkUTxOBabbage tx0 - pair1 = head utxo - pair2 = utxo !! 2 - tx1 <- - withBabbageLedgerState interpreter $ - Babbage.mkUnlockScriptTx [UTxOPair pair1, UTxOPair pair2] (UTxOIndex 1) (UTxOIndex 2) True 10000 500 - - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx0] (NodeId 1) - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx1] (NodeId 1) - - assertBlockNoBackoff dbSync 2 - assertAlonzoCounts dbSync (1, 2, 1, 1, 3, 2, 0, 0) - where - testLabel = "multipleScripts" - -multipleScriptsRollback :: IOManager -> [(Text, Text)] -> Assertion -multipleScriptsRollback = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - tx0 <- withBabbageLedgerState interpreter $ Babbage.mkLockByScriptTx (UTxOIndex 0) (Babbage.TxOutNoInline <$> [True, False, True]) 20000 20000 - let utxo = Babbage.mkUTxOBabbage tx0 - pair1 = head utxo - pair2 = utxo !! 2 - tx1 <- - withBabbageLedgerState interpreter $ - Babbage.mkUnlockScriptTx [UTxOPair pair1, UTxOPair pair2] (UTxOIndex 1) (UTxOIndex 2) True 10000 500 - - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx0] (NodeId 1) - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx1] (NodeId 1) - - assertBlockNoBackoff dbSync 2 - assertAlonzoCounts dbSync (1, 2, 1, 1, 3, 2, 0, 0) - - rollbackTo interpreter mockServer genesisPoint - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx0] (NodeId 1) - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx1] (NodeId 1) - assertBlockNoBackoff dbSync 3 - - assertAlonzoCounts dbSync (1, 2, 1, 1, 3, 2, 0, 0) - where - testLabel = "multipleScriptsRollback" - -multipleScriptsSameBlock :: IOManager -> [(Text, Text)] -> Assertion -multipleScriptsSameBlock = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkLockByScriptTx (UTxOIndex 0) (Babbage.TxOutNoInline <$> [True, False, True]) 20000 20000 st - let utxo = Babbage.mkUTxOBabbage tx0 - pair1 = head utxo - pair2 = utxo !! 2 - tx1 <- Babbage.mkUnlockScriptTx [UTxOPair pair1, UTxOPair pair2] (UTxOIndex 1) (UTxOIndex 2) True 10000 500 st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertAlonzoCounts dbSync (1, 2, 1, 1, 3, 2, 0, 0) - where - testLabel = "multipleScriptsSameBlock" - -multipleScriptsFailed :: IOManager -> [(Text, Text)] -> Assertion -multipleScriptsFailed = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - tx0 <- withBabbageLedgerState interpreter $ Babbage.mkLockByScriptTx (UTxOIndex 0) (Babbage.TxOutNoInline <$> [True, False, True]) 20000 20000 - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx0] (NodeId 1) - - let utxos = Babbage.mkUTxOBabbage tx0 - tx1 <- - withBabbageLedgerState interpreter $ - Babbage.mkUnlockScriptTx (UTxOPair <$> [head utxos, utxos !! 1, utxos !! 2]) (UTxOIndex 1) (UTxOIndex 2) False 10000 500 - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx1] (NodeId 1) - - assertBlockNoBackoff dbSync 2 - assertAlonzoCounts dbSync (0, 0, 0, 0, 3, 0, 1, 1) - where - testLabel = "multipleScriptsFailed" - -multipleScriptsFailedSameBlock :: IOManager -> [(Text, Text)] -> Assertion -multipleScriptsFailedSameBlock = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkLockByScriptTx (UTxOIndex 0) (Babbage.TxOutNoInline <$> [True, False, True]) 20000 20000 st - - let utxos = tail $ Babbage.mkUTxOBabbage tx0 - tx1 <- Babbage.mkUnlockScriptTx (UTxOPair <$> [head utxos, utxos !! 1, utxos !! 2]) (UTxOIndex 1) (UTxOIndex 2) False 10000 500 st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertAlonzoCounts dbSync (0, 0, 0, 0, 3, 0, 1, 1) - where - testLabel = "multipleScriptsFailedSameBlock" - ----------------------------------------------------------------------------------------------------------- --- Plutus Cert Scripts ----------------------------------------------------------------------------------------------------------- - -registrationScriptTx :: IOManager -> [(Text, Text)] -> Assertion -registrationScriptTx = - withFullConfigAndDropDB babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] - assertBlockNoBackoff dbSync 1 - assertScriptCert dbSync (0, 0, 0, 1) - where - testLabel = "registrationScriptTx" - -deregistrationScriptTx :: IOManager -> [(Text, Text)] -> Assertion -deregistrationScriptTx = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx1 <- Babbage.mkScriptDCertTx [(StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert)] True st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertScriptCert dbSync (1, 0, 0, 1) - where - testLabel = "deregistrationScriptTx" - -deregistrationsScriptTxs :: IOManager -> [(Text, Text)] -> Assertion -deregistrationsScriptTxs = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx1 <- Babbage.mkScriptDCertTx [(StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert)] True st - tx2 <- Babbage.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx3 <- Babbage.mkScriptDCertTx [(StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert)] True st - pure [tx0, tx1, Babbage.addValidityInterval 1000 tx2, Babbage.addValidityInterval 2000 tx3] - - assertBlockNoBackoff dbSync 1 - assertScriptCert dbSync (2, 0, 0, 1) - assertAlonzoCounts dbSync (1, 2, 1, 0, 0, 0, 0, 0) - where - testLabel = "deregistrationsScriptTxs" - -deregistrationsScriptTx :: IOManager -> [(Text, Text)] -> Assertion -deregistrationsScriptTx = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx1 <- - Babbage.mkScriptDCertTx - [ (StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert) - , (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyRegCert) - , (StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert) - ] - True - st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertScriptCert dbSync (2, 0, 0, 1) - assertAlonzoCounts dbSync (1, 2, 1, 0, 0, 0, 0, 0) - where - testLabel = "deregistrationsScriptTx" - --- Like previous but missing a redeemer. This is a known ledger issue -deregistrationsScriptTx' :: IOManager -> [(Text, Text)] -> Assertion -deregistrationsScriptTx' = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx1 <- - Babbage.mkScriptDCertTx - [ (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyUnRegCert) - , (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyRegCert) - , (StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert) - ] - True - st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - -- TODO: This is a bug! The first field should be 2. However the deregistrations - -- are missing the redeemers - assertScriptCert dbSync (0, 0, 0, 1) - assertAlonzoCounts dbSync (1, 1, 1, 0, 0, 0, 0, 0) - where - testLabel = "deregistrationsScriptTx'" - --- Like previous but missing the other redeemer. This is a known ledger issue -deregistrationsScriptTx'' :: IOManager -> [(Text, Text)] -> Assertion -deregistrationsScriptTx'' = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx1 <- - Babbage.mkScriptDCertTx - [ (StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert) - , (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyRegCert) - , (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyUnRegCert) - ] - True - st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertScriptCert dbSync (2, 0, 0, 1) - assertAlonzoCounts dbSync (1, 1, 1, 0, 0, 0, 0, 0) - where - testLabel = "deregistrationsScriptTx''" - ----------------------------------------------------------------------------------------------------------- --- Plutus MultiAsset Scripts ----------------------------------------------------------------------------------------------------------- - -mintMultiAsset :: IOManager -> [(Text, Text)] -> Assertion -mintMultiAsset = - withFullConfigAndDropDB babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ \st -> do - let val0 = MultiAsset $ Map.singleton (PolicyID alwaysMintScriptHash) (Map.singleton (head assetNames) 1) - Babbage.mkMAssetsScriptTx [UTxOIndex 0] (UTxOIndex 1) [(UTxOAddressNew 0, MaryValue (Coin 10000) mempty)] [] val0 True 100 st - - assertBlockNoBackoff dbSync 1 - assertAlonzoCounts dbSync (1, 1, 1, 1, 0, 0, 0, 0) - where - testLabel = "mintMultiAsset" - -mintMultiAssets :: IOManager -> [(Text, Text)] -> Assertion -mintMultiAssets = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - let assets0 = Map.fromList [(head assetNames, 10), (assetNames !! 1, 4)] - let policy0 = PolicyID alwaysMintScriptHash - let policy1 = PolicyID alwaysSucceedsScriptHash - let val1 = MultiAsset $ Map.fromList [(policy0, assets0), (policy1, assets0)] - tx0 <- Babbage.mkMAssetsScriptTx [UTxOIndex 0] (UTxOIndex 1) [(UTxOAddressNew 0, MaryValue (Coin 10000) mempty)] [] val1 True 100 st - tx1 <- Babbage.mkMAssetsScriptTx [UTxOIndex 2] (UTxOIndex 3) [(UTxOAddressNew 0, MaryValue (Coin 10000) mempty)] [] val1 True 200 st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertAlonzoCounts dbSync (2, 4, 1, 2, 0, 0, 0, 0) - where - testLabel = "mintMultiAssets" - -swapMultiAssets :: IOManager -> [(Text, Text)] -> Assertion -swapMultiAssets = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - let assetsMinted0 = Map.fromList [(head assetNames, 10), (assetNames !! 1, 4)] - let policy0 = PolicyID alwaysMintScriptHash - let policy1 = PolicyID alwaysSucceedsScriptHash - let mintValue0 = MultiAsset $ Map.fromList [(policy0, assetsMinted0), (policy1, assetsMinted0)] - let assets0 = Map.fromList [(head assetNames, 5), (assetNames !! 1, 2)] - let outValue0 = MaryValue (Coin 20) $ MultiAsset $ Map.fromList [(policy0, assets0), (policy1, assets0)] - - tx0 <- - Babbage.mkMAssetsScriptTx - [UTxOIndex 0] - (UTxOIndex 1) - [(UTxOAddress alwaysSucceedsScriptAddr, outValue0), (UTxOAddress alwaysMintScriptAddr, outValue0)] - [] - mintValue0 - True - 100 - st - - let utxos = Babbage.mkUTxOBabbage tx0 - tx1 <- - Babbage.mkMAssetsScriptTx - [UTxOPair (head utxos), UTxOPair (utxos !! 1), UTxOIndex 2] - (UTxOIndex 3) - [ (UTxOAddress alwaysSucceedsScriptAddr, outValue0) - , (UTxOAddress alwaysMintScriptAddr, outValue0) - , (UTxOAddressNew 0, outValue0) - , (UTxOAddressNew 0, outValue0) - ] - [] - mintValue0 - True - 200 - st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertAlonzoCounts dbSync (2, 6, 1, 2, 4, 2, 0, 0) - where - testLabel = "swapMultiAssets" diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Rollback.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Rollback.hs deleted file mode 100644 index 79ec2843b..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Rollback.hs +++ /dev/null @@ -1,257 +0,0 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module Test.Cardano.Db.Mock.Unit.Babbage.Rollback ( - simpleRollback, - bigChain, - restartAndRollback, - lazyRollback, - lazyRollbackRestart, - doubleRollback, - stakeAddressRollback, - rollbackChangeTxOrder, - rollbackFullTx, -) -where - -import Cardano.Ledger.Shelley.TxCert -import Cardano.Mock.ChainSync.Server (IOManager, addBlock, rollback) -import Cardano.Mock.Forging.Interpreter (forgeNext) -import qualified Cardano.Mock.Forging.Tx.Babbage as Babbage -import Cardano.Mock.Forging.Tx.Generic (resolvePool) -import Cardano.Mock.Forging.Types (PoolIndex (..), StakeIndex (..), UTxOIndex (..)) -import Control.Concurrent.Class.MonadSTM.Strict (atomically) -import Control.Monad (forM, forM_, void) -import Data.Text (Text) -import Ouroboros.Network.Block (blockPoint) -import Test.Cardano.Db.Mock.Config (babbageConfigDir, startDBSync, stopDBSync, withFullConfig, withFullConfigAndDropDB) -import Test.Cardano.Db.Mock.Examples (mockBlock0, mockBlock1, mockBlock2) -import Test.Cardano.Db.Mock.UnifiedApi (forgeAndSubmitBlocks, forgeNextAndSubmit, forgeNextFindLeaderAndSubmit, getBabbageLedgerState, rollbackTo, withBabbageFindLeaderAndSubmit, withBabbageFindLeaderAndSubmitTx) -import Test.Cardano.Db.Mock.Validate (assertBlockNoBackoff, assertTxCount) -import Test.Tasty.HUnit (Assertion) - -simpleRollback :: IOManager -> [(Text, Text)] -> Assertion -simpleRollback = do - withFullConfigAndDropDB babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - blk0 <- forgeNext interpreter mockBlock0 - blk1 <- forgeNext interpreter mockBlock1 - blk2 <- forgeNext interpreter mockBlock2 - atomically $ addBlock mockServer blk0 - startDBSync dbSync - atomically $ addBlock mockServer blk1 - atomically $ addBlock mockServer blk2 - assertBlockNoBackoff dbSync 3 - - atomically $ rollback mockServer (blockPoint blk1) - assertBlockNoBackoff dbSync 3 -- rollbacks effects are now delayed - where - testLabel = "simpleRollback" - -bigChain :: IOManager -> [(Text, Text)] -> Assertion -bigChain = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - forM_ (replicate 101 mockBlock0) (forgeNextAndSubmit interpreter mockServer) - startDBSync dbSync - assertBlockNoBackoff dbSync 101 - - blks' <- forM (replicate 100 mockBlock1) (forgeNextAndSubmit interpreter mockServer) - assertBlockNoBackoff dbSync 201 - - forM_ (replicate 5 mockBlock2) (forgeNextAndSubmit interpreter mockServer) - assertBlockNoBackoff dbSync 206 - - atomically $ rollback mockServer (blockPoint $ last blks') - assertBlockNoBackoff dbSync 206 - where - testLabel = "bigChain" - -restartAndRollback :: IOManager -> [(Text, Text)] -> Assertion -restartAndRollback = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - forM_ (replicate 101 mockBlock0) (forgeNextAndSubmit interpreter mockServer) - startDBSync dbSync - assertBlockNoBackoff dbSync 101 - - blks <- forM (replicate 100 mockBlock0) (forgeNextAndSubmit interpreter mockServer) - assertBlockNoBackoff dbSync 201 - - forM_ (replicate 5 mockBlock2) (forgeNextAndSubmit interpreter mockServer) - assertBlockNoBackoff dbSync 206 - - stopDBSync dbSync - atomically $ rollback mockServer (blockPoint $ last blks) - startDBSync dbSync - assertBlockNoBackoff dbSync 206 - where - testLabel = "restartAndRollback" - --- wibble -{-} -rollbackFurther :: IOManager -> [(Text, Text)] -> Assertion -rollbackFurther = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - blks <- replicateM 80 (forgeNextFindLeaderAndSubmit interpreter mockServer []) - startDBSync dbSync - assertBlockNoBackoff dbSync 80 - - -- We want to test that db-sync rollbacks temporarily to block 34 - -- and then syncs further. We add references to blocks 34 and 35, to - -- validate later that one is deleted through cascade, but the other was not - -- because a checkpoint was found. - let blockHash1 = hfBlockHash (blks !! 33) - Right bid1 <- queryDBSync dbSync $ DB.queryBlockId blockHash1 - cm1 <- queryDBSync dbSync $ DB.insertAdaPots $ - DB.AdaPots 0 1 (DB.DbLovelace 0) (DB.DbLovelace 0) (DB.DbLovelace 0) (DB.DbLovelace 0) (DB.DbLovelace 0) (DB.DbLovelace 0) bid1 - - let blockHash2 = hfBlockHash (blks !! 34) - Right bid2 <- queryDBSync dbSync $ DB.queryBlockId blockHash2 - cm2 <- queryDBSync dbSync $ DB.insertAdaPots $ - DB.AdaPots 0 1 (DB.DbLovelace 0) (DB.DbLovelace 0) (DB.DbLovelace 0) (DB.DbLovelace 0) (DB.DbLovelace 0) (DB.DbLovelace 0) bid2 - - -- Note that there is no epoch change, which would add a new entry, since we have - -- 80 blocks and not 100, which is the expected blocks/epoch. This also means there - -- no epoch snapshots - assertEqQuery dbSync DB.queryCostModel [cm1, cm2] "Unexpected CostModels" - - -- server tells db-sync to rollback to point 50. However db-sync only has - -- a snapshot at block 34, so it will go there first. There is no proper way - -- to test that db-sync temporarily is there, that's why we have this trick - -- with references. - atomically $ rollback mockServer (blockPoint $ blks !! 50) - assertBlockNoBackoff dbSync 51 - - assertEqQuery dbSync DB.queryCostModel [cm1] "Unexpected CostModel" - where - testLabel = "rollbackFurther" --} - -lazyRollback :: IOManager -> [(Text, Text)] -> Assertion -lazyRollback = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - lastBlk <- last <$> forgeAndSubmitBlocks interpreter mockServer 200 - void $ forgeAndSubmitBlocks interpreter mockServer 70 - assertBlockNoBackoff dbSync 270 - rollbackTo interpreter mockServer (blockPoint lastBlk) - -- Here we create the fork. - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] - void $ forgeAndSubmitBlocks interpreter mockServer 40 - assertBlockNoBackoff dbSync 241 - where - testLabel = "lazyRollback" - -lazyRollbackRestart :: IOManager -> [(Text, Text)] -> Assertion -lazyRollbackRestart = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - lastBlk <- last <$> forgeAndSubmitBlocks interpreter mockServer 220 - void $ forgeAndSubmitBlocks interpreter mockServer 60 - assertBlockNoBackoff dbSync 280 - - stopDBSync dbSync - rollbackTo interpreter mockServer (blockPoint lastBlk) - - startDBSync dbSync - -- Here we create the fork. - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] - void $ forgeAndSubmitBlocks interpreter mockServer 30 - assertBlockNoBackoff dbSync 251 - where - testLabel = "lazyRollbackRestart" - -doubleRollback :: IOManager -> [(Text, Text)] -> Assertion -doubleRollback = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - lastBlk1 <- last <$> forgeAndSubmitBlocks interpreter mockServer 150 - lastBlk2 <- last <$> forgeAndSubmitBlocks interpreter mockServer 100 - void $ forgeAndSubmitBlocks interpreter mockServer 100 - assertBlockNoBackoff dbSync 350 - - rollbackTo interpreter mockServer (blockPoint lastBlk2) - -- Here we create the fork. - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] - void $ forgeAndSubmitBlocks interpreter mockServer 50 - - rollbackTo interpreter mockServer (blockPoint lastBlk1) - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkSimpleDCertTx [(StakeIndexNew 0, ShelleyTxCertDelegCert . ShelleyRegCert)] - void $ forgeAndSubmitBlocks interpreter mockServer 50 - - assertBlockNoBackoff dbSync 201 - where - testLabel = "doubleRollback" - -stakeAddressRollback :: IOManager -> [(Text, Text)] -> Assertion -stakeAddressRollback = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - blk <- forgeNextFindLeaderAndSubmit interpreter mockServer [] - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - let poolId = resolvePool (PoolIndex 0) st - tx1 <- - Babbage.mkSimpleDCertTx - [ (StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert) - , (StakeIndexNew 1, \stCred -> ShelleyTxCertDelegCert $ ShelleyDelegCert stCred poolId) - ] - st - Right [tx1] - assertBlockNoBackoff dbSync 2 - rollbackTo interpreter mockServer (blockPoint blk) - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ \_ -> - Babbage.mkDummyRegisterTx 1 2 - assertBlockNoBackoff dbSync 2 - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 3 - where - testLabel = "stakeAddressRollback" - -rollbackChangeTxOrder :: IOManager -> [(Text, Text)] -> Assertion -rollbackChangeTxOrder = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - blk0 <- forgeNextFindLeaderAndSubmit interpreter mockServer [] - st <- getBabbageLedgerState interpreter - let Right tx0 = Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 500 st - let Right tx1 = Babbage.mkPaymentTx (UTxOIndex 2) (UTxOIndex 3) 10000 500 st - let Right tx2 = Babbage.mkPaymentTx (UTxOIndex 4) (UTxOIndex 5) 10000 500 st - - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \_st -> - Right [tx0, tx1] - assertBlockNoBackoff dbSync 2 - assertTxCount dbSync 13 - rollbackTo interpreter mockServer $ blockPoint blk0 - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \_st -> - Right [tx1, tx0, tx2] - assertBlockNoBackoff dbSync 2 - assertTxCount dbSync 14 - where - testLabel = "rollbackChangeTxOrder" - -rollbackFullTx :: IOManager -> [(Text, Text)] -> Assertion -rollbackFullTx = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - blk0 <- forgeNextFindLeaderAndSubmit interpreter mockServer [] - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkFullTx 0 100 st - tx1 <- Babbage.mkFullTx 1 200 st - pure [tx0, tx1] - assertBlockNoBackoff dbSync 2 - assertTxCount dbSync 13 - rollbackTo interpreter mockServer $ blockPoint blk0 - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkFullTx 0 100 st - tx1 <- Babbage.mkFullTx 1 200 st - tx2 <- Babbage.mkFullTx 2 200 st - pure [tx1, tx2, tx0] - assertBlockNoBackoff dbSync 2 - assertTxCount dbSync 14 - where - testLabel = "rollbackFullTx" diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Stake.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Stake.hs deleted file mode 100644 index 6a7f51a68..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Stake.hs +++ /dev/null @@ -1,340 +0,0 @@ -module Test.Cardano.Db.Mock.Unit.Babbage.Stake ( - -- stake address - registrationTx, - registrationsSameBlock, - registrationsSameTx, - stakeAddressPtr, - stakeAddressPtrDereg, - stakeAddressPtrUseBefore, - -- stake distribution - stakeDistGenesis, - delegations2000, - delegations2001, - delegations8000, - delegationsMany, - delegationsManyNotDense, -) -where - -import qualified Cardano.Db as DB -import Cardano.Ledger.BaseTypes (CertIx (CertIx), TxIx (TxIx)) -import Cardano.Ledger.Credential (Ptr (..)) -import Cardano.Ledger.Shelley.TxCert -import Cardano.Mock.ChainSync.Server (IOManager, addBlock) -import qualified Cardano.Mock.Forging.Tx.Babbage as Babbage -import Cardano.Mock.Forging.Tx.Babbage.Scenarios (delegateAndSendBlocks) -import Cardano.Mock.Forging.Types (StakeIndex (..), UTxOIndex (..)) -import Control.Concurrent.Class.MonadSTM.Strict (MonadSTM (..)) -import Control.Monad (forM_, replicateM_, void) -import Data.Text (Text) -import Ouroboros.Network.Block (blockSlot) -import Test.Cardano.Db.Mock.Config (babbageConfigDir, startDBSync, withFullConfig, withFullConfigAndDropDB) -import Test.Cardano.Db.Mock.UnifiedApi ( - fillEpochs, - fillUntilNextEpoch, - forgeAndSubmitBlocks, - forgeNextFindLeaderAndSubmit, - forgeNextSkipSlotsFindLeaderAndSubmit, - getBabbageLedgerState, - withBabbageFindLeaderAndSubmit, - withBabbageFindLeaderAndSubmitTx, - ) -import Test.Cardano.Db.Mock.Validate ( - assertAddrValues, - assertBlockNoBackoff, - assertBlockNoBackoffTimes, - assertCertCounts, - assertEpochStake, - assertEpochStakeEpoch, - ) -import Test.Tasty.HUnit (Assertion) - ----------------------------------------------------------------------------------------------------------- --- Stake Address ----------------------------------------------------------------------------------------------------------- - -registrationTx :: IOManager -> [(Text, Text)] -> Assertion -registrationTx = - withFullConfigAndDropDB babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] - - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert)] - - -- We add interval or else the txs would have the same id - void $ - withBabbageFindLeaderAndSubmitTx - interpreter - mockServer - ( fmap (Babbage.addValidityInterval 1000) - . Babbage.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] - ) - - void $ - withBabbageFindLeaderAndSubmitTx - interpreter - mockServer - ( fmap (Babbage.addValidityInterval 2000) - . Babbage.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert)] - ) - - assertBlockNoBackoff dbSync 4 - assertCertCounts dbSync (2, 2, 0, 0) - where - testLabel = "registrationTx" - -registrationsSameBlock :: IOManager -> [(Text, Text)] -> Assertion -registrationsSameBlock = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx1 <- Babbage.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert)] st - tx2 <- Babbage.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx3 <- Babbage.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert)] st - Right [tx0, tx1, Babbage.addValidityInterval 1000 tx2, Babbage.addValidityInterval 2000 tx3] - - assertBlockNoBackoff dbSync 1 - assertCertCounts dbSync (2, 2, 0, 0) - where - testLabel = "registrationsSameBlock" - -registrationsSameTx :: IOManager -> [(Text, Text)] -> Assertion -registrationsSameTx = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkSimpleDCertTx - [ (StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert) - , (StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert) - , (StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert) - , (StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert) - ] - - assertBlockNoBackoff dbSync 1 - assertCertCounts dbSync (2, 2, 0, 0) - where - testLabel = "registrationsSameTx" - -stakeAddressPtr :: IOManager -> [(Text, Text)] -> Assertion -stakeAddressPtr = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - blk <- - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] - - let ptr = Ptr (blockSlot blk) (TxIx 0) (CertIx 0) - - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkPaymentTx (UTxOIndex 0) (UTxOAddressNewWithPtr 0 ptr) 20000 20000 - - assertBlockNoBackoff dbSync 2 - assertCertCounts dbSync (1, 0, 0, 0) - where - testLabel = "stakeAddressPtr" - -stakeAddressPtrDereg :: IOManager -> [(Text, Text)] -> Assertion -stakeAddressPtrDereg = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - blk <- - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkSimpleDCertTx [(StakeIndexNew 0, ShelleyTxCertDelegCert . ShelleyRegCert)] - - let ptr0 = Ptr (blockSlot blk) (TxIx 0) (CertIx 0) - - blk' <- withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkPaymentTx (UTxOIndex 0) (UTxOAddressNewWithPtr 0 ptr0) 20000 20000 st - tx1 <- - Babbage.mkSimpleDCertTx - [ (StakeIndexNew 0, ShelleyTxCertDelegCert . ShelleyUnRegCert) - , (StakeIndexNew 0, ShelleyTxCertDelegCert . ShelleyRegCert) - ] - st - pure [tx0, tx1] - - let ptr1 = Ptr (blockSlot blk') (TxIx 1) (CertIx 1) - - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkPaymentTx (UTxOIndex 1) (UTxOAddressNewWithPtr 0 ptr1) 20000 20000 st - tx1 <- Babbage.mkPaymentTx (UTxOIndex 2) (UTxOAddressNewWithPtr 0 ptr0) 20000 20000 st - pure [tx0, tx1] - - st <- getBabbageLedgerState interpreter - assertBlockNoBackoff dbSync 3 - assertCertCounts dbSync (2, 1, 0, 0) - -- The 2 addresses have the same payment credentials and they reference the same - -- stake credentials, however they have - assertAddrValues dbSync (UTxOAddressNewWithPtr 0 ptr0) (DB.DbLovelace 40000) st - assertAddrValues dbSync (UTxOAddressNewWithPtr 0 ptr1) (DB.DbLovelace 20000) st - where - testLabel = "stakeAddressPtrDereg" - -stakeAddressPtrUseBefore :: IOManager -> [(Text, Text)] -> Assertion -stakeAddressPtrUseBefore = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - -- first use this stake credential - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkPaymentTx (UTxOIndex 1) (UTxOAddressNewWithStake 0 (StakeIndexNew 1)) 10000 500 - - -- and then register it - blk <- - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] - - let ptr = Ptr (blockSlot blk) (TxIx 0) (CertIx 0) - - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkPaymentTx (UTxOIndex 0) (UTxOAddressNewWithPtr 0 ptr) 20000 20000 - - assertBlockNoBackoff dbSync 3 - assertCertCounts dbSync (1, 0, 0, 0) - where - testLabel = "stakeAddressPtrUseBefore" - ----------------------------------------------------------------------------------------------------------- --- Stake Distribution ----------------------------------------------------------------------------------------------------------- -stakeDistGenesis :: IOManager -> [(Text, Text)] -> Assertion -stakeDistGenesis = - withFullConfigAndDropDB babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - a <- fillUntilNextEpoch interpreter mockServer - assertBlockNoBackoff dbSync (fromIntegral $ length a) - -- There are 5 delegations in genesis - assertEpochStake dbSync 5 - where - testLabel = "stakeDistGenesis" - -delegations2000 :: IOManager -> [(Text, Text)] -> Assertion -delegations2000 = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - a <- delegateAndSendBlocks 1995 interpreter - forM_ a $ atomically . addBlock mockServer - b <- fillUntilNextEpoch interpreter mockServer - c <- forgeAndSubmitBlocks interpreter mockServer 10 - - assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c) - -- There are exactly 2000 entries on the second epoch, 5 from genesis and 1995 manually added - assertEpochStakeEpoch dbSync 2 2000 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c + 1) - assertEpochStakeEpoch dbSync 2 2000 - where - testLabel = "delegations2000" - -delegations2001 :: IOManager -> [(Text, Text)] -> Assertion -delegations2001 = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - a <- delegateAndSendBlocks 1996 interpreter - forM_ a $ atomically . addBlock mockServer - b <- fillUntilNextEpoch interpreter mockServer - c <- forgeAndSubmitBlocks interpreter mockServer 9 - - assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c) - assertEpochStakeEpoch dbSync 2 0 - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c + 1) - assertEpochStakeEpoch dbSync 2 2000 - -- The remaining entry is inserted on the next block. - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c + 2) - assertEpochStakeEpoch dbSync 2 2001 - where - testLabel = "delegations2001" - -delegations8000 :: IOManager -> [(Text, Text)] -> Assertion -delegations8000 = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - a <- delegateAndSendBlocks 7995 interpreter - forM_ a $ atomically . addBlock mockServer - b <- fillEpochs interpreter mockServer 2 - c <- forgeAndSubmitBlocks interpreter mockServer 10 - - assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c) - assertEpochStakeEpoch dbSync 3 2000 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertEpochStakeEpoch dbSync 3 4000 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertEpochStakeEpoch dbSync 3 6000 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertEpochStakeEpoch dbSync 3 8000 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertEpochStakeEpoch dbSync 3 8000 - where - testLabel = "delegations8000" - -delegationsMany :: IOManager -> [(Text, Text)] -> Assertion -delegationsMany = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - a <- delegateAndSendBlocks 40000 interpreter - forM_ a $ atomically . addBlock mockServer - b <- fillEpochs interpreter mockServer 4 - c <- forgeAndSubmitBlocks interpreter mockServer 10 - - -- too long. We cannot use default delays - assertBlockNoBackoffTimes (repeat 10) dbSync (fromIntegral $ length a + length b + length c) - -- The slice size here is - -- 1 + div (delegationsLen * 5) expectedBlocks = 2001 - -- instead of 2000, because there are many delegations - assertEpochStakeEpoch dbSync 7 2001 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertEpochStakeEpoch dbSync 7 4002 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertEpochStakeEpoch dbSync 7 6003 - where - testLabel = "delegationsMany" - -delegationsManyNotDense :: IOManager -> [(Text, Text)] -> Assertion -delegationsManyNotDense = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - a <- delegateAndSendBlocks 40000 interpreter - forM_ a $ atomically . addBlock mockServer - b <- fillEpochs interpreter mockServer 4 - c <- forgeAndSubmitBlocks interpreter mockServer 10 - - -- too long. We cannot use default delays - assertBlockNoBackoffTimes (repeat 10) dbSync (fromIntegral $ length a + length b + length c) - -- The slice size here is - -- 1 + div (delegationsLen * 5) expectedBlocks = 2001 - -- instead of 2000, because there are many delegations - assertEpochStakeEpoch dbSync 7 2001 - - -- Blocks come on average every 5 slots. If we skip 15 slots before each block, - -- we are expected to get only 1/4 of the expected blocks. The adjusted slices - -- should still be long enough to cover everything. - replicateM_ 40 $ - forgeNextSkipSlotsFindLeaderAndSubmit interpreter mockServer 15 [] - - -- Even if the chain is sparse, all distributions are inserted. - assertEpochStakeEpoch dbSync 7 40005 - where - testLabel = "delegationsManyNotDense" diff --git a/cardano-db-sync/app/cardano-db-sync.hs b/cardano-db-sync/app/cardano-db-sync.hs index 62f7d1bf6..9979a892c 100644 --- a/cardano-db-sync/app/cardano-db-sync.hs +++ b/cardano-db-sync/app/cardano-db-sync.hs @@ -46,7 +46,7 @@ main = do -- Or to ignore ledger and not specify the state (Nothing, LedgerIgnore) -> error stateDirErrorMsg -- Otherwise, it's OK - _ -> pure () + _otherwise -> pure () let prometheusPort = dncPrometheusPort syncNodeConfigFromFile withMetricSetters prometheusPort $ \metricsSetters -> @@ -87,8 +87,6 @@ pRunDbSyncNode = do <*> pPGPassSource <*> pEpochDisabled <*> pHasCache - <*> pSkipFix - <*> pOnlyFix <*> pForceIndexes <*> pHasInOut <*> pure 500 @@ -144,15 +142,6 @@ pEpochDisabled = <> Opt.help "Makes epoch table remain empty" ) -pSkipFix :: Parser Bool -pSkipFix = - Opt.flag - False - True - ( Opt.long "skip-fix" - <> Opt.help "Disables the db-sync fix procedure for the wrong datum and redeemer_data bytes." - ) - pForceIndexes :: Parser Bool pForceIndexes = Opt.flag @@ -162,18 +151,6 @@ pForceIndexes = <> Opt.help "Forces the Index creation at the start of db-sync. Normally they're created later." ) -pOnlyFix :: Parser Bool -pOnlyFix = - Opt.flag - False - True - ( Opt.long "fix-only" - <> Opt.help - "Runs only the db-sync fix procedure for the wrong datum, redeemer_data and plutus script bytes and exits. \ - \This doesn't run any migrations. This can also be ran on previous schema, ie 13.0 13.1 to fix the issues without \ - \bumping the schema version minor number." - ) - pHasCache :: Parser Bool pHasCache = Opt.flag diff --git a/cardano-db-sync/src/Cardano/DbSync.hs b/cardano-db-sync/src/Cardano/DbSync.hs index 9df654d4c..ada70cb44 100644 --- a/cardano-db-sync/src/Cardano/DbSync.hs +++ b/cardano-db-sync/src/Cardano/DbSync.hs @@ -125,7 +125,6 @@ runDbSync metricsSetters knownMigrations iomgr trce params syncNodeConfigFromFil trce iomgr connectionString - ranMigrations (void . runMigration) syncNodeConfigFromFile params @@ -153,15 +152,13 @@ runSyncNode :: Trace IO Text -> IOManager -> ConnectionString -> - -- | migrations were ran on startup - Bool -> -- | run migration function RunMigration -> SyncNodeConfig -> SyncNodeParams -> SyncOptions -> IO () -runSyncNode metricsSetters trce iomgr dbConnString ranMigrations runMigrationFnc syncNodeConfigFromFile syncNodeParams syncOptions = do +runSyncNode metricsSetters trce iomgr dbConnString runMigrationFnc syncNodeConfigFromFile syncNodeParams syncOptions = do whenJust maybeLedgerDir $ \enpLedgerStateDir -> do createDirectoryIfMissing True (unLedgerStateDir enpLedgerStateDir) @@ -188,7 +185,6 @@ runSyncNode metricsSetters trce iomgr dbConnString ranMigrations runMigrationFnc genCfg syncNodeConfigFromFile syncNodeParams - ranMigrations runMigrationFnc -- Warn the user that jsonb datatypes are being removed from the database schema. @@ -246,8 +242,6 @@ extractSyncOptions snp aop snc = && not (enpEpochDisabled snp || not (enpHasCache snp)) , soptAbortOnInvalid = aop , soptCache = enpHasCache snp - , soptSkipFix = enpSkipFix snp - , soptOnlyFix = enpOnlyFix snp , soptPruneConsumeMigration = initPruneConsumeMigration isTxOutConsumed' diff --git a/cardano-db-sync/src/Cardano/DbSync/Api.hs b/cardano-db-sync/src/Cardano/DbSync/Api.hs index 81f259ab5..a24f1baae 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Api.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Api.hs @@ -13,11 +13,6 @@ module Cardano.DbSync.Api ( getConsistentLevel, isConsistent, getIsConsumedFixed, - noneFixed, - isDataFixed, - getIsSyncFixed, - setIsFixed, - setIsFixedAndMigrate, getDisableInOutState, getRanIndexes, runIndexMigrations, @@ -125,26 +120,6 @@ getIsConsumedFixed env = pcm = soptPruneConsumeMigration $ envOptions env backend = envBackend env -noneFixed :: FixesRan -> Bool -noneFixed NoneFixRan = True -noneFixed _ = False - -isDataFixed :: FixesRan -> Bool -isDataFixed DataFixRan = True -isDataFixed _ = False - -getIsSyncFixed :: SyncEnv -> IO FixesRan -getIsSyncFixed = readTVarIO . envIsFixed - -setIsFixed :: SyncEnv -> FixesRan -> IO () -setIsFixed env fr = do - atomically $ writeTVar (envIsFixed env) fr - -setIsFixedAndMigrate :: SyncEnv -> FixesRan -> IO () -setIsFixedAndMigrate env fr = do - envRunDelayedMigration env DB.Fix - atomically $ writeTVar (envIsFixed env) fr - getDisableInOutState :: SyncEnv -> IO Bool getDisableInOutState syncEnv = do bst <- readTVarIO $ envBootstrap syncEnv @@ -343,10 +318,9 @@ mkSyncEnv :: SystemStart -> SyncNodeConfig -> SyncNodeParams -> - Bool -> RunMigration -> IO SyncEnv -mkSyncEnv trce backend connectionString syncOptions protoInfo nw nwMagic systemStart syncNodeConfigFromFile syncNP ranMigrations runMigrationFnc = do +mkSyncEnv trce backend connectionString syncOptions protoInfo nw nwMagic systemStart syncNodeConfigFromFile syncNP runMigrationFnc = do dbCNamesVar <- newTVarIO =<< dbConstraintNamesExists backend cache <- if soptCache syncOptions @@ -361,7 +335,6 @@ mkSyncEnv trce backend connectionString syncOptions protoInfo nw nwMagic systemS } else pure useNoCache consistentLevelVar <- newTVarIO Unchecked - fixDataVar <- newTVarIO $ if ranMigrations then DataFixRan else NoneFixRan indexesVar <- newTVarIO $ enpForceIndexes syncNP bts <- getBootstrapInProgress trce (isTxOutConsumedBootstrap' syncNodeConfigFromFile) backend bootstrapVar <- newTVarIO bts @@ -403,7 +376,6 @@ mkSyncEnv trce backend connectionString syncOptions protoInfo nw nwMagic systemS , envCurrentEpochNo = epochVar , envEpochSyncTime = epochSyncTime , envIndexes = indexesVar - , envIsFixed = fixDataVar , envLedgerEnv = ledgerEnvType , envNetworkMagic = nwMagic , envOffChainPoolResultQueue = oprq @@ -427,12 +399,10 @@ mkSyncEnvFromConfig :: GenesisConfig -> SyncNodeConfig -> SyncNodeParams -> - -- | migrations were ran on startup - Bool -> -- | run migration function RunMigration -> IO (Either SyncNodeError SyncEnv) -mkSyncEnvFromConfig trce backend connectionString syncOptions genCfg syncNodeConfigFromFile syncNodeParams ranMigration runMigrationFnc = +mkSyncEnvFromConfig trce backend connectionString syncOptions genCfg syncNodeConfigFromFile syncNodeParams runMigrationFnc = case genCfg of GenesisCardano _ bCfg sCfg _ _ | unProtocolMagicId (Byron.configProtocolMagicId bCfg) /= Shelley.sgNetworkMagic (scConfig sCfg) -> @@ -468,7 +438,6 @@ mkSyncEnvFromConfig trce backend connectionString syncOptions genCfg syncNodeCon (SystemStart . Byron.gdStartTime $ Byron.configGenesisData bCfg) syncNodeConfigFromFile syncNodeParams - ranMigration runMigrationFnc -- | 'True' is for in memory points and 'False' for on disk diff --git a/cardano-db-sync/src/Cardano/DbSync/Api/Types.hs b/cardano-db-sync/src/Cardano/DbSync/Api/Types.hs index ac7e85666..cb10af966 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Api/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Api/Types.hs @@ -8,7 +8,6 @@ module Cardano.DbSync.Api.Types ( InsertOptions (..), LedgerEnv (..), RunMigration, - FixesRan (..), ConsistentLevel (..), CurrentEpochNo (..), ) where @@ -46,7 +45,6 @@ data SyncEnv = SyncEnv , envCurrentEpochNo :: !(StrictTVar IO CurrentEpochNo) , envEpochSyncTime :: !(StrictTVar IO UTCTime) , envIndexes :: !(StrictTVar IO Bool) - , envIsFixed :: !(StrictTVar IO FixesRan) , envBootstrap :: !(StrictTVar IO Bool) , envLedgerEnv :: !LedgerEnv , envNetworkMagic :: !NetworkMagic @@ -64,8 +62,6 @@ data SyncOptions = SyncOptions { soptEpochAndCacheEnabled :: !Bool , soptAbortOnInvalid :: !Bool , soptCache :: !Bool - , soptSkipFix :: !Bool - , soptOnlyFix :: !Bool , soptPruneConsumeMigration :: !DB.PruneConsumeMigration , soptInsertOptions :: !InsertOptions , snapshotEveryFollowing :: !Word64 @@ -98,8 +94,6 @@ data LedgerEnv where type RunMigration = DB.MigrationToRun -> IO () -data FixesRan = NoneFixRan | DataFixRan | AllFixRan - data ConsistentLevel = Consistent | DBAheadOfLedger | Unchecked deriving (Show, Eq) diff --git a/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs b/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs index 813ce2956..333405a7e 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs @@ -103,8 +103,6 @@ data SyncNodeParams = SyncNodeParams , enpPGPassSource :: !PGPassSource , enpEpochDisabled :: !Bool , enpHasCache :: !Bool - , enpSkipFix :: !Bool - , enpOnlyFix :: !Bool , enpForceIndexes :: !Bool , enpHasInOut :: !Bool , enpSnEveryFollowing :: !Word64 diff --git a/cardano-db-sync/src/Cardano/DbSync/Sync.hs b/cardano-db-sync/src/Cardano/DbSync/Sync.hs index de827a39d..e8724185d 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Sync.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Sync.hs @@ -201,32 +201,30 @@ dbSyncProtocols syncEnv metricsSetters tc codecConfig version bversion = localChainSyncPtcl = InitiatorProtocolOnly $ MiniProtocolCb $ \_ctx channel -> liftIO . logException tracer "ChainSyncWithBlocksPtcl: " $ do - when True $ do - logInfo tracer "Starting ChainSync client" - setConsistentLevel syncEnv Unchecked + logInfo tracer "Starting ChainSync client" + setConsistentLevel syncEnv Unchecked - (latestPoints, currentTip) <- waitRestartState tc - let (inMemory, onDisk) = List.span snd latestPoints - logInfo tracer $ - mconcat - [ "Suggesting intersection points from memory: " - , textShow (fst <$> inMemory) - , " and from disk: " - , textShow (fst <$> onDisk) - ] - void $ - runPipelinedPeer - localChainSyncTracer - (cChainSyncCodec codecs) - channel - ( chainSyncClientPeerPipelined $ - chainSyncClient metricsSetters tracer (fst <$> latestPoints) currentTip tc - ) - atomically $ writeDbActionQueue tc DbFinish - -- We should return leftover bytes returned by 'runPipelinedPeer', but - -- client application do not care about them (it's only important if one - -- would like to restart a protocol on the same mux and thus bearer). - pure () + (latestPoints, currentTip) <- waitRestartState tc + let (inMemory, onDisk) = List.span snd latestPoints + logInfo tracer $ + mconcat + [ "Suggesting intersection points from memory: " + , textShow (fst <$> inMemory) + , " and from disk: " + , textShow (fst <$> onDisk) + ] + void $ + runPipelinedPeer + localChainSyncTracer + (cChainSyncCodec codecs) + channel + ( chainSyncClientPeerPipelined $ + chainSyncClient metricsSetters tracer (fst <$> latestPoints) currentTip tc + ) + atomically $ writeDbActionQueue tc DbFinish + -- We should return leftover bytes returned by 'runPipelinedPeer', but + -- client application do not care about them (it's only important if one + -- would like to restart a protocol on the same mux and thus bearer). pure ((), Nothing) dummylocalTxSubmit :: RunMiniProtocolWithMinimalCtx 'InitiatorMode LocalAddress BSL.ByteString IO () Void diff --git a/cardano-db-sync/test/Cardano/DbSync/Gen.hs b/cardano-db-sync/test/Cardano/DbSync/Gen.hs index 86becae0f..2fbbdb406 100644 --- a/cardano-db-sync/test/Cardano/DbSync/Gen.hs +++ b/cardano-db-sync/test/Cardano/DbSync/Gen.hs @@ -70,8 +70,6 @@ syncNodeParams = <*> Gen.bool <*> Gen.bool <*> Gen.bool - <*> Gen.bool - <*> Gen.bool <*> Gen.word64 (Range.linear 0 1000) <*> Gen.word64 (Range.linear 0 1000) <*> pure Nothing diff --git a/cardano-db-tool/app/cardano-db-tool.hs b/cardano-db-tool/app/cardano-db-tool.hs index 821d4cdcb..66690ac2f 100644 --- a/cardano-db-tool/app/cardano-db-tool.hs +++ b/cardano-db-tool/app/cardano-db-tool.hs @@ -37,7 +37,7 @@ data Command = CmdCreateMigration !MigrationDir !TxOutTableType | CmdReport !Report !TxOutTableType | CmdRollback !SlotNo !TxOutTableType - | CmdRunMigrations !MigrationDir !Bool !Bool !(Maybe LogFileDir) !TxOutTableType + | CmdRunMigrations !MigrationDir !Bool !(Maybe LogFileDir) !TxOutTableType | CmdTxOutMigration !TxOutTableType | CmdUtxoSetAtBlock !Word64 !TxOutTableType | CmdPrepareSnapshot !PrepareSnapshotArgs @@ -51,7 +51,7 @@ runCommand cmd = CmdCreateMigration mdir txOutAddressType -> runCreateMigration mdir txOutAddressType CmdReport report txOutAddressType -> runReport report txOutAddressType CmdRollback slotNo txOutAddressType -> runRollback slotNo txOutAddressType - CmdRunMigrations mdir forceIndexes mockFix mldir txOutTabletype -> do + CmdRunMigrations mdir forceIndexes mldir txOutTabletype -> do pgConfig <- runOrThrowIODb (readPGPass PGPassDefaultEnv) unofficial <- snd <$> runMigrations pgConfig False mdir mldir Initial txOutTabletype unless (null unofficial) $ @@ -60,9 +60,6 @@ runCommand cmd = when forceIndexes $ void $ runMigrations pgConfig False mdir mldir Indexes txOutTabletype - when mockFix $ - void $ - runMigrations pgConfig False mdir mldir Fix txOutTabletype CmdTxOutMigration txOutTableType -> do runWithConnectionNoLogging PGPassDefaultEnv $ migrateTxOutDbTool txOutTableType CmdUtxoSetAtBlock blkid txOutAddressType -> utxoSetAtSlot txOutAddressType blkid @@ -170,7 +167,6 @@ pCommand = CmdRunMigrations <$> pMigrationDir <*> pForceIndexes - <*> pMockFix <*> optional pLogFileDir <*> pTxOutTableType @@ -232,20 +228,6 @@ pForceIndexes = ) ) -pMockFix :: Parser Bool -pMockFix = - Opt.flag - False - True - ( Opt.long "mock-fix" - <> Opt.help - ( mconcat - [ "Mocks the execution of the fix chainsync procedure" - , " By using this flag, db-sync later won't run the fixing procedures." - ] - ) - ) - pTxOutTableType :: Parser TxOutTableType pTxOutTableType = Opt.flag diff --git a/cardano-db/src/Cardano/Db/Migration.hs b/cardano-db/src/Cardano/Db/Migration.hs index 582e40117..be65062c1 100644 --- a/cardano-db/src/Cardano/Db/Migration.hs +++ b/cardano-db/src/Cardano/Db/Migration.hs @@ -101,7 +101,7 @@ data MigrationValidateError = UnknownMigrationsFound instance Exception MigrationValidateError -data MigrationToRun = Initial | Full | Fix | Indexes +data MigrationToRun = Initial | Full | Indexes deriving (Show, Eq) -- | Run the migrations in the provided 'MigrationDir' and write date stamped log file @@ -144,11 +144,9 @@ runMigrations pgconfig quiet migrationDir mLogfiledir mToRun txOutTableType = do filterMigrations scripts = case mToRun of Full -> pure (filter filterIndexesFull scripts, True) Initial -> pure (filter filterInitial scripts, True) - Fix -> pure (filter filterFix scripts, False) Indexes -> do pure (filter filterIndexes scripts, False) - filterFix (mv, _) = mvStage mv == 2 && mvVersion mv > hardCoded3_0 filterIndexesFull (mv, _) = do case txOutTableType of TxOutCore -> True @@ -159,9 +157,6 @@ runMigrations pgconfig quiet migrationDir mLogfiledir mToRun txOutTableType = do TxOutCore -> mvStage mv == 4 TxOutVariantAddress -> mvStage mv == 4 && mvVersion mv > 1 -hardCoded3_0 :: Int -hardCoded3_0 = 19 - -- Build hash for each file found in a directory. validateMigrations :: MigrationDir -> [(Text, Text)] -> IO (Maybe (MigrationValidateError, Bool)) validateMigrations migrationDir knownMigrations = do