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/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 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..9979a892c 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 @@ -43,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 -> @@ -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 @@ -104,8 +87,6 @@ pRunDbSyncNode = do <*> pPGPassSource <*> pEpochDisabled <*> pHasCache - <*> pSkipFix - <*> pOnlyFix <*> pForceIndexes <*> pHasInOut <*> pure 500 @@ -161,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 @@ -179,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 @@ -244,169 +204,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.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 02f0b9745..88a067898 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 @@ -360,7 +334,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 @@ -402,7 +375,6 @@ mkSyncEnv trce backend connectionString syncOptions protoInfo nw nwMagic systemS , envCurrentEpochNo = epochVar , envEpochSyncTime = epochSyncTime , envIndexes = indexesVar - , envIsFixed = fixDataVar , envLedgerEnv = ledgerEnvType , envNetworkMagic = nwMagic , envOffChainPoolResultQueue = oprq @@ -426,12 +398,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) -> @@ -467,7 +437,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/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..e8724185d 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,103 +197,34 @@ dbSyncProtocols syncEnv metricsSetters tc codecConfig version bversion = tracer :: Trace IO Text tracer = getTrace syncEnv - backend :: SqlBackend - backend = envBackend syncEnv + localChainSyncPtcl :: RunMiniProtocolWithMinimalCtx 'InitiatorMode LocalAddress BSL.ByteString IO () Void + localChainSyncPtcl = InitiatorProtocolOnly $ + MiniProtocolCb $ \_ctx channel -> + liftIO . logException tracer "ChainSyncWithBlocksPtcl: " $ do + logInfo tracer "Starting ChainSync client" + setConsistentLevel syncEnv Unchecked - 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 + (latestPoints, currentTip) <- waitRestartState tc + let (inMemory, onDisk) = List.span snd latestPoints logInfo tracer $ - mconcat ["Found ", textShow wrongEntriesSize, " consumed_by_tx_id wrong entries"] - fixedEntries <- - runPeer + mconcat + [ "Suggesting intersection points from memory: " + , textShow (fst <$> inMemory) + , " and from disk: " + , textShow (fst <$> onDisk) + ] + void $ + runPipelinedPeer localChainSyncTracer (cChainSyncCodec codecs) channel - ( Client.chainSyncClientPeer $ - chainSyncClientFixConsumed backend syncEnv wrongEntriesSize + ( chainSyncClientPeerPipelined $ + chainSyncClient metricsSetters tracer (fst <$> latestPoints) currentTip tc ) - 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 - 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 () + 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 @@ -461,175 +383,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-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/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/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 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 - - |]