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 12e512b70..c8ec67e94 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs @@ -43,13 +43,15 @@ module Test.Cardano.Db.Mock.Config ( withCustomConfigAndLogs, withFullConfig', replaceConfigFile, + txOutTableTypeFromConfig, ) where import Cardano.Api (NetworkMagic (..)) -import qualified Cardano.Db as Db +import qualified Cardano.Db as DB import Cardano.DbSync import Cardano.DbSync.Config import Cardano.DbSync.Config.Cardano +import Cardano.DbSync.Config.Types (SyncInsertOptions (..), TxOutConfig (..), UseTxOutAddress (..)) import Cardano.DbSync.Error (runOrThrowIO) import Cardano.DbSync.Types (CardanoBlock, MetricSetters (..)) import Cardano.Mock.ChainSync.Server @@ -209,16 +211,16 @@ pollDBSync env = do withDBSyncEnv :: IO DBSyncEnv -> (DBSyncEnv -> IO a) -> IO a withDBSyncEnv mkEnv = bracket mkEnv stopDBSyncIfRunning -getDBSyncPGPass :: DBSyncEnv -> Db.PGPassSource +getDBSyncPGPass :: DBSyncEnv -> DB.PGPassSource getDBSyncPGPass = enpPGPassSource . dbSyncParams queryDBSync :: DBSyncEnv -> ReaderT SqlBackend (NoLoggingT IO) a -> IO a -queryDBSync env = Db.runWithConnectionNoLogging (getDBSyncPGPass env) +queryDBSync env = DB.runWithConnectionNoLogging (getDBSyncPGPass env) getPoolLayer :: DBSyncEnv -> IO PoolDataLayer getPoolLayer env = do - pgconfig <- runOrThrowIO $ Db.readPGPass (enpPGPassSource $ dbSyncParams env) - pool <- runNoLoggingT $ createPostgresqlPool (Db.toConnectionString pgconfig) 1 -- Pool size of 1 for tests + pgconfig <- runOrThrowIO $ DB.readPGPass (enpPGPassSource $ dbSyncParams env) + pool <- runNoLoggingT $ createPostgresqlPool (DB.toConnectionString pgconfig) 1 -- Pool size of 1 for tests pure $ postgresqlPoolDataLayer nullTracer @@ -259,7 +261,7 @@ mkShelleyCredentials bulkFile = do -- | staticDir can be shared by tests running in parallel. mutableDir not. mkSyncNodeParams :: FilePath -> FilePath -> CommandLineArgs -> IO SyncNodeParams mkSyncNodeParams staticDir mutableDir CommandLineArgs {..} = do - pgconfig <- runOrThrowIO Db.readPGPassDefault + pgconfig <- runOrThrowIO DB.readPGPassDefault pure $ SyncNodeParams @@ -267,7 +269,7 @@ mkSyncNodeParams staticDir mutableDir CommandLineArgs {..} = do , enpSocketPath = SocketPath $ mutableDir ".socket" , enpMaybeLedgerStateDir = Just $ LedgerStateDir $ mutableDir "ledger-states" , enpMigrationDir = MigrationDir "../schema" - , enpPGPassSource = Db.PGPassCached pgconfig + , enpPGPassSource = DB.PGPassCached pgconfig , enpEpochDisabled = claEpochDisabled , enpHasCache = claHasCache , enpSkipFix = claSkipFix @@ -503,12 +505,12 @@ withFullConfig' WithConfigArgs {..} cmdLineArgs mSyncNodeConfig configFilePath t -- we dont fork dbsync here. Just prepare it as an action withDBSyncEnv (mkDBSyncEnv dbsyncParams syncNodeConfig partialDbSyncRun) $ \dbSyncEnv -> do let pgPass = getDBSyncPGPass dbSyncEnv - tableNames <- Db.getAllTablleNames pgPass + tableNames <- DB.getAllTablleNames pgPass -- We only want to create the table schema once for the tests so here we check -- if there are any table names. if null tableNames || shouldDropDB - then void . hSilence [stderr] $ Db.recreateDB pgPass - else void . hSilence [stderr] $ Db.truncateTables pgPass tableNames + then void . hSilence [stderr] $ DB.recreateDB pgPass + else void . hSilence [stderr] $ DB.truncateTables pgPass tableNames action interpreter mockServer dbSyncEnv where mutableDir = mkMutableDir testLabelFilePath @@ -534,3 +536,15 @@ replaceConfigFile newFilename dbSync@DBSyncEnv {..} = do configDir = mkConfigDir . takeDirectory . unConfigFile . enpConfigFile $ dbSyncParams newParams = dbSyncParams {enpConfigFile = ConfigFile $ configDir newFilename} + +txOutTableTypeFromConfig :: DBSyncEnv -> DB.TxOutTableType +txOutTableTypeFromConfig dbSyncEnv = + case sioTxOut $ dncInsertOptions $ dbSyncConfig dbSyncEnv of + TxOutDisable -> DB.TxOutCore + TxOutEnable useTxOutAddress -> getTxOutTT useTxOutAddress + TxOutConsumed _ useTxOutAddress -> getTxOutTT useTxOutAddress + TxOutConsumedPrune _ useTxOutAddress -> getTxOutTT useTxOutAddress + TxOutConsumedBootstrap _ useTxOutAddress -> getTxOutTT useTxOutAddress + where + getTxOutTT :: UseTxOutAddress -> DB.TxOutTableType + getTxOutTT value = if unUseTxOutAddress value then DB.TxOutVariantAddress else DB.TxOutCore diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Config.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Config.hs index 98dd3ce4e..a51330ddc 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Config.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Config.hs @@ -34,7 +34,6 @@ insertConfig = do , sioPoolStats = PoolStatsConfig False , sioJsonType = JsonTypeDisable , sioRemoveJsonbFromSchema = RemoveJsonbFromSchemaConfig False - , sioAddressDetail = AddressDetailConfig False } dncInsertOptions cfg @?= expected 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 index c64f0ff0c..290bbd0a5 100644 --- 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 @@ -29,7 +29,10 @@ module Test.Cardano.Db.Mock.Unit.Alonzo.Plutus ( ) 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 (..)) @@ -90,12 +93,26 @@ simpleScript = Alonzo.mkLockByScriptTx (UTxOIndex 0) [True] 20000 20000 assertBlockNoBackoff dbSync (fromIntegral $ length a + 2) - assertEqQuery dbSync (fmap getOutFields <$> DB.queryScriptOutputs) [expectedFields] "Unexpected script outputs" + assertEqQuery dbSync (fmap getOutFields <$> DB.queryScriptOutputs TxOutCore) [expectedFields] "Unexpected script outputs" where testLabel = "simpleScript-alonzo" - getOutFields txOut = (DB.txOutAddress txOut, DB.txOutAddressHasScript txOut, DB.txOutValue txOut, DB.txOutDataHash txOut) + 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 = - ( Just $ renderAddress alwaysSucceedsScriptAddr + ( renderAddress alwaysSucceedsScriptAddr , True , DB.DbLovelace 20000 , Just $ Crypto.hashToBytes (extractHash $ hashData @StandardAlonzo plutusDataList) 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 index e392e2ff1..84fc8d38d 100644 --- 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 @@ -20,6 +20,7 @@ module Test.Cardano.Db.Mock.Unit.Babbage.Config.MigrateConsumedPruneTxOut ( bootstrapRestartMissingFlag, ) where +import Cardano.Db (TxOutTableType (..)) import qualified Cardano.Db as DB import Cardano.DbSync.Config.Types import Cardano.Mock.ChainSync.Server (IOManager, addBlock) @@ -39,6 +40,7 @@ import Test.Cardano.Db.Mock.Config ( replaceConfigFile, startDBSync, stopDBSync, + txOutTableTypeFromConfig, withCustomConfig, withCustomConfigAndDropDB, ) @@ -74,6 +76,7 @@ txConsumedColumnCheck = do basicPrune :: IOManager -> [(Text, Text)] -> Assertion basicPrune = do withCustomConfig cmdLineArgs Nothing babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do + let txOutTableType = txOutTableTypeFromConfig dbSyncEnv startDBSync dbSyncEnv -- add 50 block b1 <- forgeAndSubmitBlocks interpreter mockServer 50 @@ -82,13 +85,13 @@ basicPrune = do 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 14 "new epoch didn't prune tx_out column that are null" + 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 12 "the pruning didn't work correctly as the tx-out count is incorrect" + 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 @@ -101,6 +104,7 @@ basicPrune = do pruneWithSimpleRollback :: IOManager -> [(Text, Text)] -> Assertion pruneWithSimpleRollback = do withCustomConfig cmdLineArgs Nothing babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do + let txOutTableType = txOutTableTypeFromConfig dbSyncEnv blk0 <- forgeNext interpreter mockBlock0 blk1 <- forgeNext interpreter mockBlock1 atomically $ addBlock mockServer blk0 @@ -108,15 +112,15 @@ pruneWithSimpleRollback = do 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 14 "" + assertEqQuery dbSyncEnv (DB.queryTxOutCount txOutTableType) 14 "" b1 <- forgeAndSubmitBlocks interpreter mockServer 96 assertBlockNoBackoff dbSyncEnv (fullBlockSize b1) - assertEqQuery dbSyncEnv DB.queryTxOutCount 12 "the txOut count is incorrect" - assertEqQuery dbSyncEnv DB.queryTxOutConsumedCount 0 "Unexpected TxOutConsumedByTxId count after prune" + 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 0 "Unexpected TxOutConsumedByTxId cout after rollback" + assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId cout after rollback" assertBlockNoBackoff dbSyncEnv $ fullBlockSize b1 where fullBlockSize b = fromIntegral $ length b + 4 @@ -129,6 +133,7 @@ pruneWithSimpleRollback = do pruneWithFullTxRollback :: IOManager -> [(Text, Text)] -> Assertion pruneWithFullTxRollback = do withCustomConfig cmdLineArgs Nothing babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do + let txOutTableType = txOutTableTypeFromConfig dbSyncEnv startDBSync dbSyncEnv blk0 <- forgeNextFindLeaderAndSubmit interpreter mockServer [] void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do @@ -138,7 +143,7 @@ pruneWithFullTxRollback = do assertBlockNoBackoff dbSyncEnv 2 assertTxCount dbSyncEnv 13 assertUnspentTx dbSyncEnv - assertEqQuery dbSyncEnv DB.queryTxOutCount 14 "new epoch didn't prune tx_out column that are null" + 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 @@ -147,7 +152,7 @@ pruneWithFullTxRollback = do pure [tx1, tx2, tx0] assertBlockNoBackoff dbSyncEnv 2 assertTxCount dbSyncEnv 14 - assertEqQuery dbSyncEnv DB.queryTxOutCount 16 "new epoch didn't prune tx_out column that are null" + assertEqQuery dbSyncEnv (DB.queryTxOutCount txOutTableType) 16 "new epoch didn't prune tx_out column that are null" assertUnspentTx dbSyncEnv where cmdLineArgs = @@ -164,6 +169,7 @@ pruningShouldKeepSomeTx ioManager names = do withConfig' syncNodeConfig $ \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 @@ -171,13 +177,13 @@ pruningShouldKeepSomeTx ioManager names = do b2 <- forgeAndSubmitBlocks interpreter mockServer 18 assertBlockNoBackoff dbSyncEnv (fromIntegral $ length (b1 <> b2) + 2) -- the two marked TxOutConsumedByTxId should not be pruned - assertEqQuery dbSyncEnv DB.queryTxOutConsumedCount 2 "Unexpected TxOutConsumedByTxId count after prune" + 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 0 "Unexpected TxOutConsumedByTxId count after prune" + assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId count after prune" where withConfig' cfg f = withCustomConfig cmdLineArgs (Just cfg) babbageConfigDir testLabel f ioManager names @@ -189,7 +195,7 @@ pruningShouldKeepSomeTx ioManager names = do initCfg { dncInsertOptions = (dncInsertOptions initCfg) - { sioTxOut = TxOutPrune (ForceTxIn False) + { sioTxOut = TxOutConsumedPrune (ForceTxIn False) (UseTxOutAddress False) } } @@ -204,6 +210,7 @@ pruneAndRollBackOneBlock :: IOManager -> [(Text, Text)] -> Assertion pruneAndRollBackOneBlock = do withCustomConfig cmdLineArgs Nothing 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 @@ -215,18 +222,18 @@ pruneAndRollBackOneBlock = do 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 2 "Unexpected TxOutConsumedByTxId count before rollback" + 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 1 "Unexpected TxOutConsumedByTxId count after 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 0 "Unexpected TxOutConsumedByTxId count after rollback" + assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId count after rollback" where cmdLineArgs = initCommandLineArgs @@ -239,6 +246,7 @@ noPruneAndRollBack :: IOManager -> [(Text, Text)] -> Assertion noPruneAndRollBack = do withCustomConfig cmdLineArgs Nothing 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 @@ -250,18 +258,18 @@ noPruneAndRollBack = do 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 2 "Unexpected TxOutConsumedByTxId count before rollback" + 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 1 "Unexpected TxOutConsumedByTxId count after 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 1 "Unexpected TxOutConsumedByTxId count after rollback" + assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 1 "Unexpected TxOutConsumedByTxId count after rollback" where cmdLineArgs = initCommandLineArgs @@ -273,6 +281,7 @@ pruneSameBlock :: IOManager -> [(Text, Text)] -> Assertion pruneSameBlock = withCustomConfig cmdLineArgs Nothing 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 @@ -281,15 +290,15 @@ pruneSameBlock = tx1 <- Babbage.mkPaymentTx (UTxOPair utxo0) (UTxOIndex 2) 10000 500 st pure [tx0, tx1] assertBlockNoBackoff dbSyncEnv 78 - assertEqQuery dbSyncEnv DB.queryTxOutConsumedCount 2 "Unexpected TxOutConsumedByTxId before rollback" + assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 2 "Unexpected TxOutConsumedByTxId before rollback" void $ forgeAndSubmitBlocks interpreter mockServer 22 assertBlockNoBackoff dbSyncEnv 100 - assertEqQuery dbSyncEnv DB.queryTxOutConsumedCount 0 "Unexpected TxOutConsumedByTxId after prune" + 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 0 "Unexpected TxOutConsumedByTxId after rollback" + assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId after rollback" where cmdLineArgs = initCommandLineArgs @@ -301,6 +310,7 @@ noPruneSameBlock :: IOManager -> [(Text, Text)] -> Assertion noPruneSameBlock = withCustomConfig cmdLineArgs Nothing 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 @@ -314,7 +324,7 @@ noPruneSameBlock = assertBlockNoBackoff dbSyncEnv 100 void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] assertBlockNoBackoff dbSyncEnv 98 - assertEqQuery dbSyncEnv DB.queryTxOutConsumedCount 0 "Unexpected TxOutConsumedByTxId after rollback" + assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId after rollback" where cmdLineArgs = initCommandLineArgs 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 index d082c90fc..3c75ffcf8 100644 --- 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 @@ -34,7 +34,6 @@ insertConfig = do , sioPoolStats = PoolStatsConfig False , sioJsonType = JsonTypeDisable , sioRemoveJsonbFromSchema = RemoveJsonbFromSchemaConfig False - , sioAddressDetail = AddressDetailConfig False } dncInsertOptions cfg @?= expected 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 index 02d2699fe..2135f8056 100644 --- 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 @@ -32,6 +32,8 @@ module Test.Cardano.Db.Mock.Unit.Babbage.Plutus ( 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 (..)) @@ -61,7 +63,7 @@ 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, withFullConfig, withFullConfigAndDropDB) +import Test.Cardano.Db.Mock.Config (babbageConfigDir, startDBSync, txOutTableTypeFromConfig, withFullConfig, withFullConfigAndDropDB) import Test.Cardano.Db.Mock.UnifiedApi ( fillUntilNextEpoch, forgeNextAndSubmit, @@ -88,6 +90,8 @@ 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 @@ -97,12 +101,28 @@ simpleScript = Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutNoInline True] 20000 20000 assertBlockNoBackoff dbSync (fromIntegral $ length a + 2) - assertEqQuery dbSync (fmap getOutFields <$> DB.queryScriptOutputs) [expectedFields] "Unexpected script outputs" + assertEqQuery dbSync (fmap getOutFields <$> DB.queryScriptOutputs txOutTableType) [expectedFields] "Unexpected script outputs" where testLabel = "simpleScript" - getOutFields txOut = (DB.txOutAddress txOut, DB.txOutAddressHasScript txOut, DB.txOutValue txOut, DB.txOutDataHash txOut) + 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 = - ( Just $ renderAddress alwaysSucceedsScriptAddr + ( renderAddress alwaysSucceedsScriptAddr , True , DB.DbLovelace 20000 , Just $ Crypto.hashToBytes (extractHash $ hashData @StandardBabbage plutusDataList) diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Config/MigrateConsumedPruneTxOut.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Config/MigrateConsumedPruneTxOut.hs index f1eb3e156..1bcf65e97 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Config/MigrateConsumedPruneTxOut.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Config/MigrateConsumedPruneTxOut.hs @@ -77,6 +77,7 @@ basicPrune :: IOManager -> [(Text, Text)] -> Assertion basicPrune = do withCustomConfig args Nothing cfgDir testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync + let txOutTableType = txOutTableTypeFromConfig dbSync -- Add some blocks blks <- forgeAndSubmitBlocks interpreter mockServer 50 @@ -91,13 +92,13 @@ basicPrune = do -- Check tx-out count before pruning assertBlockNoBackoff dbSync (fullBlockSize blks) - assertEqQuery dbSync DB.queryTxOutCount 14 "new epoch didn't prune tx_out column that are null" + assertEqQuery dbSync (DB.queryTxOutCount txOutTableType) 14 "new epoch didn't prune tx_out column that are null" blks' <- forgeAndSubmitBlocks interpreter mockServer 48 assertBlockNoBackoff dbSync (fullBlockSize $ blks <> blks') -- Check that tx_out was pruned - assertEqQuery dbSync DB.queryTxOutCount 12 "the pruning didn't work correctly as the tx-out count is incorrect" + assertEqQuery dbSync (DB.queryTxOutCount txOutTableType) 12 "the pruning didn't work correctly as the tx-out count is incorrect" -- Check unspent tx assertUnspentTx dbSync where @@ -112,6 +113,7 @@ basicPrune = do pruneWithSimpleRollback :: IOManager -> [(Text, Text)] -> Assertion pruneWithSimpleRollback = withCustomConfig cmdLineArgs Nothing conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do + let txOutTableType = txOutTableTypeFromConfig dbSync -- Forge some blocks blk0 <- forgeNext interpreter mockBlock0 blk1 <- forgeNext interpreter mockBlock1 @@ -127,18 +129,18 @@ pruneWithSimpleRollback = void $ withConwayFindLeaderAndSubmitTx interpreter mockServer $ Conway.mkPaymentTx (UTxOIndex 1) (UTxOIndex 0) 10_000 10_000 0 - assertEqQuery dbSync DB.queryTxOutCount 14 "" + assertEqQuery dbSync (DB.queryTxOutCount txOutTableType) 14 "" -- Submit some blocks blks <- forgeAndSubmitBlocks interpreter mockServer 96 assertBlockNoBackoff dbSync (fullBlockSize blks) - assertEqQuery dbSync DB.queryTxOutCount 12 "the txOut count is incorrect" - assertEqQuery dbSync DB.queryTxOutConsumedCount 0 "Unexpected TxOutConsumedByTxId count after prune" + assertEqQuery dbSync (DB.queryTxOutCount txOutTableType) 12 "the txOut count is incorrect" + assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId count after prune" assertUnspentTx dbSync -- Rollback rollbackTo interpreter mockServer (blockPoint blk1) - assertEqQuery dbSync DB.queryTxOutConsumedCount 0 "Unexpected TxOutConsumedByTxId count after rollback" + assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId count after rollback" assertBlockNoBackoff dbSync (fullBlockSize blks) where cmdLineArgs = @@ -152,6 +154,7 @@ pruneWithFullTxRollback :: IOManager -> [(Text, Text)] -> Assertion pruneWithFullTxRollback = withCustomConfig cmdLineArgs Nothing conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync + let txOutTableType = txOutTableTypeFromConfig dbSync -- Forge a block blk0 <- forgeNextFindLeaderAndSubmit interpreter mockServer [] -- Add some transactions @@ -164,7 +167,7 @@ pruneWithFullTxRollback = assertBlockNoBackoff dbSync 2 assertTxCount dbSync 13 assertUnspentTx dbSync - assertEqQuery dbSync DB.queryTxOutCount 14 "new epoch didn't prune tx_out column that are null" + assertEqQuery dbSync (DB.queryTxOutCount txOutTableType) 14 "new epoch didn't prune tx_out column that are null" -- Rollback rollbackTo interpreter mockServer $ blockPoint blk0 @@ -178,7 +181,7 @@ pruneWithFullTxRollback = -- Verify tx_out was pruned again assertBlockNoBackoff dbSync 2 assertTxCount dbSync 14 - assertEqQuery dbSync DB.queryTxOutCount 16 "new epoch didn't prune tx_out column that are null" + assertEqQuery dbSync (DB.queryTxOutCount txOutTableType) 16 "new epoch didn't prune tx_out column that are null" assertUnspentTx dbSync where cmdLineArgs = @@ -194,7 +197,7 @@ pruningShouldKeepSomeTx ioManager names = do withConfig' syncNodeConfig $ \interpreter mockServer dbSync -> do startDBSync dbSync - + let txOutTableType = txOutTableTypeFromConfig dbSync -- Forge some blocks blk1 <- forgeAndSubmitBlocks interpreter mockServer 80 -- These two blocks/transactions will fall within the last (2 * securityParam) 20 @@ -208,14 +211,14 @@ pruningShouldKeepSomeTx ioManager names = do blk2 <- forgeAndSubmitBlocks interpreter mockServer 18 -- Verify the two transactions above weren't pruned assertBlockNoBackoff dbSync (fromIntegral $ length (blk1 <> blk2) + 2) - assertEqQuery dbSync DB.queryTxOutConsumedCount 2 "Unexpected TxOutConsumedByTxId count after prune" + assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutTableType) 2 "Unexpected TxOutConsumedByTxId count after prune" -- Add more blocks blk3 <- forgeAndSubmitBlocks interpreter mockServer 110 -- Verify everything has been pruned assertBlockNoBackoff dbSync (fromIntegral $ length (blk1 <> blk2 <> blk3) + 2) assertTxInCount dbSync 0 - assertEqQuery dbSync DB.queryTxOutConsumedCount 0 "Unexpected TxOutConsumedByTxId count after prune" + assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId count after prune" where withConfig' cfg f = withCustomConfig cmdLineArgs (Just cfg) conwayConfigDir testLabel f ioManager names @@ -227,7 +230,7 @@ pruningShouldKeepSomeTx ioManager names = do initCfg { dncInsertOptions = (dncInsertOptions initCfg) - { sioTxOut = TxOutPrune (ForceTxIn False) + { sioTxOut = TxOutConsumedPrune (ForceTxIn False) (UseTxOutAddress False) } } @@ -242,6 +245,7 @@ pruneAndRollBackOneBlock = withCustomConfig cmdLineArgs Nothing conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync + let txOutTableType = txOutTableTypeFromConfig dbSync -- Forge some blocks void $ forgeAndSubmitBlocks interpreter mockServer 98 -- These transactions will fall within the last (2 * securityParam) 20 @@ -257,7 +261,7 @@ pruneAndRollBackOneBlock = void $ withConwayFindLeaderAndSubmit interpreter mockServer (\_ -> sequence [tx1]) -- Verify the last 2 transactions weren't pruned assertBlockNoBackoff dbSync 101 - assertEqQuery dbSync DB.queryTxOutConsumedCount 2 "Unexpected TxOutConsumedByTxId count before rollback" + assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutTableType) 2 "Unexpected TxOutConsumedByTxId count before rollback" rollbackTo interpreter mockServer (blockPoint blk100) @@ -265,13 +269,13 @@ pruneAndRollBackOneBlock = void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] -- Verify the transactions were removed in the rollback assertBlockNoBackoff dbSync 101 - assertEqQuery dbSync DB.queryTxOutConsumedCount 1 "Unexpected TxOutConsumedByTxId count after rollback" + assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutTableType) 1 "Unexpected TxOutConsumedByTxId count after rollback" -- Trigger a prune void $ forgeAndSubmitBlocks interpreter mockServer 102 -- Verify everything was pruned assertBlockNoBackoff dbSync 203 - assertEqQuery dbSync DB.queryTxOutConsumedCount 0 "Unexpected TxOutConsumedByTxId count after rollback" + assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId count after rollback" where cmdLineArgs = initCommandLineArgs @@ -284,6 +288,7 @@ noPruneAndRollBack = withCustomConfig cmdLineArgs Nothing conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync + let txOutTableType = txOutTableTypeFromConfig dbSync -- Forge some blocks void $ forgeAndSubmitBlocks interpreter mockServer 98 -- Add a block with transactions @@ -299,7 +304,7 @@ noPruneAndRollBack = -- Verify the transactions weren't pruned assertBlockNoBackoff dbSync 101 - assertEqQuery dbSync DB.queryTxOutConsumedCount 2 "Unexpected TxOutConsumedByTxId count before rollback" + assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutTableType) 2 "Unexpected TxOutConsumedByTxId count before rollback" rollbackTo interpreter mockServer (blockPoint blk100) @@ -307,13 +312,13 @@ noPruneAndRollBack = void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] -- Verify transactions were removed assertBlockNoBackoff dbSync 101 - assertEqQuery dbSync DB.queryTxOutConsumedCount 1 "Unexpected TxOutConsumedByTxId count after rollback" + assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutTableType) 1 "Unexpected TxOutConsumedByTxId count after rollback" -- Add some more blocks void $ forgeAndSubmitBlocks interpreter mockServer 102 -- Verify nothing has been pruned assertBlockNoBackoff dbSync 203 - assertEqQuery dbSync DB.queryTxOutConsumedCount 1 "Unexpected TxOutConsumedByTxId count after rollback" + assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutTableType) 1 "Unexpected TxOutConsumedByTxId count after rollback" where cmdLineArgs = initCommandLineArgs @@ -326,6 +331,7 @@ pruneSameBlock = withCustomConfig cmdLineArgs Nothing conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync + let txOutTableType = txOutTableTypeFromConfig dbSync -- Forge some blocks void $ forgeAndSubmitBlocks interpreter mockServer 76 blk77 <- forgeNextFindLeaderAndSubmit interpreter mockServer [] @@ -337,13 +343,13 @@ pruneSameBlock = pure [tx0, tx1] -- Verify the transactions weren't pruned assertBlockNoBackoff dbSync 78 - assertEqQuery dbSync DB.queryTxOutConsumedCount 2 "Unexpected TxOutConsumedByTxId before rollback" + assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutTableType) 2 "Unexpected TxOutConsumedByTxId before rollback" -- Trigger a prune void $ forgeAndSubmitBlocks interpreter mockServer 22 -- Verify the transactions were pruned assertBlockNoBackoff dbSync 100 - assertEqQuery dbSync DB.queryTxOutConsumedCount 0 "Unexpected TxOutConsumedByTxId after prune" + assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId after prune" rollbackTo interpreter mockServer (blockPoint blk77) @@ -352,7 +358,7 @@ pruneSameBlock = -- Verify the transactions were pruned again assertBlockNoBackoff dbSync 78 assertTxInCount dbSync 0 - assertEqQuery dbSync DB.queryTxOutConsumedCount 0 "Unexpected TxOutConsumedByTxId after rollback" + assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId after rollback" where cmdLineArgs = initCommandLineArgs @@ -387,7 +393,7 @@ noPruneSameBlock = void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] -- Verify everything was pruned assertBlockNoBackoff dbSync 98 - assertEqQuery dbSync DB.queryTxOutConsumedCount 0 "Unexpected TxOutConsumedByTxId after rollback" + assertEqQuery dbSync (DB.queryTxOutConsumedCount $ txOutTableTypeFromConfig dbSync) 0 "Unexpected TxOutConsumedByTxId after rollback" where cmdLineArgs = initCommandLineArgs diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Config/Parse.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Config/Parse.hs index f039ccb79..50dedf206 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Config/Parse.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Config/Parse.hs @@ -104,7 +104,6 @@ insertConfig = do , sioPoolStats = PoolStatsConfig False , sioJsonType = JsonTypeDisable , sioRemoveJsonbFromSchema = RemoveJsonbFromSchemaConfig False - , sioAddressDetail = AddressDetailConfig False } dncInsertOptions cfg @?= expected diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Plutus.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Plutus.hs index 175b54424..61aa1bcde 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Plutus.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Plutus.hs @@ -37,6 +37,8 @@ module Test.Cardano.Db.Mock.Unit.Conway.Plutus ( import Cardano.Crypto.Hash.Class (hashToBytes) 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 (Coin (..)) import Cardano.Ledger.Mary.Value (MaryValue (..), MultiAsset (..), PolicyID (..)) @@ -51,6 +53,7 @@ import Cardano.Mock.Query (queryMultiAssetCount) import Cardano.Prelude hiding (head) import qualified Data.Map as Map import Data.Maybe.Strict (StrictMaybe (..)) +import GHC.Base (error) import Ouroboros.Consensus.Shelley.Eras (StandardConway ()) import Ouroboros.Network.Block (genesisPoint) import Test.Cardano.Db.Mock.Config @@ -63,6 +66,7 @@ simpleScript :: IOManager -> [(Text, Text)] -> Assertion simpleScript = withFullConfigAndDropDB conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync + let txOutTableType = txOutTableTypeFromConfig dbSync -- Forge a block with stake credentials void $ Api.registerAllStakeCreds interpreter mockServer @@ -78,19 +82,31 @@ simpleScript = assertBlockNoBackoff dbSync (length epoch + 2) assertEqQuery dbSync - (map getOutFields <$> DB.queryScriptOutputs) + (map getOutFields <$> DB.queryScriptOutputs txOutTableType) [expectedFields] "Unexpected script outputs" where testLabel = "conwaySimpleScript" getOutFields txOut = - ( DB.txOutAddress txOut - , DB.txOutAddressHasScript txOut - , DB.txOutValue txOut - , DB.txOutDataHash txOut - ) + case txOut 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 "conwaySimpleScript: expected an address" + expectedFields = - ( Just $ renderAddress Examples.alwaysSucceedsScriptAddr + ( renderAddress Examples.alwaysSucceedsScriptAddr , True , DB.DbLovelace 20_000 , Just $ diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs index 06a3be995..574e033ef 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs @@ -44,6 +44,8 @@ module Test.Cardano.Db.Mock.Validate ( import Cardano.Db import qualified Cardano.Db as DB +import qualified Cardano.Db.Schema.Core.TxOut as C +import qualified Cardano.DbSync.Era.Shelley.Generic as Generic import Cardano.DbSync.Era.Shelley.Generic.Util import qualified Cardano.Ledger.Address as Ledger import Cardano.Ledger.BaseTypes @@ -104,7 +106,7 @@ assertTxCount env n = do assertTxOutCount :: DBSyncEnv -> Word -> IO () assertTxOutCount env n = do - assertEqBackoff env queryTxOutCount n defaultDelays "Unexpected txOut count" + assertEqBackoff env (queryTxOutCount TxOutCore) n defaultDelays "Unexpected txOut count" assertTxInCount :: DBSyncEnv -> Word -> IO () assertTxInCount env n = do @@ -135,8 +137,8 @@ expectFailSilent name action = testCase name $ do -- checking that unspent count matches from tx_in to tx_out assertUnspentTx :: DBSyncEnv -> IO () assertUnspentTx syncEnv = do - unspentTxCount <- queryDBSync syncEnv DB.queryTxOutConsumedNullCount - consumedNullCount <- queryDBSync syncEnv DB.queryTxOutUnspentCount + unspentTxCount <- queryDBSync syncEnv $ DB.queryTxOutConsumedNullCount TxOutCore + consumedNullCount <- queryDBSync syncEnv $ DB.queryTxOutUnspentCount TxOutCore assertEqual "Unexpected tx unspent count between tx-in & tx-out" unspentTxCount consumedNullCount defaultDelays :: [Int] @@ -211,8 +213,8 @@ assertAddrValues :: IO () assertAddrValues env ix expected sta = do addr <- assertRight $ resolveAddress ix sta - let address = Ledger.serialiseAddr addr - q = queryAddressOutputs address + let address = Generic.renderAddress addr + q = queryAddressOutputs TxOutCore address assertEqBackoff env q expected defaultDelays "Unexpected Balance" assertRight :: Show err => Either err a -> IO a @@ -371,7 +373,7 @@ assertAlonzoCounts env expected = colInputs <- maybe 0 unValue . listToMaybe <$> (select . from $ \(_a :: SqlExpr (Entity CollateralTxIn)) -> pure countRows) - scriptOutputs <- fromIntegral . length <$> queryScriptOutputs + scriptOutputs <- fromIntegral . length <$> queryScriptOutputs TxOutCore redeemerTxIn <- fromIntegral . length <$> queryTxInRedeemer invalidTx <- fromIntegral . length <$> queryInvalidTx txIninvalidTx <- fromIntegral . length <$> queryTxInFailedTx @@ -404,7 +406,7 @@ assertBabbageCounts env expected = colInputs <- maybe 0 unValue . listToMaybe <$> (select . from $ \(_a :: SqlExpr (Entity CollateralTxIn)) -> pure countRows) - scriptOutputs <- fromIntegral . length <$> queryScriptOutputs + scriptOutputs <- fromIntegral . length <$> queryScriptOutputs TxOutCore redeemerTxIn <- fromIntegral . length <$> queryTxInRedeemer invalidTx <- fromIntegral . length <$> queryInvalidTx txIninvalidTx <- fromIntegral . length <$> queryTxInFailedTx @@ -419,10 +421,10 @@ assertBabbageCounts env expected = <$> (select . from $ \(_a :: SqlExpr (Entity CollateralTxOut)) -> pure countRows) inlineDatum <- maybe 0 unValue . listToMaybe - <$> (select . from $ \txOut -> where_ (isJust (txOut ^. TxOutInlineDatumId)) >> pure countRows) + <$> (select . from $ \txOut -> where_ (isJust (txOut ^. C.TxOutInlineDatumId)) >> pure countRows) referenceScript <- maybe 0 unValue . listToMaybe - <$> (select . from $ \txOut -> where_ (isJust (txOut ^. TxOutReferenceScriptId)) >> pure countRows) + <$> (select . from $ \txOut -> where_ (isJust (txOut ^. C.TxOutReferenceScriptId)) >> pure countRows) pure ( scripts , redeemers diff --git a/cardano-db-sync/src/Cardano/DbSync.hs b/cardano-db-sync/src/Cardano/DbSync.hs index 8bc941b70..12d95028d 100644 --- a/cardano-db-sync/src/Cardano/DbSync.hs +++ b/cardano-db-sync/src/Cardano/DbSync.hs @@ -26,6 +26,7 @@ module Cardano.DbSync ( import Cardano.BM.Trace (Trace, logError, logInfo, logWarning) import qualified Cardano.Crypto as Crypto +import qualified Cardano.Db as DB import qualified Cardano.Db as Db import Cardano.DbSync.Api import Cardano.DbSync.Api.Types (InsertOptions (..), RunMigration, SyncEnv (..), SyncOptions (..), envLedgerEnv) @@ -118,7 +119,7 @@ runDbSync metricsSetters knownMigrations iomgr trce params syncNodeConfigFromFil -- For testing and debugging. whenJust (enpMaybeRollback params) $ \slotNo -> - void $ unsafeRollback trce pgConfig slotNo + void $ unsafeRollback trce (txOutConfigToTableType txOutConfig) pgConfig slotNo runSyncNode metricsSetters trce @@ -145,6 +146,8 @@ runDbSync metricsSetters knownMigrations iomgr trce params syncNodeConfigFromFil syncOpts = extractSyncOptions params abortOnPanic syncNodeConfigFromFile + txOutConfig = sioTxOut $ dncInsertOptions syncNodeConfigFromFile + runSyncNode :: MetricSetters -> Trace IO Text -> @@ -238,7 +241,7 @@ extractSyncOptions :: SyncNodeParams -> Bool -> SyncNodeConfig -> SyncOptions extractSyncOptions snp aop snc = SyncOptions { soptEpochAndCacheEnabled = - not isTxOutBootstrap' + not isTxOutConsumedBootstrap' && ioInOut iopts && not (enpEpochDisabled snp && enpHasCache snp) , soptAbortOnInvalid = aop @@ -248,8 +251,8 @@ extractSyncOptions snp aop snc = , soptPruneConsumeMigration = initPruneConsumeMigration isTxOutConsumed' - isTxOutPrune' - isTxOutBootstrap' + isTxOutConsumedPrune' + isTxOutConsumedBootstrap' forceTxIn' , soptInsertOptions = iopts , snapshotEveryFollowing = enpSnEveryFollowing snp @@ -278,7 +281,7 @@ extractSyncOptions snp aop snc = , ioPoolStats = isPoolStatsEnabled (sioPoolStats (dncInsertOptions snc)) , ioGov = useGovernance , ioRemoveJsonbFromSchema = isRemoveJsonbFromSchemaEnabled (sioRemoveJsonbFromSchema (dncInsertOptions snc)) - , ioAddressDetail = useAddressDetailTable (sioAddressDetail (dncInsertOptions snc)) + , ioTxOutTableType = ioTxOutTableType' } useLedger = sioLedger (dncInsertOptions snc) == LedgerEnable @@ -288,10 +291,11 @@ extractSyncOptions snp aop snc = isGovernanceEnabled (sioGovernance (dncInsertOptions snc)) isTxOutConsumed' = isTxOutConsumed . sioTxOut . dncInsertOptions $ snc - isTxOutPrune' = isTxOutPrune . sioTxOut . dncInsertOptions $ snc - isTxOutBootstrap' = isTxOutBootstrap . sioTxOut . dncInsertOptions $ snc + isTxOutConsumedPrune' = isTxOutConsumedPrune . sioTxOut . dncInsertOptions $ snc + isTxOutConsumedBootstrap' = isTxOutConsumedBootstrap . sioTxOut . dncInsertOptions $ snc isTxOutEnabled' = isTxOutEnabled . sioTxOut . dncInsertOptions $ snc forceTxIn' = forceTxIn . sioTxOut . dncInsertOptions $ snc + ioTxOutTableType' = txOutConfigToTableType $ sioTxOut $ dncInsertOptions snc startupReport :: Trace IO Text -> Bool -> SyncNodeParams -> IO () startupReport trce aop params = do @@ -299,3 +303,11 @@ startupReport trce aop params = do logInfo trce $ mconcat ["Git hash: ", Db.gitRev] logInfo trce $ mconcat ["Enviroment variable DbSyncAbortOnPanic: ", textShow aop] logInfo trce $ textShow params + +txOutConfigToTableType :: TxOutConfig -> DB.TxOutTableType +txOutConfigToTableType config = case config of + TxOutEnable (UseTxOutAddress flag) -> if flag then DB.TxOutVariantAddress else DB.TxOutCore + TxOutDisable -> DB.TxOutCore + TxOutConsumed _ (UseTxOutAddress flag) -> if flag then DB.TxOutVariantAddress else DB.TxOutCore + TxOutConsumedPrune _ (UseTxOutAddress flag) -> if flag then DB.TxOutVariantAddress else DB.TxOutCore + TxOutConsumedBootstrap _ (UseTxOutAddress flag) -> if flag then DB.TxOutVariantAddress else DB.TxOutCore diff --git a/cardano-db-sync/src/Cardano/DbSync/Api.hs b/cardano-db-sync/src/Cardano/DbSync/Api.hs index 0208e1854..ea3fbb677 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Api.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Api.hs @@ -29,6 +29,7 @@ module Cardano.DbSync.Api ( getPruneInterval, whenConsumeOrPruneTxOut, whenPruneTxOut, + getTxOutTableType, getHasConsumedOrPruneTxOut, getSkipTxIn, getPrunes, @@ -117,9 +118,10 @@ isConsistent env = do getIsConsumedFixed :: SyncEnv -> IO (Maybe Word64) getIsConsumedFixed env = case (DB.pcmPruneTxOut pcm, DB.pcmConsumeOrPruneTxOut pcm) of - (False, True) -> Just <$> DB.runDbIohkNoLogging backend Multiplex.queryWrongConsumedBy + (False, True) -> Just <$> DB.runDbIohkNoLogging backend (Multiplex.queryWrongConsumedBy txOutTableType) _ -> pure Nothing where + txOutTableType = getTxOutTableType env pcm = soptPruneConsumeMigration $ envOptions env backend = envBackend env @@ -176,10 +178,12 @@ getPruneConsume = soptPruneConsumeMigration . envOptions runExtraMigrationsMaybe :: SyncEnv -> IO () runExtraMigrationsMaybe syncEnv = do let pcm = getPruneConsume syncEnv + txOutTableType = getTxOutTableType syncEnv logInfo (getTrace syncEnv) $ textShow pcm DB.runDbIohkNoLogging (envBackend syncEnv) $ DB.runExtraMigrations (getTrace syncEnv) + txOutTableType (getSafeBlockNoDiff syncEnv) pcm @@ -205,6 +209,9 @@ whenPruneTxOut :: (MonadIO m) => SyncEnv -> m () -> m () whenPruneTxOut env = when (DB.pcmPruneTxOut $ getPruneConsume env) +getTxOutTableType :: SyncEnv -> DB.TxOutTableType +getTxOutTableType syncEnv = ioTxOutTableType . soptInsertOptions $ envOptions syncEnv + getHasConsumedOrPruneTxOut :: SyncEnv -> Bool getHasConsumedOrPruneTxOut = DB.pcmConsumeOrPruneTxOut . getPruneConsume @@ -355,7 +362,7 @@ mkSyncEnv trce backend connectionString syncOptions protoInfo nw nwMagic systemS consistentLevelVar <- newTVarIO Unchecked fixDataVar <- newTVarIO $ if ranMigrations then DataFixRan else NoneFixRan indexesVar <- newTVarIO $ enpForceIndexes syncNP - bts <- getBootstrapInProgress trce (isTxOutBootstrap' syncNodeConfigFromFile) backend + bts <- getBootstrapInProgress trce (isTxOutConsumedBootstrap' syncNodeConfigFromFile) backend bootstrapVar <- newTVarIO bts -- Offline Pool + Anchor queues opwq <- newTBQueueIO 1000 @@ -409,7 +416,7 @@ mkSyncEnv trce backend connectionString syncOptions protoInfo nw nwMagic systemS } where hasLedger' = hasLedger . sioLedger . dncInsertOptions - isTxOutBootstrap' = isTxOutBootstrap . sioTxOut . dncInsertOptions + isTxOutConsumedBootstrap' = isTxOutConsumedBootstrap . sioTxOut . dncInsertOptions mkSyncEnvFromConfig :: Trace IO Text -> diff --git a/cardano-db-sync/src/Cardano/DbSync/Api/Ledger.hs b/cardano-db-sync/src/Cardano/DbSync/Api/Ledger.hs index 20f1df1d8..399541c49 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Api/Ledger.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Api/Ledger.hs @@ -65,7 +65,7 @@ migrateBootstrapUTxO syncEnv = do HasLedger lenv -> do liftIO $ logInfo trce "Starting UTxO bootstrap migration" cls <- liftIO $ readCurrentStateUnsafe lenv - count <- lift DB.deleteTxOut + count <- lift $ DB.deleteTxOut (getTxOutTableType syncEnv) when (count > 0) $ liftIO $ logWarning trce $ @@ -83,7 +83,7 @@ storeUTxOFromLedger :: (MonadBaseControl IO m, MonadIO m) => SyncEnv -> ExtLedge storeUTxOFromLedger env st = case ledgerState st of LedgerStateBabbage bts -> storeUTxO env (getUTxO bts) LedgerStateConway stc -> storeUTxO env (getUTxO stc) - _ -> liftIO $ logError trce "storeUTxOFromLedger is only supported after Babbage" + _otherwise -> liftIO $ logError trce "storeUTxOFromLedger is only supported after Babbage" where trce = getTrace env getUTxO st' = @@ -140,10 +140,12 @@ storePage :: storePage syncEnv percQuantum (n, ls) = do when (n `mod` 10 == 0) $ liftIO $ logInfo trce $ "Bootstrap in progress " <> prc <> "%" txOuts <- mapM (prepareTxOut syncEnv) ls - txOutIds <- lift . DB.insertManyTxOutPlex True False $ etoTxOut . fst <$> txOuts - let maTxOuts = concatMap mkmaTxOuts $ zip txOutIds (snd <$> txOuts) + txOutIds <- + lift . DB.insertManyTxOut False $ etoTxOut . fst <$> txOuts + let maTxOuts = concatMap (mkmaTxOuts txOutTableType) $ zip txOutIds (snd <$> txOuts) void . lift $ DB.insertManyMaTxOut maTxOuts where + txOutTableType = getTxOutTableType syncEnv trce = getTrace syncEnv prc = Text.pack $ showGFloat (Just 1) (max 0 $ min 100.0 (fromIntegral n * percQuantum)) "" diff --git a/cardano-db-sync/src/Cardano/DbSync/Api/Types.hs b/cardano-db-sync/src/Cardano/DbSync/Api/Types.hs index 48de5c47d..ac7e85666 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Api/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Api/Types.hs @@ -87,7 +87,7 @@ data InsertOptions = InsertOptions , ioPoolStats :: !Bool , ioGov :: !Bool , ioRemoveJsonbFromSchema :: !Bool - , ioAddressDetail :: !Bool + , ioTxOutTableType :: !DB.TxOutTableType } deriving (Show) diff --git a/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs b/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs index 5eda68209..1c2c867bc 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs @@ -19,7 +19,7 @@ module Cardano.DbSync.Config.Types ( GenesisHashAlonzo (..), GenesisHashConway (..), RemoveJsonbFromSchemaConfig (..), - AddressDetailConfig (..), + TxOutTableTypeConfig (..), SyncNodeConfig (..), SyncPreConfig (..), SyncInsertConfig (..), @@ -28,6 +28,7 @@ module Cardano.DbSync.Config.Types ( TxCBORConfig (..), PoolStatsConfig (..), TxOutConfig (..), + UseTxOutAddress (..), ForceTxIn (..), LedgerInsertConfig (..), ShelleyInsertConfig (..), @@ -53,9 +54,9 @@ module Cardano.DbSync.Config.Types ( isMultiAssetEnabled, isMetadataEnabled, isPlutusEnabled, - isTxOutBootstrap, + isTxOutConsumedBootstrap, isTxOutConsumed, - isTxOutPrune, + isTxOutConsumedPrune, forceTxIn, fullInsertOptions, onlyUTxOInsertOptions, @@ -68,7 +69,7 @@ import qualified Cardano.BM.Data.Configuration as Logging import qualified Cardano.Chain.Update as Byron import Cardano.Crypto (RequiresNetworkMagic (..)) import qualified Cardano.Crypto.Hash as Crypto -import Cardano.Db (MigrationDir, PGPassSource (..)) +import Cardano.Db (MigrationDir, PGPassSource (..), TxOutTableType (..)) import Cardano.Prelude import Cardano.Slotting.Slot (SlotNo (..)) import Control.Monad (fail) @@ -184,7 +185,6 @@ data SyncInsertOptions = SyncInsertOptions , sioPoolStats :: PoolStatsConfig , sioJsonType :: JsonTypeConfig , sioRemoveJsonbFromSchema :: RemoveJsonbFromSchemaConfig - , sioAddressDetail :: AddressDetailConfig } deriving (Eq, Show) @@ -199,17 +199,21 @@ newtype PoolStatsConfig = PoolStatsConfig deriving (Eq, Show) data TxOutConfig - = TxOutEnable + = TxOutEnable UseTxOutAddress | TxOutDisable - | TxOutConsumed ForceTxIn - | TxOutPrune ForceTxIn - | TxOutBootstrap ForceTxIn + | TxOutConsumed ForceTxIn UseTxOutAddress + | TxOutConsumedPrune ForceTxIn UseTxOutAddress + | TxOutConsumedBootstrap ForceTxIn UseTxOutAddress deriving (Eq, Show) newtype ForceTxIn = ForceTxIn {unForceTxIn :: Bool} deriving (Eq, Show) deriving newtype (ToJSON, FromJSON) +newtype UseTxOutAddress = UseTxOutAddress {unUseTxOutAddress :: Bool} + deriving (Eq, Show) + deriving newtype (ToJSON, FromJSON) + data LedgerInsertConfig = LedgerEnable | LedgerDisable @@ -259,8 +263,8 @@ newtype RemoveJsonbFromSchemaConfig = RemoveJsonbFromSchemaConfig } deriving (Eq, Show) -newtype AddressDetailConfig = AddressDetailConfig - { useAddressDetailTable :: Bool +newtype TxOutTableTypeConfig = TxOutTableTypeConfig + { unTxOutTableTypeConfig :: TxOutTableType } deriving (Eq, Show) @@ -326,28 +330,28 @@ pcNodeConfigFilePath = unNodeConfigFile . pcNodeConfigFile isTxOutEnabled :: TxOutConfig -> Bool isTxOutEnabled TxOutDisable = False -isTxOutEnabled TxOutEnable = True -isTxOutEnabled (TxOutConsumed _) = True -isTxOutEnabled (TxOutPrune _) = True -isTxOutEnabled (TxOutBootstrap _) = True +isTxOutEnabled (TxOutEnable _) = True +isTxOutEnabled (TxOutConsumed _ _) = True +isTxOutEnabled (TxOutConsumedPrune _ _) = True +isTxOutEnabled (TxOutConsumedBootstrap _ _) = True -isTxOutBootstrap :: TxOutConfig -> Bool -isTxOutBootstrap (TxOutBootstrap _) = True -isTxOutBootstrap _ = False +isTxOutConsumedBootstrap :: TxOutConfig -> Bool +isTxOutConsumedBootstrap (TxOutConsumedBootstrap _ _) = True +isTxOutConsumedBootstrap _ = False isTxOutConsumed :: TxOutConfig -> Bool -isTxOutConsumed (TxOutConsumed _) = True +isTxOutConsumed (TxOutConsumed _ _) = True isTxOutConsumed _ = False -isTxOutPrune :: TxOutConfig -> Bool -isTxOutPrune (TxOutPrune _) = True -isTxOutPrune _ = False +isTxOutConsumedPrune :: TxOutConfig -> Bool +isTxOutConsumedPrune (TxOutConsumedPrune _ _) = True +isTxOutConsumedPrune _ = False forceTxIn :: TxOutConfig -> Bool -forceTxIn (TxOutConsumed f) = unForceTxIn f -forceTxIn (TxOutPrune f) = unForceTxIn f -forceTxIn (TxOutBootstrap f) = unForceTxIn f -forceTxIn TxOutEnable = False +forceTxIn (TxOutConsumed f _) = unForceTxIn f +forceTxIn (TxOutConsumedPrune f _) = unForceTxIn f +forceTxIn (TxOutConsumedBootstrap f _) = unForceTxIn f +forceTxIn (TxOutEnable _) = False forceTxIn TxOutDisable = False hasLedger :: LedgerInsertConfig -> Bool @@ -446,7 +450,6 @@ parseOverrides obj baseOptions = do <*> obj .:? "pool_stats" .!= sioPoolStats baseOptions <*> obj .:? "json_type" .!= sioJsonType baseOptions <*> obj .:? "remove_jsonb_from_schema" .!= sioRemoveJsonbFromSchema baseOptions - <*> obj .:? "use_address_table" .!= sioAddressDetail baseOptions instance ToJSON SyncInsertConfig where toJSON (SyncInsertConfig preset options) = @@ -467,7 +470,6 @@ optionsToList SyncInsertOptions {..} = , toJsonIfSet "offchain_pool_data" sioOffchainPoolData , toJsonIfSet "pool_stats" sioPoolStats , toJsonIfSet "json_type" sioJsonType - , toJsonIfSet "remove_jsonb_from_schema" sioRemoveJsonbFromSchema ] toJsonIfSet :: ToJSON a => Text -> a -> Maybe Pair @@ -489,7 +491,6 @@ instance FromJSON SyncInsertOptions where <*> obj .:? "pool_stat" .!= sioPoolStats def <*> obj .:? "json_type" .!= sioJsonType def <*> obj .:? "remove_jsonb_from_schema" .!= sioRemoveJsonbFromSchema def - <*> obj .:? "use_address_table" .!= sioAddressDetail def instance ToJSON SyncInsertOptions where toJSON SyncInsertOptions {..} = @@ -534,33 +535,42 @@ instance ToJSON TxOutConfig where Aeson.object [ "value" .= value cfg , "force_tx_in" .= forceTxIn' cfg + , "use_address_table" .= useTxOutAddress' cfg ] where value :: TxOutConfig -> Text - value TxOutEnable = "enable" + value (TxOutEnable _) = "enable" value TxOutDisable = "disable" - value (TxOutConsumed _) = "consumed" - value (TxOutPrune _) = "prune" - value (TxOutBootstrap _) = "bootstrap" + value (TxOutConsumed _ _) = "consumed" + value (TxOutConsumedPrune _ _) = "prune" + value (TxOutConsumedBootstrap _ _) = "bootstrap" forceTxIn' :: TxOutConfig -> Maybe Bool - forceTxIn' TxOutEnable = Nothing + forceTxIn' (TxOutEnable _) = Nothing forceTxIn' TxOutDisable = Nothing - forceTxIn' (TxOutConsumed f) = Just (unForceTxIn f) - forceTxIn' (TxOutPrune f) = Just (unForceTxIn f) - forceTxIn' (TxOutBootstrap f) = Just (unForceTxIn f) + forceTxIn' (TxOutConsumed f _) = Just (unForceTxIn f) + forceTxIn' (TxOutConsumedPrune f _) = Just (unForceTxIn f) + forceTxIn' (TxOutConsumedBootstrap f _) = Just (unForceTxIn f) + + useTxOutAddress' :: TxOutConfig -> Maybe Bool + useTxOutAddress' (TxOutEnable u) = Just (unUseTxOutAddress u) + useTxOutAddress' TxOutDisable = Nothing + useTxOutAddress' (TxOutConsumed _ u) = Just (unUseTxOutAddress u) + useTxOutAddress' (TxOutConsumedPrune _ u) = Just (unUseTxOutAddress u) + useTxOutAddress' (TxOutConsumedBootstrap _ u) = Just (unUseTxOutAddress u) instance FromJSON TxOutConfig where parseJSON = Aeson.withObject "tx_out" $ \obj -> do val <- obj .: "value" + useAddress' <- obj .: "use_address_table" .!= UseTxOutAddress False forceTxIn' <- obj .:? "force_tx_in" .!= ForceTxIn False case val :: Text of - "enable" -> pure TxOutEnable + "enable" -> pure (TxOutEnable useAddress') "disable" -> pure TxOutDisable - "consumed" -> pure (TxOutConsumed forceTxIn') - "prune" -> pure (TxOutPrune forceTxIn') - "bootstrap" -> pure (TxOutBootstrap forceTxIn') + "consumed" -> pure (TxOutConsumed forceTxIn' useAddress') + "prune" -> pure (TxOutConsumedPrune forceTxIn' useAddress') + "bootstrap" -> pure (TxOutConsumedBootstrap forceTxIn' useAddress') other -> fail $ "unexpected tx_out: " <> show other instance ToJSON LedgerInsertConfig where @@ -680,14 +690,14 @@ instance FromJSON RemoveJsonbFromSchemaConfig where instance ToJSON RemoveJsonbFromSchemaConfig where toJSON = boolToEnableDisable . isRemoveJsonbFromSchemaEnabled -instance FromJSON AddressDetailConfig where - parseJSON = Aeson.withText "use_address_table" $ \v -> - case enableDisableToBool v of - Just g -> pure (AddressDetailConfig g) - Nothing -> fail $ "unexpected use_address_table: " <> show v +instance FromJSON TxOutTableTypeConfig where + parseJSON = Aeson.withText "add_address_table_to_txout" $ \v -> + case enableDisableToTxOutTableType v of + Just g -> pure (TxOutTableTypeConfig g) + Nothing -> fail $ "unexpected add_address_table_to_txout: " <> show v -instance ToJSON AddressDetailConfig where - toJSON = boolToEnableDisable . useAddressDetailTable +instance ToJSON TxOutTableTypeConfig where + toJSON = addressTypeToEnableDisable . unTxOutTableTypeConfig instance FromJSON OffchainPoolDataConfig where parseJSON = Aeson.withText "offchain_pool_data" $ \v -> @@ -714,7 +724,7 @@ instance Default SyncInsertOptions where def = SyncInsertOptions { sioTxCBOR = TxCBORConfig False - , sioTxOut = TxOutEnable + , sioTxOut = TxOutEnable (UseTxOutAddress False) , sioLedger = LedgerEnable , sioShelley = ShelleyEnable , sioRewards = RewardsConfig True @@ -726,14 +736,13 @@ instance Default SyncInsertOptions where , sioPoolStats = PoolStatsConfig False , sioJsonType = JsonTypeText , sioRemoveJsonbFromSchema = RemoveJsonbFromSchemaConfig False - , sioAddressDetail = AddressDetailConfig False } fullInsertOptions :: SyncInsertOptions fullInsertOptions = SyncInsertOptions { sioTxCBOR = TxCBORConfig False - , sioTxOut = TxOutEnable + , sioTxOut = TxOutEnable (UseTxOutAddress False) , sioLedger = LedgerEnable , sioShelley = ShelleyEnable , sioRewards = RewardsConfig True @@ -745,14 +754,13 @@ fullInsertOptions = , sioPoolStats = PoolStatsConfig True , sioJsonType = JsonTypeText , sioRemoveJsonbFromSchema = RemoveJsonbFromSchemaConfig False - , sioAddressDetail = AddressDetailConfig False } onlyUTxOInsertOptions :: SyncInsertOptions onlyUTxOInsertOptions = SyncInsertOptions { sioTxCBOR = TxCBORConfig False - , sioTxOut = TxOutBootstrap (ForceTxIn False) + , sioTxOut = TxOutConsumedBootstrap (ForceTxIn False) (UseTxOutAddress False) , sioLedger = LedgerIgnore , sioShelley = ShelleyDisable , sioRewards = RewardsConfig True @@ -764,7 +772,6 @@ onlyUTxOInsertOptions = , sioPoolStats = PoolStatsConfig False , sioJsonType = JsonTypeText , sioRemoveJsonbFromSchema = RemoveJsonbFromSchemaConfig False - , sioAddressDetail = AddressDetailConfig False } onlyGovInsertOptions :: SyncInsertOptions @@ -791,9 +798,18 @@ disableAllInsertOptions = , sioGovernance = GovernanceConfig False , sioJsonType = JsonTypeText , sioRemoveJsonbFromSchema = RemoveJsonbFromSchemaConfig False - , sioAddressDetail = AddressDetailConfig False } +addressTypeToEnableDisable :: IsString s => TxOutTableType -> s +addressTypeToEnableDisable TxOutVariantAddress = "enable" +addressTypeToEnableDisable TxOutCore = "disable" + +enableDisableToTxOutTableType :: (Eq s, IsString s) => s -> Maybe TxOutTableType +enableDisableToTxOutTableType = \case + "enable" -> Just TxOutVariantAddress + "disable" -> Just TxOutCore + _ -> Nothing + boolToEnableDisable :: IsString s => Bool -> s boolToEnableDisable True = "enable" boolToEnableDisable False = "disable" diff --git a/cardano-db-sync/src/Cardano/DbSync/Default.hs b/cardano-db-sync/src/Cardano/DbSync/Default.hs index 0285533c1..010ee9fcc 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Default.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Default.hs @@ -179,10 +179,11 @@ insertBlock syncEnv cblk applyRes firstAfterRollback tookSnapshot = do whenPruneTxOut syncEnv $ when (unBlockNo blkNo `mod` getPruneInterval syncEnv == 0) $ do - lift $ DB.deleteConsumedTxOut tracer (getSafeBlockNoDiff syncEnv) + lift $ DB.deleteConsumedTxOut tracer txOutTableType (getSafeBlockNoDiff syncEnv) commitOrIndexes withinTwoMin withinHalfHour where tracer = getTrace syncEnv + txOutTableType = getTxOutTableType syncEnv iopts = getInsertOptions syncEnv updateEpoch details isNewEpochEvent = diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Genesis.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Genesis.hs index 772da6e6f..7189794b0 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Genesis.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Genesis.hs @@ -17,8 +17,10 @@ import qualified Cardano.Chain.Genesis as Byron import qualified Cardano.Chain.UTxO as Byron import qualified Cardano.Crypto 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.Api -import Cardano.DbSync.Api.Types (SyncEnv (..), SyncOptions (..), ioAddressDetail) +import Cardano.DbSync.Api.Types (SyncEnv (..)) import Cardano.DbSync.Config.Types import qualified Cardano.DbSync.Era.Byron.Util as Byron import Cardano.DbSync.Era.Util (liftLookupFail) @@ -44,20 +46,20 @@ insertValidateGenesisDist :: insertValidateGenesisDist syncEnv (NetworkName networkName) cfg = do -- Setting this to True will log all 'Persistent' operations which is great -- for debugging, but otherwise *way* too chatty. - disInOut <- liftIO $ getDisableInOutState syncEnv - let hasConsumed = getHasConsumedOrPruneTxOut syncEnv - prunes = getPrunes syncEnv if False - then newExceptT $ DB.runDbIohkLogging (envBackend syncEnv) tracer (insertAction hasConsumed prunes disInOut) - else newExceptT $ DB.runDbIohkNoLogging (envBackend syncEnv) (insertAction hasConsumed prunes disInOut) + then newExceptT $ DB.runDbIohkLogging (envBackend syncEnv) tracer insertAction + else newExceptT $ DB.runDbIohkNoLogging (envBackend syncEnv) insertAction where tracer = getTrace syncEnv - insertAction :: Bool -> Bool -> Bool -> (MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m (Either SyncNodeError ()) - insertAction hasConsumed prunes disInOut = do + insertAction :: (MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m (Either SyncNodeError ()) + insertAction = do + disInOut <- liftIO $ getDisableInOutState syncEnv + let prunes = getPrunes syncEnv + ebid <- DB.queryBlockId (configGenesisHash cfg) case ebid of - Right bid -> validateGenesisDistribution prunes disInOut tracer networkName cfg bid + Right bid -> validateGenesisDistribution syncEnv prunes disInOut tracer networkName cfg bid Left _ -> runExceptT $ do liftIO $ logInfo tracer "Inserting Byron Genesis distribution" @@ -105,17 +107,18 @@ insertValidateGenesisDist syncEnv (NetworkName networkName) cfg = do , DB.blockOpCert = Nothing , DB.blockOpCertCounter = Nothing } - mapM_ (insertTxOuts syncEnv hasConsumed disInOut bid) $ genesisTxos cfg + mapM_ (insertTxOutsByron syncEnv disInOut bid) $ genesisTxos cfg liftIO . logInfo tracer $ "Initial genesis distribution populated. Hash " <> renderByteArray (configGenesisHash cfg) - supply <- lift DB.queryTotalSupply + supply <- lift $ DB.queryGenesisSupply $ getTxOutTableType syncEnv liftIO $ logInfo tracer ("Total genesis supply of Ada: " <> DB.renderAda supply) -- | Validate that the initial Genesis distribution in the DB matches the Genesis data. validateGenesisDistribution :: (MonadBaseControl IO m, MonadIO m) => + SyncEnv -> Bool -> Bool -> Trace IO Text -> @@ -123,7 +126,7 @@ validateGenesisDistribution :: Byron.Config -> DB.BlockId -> ReaderT SqlBackend m (Either SyncNodeError ()) -validateGenesisDistribution prunes disInOut tracer networkName cfg bid = +validateGenesisDistribution syncEnv prunes disInOut tracer networkName cfg bid = runExceptT $ do meta <- liftLookupFail "validateGenesisDistribution" DB.queryMeta @@ -156,7 +159,7 @@ validateGenesisDistribution prunes disInOut tracer networkName cfg bid = , textShow txCount ] unless disInOut $ do - totalSupply <- lift DB.queryGenesisSupply + totalSupply <- lift $ DB.queryGenesisSupply $ getTxOutTableType syncEnv case DB.word64ToAda <$> configGenesisSupply cfg of Left err -> dbSyncNodeError $ "validateGenesisDistribution: " <> textShow err Right expectedSupply -> @@ -172,17 +175,16 @@ validateGenesisDistribution prunes disInOut tracer networkName cfg bid = logInfo tracer "Initial genesis distribution present and correct" logInfo tracer ("Total genesis supply of Ada: " <> DB.renderAda totalSupply) --- ----------------------------------------------------------------------------- +------------------------------------------------------------------------------- -insertTxOuts :: +insertTxOutsByron :: (MonadBaseControl IO m, MonadIO m) => SyncEnv -> Bool -> - Bool -> DB.BlockId -> (Byron.Address, Byron.Lovelace) -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertTxOuts syncEnv hasConsumed disInOut blkId (address, value) = do +insertTxOutsByron syncEnv disInOut blkId (address, value) = do case txHashOfAddress address of Left err -> throwError err Right val -> lift $ do @@ -204,56 +206,64 @@ insertTxOuts syncEnv hasConsumed disInOut blkId (address, value) = do , DB.txScriptSize = 0 , DB.txTreasuryDonation = DB.DbLovelace 0 } - -- Insert the address detail config is active - if ioAddressDetail . soptInsertOptions $ envOptions syncEnv - then do - addrDetailId <- insertAddressDetail - DB.insertTxOutPlex hasConsumed disInOut $ - DB.TxOut - { DB.txOutTxId = txId - , DB.txOutIndex = 0 - , DB.txOutAddress = Nothing - , DB.txOutAddressHasScript = False - , DB.txOutPaymentCred = Nothing - , DB.txOutStakeAddressId = Nothing - , DB.txOutValue = DB.DbLovelace (Byron.unsafeGetLovelace value) - , DB.txOutDataHash = Nothing - , DB.txOutInlineDatumId = Nothing - , DB.txOutReferenceScriptId = Nothing - , DB.txOutAddressDetailId = Just addrDetailId - } - else - DB.insertTxOutPlex hasConsumed disInOut $ - DB.TxOut - { DB.txOutTxId = txId - , DB.txOutIndex = 0 - , DB.txOutAddress = Just $ Text.decodeUtf8 $ Byron.addrToBase58 address - , DB.txOutAddressHasScript = False - , DB.txOutPaymentCred = Nothing - , DB.txOutStakeAddressId = Nothing - , DB.txOutValue = DB.DbLovelace (Byron.unsafeGetLovelace value) - , DB.txOutDataHash = Nothing - , DB.txOutInlineDatumId = Nothing - , DB.txOutReferenceScriptId = Nothing - , DB.txOutAddressDetailId = Nothing - } + -- + unless disInOut $ + case getTxOutTableType syncEnv of + DB.TxOutCore -> + void . DB.insertTxOut $ + DB.CTxOutW + C.TxOut + { C.txOutTxId = txId + , C.txOutIndex = 0 + , C.txOutAddress = Text.decodeUtf8 $ Byron.addrToBase58 address + , C.txOutAddressHasScript = False + , C.txOutPaymentCred = Nothing + , C.txOutStakeAddressId = Nothing + , C.txOutValue = DB.DbLovelace (Byron.unsafeGetLovelace value) + , C.txOutDataHash = Nothing + , C.txOutInlineDatumId = Nothing + , C.txOutReferenceScriptId = Nothing + , C.txOutConsumedByTxId = Nothing + } + DB.TxOutVariantAddress -> do + let addrRaw = serialize' address + vAddress = mkVAddress addrRaw + addrDetailId <- insertAddress addrRaw vAddress + void . DB.insertTxOut $ + DB.VTxOutW (mkVTxOut txId addrDetailId) Nothing where - insertAddressDetail :: + mkVTxOut :: DB.TxId -> V.AddressId -> V.TxOut + mkVTxOut txId addrDetailId = + V.TxOut + { V.txOutTxId = txId + , V.txOutIndex = 0 + , V.txOutValue = DB.DbLovelace (Byron.unsafeGetLovelace value) + , V.txOutDataHash = Nothing + , V.txOutInlineDatumId = Nothing + , V.txOutReferenceScriptId = Nothing + , V.txOutAddressId = addrDetailId + , V.txOutConsumedByTxId = Nothing + } + + mkVAddress :: ByteString -> V.Address + mkVAddress addrRaw = do + V.Address + { V.addressAddress = Text.decodeUtf8 $ Byron.addrToBase58 address + , V.addressRaw = addrRaw + , V.addressHasScript = False + , V.addressPaymentCred = Nothing -- Byron does not have a payment credential. + , V.addressStakeAddressId = Nothing -- Byron does not have a stake address. + } + + insertAddress :: (MonadBaseControl IO m, MonadIO m) => - ReaderT SqlBackend m DB.AddressDetailId - insertAddressDetail = do - let addrRaw = serialize' address - mAddrId <- DB.queryAddressDetailId addrRaw + ByteString -> + V.Address -> + ReaderT SqlBackend m V.AddressId + insertAddress addrRaw vAdrs = do + mAddrId <- DB.queryAddressId addrRaw case mAddrId of - Nothing -> - DB.insertAddressDetail - DB.AddressDetail - { DB.addressDetailAddress = Text.decodeUtf8 $ Byron.addrToBase58 address - , DB.addressDetailAddressRaw = addrRaw - , DB.addressDetailHasScript = False - , DB.addressDetailPaymentCred = Nothing -- Byron does not have a payment credential. - , DB.addressDetailStakeAddressId = Nothing -- Byron does not have a stake address. - } + Nothing -> DB.insertAddress vAdrs -- this address is already in the database, so we can just return the id to be linked to the txOut. Just addrId -> pure addrId diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Insert.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Insert.hs index 38751ba54..d18a87e5f 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Insert.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Insert.hs @@ -20,6 +20,8 @@ import qualified Cardano.Chain.Update as Byron hiding (protocolVersion) import qualified Cardano.Crypto as Crypto (serializeCborHash) import Cardano.Db (DbLovelace (..)) 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.Api import Cardano.DbSync.Api.Types (InsertOptions (..), SyncEnv (..), SyncOptions (..)) import Cardano.DbSync.Cache ( @@ -279,7 +281,7 @@ insertByronTx' :: Word64 -> ExceptT SyncNodeError (ReaderT SqlBackend m) Word64 insertByronTx' syncEnv blkId tx blockIndex = do - resolvedInputs <- mapM resolveTxInputs (toList $ Byron.txInputs (Byron.taTx tx)) + resolvedInputs <- mapM (resolveTxInputs txOutTableType) (toList $ Byron.txInputs (Byron.taTx tx)) valFee <- firstExceptT annotateTx $ ExceptT $ pure (calculateTxFee (Byron.taTx tx) resolvedInputs) txId <- lift . DB.insertTx $ @@ -312,7 +314,7 @@ insertByronTx' syncEnv blkId tx blockIndex = do -- Insert outputs for a transaction before inputs in case the inputs for this transaction -- references the output (not sure this can even happen). disInOut <- liftIO $ getDisableInOutState syncEnv - lift $ zipWithM_ (insertTxOut syncEnv (getHasConsumedOrPruneTxOut syncEnv) disInOut txId) [0 ..] (toList . Byron.txOutputs $ Byron.taTx tx) + lift $ zipWithM_ (insertTxOutByron syncEnv (getHasConsumedOrPruneTxOut syncEnv) disInOut txId) [0 ..] (toList . Byron.txOutputs $ Byron.taTx tx) unless (getSkipTxIn syncEnv) $ mapM_ (insertTxIn tracer txId) resolvedInputs whenConsumeOrPruneTxOut syncEnv $ @@ -321,6 +323,7 @@ insertByronTx' syncEnv blkId tx blockIndex = do -- fees are being returned so we can sum them and put them in cache to use when updating epochs pure $ unDbLovelace $ vfFee valFee where + txOutTableType = getTxOutTableType syncEnv iopts = getInsertOptions syncEnv tracer :: Trace IO Text @@ -334,7 +337,7 @@ insertByronTx' syncEnv blkId tx blockIndex = do prepUpdate txId (_, _, txOutId, _) = (txOutId, txId) -insertTxOut :: +insertTxOutByron :: (MonadBaseControl IO m, MonadIO m) => SyncEnv -> Bool -> @@ -343,58 +346,62 @@ insertTxOut :: Word32 -> Byron.TxOut -> ReaderT SqlBackend m () -insertTxOut syncEnv hasConsumed bootStrap txId index txout = - do - -- check if we should use AddressDetail or not - if ioAddressDetail . soptInsertOptions $ envOptions syncEnv - then do - addrDetailId <- insertAddressDetail - DB.insertTxOutPlex hasConsumed bootStrap $ - DB.TxOut - { DB.txOutTxId = txId - , DB.txOutIndex = fromIntegral index - , DB.txOutAddress = Nothing - , DB.txOutAddressHasScript = False - , DB.txOutPaymentCred = Nothing - , DB.txOutStakeAddressId = Nothing - , DB.txOutValue = DbLovelace (Byron.unsafeGetLovelace $ Byron.txOutValue txout) - , DB.txOutDataHash = Nothing - , DB.txOutInlineDatumId = Nothing - , DB.txOutReferenceScriptId = Nothing - , DB.txOutAddressDetailId = Just addrDetailId - } - else - DB.insertTxOutPlex hasConsumed bootStrap $ - DB.TxOut - { DB.txOutTxId = txId - , DB.txOutIndex = fromIntegral index - , DB.txOutAddress = Just $ Text.decodeUtf8 $ Byron.addrToBase58 (Byron.txOutAddress txout) - , DB.txOutAddressHasScript = False - , DB.txOutPaymentCred = Nothing -- Byron does not have a payment credential. - , DB.txOutStakeAddressId = Nothing -- Byron does not have a stake address. - , DB.txOutValue = DbLovelace (Byron.unsafeGetLovelace $ Byron.txOutValue txout) - , DB.txOutDataHash = Nothing - , DB.txOutInlineDatumId = Nothing - , DB.txOutReferenceScriptId = Nothing - , DB.txOutAddressDetailId = Nothing - } +insertTxOutByron syncEnv _hasConsumed bootStrap txId index txout = + unless bootStrap $ + case ioTxOutTableType . soptInsertOptions $ envOptions syncEnv of + DB.TxOutCore -> do + void . DB.insertTxOut $ + DB.CTxOutW $ + C.TxOut + { C.txOutAddress = Text.decodeUtf8 $ Byron.addrToBase58 (Byron.txOutAddress txout) + , C.txOutAddressHasScript = False + , C.txOutDataHash = Nothing + , C.txOutConsumedByTxId = Nothing + , C.txOutIndex = fromIntegral index + , C.txOutInlineDatumId = Nothing + , C.txOutPaymentCred = Nothing -- Byron does not have a payment credential. + , C.txOutReferenceScriptId = Nothing + , C.txOutStakeAddressId = Nothing -- Byron does not have a stake address. + , C.txOutTxId = txId + , C.txOutValue = DbLovelace (Byron.unsafeGetLovelace $ Byron.txOutValue txout) + } + DB.TxOutVariantAddress -> do + addrDetailId <- insertAddress + void . DB.insertTxOut $ DB.VTxOutW (vTxOut addrDetailId) Nothing where - insertAddressDetail :: + addrRaw :: ByteString + addrRaw = serialize' (Byron.txOutAddress txout) + + vTxOut :: V.AddressId -> V.TxOut + vTxOut addrDetailId = + V.TxOut + { V.txOutAddressId = addrDetailId + , V.txOutConsumedByTxId = Nothing + , V.txOutDataHash = Nothing + , V.txOutIndex = fromIntegral index + , V.txOutInlineDatumId = Nothing + , V.txOutReferenceScriptId = Nothing + , V.txOutTxId = txId + , V.txOutValue = DbLovelace (Byron.unsafeGetLovelace $ Byron.txOutValue txout) + } + + vAddress :: V.Address + vAddress = + V.Address + { V.addressAddress = Text.decodeUtf8 $ Byron.addrToBase58 (Byron.txOutAddress txout) + , V.addressRaw = addrRaw + , V.addressHasScript = False + , V.addressPaymentCred = Nothing -- Byron does not have a payment credential. + , V.addressStakeAddressId = Nothing -- Byron does not have a stake address. + } + + insertAddress :: (MonadBaseControl IO m, MonadIO m) => - ReaderT SqlBackend m DB.AddressDetailId - insertAddressDetail = do - let addrRaw = serialize' (Byron.txOutAddress txout) - mAddrId <- DB.queryAddressDetailId addrRaw + ReaderT SqlBackend m V.AddressId + insertAddress = do + mAddrId <- DB.queryAddressId addrRaw case mAddrId of - Nothing -> - DB.insertAddressDetail - DB.AddressDetail - { DB.addressDetailAddress = Text.decodeUtf8 $ Byron.addrToBase58 (Byron.txOutAddress txout) - , DB.addressDetailAddressRaw = addrRaw - , DB.addressDetailHasScript = False - , DB.addressDetailPaymentCred = Nothing -- Byron does not have a payment credential. - , DB.addressDetailStakeAddressId = Nothing -- Byron does not have a stake address. - } + Nothing -> DB.insertAddress vAddress -- this address is already in the database, so we can just return the id to be linked to the txOut. Just addrId -> pure addrId @@ -402,7 +409,7 @@ insertTxIn :: (MonadBaseControl IO m, MonadIO m) => Trace IO Text -> DB.TxId -> - (Byron.TxIn, DB.TxId, DB.TxOutId, DbLovelace) -> + (Byron.TxIn, DB.TxId, DB.TxOutIdW, DbLovelace) -> ExceptT SyncNodeError (ReaderT SqlBackend m) DB.TxInId insertTxIn _tracer txInTxId (Byron.TxInUtxo _txHash inIndex, txOutTxId, _, _) = do lift . DB.insertTxIn $ @@ -415,15 +422,15 @@ insertTxIn _tracer txInTxId (Byron.TxInUtxo _txHash inIndex, txOutTxId, _, _) = -- ----------------------------------------------------------------------------- -resolveTxInputs :: MonadIO m => Byron.TxIn -> ExceptT SyncNodeError (ReaderT SqlBackend m) (Byron.TxIn, DB.TxId, DB.TxOutId, DbLovelace) -resolveTxInputs txIn@(Byron.TxInUtxo txHash index) = do - res <- liftLookupFail "resolveInput" $ DB.queryTxOutIdValue (Byron.unTxHash txHash, fromIntegral index) +resolveTxInputs :: MonadIO m => DB.TxOutTableType -> Byron.TxIn -> ExceptT SyncNodeError (ReaderT SqlBackend m) (Byron.TxIn, DB.TxId, DB.TxOutIdW, DbLovelace) +resolveTxInputs txOutTableType txIn@(Byron.TxInUtxo txHash index) = do + res <- liftLookupFail "resolveInput" $ DB.queryTxOutIdValue txOutTableType (Byron.unTxHash txHash, fromIntegral index) pure $ convert res where - convert :: (DB.TxId, DB.TxOutId, DbLovelace) -> (Byron.TxIn, DB.TxId, DB.TxOutId, DbLovelace) + convert :: (DB.TxId, DB.TxOutIdW, DbLovelace) -> (Byron.TxIn, DB.TxId, DB.TxOutIdW, DbLovelace) convert (txId, txOutId, lovelace) = (txIn, txId, txOutId, lovelace) -calculateTxFee :: Byron.Tx -> [(Byron.TxIn, DB.TxId, DB.TxOutId, DbLovelace)] -> Either SyncNodeError ValueFee +calculateTxFee :: Byron.Tx -> [(Byron.TxIn, DB.TxId, DB.TxOutIdW, DbLovelace)] -> Either SyncNodeError ValueFee calculateTxFee tx resolvedInputs = do outval <- first (\e -> SNErrDefault $ "calculateTxFee: " <> textShow e) output when (null resolvedInputs) $ diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs index 0de7ec583..b12b71d12 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs @@ -13,6 +13,8 @@ module Cardano.DbSync.Era.Shelley.Genesis ( import Cardano.BM.Trace (Trace, logError, logInfo) 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.Api import Cardano.DbSync.Api.Types (InsertOptions (..), SyncEnv (..), SyncOptions (..)) import Cardano.DbSync.Cache (tryUpdateCacheTx) @@ -63,16 +65,15 @@ insertValidateGenesisDist :: Bool -> ExceptT SyncNodeError IO () insertValidateGenesisDist syncEnv networkName cfg shelleyInitiation = do - let hasConsumed = getHasConsumedOrPruneTxOut syncEnv - prunes = getPrunes syncEnv + let prunes = getPrunes syncEnv -- Setting this to True will log all 'Persistent' operations which is great -- for debugging, but otherwise *way* too chatty. when (not shelleyInitiation && (hasInitialFunds || hasStakes)) $ do liftIO $ logError tracer $ show SNErrIgnoreShelleyInitiation throwError SNErrIgnoreShelleyInitiation if False - then newExceptT $ DB.runDbIohkLogging (envBackend syncEnv) tracer (insertAction hasConsumed prunes) - else newExceptT $ DB.runDbIohkNoLogging (envBackend syncEnv) (insertAction hasConsumed prunes) + then newExceptT $ DB.runDbIohkLogging (envBackend syncEnv) tracer (insertAction prunes) + else newExceptT $ DB.runDbIohkNoLogging (envBackend syncEnv) (insertAction prunes) where tracer = getTrace syncEnv @@ -85,11 +86,11 @@ insertValidateGenesisDist syncEnv networkName cfg shelleyInitiation = do expectedTxCount :: Word64 expectedTxCount = fromIntegral $ genesisUTxOSize cfg + if hasStakes then 1 else 0 - insertAction :: (MonadBaseControl IO m, MonadIO m) => Bool -> Bool -> ReaderT SqlBackend m (Either SyncNodeError ()) - insertAction hasConsumed prunes = do + insertAction :: (MonadBaseControl IO m, MonadIO m) => Bool -> ReaderT SqlBackend m (Either SyncNodeError ()) + insertAction prunes = do ebid <- DB.queryBlockId (configGenesisHash cfg) case ebid of - Right bid -> validateGenesisDistribution prunes tracer networkName cfg bid expectedTxCount + Right bid -> validateGenesisDistribution syncEnv prunes networkName cfg bid expectedTxCount Left _ -> runExceptT $ do liftIO $ logInfo tracer "Inserting Shelley Genesis distribution" @@ -151,27 +152,30 @@ insertValidateGenesisDist syncEnv networkName cfg shelleyInitiation = do , DB.blockOpCertCounter = Nothing } disInOut <- liftIO $ getDisableInOutState syncEnv - lift $ mapM_ (insertTxOuts syncEnv tracer hasConsumed disInOut bid) $ genesisUtxOs cfg + unless disInOut $ do + lift $ mapM_ (insertTxOuts syncEnv tracer bid) $ genesisUtxOs cfg liftIO . logInfo tracer $ "Initial genesis distribution populated. Hash " <> renderByteArray (configGenesisHash cfg) when hasStakes $ insertStaking tracer useNoCache bid cfg - supply <- lift DB.queryTotalSupply + supply <- lift $ DB.queryTotalSupply (getTxOutTableType syncEnv) liftIO $ logInfo tracer ("Total genesis supply of Ada: " <> DB.renderAda supply) -- | Validate that the initial Genesis distribution in the DB matches the Genesis data. validateGenesisDistribution :: (MonadBaseControl IO m, MonadIO m) => + SyncEnv -> Bool -> - Trace IO Text -> Text -> ShelleyGenesis StandardCrypto -> DB.BlockId -> Word64 -> ReaderT SqlBackend m (Either SyncNodeError ()) -validateGenesisDistribution prunes tracer networkName cfg bid expectedTxCount = +validateGenesisDistribution syncEnv prunes networkName cfg bid expectedTxCount = runExceptT $ do + let tracer = getTrace syncEnv + txOutTableType = getTxOutTableType syncEnv liftIO $ logInfo tracer "Validating Genesis distribution" meta <- liftLookupFail "Shelley.validateGenesisDistribution" DB.queryMeta @@ -202,7 +206,7 @@ validateGenesisDistribution prunes tracer networkName cfg bid expectedTxCount = , " but got " , textShow txCount ] - totalSupply <- lift DB.queryShelleyGenesisSupply + totalSupply <- lift $ DB.queryShelleyGenesisSupply txOutTableType let expectedSupply = configGenesisSupply cfg when (expectedSupply /= totalSupply && not prunes) $ dbSyncNodeError $ @@ -222,12 +226,10 @@ insertTxOuts :: (MonadBaseControl IO m, MonadIO m) => SyncEnv -> Trace IO Text -> - Bool -> - Bool -> DB.BlockId -> (TxIn StandardCrypto, ShelleyTxOut StandardShelley) -> ReaderT SqlBackend m () -insertTxOuts syncEnv trce hasConsumed disInOut blkId (TxIn txInId _, txOut) = do +insertTxOuts syncEnv trce blkId (TxIn txInId _, txOut) = do -- Each address/value pair of the initial coin distribution comes from an artifical transaction -- with a hash generated by hashing the address. txId <- @@ -249,59 +251,61 @@ insertTxOuts syncEnv trce hasConsumed disInOut blkId (TxIn txInId _, txOut) = do tryUpdateCacheTx (envCache syncEnv) txInId txId _ <- insertStakeAddressRefIfMissing trce useNoCache (txOut ^. Core.addrTxOutL) - -- TODO: use the `ioAddressDetail` field to insert the extended address. - if ioAddressDetail . soptInsertOptions $ envOptions syncEnv - then do - addrDetailId <- insertAddressDetail - DB.insertTxOutPlex hasConsumed disInOut $ - DB.TxOut - { DB.txOutTxId = txId - , DB.txOutIndex = 0 - , DB.txOutAddress = Nothing - , DB.txOutAddressHasScript = hasScript - , DB.txOutPaymentCred = Generic.maybePaymentCred addr - , DB.txOutStakeAddressId = Nothing -- No stake addresses in Shelley Genesis - , DB.txOutValue = Generic.coinToDbLovelace (txOut ^. Core.valueTxOutL) - , DB.txOutDataHash = Nothing -- No output datum in Shelley Genesis - , DB.txOutInlineDatumId = Nothing - , DB.txOutReferenceScriptId = Nothing - , DB.txOutAddressDetailId = Just addrDetailId - } - else - DB.insertTxOutPlex hasConsumed disInOut $ - DB.TxOut - { DB.txOutAddress = Just $ Generic.renderAddress addr - , DB.txOutAddressDetailId = Nothing - , DB.txOutAddressHasScript = hasScript - , DB.txOutDataHash = Nothing -- No output datum in Shelley Genesis - , DB.txOutIndex = 0 - , DB.txOutInlineDatumId = Nothing - , DB.txOutPaymentCred = Generic.maybePaymentCred addr - , DB.txOutReferenceScriptId = Nothing - , DB.txOutStakeAddressId = Nothing -- No stake addresses in Shelley Genesis - , DB.txOutTxId = txId - , DB.txOutValue = Generic.coinToDbLovelace (txOut ^. Core.valueTxOutL) - } + case ioTxOutTableType . soptInsertOptions $ envOptions syncEnv of + DB.TxOutCore -> + void . DB.insertTxOut $ + DB.CTxOutW + C.TxOut + { C.txOutAddress = Generic.renderAddress addr + , C.txOutAddressHasScript = hasScript + , C.txOutDataHash = Nothing -- No output datum in Shelley Genesis + , C.txOutIndex = 0 + , C.txOutInlineDatumId = Nothing + , C.txOutPaymentCred = Generic.maybePaymentCred addr + , C.txOutReferenceScriptId = Nothing + , C.txOutStakeAddressId = Nothing -- No stake addresses in Shelley Genesis + , C.txOutTxId = txId + , C.txOutValue = Generic.coinToDbLovelace (txOut ^. Core.valueTxOutL) + , C.txOutConsumedByTxId = Nothing + } + DB.TxOutVariantAddress -> do + addrDetailId <- insertAddress + void . DB.insertTxOut $ DB.VTxOutW (makeVTxOut addrDetailId txId) Nothing where addr = txOut ^. Core.addrTxOutL hasScript = maybe False Generic.hasCredScript (Generic.getPaymentCred addr) + addrRaw = serialiseAddr addr + + makeVTxOut :: V.AddressId -> DB.TxId -> V.TxOut + makeVTxOut addrDetailId txId = + V.TxOut + { V.txOutAddressId = addrDetailId + , V.txOutConsumedByTxId = Nothing + , V.txOutDataHash = Nothing -- No output datum in Shelley Genesis + , V.txOutIndex = 0 + , V.txOutInlineDatumId = Nothing + , V.txOutReferenceScriptId = Nothing + , V.txOutTxId = txId + , V.txOutValue = Generic.coinToDbLovelace (txOut ^. Core.valueTxOutL) + } + + vAddress :: V.Address + vAddress = + V.Address + { V.addressAddress = Generic.renderAddress addr + , V.addressRaw = addrRaw + , V.addressHasScript = hasScript + , V.addressPaymentCred = Generic.maybePaymentCred addr + , V.addressStakeAddressId = Nothing -- No stake addresses in Shelley Genesis + } - insertAddressDetail :: + insertAddress :: (MonadBaseControl IO m, MonadIO m) => - ReaderT SqlBackend m DB.AddressDetailId - insertAddressDetail = do - let addrRaw = serialiseAddr addr - mAddrId <- DB.queryAddressDetailId addrRaw + ReaderT SqlBackend m V.AddressId + insertAddress = do + mAddrId <- DB.queryAddressId addrRaw case mAddrId of - Nothing -> - DB.insertAddressDetail - DB.AddressDetail - { DB.addressDetailAddress = Generic.renderAddress addr - , DB.addressDetailAddressRaw = addrRaw - , DB.addressDetailHasScript = hasScript - , DB.addressDetailPaymentCred = Generic.maybePaymentCred addr - , DB.addressDetailStakeAddressId = Nothing -- No stake addresses in Shelley Genesis - } + Nothing -> DB.insertAddress vAddress -- this address is already in the database, so we can just return the id to be linked to the txOut. Just addrId -> pure addrId diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Query.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Query.hs index cc8709a08..1317b9604 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Query.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Query.hs @@ -12,6 +12,8 @@ module Cardano.DbSync.Era.Shelley.Query ( ) where import Cardano.Db +import qualified Cardano.DbSync.Api as Db +import Cardano.DbSync.Api.Types (SyncEnv) import qualified Cardano.DbSync.Era.Shelley.Generic as Generic import Cardano.DbSync.Util import Cardano.Prelude hiding (Ptr, from, maybeToEither, on) @@ -24,18 +26,18 @@ import Database.Esqueleto.Experimental ( resolveStakeAddress :: MonadIO m => ByteString -> ReaderT SqlBackend m (Either LookupFail StakeAddressId) resolveStakeAddress addr = queryStakeAddress addr renderByteArray -resolveInputTxOutId :: MonadIO m => Generic.TxIn -> ReaderT SqlBackend m (Either LookupFail (TxId, TxOutId)) -resolveInputTxOutId txIn = - queryTxOutId (Generic.toTxHash txIn, fromIntegral (Generic.txInIndex txIn)) +resolveInputTxOutId :: MonadIO m => SyncEnv -> Generic.TxIn -> ReaderT SqlBackend m (Either LookupFail (TxId, TxOutIdW)) +resolveInputTxOutId syncEnv txIn = + queryTxOutId (Db.getTxOutTableType syncEnv) (Generic.toTxHash txIn, fromIntegral (Generic.txInIndex txIn)) -resolveInputValue :: MonadIO m => Generic.TxIn -> ReaderT SqlBackend m (Either LookupFail (TxId, DbLovelace)) -resolveInputValue txIn = - queryTxOutValue (Generic.toTxHash txIn, fromIntegral (Generic.txInIndex txIn)) +resolveInputValue :: MonadIO m => SyncEnv -> Generic.TxIn -> ReaderT SqlBackend m (Either LookupFail (TxId, DbLovelace)) +resolveInputValue syncEnv txIn = + queryTxOutValue (Db.getTxOutTableType syncEnv) (Generic.toTxHash txIn, fromIntegral (Generic.txInIndex txIn)) -resolveInputTxOutIdValue :: MonadIO m => Generic.TxIn -> ReaderT SqlBackend m (Either LookupFail (TxId, TxOutId, DbLovelace)) -resolveInputTxOutIdValue txIn = - queryTxOutIdValue (Generic.toTxHash txIn, fromIntegral (Generic.txInIndex txIn)) +resolveInputTxOutIdValue :: MonadIO m => SyncEnv -> Generic.TxIn -> ReaderT SqlBackend m (Either LookupFail (TxId, TxOutIdW, DbLovelace)) +resolveInputTxOutIdValue syncEnv txIn = + queryTxOutIdValue (Db.getTxOutTableType syncEnv) (Generic.toTxHash txIn, fromIntegral (Generic.txInIndex txIn)) -queryResolveInputCredentials :: MonadIO m => Generic.TxIn -> ReaderT SqlBackend m (Either LookupFail (Maybe ByteString, Bool)) -queryResolveInputCredentials txIn = do - queryTxOutCredentials (Generic.toTxHash txIn, fromIntegral (Generic.txInIndex txIn)) +queryResolveInputCredentials :: MonadIO m => SyncEnv -> Generic.TxIn -> ReaderT SqlBackend m (Either LookupFail (Maybe ByteString, Bool)) +queryResolveInputCredentials syncEnv txIn = do + queryTxOutCredentials (Db.getTxOutTableType syncEnv) (Generic.toTxHash txIn, fromIntegral (Generic.txInIndex txIn)) diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Grouped.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Grouped.hs index ba4dcbe65..4b3a7c7df 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Grouped.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Grouped.hs @@ -15,8 +15,10 @@ module Cardano.DbSync.Era.Universal.Insert.Grouped ( ) where import Cardano.BM.Trace (Trace, logWarning) -import Cardano.Db (DbLovelace (..), minIdsToText) +import Cardano.Db (DbLovelace (..), MinIds (..), minIdsCoreToText, minIdsVariantToText) 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.Api import Cardano.DbSync.Api.Types (SyncEnv (..)) import Cardano.DbSync.Cache (queryTxIdWithCache) @@ -61,13 +63,13 @@ data MissingMaTxOut = MissingMaTxOut -- reference outputs that are not inserted to the db yet. data ExtendedTxOut = ExtendedTxOut { etoTxHash :: !ByteString - , etoTxOut :: !DB.TxOut + , etoTxOut :: !DB.TxOutW , etoPaymentCred :: !(Maybe ByteString) } data ExtendedTxIn = ExtendedTxIn { etiTxIn :: !DB.TxIn - , etiTxOutId :: !(Either Generic.TxIn DB.TxOutId) + , etiTxOutId :: !(Either Generic.TxIn DB.TxOutIdW) } deriving (Show) @@ -88,11 +90,11 @@ insertBlockGroupedData :: (MonadBaseControl IO m, MonadIO m) => SyncEnv -> BlockGroupedData -> - ExceptT SyncNodeError (ReaderT SqlBackend m) DB.MinIds + ExceptT SyncNodeError (ReaderT SqlBackend m) DB.MinIdsWrapper insertBlockGroupedData syncEnv grouped = do disInOut <- liftIO $ getDisableInOutState syncEnv - txOutIds <- lift . DB.insertManyTxOutPlex (getHasConsumedOrPruneTxOut syncEnv) disInOut $ etoTxOut . fst <$> groupedTxOut grouped - let maTxOuts = concatMap mkmaTxOuts $ zip txOutIds (snd <$> groupedTxOut grouped) + txOutIds <- lift . DB.insertManyTxOut disInOut $ etoTxOut . fst <$> groupedTxOut grouped + let maTxOuts = concatMap (mkmaTxOuts txOutTableType) $ zip txOutIds (snd <$> groupedTxOut grouped) maTxOutIds <- lift $ DB.insertManyMaTxOut maTxOuts txInIds <- if getSkipTxIn syncEnv @@ -104,26 +106,55 @@ insertBlockGroupedData syncEnv grouped = do lift $ DB.updateListTxOutConsumedByTxId $ catMaybes updateTuples void . lift . DB.insertManyTxMetadata $ groupedTxMetadata grouped void . lift . DB.insertManyTxMint $ groupedTxMint grouped - pure $ DB.MinIds (listToMaybe txInIds) (listToMaybe txOutIds) (listToMaybe maTxOutIds) + pure $ makeMinId txInIds txOutIds maTxOutIds where tracer = getTrace syncEnv + txOutTableType = getTxOutTableType syncEnv -mkmaTxOuts :: (DB.TxOutId, [MissingMaTxOut]) -> [DB.MaTxOut] -mkmaTxOuts (txOutId, mmtos) = mkmaTxOut <$> mmtos + makeMinId :: [DB.TxInId] -> [DB.TxOutIdW] -> [DB.MaTxOutIdW] -> DB.MinIdsWrapper + makeMinId txInIds txOutIds maTxOutIds = + case txOutTableType of + DB.TxOutCore -> do + DB.CMinIdsWrapper $ + DB.MinIds + { minTxInId = listToMaybe txInIds + , minTxOutId = listToMaybe $ DB.convertTxOutIdCore txOutIds + , minMaTxOutId = listToMaybe $ DB.convertMaTxOutIdCore maTxOutIds + } + DB.TxOutVariantAddress -> + DB.VMinIdsWrapper $ + DB.MinIds + { minTxInId = listToMaybe txInIds + , minTxOutId = listToMaybe $ DB.convertTxOutIdVariant txOutIds + , minMaTxOutId = listToMaybe $ DB.convertMaTxOutIdVariant maTxOutIds + } + +mkmaTxOuts :: DB.TxOutTableType -> (DB.TxOutIdW, [MissingMaTxOut]) -> [DB.MaTxOutW] +mkmaTxOuts _txOutTableType (txOutId, mmtos) = mkmaTxOut <$> mmtos where - mkmaTxOut :: MissingMaTxOut -> DB.MaTxOut + mkmaTxOut :: MissingMaTxOut -> DB.MaTxOutW mkmaTxOut missingMaTx = - DB.MaTxOut - { DB.maTxOutIdent = mmtoIdent missingMaTx - , DB.maTxOutQuantity = mmtoQuantity missingMaTx - , DB.maTxOutTxOutId = txOutId - } + case txOutId of + DB.CTxOutIdW txOutId' -> + DB.CMaTxOutW $ + C.MaTxOut + { C.maTxOutIdent = mmtoIdent missingMaTx + , C.maTxOutQuantity = mmtoQuantity missingMaTx + , C.maTxOutTxOutId = txOutId' + } + DB.VTxOutIdW txOutId' -> + DB.VMaTxOutW + V.MaTxOut + { V.maTxOutIdent = mmtoIdent missingMaTx + , V.maTxOutQuantity = mmtoQuantity missingMaTx + , V.maTxOutTxOutId = txOutId' + } prepareUpdates :: (MonadBaseControl IO m, MonadIO m) => Trace IO Text -> ExtendedTxIn -> - m (Maybe (DB.TxOutId, DB.TxId)) + m (Maybe (DB.TxOutIdW, DB.TxId)) prepareUpdates trce eti = case etiTxOutId eti of Right txOutId -> pure $ Just (txOutId, DB.txInTxInId (etiTxIn eti)) Left _ -> do @@ -133,14 +164,22 @@ prepareUpdates trce eti = case etiTxOutId eti of insertReverseIndex :: (MonadBaseControl IO m, MonadIO m) => DB.BlockId -> - DB.MinIds -> + DB.MinIdsWrapper -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertReverseIndex blockId minIds = - void . lift . DB.insertReverseIndex $ - DB.ReverseIndex - { DB.reverseIndexBlockId = blockId - , DB.reverseIndexMinIds = minIdsToText minIds - } +insertReverseIndex blockId minIdsWrapper = + case minIdsWrapper of + DB.CMinIdsWrapper minIds -> + void . lift . DB.insertReverseIndex $ + DB.ReverseIndex + { DB.reverseIndexBlockId = blockId + , DB.reverseIndexMinIds = minIdsCoreToText minIds + } + DB.VMinIdsWrapper minIds -> + void . lift . DB.insertReverseIndex $ + DB.ReverseIndex + { DB.reverseIndexBlockId = blockId + , DB.reverseIndexMinIds = minIdsVariantToText minIds + } -- | If we can't resolve from the db, we fall back to the provided outputs -- This happens the input consumes an output introduced in the same block. @@ -151,38 +190,47 @@ resolveTxInputs :: Bool -> [ExtendedTxOut] -> Generic.TxIn -> - ExceptT SyncNodeError (ReaderT SqlBackend m) (Generic.TxIn, DB.TxId, Either Generic.TxIn DB.TxOutId, Maybe DbLovelace) + ExceptT SyncNodeError (ReaderT SqlBackend m) (Generic.TxIn, DB.TxId, Either Generic.TxIn DB.TxOutIdW, Maybe DbLovelace) resolveTxInputs syncEnv hasConsumed needsValue groupedOutputs txIn = liftLookupFail ("resolveTxInputs " <> textShow txIn <> " ") $ do qres <- case (hasConsumed, needsValue) of - (_, True) -> fmap convertFoundAll <$> resolveInputTxOutIdValue txIn - (False, _) -> fmap convertnotFound <$> queryTxIdWithCache (envCache syncEnv) (Generic.txInTxId txIn) - (True, False) -> fmap convertFoundTxOutId <$> resolveInputTxOutId txIn + (_, True) -> fmap convertFoundAll <$> resolveInputTxOutIdValue syncEnv txIn + (False, _) -> fmap convertnotFoundCache <$> queryTxIdWithCache (envCache syncEnv) (Generic.txInTxId txIn) + (True, False) -> fmap convertFoundTxOutId <$> resolveInputTxOutId syncEnv txIn case qres of Right ret -> pure $ Right ret Left err -> case (resolveInMemory txIn groupedOutputs, hasConsumed, needsValue) of (Nothing, _, _) -> pure $ Left err - (Just eutxo, True, True) -> pure $ Right $ convertFoundValue (DB.txOutTxId (etoTxOut eutxo), DB.txOutValue (etoTxOut eutxo)) - (Just eutxo, _, _) -> pure $ Right $ convertnotFound $ DB.txOutTxId (etoTxOut eutxo) + (Just eutxo, True, True) -> pure $ Right $ convertFoundValue (etoTxOut eutxo) + (Just eutxo, _, _) -> pure $ Right $ convertnotFound (etoTxOut eutxo) where - convertnotFound :: DB.TxId -> (Generic.TxIn, DB.TxId, Either Generic.TxIn DB.TxOutId, Maybe DbLovelace) - convertnotFound txId = (txIn, txId, Left txIn, Nothing) + convertnotFoundCache :: DB.TxId -> (Generic.TxIn, DB.TxId, Either Generic.TxIn DB.TxOutIdW, Maybe DbLovelace) + convertnotFoundCache txId = (txIn, txId, Left txIn, Nothing) + + convertnotFound :: DB.TxOutW -> (Generic.TxIn, DB.TxId, Either Generic.TxIn DB.TxOutIdW, Maybe DbLovelace) + convertnotFound txOutWrapper = case txOutWrapper of + DB.CTxOutW cTxOut -> (txIn, C.txOutTxId cTxOut, Left txIn, Nothing) + DB.VTxOutW vTxOut _ -> (txIn, V.txOutTxId vTxOut, Left txIn, Nothing) - convertFoundTxOutId :: (DB.TxId, DB.TxOutId) -> (Generic.TxIn, DB.TxId, Either Generic.TxIn DB.TxOutId, Maybe DbLovelace) + convertFoundTxOutId :: (DB.TxId, DB.TxOutIdW) -> (Generic.TxIn, DB.TxId, Either Generic.TxIn DB.TxOutIdW, Maybe DbLovelace) convertFoundTxOutId (txId, txOutId) = (txIn, txId, Right txOutId, Nothing) - convertFoundValue :: (DB.TxId, DbLovelace) -> (Generic.TxIn, DB.TxId, Either Generic.TxIn DB.TxOutId, Maybe DbLovelace) - convertFoundValue (txId, lovelace) = (txIn, txId, Left txIn, Just lovelace) + -- convertFoundValue :: (DB.TxId, DbLovelace) -> (Generic.TxIn, DB.TxId, Either Generic.TxIn DB.TxOutIdW, Maybe DbLovelace) + convertFoundValue :: DB.TxOutW -> (Generic.TxIn, DB.TxId, Either Generic.TxIn DB.TxOutIdW, Maybe DbLovelace) + convertFoundValue txOutWrapper = case txOutWrapper of + DB.CTxOutW cTxOut -> (txIn, C.txOutTxId cTxOut, Left txIn, Just $ C.txOutValue cTxOut) + DB.VTxOutW vTxOut _ -> (txIn, V.txOutTxId vTxOut, Left txIn, Just $ V.txOutValue vTxOut) + -- (txIn, txId, Left txIn, Just lovelace) - convertFoundAll :: (DB.TxId, DB.TxOutId, DbLovelace) -> (Generic.TxIn, DB.TxId, Either Generic.TxIn DB.TxOutId, Maybe DbLovelace) + convertFoundAll :: (DB.TxId, DB.TxOutIdW, DbLovelace) -> (Generic.TxIn, DB.TxId, Either Generic.TxIn DB.TxOutIdW, Maybe DbLovelace) convertFoundAll (txId, txOutId, lovelace) = (txIn, txId, Right txOutId, Just lovelace) resolveRemainingInputs :: MonadIO m => [ExtendedTxIn] -> - [(DB.TxOutId, ExtendedTxOut)] -> + [(DB.TxOutIdW, ExtendedTxOut)] -> ExceptT SyncNodeError (ReaderT SqlBackend m) [ExtendedTxIn] resolveRemainingInputs etis mp = mapM f etis @@ -196,18 +244,23 @@ resolveRemainingInputs etis mp = resolveScriptHash :: (MonadBaseControl IO m, MonadIO m) => + SyncEnv -> [ExtendedTxOut] -> Generic.TxIn -> ExceptT SyncNodeError (ReaderT SqlBackend m) (Maybe ByteString) -resolveScriptHash groupedOutputs txIn = +resolveScriptHash syncEnv groupedOutputs txIn = liftLookupFail "resolveScriptHash" $ do - qres <- fmap fst <$> queryResolveInputCredentials txIn + qres <- fmap fst <$> queryResolveInputCredentials syncEnv txIn case qres of Right ret -> pure $ Right ret Left err -> case resolveInMemory txIn groupedOutputs of Nothing -> pure $ Left err - Just eutxo -> pure $ Right $ DB.txOutPaymentCred $ etoTxOut eutxo + Just eutxo -> case etoTxOut eutxo of + DB.CTxOutW cTxOut -> pure $ Right $ C.txOutPaymentCred cTxOut + DB.VTxOutW _ vAddress -> case vAddress of + Nothing -> pure $ Left $ DB.DBTxOutVariant "resolveScriptHash: VTxOutW with Nothing address" + Just vAddr -> pure $ Right $ V.addressPaymentCred vAddr resolveInMemory :: Generic.TxIn -> [ExtendedTxOut] -> Maybe ExtendedTxOut resolveInMemory txIn = @@ -216,4 +269,9 @@ resolveInMemory txIn = matches :: Generic.TxIn -> ExtendedTxOut -> Bool matches txIn eutxo = Generic.toTxHash txIn == etoTxHash eutxo - && Generic.txInIndex txIn == DB.txOutIndex (etoTxOut eutxo) + && Generic.txInIndex txIn == getTxOutIndex (etoTxOut eutxo) + where + getTxOutIndex :: DB.TxOutW -> Word64 + getTxOutIndex txOutWrapper = case txOutWrapper of + DB.CTxOutW cTxOut -> C.txOutIndex cTxOut + DB.VTxOutW vTxOut _ -> V.txOutIndex vTxOut diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Other.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Other.hs index ed7002ec9..4099e8427 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Other.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Other.hs @@ -20,6 +20,8 @@ module Cardano.DbSync.Era.Universal.Insert.Other ( import Cardano.BM.Trace (Trace) import qualified Cardano.Db as DB +import Cardano.DbSync.Api (getTrace) +import Cardano.DbSync.Api.Types (SyncEnv) import Cardano.DbSync.Cache (insertDatumAndCache, queryDatum, queryMAWithCache, queryOrInsertRewardAccount, queryOrInsertStakeAddress) import Cardano.DbSync.Cache.Types (CacheAction (..), CacheStatus (..)) import qualified Cardano.DbSync.Era.Shelley.Generic as Generic @@ -42,13 +44,13 @@ import Ouroboros.Consensus.Cardano.Block (StandardCrypto) -------------------------------------------------------------------------------------------- insertRedeemer :: (MonadBaseControl IO m, MonadIO m) => - Trace IO Text -> + SyncEnv -> Bool -> [ExtendedTxOut] -> DB.TxId -> (Word64, Generic.TxRedeemer) -> ExceptT SyncNodeError (ReaderT SqlBackend m) (Word64, DB.RedeemerId) -insertRedeemer tracer disInOut groupedOutputs txId (rix, redeemer) = do +insertRedeemer syncEnv disInOut groupedOutputs txId (rix, redeemer) = do tdId <- insertRedeemerData tracer txId $ Generic.txRedeemerData redeemer scriptHash <- findScriptHash rid <- @@ -66,6 +68,7 @@ insertRedeemer tracer disInOut groupedOutputs txId (rix, redeemer) = do } pure (rix, rid) where + tracer = getTrace syncEnv findScriptHash :: (MonadBaseControl IO m, MonadIO m) => ExceptT SyncNodeError (ReaderT SqlBackend m) (Maybe ByteString) @@ -74,7 +77,7 @@ insertRedeemer tracer disInOut groupedOutputs txId (rix, redeemer) = do (True, _) -> pure Nothing (_, Nothing) -> pure Nothing (_, Just (Right bs)) -> pure $ Just bs - (_, Just (Left txIn)) -> resolveScriptHash groupedOutputs txIn + (_, Just (Left txIn)) -> resolveScriptHash syncEnv groupedOutputs txIn insertRedeemerData :: (MonadBaseControl IO m, MonadIO m) => diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Tx.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Tx.hs index bf98c8e53..5afdbbbfa 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Tx.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Tx.hs @@ -20,6 +20,8 @@ import Cardano.DbSync.Api import Cardano.DbSync.Api.Types (InsertOptions (..), SyncEnv (..)) import Cardano.DbSync.Cache.Types (CacheStatus (..)) +import qualified Cardano.Db.Schema.Core.TxOut as C +import qualified Cardano.Db.Schema.Variant.TxOut as V import Cardano.DbSync.Cache (queryTxIdWithCache, tryUpdateCacheTx) import qualified Cardano.DbSync.Era.Shelley.Generic as Generic import Cardano.DbSync.Era.Shelley.Generic.Metadata (TxMetadataValue (..), metadataValueToJsonNoSchema) @@ -152,7 +154,7 @@ insertTx syncEnv isMember blkId epochNo slotNo applyResult blockIndex tx grouped Map.fromList <$> whenFalseMempty (ioPlutusExtra iopts) - (mapM (insertRedeemer tracer disInOut (fst <$> groupedTxOut grouped) txId) (Generic.txRedeemer tx)) + (mapM (insertRedeemer syncEnv disInOut (fst <$> groupedTxOut grouped) txId) (Generic.txRedeemer tx)) when (ioPlutusExtra iopts) $ do mapM_ (insertDatum tracer cache txId) (Generic.txData tx) @@ -224,40 +226,42 @@ insertTxOut tracer cache iopts (txId, txHash) (Generic.TxOut index addr value ma whenMaybe mScript $ lift . insertScript tracer txId !txOut <- - if ioAddressDetail iopts - then do - addrId <- lift $ insertAddress addr mSaId hasScript - pure - DB.TxOut - { DB.txOutAddress = Nothing - , DB.txOutAddressDetailId = Just addrId - , DB.txOutAddressHasScript = hasScript - , DB.txOutDataHash = Generic.dataHashToBytes <$> Generic.getTxOutDatumHash dt - , DB.txOutIndex = index - , DB.txOutInlineDatumId = mDatumId - , DB.txOutPaymentCred = Nothing - , DB.txOutReferenceScriptId = mScriptId - , DB.txOutStakeAddressId = mSaId - , DB.txOutTxId = txId - , DB.txOutValue = Generic.coinToDbLovelace value - } - else - pure - DB.TxOut - { DB.txOutAddress = Just addrText - , DB.txOutAddressDetailId = Nothing - , DB.txOutAddressHasScript = hasScript - , DB.txOutDataHash = Generic.dataHashToBytes <$> Generic.getTxOutDatumHash dt - , DB.txOutIndex = index - , DB.txOutInlineDatumId = mDatumId - , DB.txOutPaymentCred = Generic.maybePaymentCred addr - , DB.txOutReferenceScriptId = mScriptId - , DB.txOutStakeAddressId = mSaId - , DB.txOutTxId = txId - , DB.txOutValue = Generic.coinToDbLovelace value - } + case ioTxOutTableType iopts of + DB.TxOutCore -> + pure $ + DB.CTxOutW $ + C.TxOut + { C.txOutAddress = addrText + , C.txOutAddressHasScript = hasScript + , C.txOutConsumedByTxId = Nothing + , C.txOutDataHash = Generic.dataHashToBytes <$> Generic.getTxOutDatumHash dt + , C.txOutIndex = index + , C.txOutInlineDatumId = mDatumId + , C.txOutPaymentCred = Generic.maybePaymentCred addr + , C.txOutReferenceScriptId = mScriptId + , C.txOutStakeAddressId = mSaId + , C.txOutTxId = txId + , C.txOutValue = Generic.coinToDbLovelace value + } + DB.TxOutVariantAddress -> do + let vAddress = + V.Address + { V.addressAddress = Generic.renderAddress addr + , V.addressRaw = Ledger.serialiseAddr addr + , V.addressHasScript = hasScript + , V.addressPaymentCred = Generic.maybePaymentCred addr + , V.addressStakeAddressId = mSaId + } + addrId <- lift $ insertAddress addr vAddress + pure $ + DB.VTxOutW + (mkTxOutVariant addrId mDatumId mScriptId) + Nothing -- TODO: Unsure about what we should return here for eutxo - let !eutxo = ExtendedTxOut txHash txOut (if ioAddressDetail iopts then Generic.maybePaymentCred addr else Nothing) + let !eutxo = + case ioTxOutTableType iopts of + DB.TxOutCore -> ExtendedTxOut txHash txOut Nothing + DB.TxOutVariantAddress -> ExtendedTxOut txHash txOut $ Generic.maybePaymentCred addr !maTxOuts <- whenFalseMempty (ioMultiAssets iopts) $ insertMaTxOuts tracer cache maMap pure (eutxo, maTxOuts) where @@ -267,24 +271,28 @@ insertTxOut tracer cache iopts (txId, txHash) (Generic.TxOut index addr value ma addrText :: Text addrText = Generic.renderAddress addr + mkTxOutVariant :: V.AddressId -> Maybe DB.DatumId -> Maybe DB.ScriptId -> V.TxOut + mkTxOutVariant addrId mDatumId mScriptId = + V.TxOut + { V.txOutAddressId = addrId + , V.txOutConsumedByTxId = Nothing + , V.txOutDataHash = Generic.dataHashToBytes <$> Generic.getTxOutDatumHash dt + , V.txOutIndex = index + , V.txOutInlineDatumId = mDatumId + , V.txOutReferenceScriptId = mScriptId + , V.txOutTxId = txId + , V.txOutValue = Generic.coinToDbLovelace value + } + insertAddress :: (MonadBaseControl IO m, MonadIO m) => Ledger.Addr StandardCrypto -> - Maybe DB.StakeAddressId -> - Bool -> -- hasScript - ReaderT SqlBackend m DB.AddressDetailId -insertAddress address mStakeAddr hasScript = do - mAddrId <- DB.queryAddressDetailId addrRaw + V.Address -> + ReaderT SqlBackend m V.AddressId +insertAddress address vAddress = do + mAddrId <- DB.queryAddressId addrRaw case mAddrId of - Nothing -> - DB.insertAddressDetail - DB.AddressDetail - { DB.addressDetailAddress = Generic.renderAddress address - , DB.addressDetailAddressRaw = addrRaw - , DB.addressDetailHasScript = hasScript - , DB.addressDetailPaymentCred = Generic.maybePaymentCred address - , DB.addressDetailStakeAddressId = mStakeAddr - } + Nothing -> DB.insertAddress vAddress Just addrId -> pure addrId where addrRaw = Ledger.serialiseAddr address @@ -483,7 +491,7 @@ insertReferenceTxIn syncEnv _tracer txInId txIn = do prepareTxIn :: DB.TxId -> Map Word64 DB.RedeemerId -> - (Generic.TxIn, DB.TxId, Either Generic.TxIn DB.TxOutId) -> + (Generic.TxIn, DB.TxId, Either Generic.TxIn DB.TxOutIdW) -> ExtendedTxIn prepareTxIn txInId redeemers (txIn, txOutId, mTxOutId) = ExtendedTxIn diff --git a/cardano-db-sync/src/Cardano/DbSync/Fix/ConsumedBy.hs b/cardano-db-sync/src/Cardano/DbSync/Fix/ConsumedBy.hs index 9a721fd3f..dc8f2f15d 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Fix/ConsumedBy.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Fix/ConsumedBy.hs @@ -16,25 +16,27 @@ import Cardano.Prelude hiding (length, (.)) import Database.Persist.SqlBackend.Internal import Ouroboros.Consensus.Byron.Ledger (ByronBlock (..)) import Ouroboros.Consensus.Cardano.Block (HardForkBlock (..)) +import Cardano.DbSync.Api.Types (SyncEnv) +import Cardano.DbSync.Api (getTxOutTableType, getTrace) -type FixEntry = (DB.TxOutId, DB.TxId) +type FixEntry = (DB.TxOutIdW, DB.TxId) -- | Nothing when the syncing must stop. -fixConsumedBy :: SqlBackend -> Trace IO Text -> CardanoBlock -> IO (Maybe [FixEntry]) -fixConsumedBy backend tracer cblk = case cblk of - BlockByron blk -> fixBlock backend tracer blk +fixConsumedBy :: SqlBackend -> SyncEnv -> CardanoBlock -> IO (Maybe [FixEntry]) +fixConsumedBy backend syncEnv cblk = case cblk of + BlockByron blk -> fixBlock backend syncEnv blk _ -> pure Nothing -fixBlock :: SqlBackend -> Trace IO Text -> ByronBlock -> IO (Maybe [FixEntry]) -fixBlock backend tracer bblk = case byronBlockRaw bblk of +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 (blockPayload blk)) backend + mEntries <- runReaderT (runExceptT $ mapM (fixTx syncEnv) (blockPayload blk)) backend case mEntries of Right newEntries -> pure $ Just $ concat newEntries Left err -> do liftIO $ - logWarning tracer $ + logWarning (getTrace syncEnv) $ mconcat [ "While fixing block " , textShow bblk @@ -43,12 +45,13 @@ fixBlock backend tracer bblk = case byronBlockRaw bblk of ] pure Nothing -fixTx :: MonadIO m => Byron.TxAux -> ExceptT SyncNodeError (ReaderT SqlBackend m) [FixEntry] -fixTx tx = do +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 (toList $ Byron.txInputs (Byron.taTx tx)) + 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) diff --git a/cardano-db-sync/src/Cardano/DbSync/Fix/PlutusDataBytes.hs b/cardano-db-sync/src/Cardano/DbSync/Fix/PlutusDataBytes.hs index 29e51494a..29e189867 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Fix/PlutusDataBytes.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Fix/PlutusDataBytes.hs @@ -12,7 +12,7 @@ module Cardano.DbSync.Fix.PlutusDataBytes where import Cardano.BM.Trace (Trace, logInfo, logWarning) -import qualified Cardano.Db.Old.V13_0 as DB_V_13_0 +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 diff --git a/cardano-db-sync/src/Cardano/DbSync/Fix/PlutusScripts.hs b/cardano-db-sync/src/Cardano/DbSync/Fix/PlutusScripts.hs index fb6c99684..31c0724fa 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Fix/PlutusScripts.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Fix/PlutusScripts.hs @@ -31,7 +31,7 @@ import qualified Cardano.Ledger.Core as Ledger -- import Cardano.Ledger.Plutus.Language import Cardano.Db (ScriptType (..), maybeToEither) -import qualified Cardano.Db.Old.V13_0 as DB_V_13_0 +import qualified Cardano.Db.Version.V13_0 as DB_V_13_0 import Cardano.BM.Trace (Trace, logInfo, logWarning) diff --git a/cardano-db-sync/src/Cardano/DbSync/Rollback.hs b/cardano-db-sync/src/Cardano/DbSync/Rollback.hs index 7f677f265..dcb09d60b 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Rollback.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Rollback.hs @@ -48,9 +48,9 @@ rollbackFromBlockNo syncEnv blkNo = do , textShow blkNo ] lift $ do - (mTxId, deletedBlockCount) <- DB.deleteBlocksBlockId trce blockId + (mTxId, deletedBlockCount) <- DB.deleteBlocksBlockId trce txOutTable blockId whenConsumeOrPruneTxOut syncEnv $ - DB.setNullTxOut trce mTxId + DB.querySetNullTxOut trce txOutTable mTxId DB.deleteEpochRows epochNo DB.deleteDrepDistr epochNo DB.deleteRewardRest epochNo @@ -71,6 +71,7 @@ rollbackFromBlockNo syncEnv blkNo = do where trce = getTrace syncEnv cache = envCache syncEnv + txOutTable = getTxOutTableType syncEnv prepareRollback :: SyncEnv -> CardanoPoint -> Tip CardanoBlock -> IO (Either SyncNodeError Bool) prepareRollback syncEnv point serverTip = @@ -117,7 +118,7 @@ prepareRollback syncEnv point serverTip = pure False -- For testing and debugging. -unsafeRollback :: Trace IO Text -> DB.PGConfig -> SlotNo -> IO (Either SyncNodeError ()) -unsafeRollback trce config slotNo = do +unsafeRollback :: Trace IO Text -> DB.TxOutTableType -> DB.PGConfig -> SlotNo -> IO (Either SyncNodeError ()) +unsafeRollback trce txOutTableType config slotNo = do logInfo trce $ "Forced rollback to slot " <> textShow (unSlotNo slotNo) - Right <$> DB.runDbNoLogging (DB.PGPassCached config) (void $ DB.deleteBlocksSlotNo trce slotNo) + Right <$> DB.runDbNoLogging (DB.PGPassCached config) (void $ DB.deleteBlocksSlotNo trce txOutTableType slotNo) diff --git a/cardano-db-sync/src/Cardano/DbSync/Sync.hs b/cardano-db-sync/src/Cardano/DbSync/Sync.hs index f35951101..656f81b4e 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Sync.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Sync.hs @@ -225,7 +225,7 @@ dbSyncProtocols syncEnv metricsSetters tc codecConfig version bversion = (cChainSyncCodec codecs) channel ( Client.chainSyncClientPeer $ - chainSyncClientFixConsumed backend tracer wrongEntriesSize + chainSyncClientFixConsumed backend syncEnv wrongEntriesSize ) logInfo tracer $ mconcat ["Fixed ", textShow fixedEntries, " consumed_by_tx_id wrong entries"] @@ -463,11 +463,12 @@ drainThePipe n0 client = go n0 } chainSyncClientFixConsumed :: - SqlBackend -> Trace IO Text -> Word64 -> ChainSyncClient CardanoBlock (Point CardanoBlock) (Tip CardanoBlock) IO Integer -chainSyncClientFixConsumed backend tracer wrongTotalSize = Client.ChainSyncClient $ do + 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 -> @@ -482,7 +483,7 @@ chainSyncClientFixConsumed backend tracer wrongTotalSize = Client.ChainSyncClien clientStNext (sizeFixedTotal, (sizeFixEntries, fixEntries)) = Client.ClientStNext { Client.recvMsgRollForward = \blk _tip -> Client.ChainSyncClient $ do - mNewEntries <- fixConsumedBy backend tracer blk + mNewEntries <- fixConsumedBy backend syncEnv blk case mNewEntries of Nothing -> do fixAccumulatedEntries fixEntries diff --git a/cardano-db-sync/test/Cardano/DbSync/Gen.hs b/cardano-db-sync/test/Cardano/DbSync/Gen.hs index 2c146b48b..b7d601b9c 100644 --- a/cardano-db-sync/test/Cardano/DbSync/Gen.hs +++ b/cardano-db-sync/test/Cardano/DbSync/Gen.hs @@ -116,8 +116,7 @@ syncInsertConfig = syncInsertOptions :: Gen SyncInsertOptions syncInsertOptions = - SyncInsertOptions - <$> (TxCBORConfig <$> Gen.bool) + (SyncInsertOptions . TxCBORConfig <$> Gen.bool) <*> txOutConfig <*> Gen.element [LedgerEnable, LedgerDisable, LedgerIgnore] <*> shelleyConfig @@ -130,16 +129,15 @@ syncInsertOptions = <*> (PoolStatsConfig <$> Gen.bool) <*> Gen.element [JsonTypeText, JsonTypeJsonb, JsonTypeDisable] <*> (RemoveJsonbFromSchemaConfig <$> Gen.bool) - <*> (AddressDetailConfig <$> Gen.bool) txOutConfig :: Gen TxOutConfig txOutConfig = Gen.choice - [ pure TxOutEnable + [ TxOutEnable . UseTxOutAddress <$> Gen.bool , pure TxOutDisable - , TxOutConsumed <$> (ForceTxIn <$> Gen.bool) - , TxOutPrune <$> (ForceTxIn <$> Gen.bool) - , TxOutBootstrap <$> (ForceTxIn <$> Gen.bool) + , (TxOutConsumed . ForceTxIn <$> Gen.bool) <*> (UseTxOutAddress <$> Gen.bool) + , (TxOutConsumedPrune . ForceTxIn <$> Gen.bool) <*> (UseTxOutAddress <$> Gen.bool) + , (TxOutConsumedBootstrap . ForceTxIn <$> Gen.bool) <*> (UseTxOutAddress <$> Gen.bool) ] shelleyConfig :: Gen ShelleyInsertConfig diff --git a/cardano-db-sync/test/Cardano/DbSyncTest.hs b/cardano-db-sync/test/Cardano/DbSyncTest.hs index d209d4d87..a9eb1b5d0 100644 --- a/cardano-db-sync/test/Cardano/DbSyncTest.hs +++ b/cardano-db-sync/test/Cardano/DbSyncTest.hs @@ -45,11 +45,11 @@ prop_extractSyncOptionsPruneConsumeMigration = property $ do let syncOptions = extractSyncOptions syncNodeParams abortOnPanic syncNodeConfig expectedPruneConsume = case sioTxOut (dncInsertOptions syncNodeConfig) of - TxOutEnable -> initPruneConsumeMigration False False False False + TxOutEnable _ -> initPruneConsumeMigration False False False False TxOutDisable -> initPruneConsumeMigration False False False False - TxOutBootstrap (ForceTxIn f) -> initPruneConsumeMigration False False True f - TxOutPrune (ForceTxIn f) -> initPruneConsumeMigration False True False f - TxOutConsumed (ForceTxIn f) -> initPruneConsumeMigration True False False f + TxOutConsumedBootstrap (ForceTxIn f) _ -> initPruneConsumeMigration False False True f + TxOutConsumedPrune (ForceTxIn f) _ -> initPruneConsumeMigration False True False f + TxOutConsumed (ForceTxIn f) _ -> initPruneConsumeMigration True False False f soptPruneConsumeMigration syncOptions === expectedPruneConsume @@ -104,12 +104,12 @@ coverTxOut :: MonadTest m => SyncNodeConfig -> m () coverTxOut syncNodeConfig = do let isTxOutEnabled' = isTxOutEnabled . sioTxOut . dncInsertOptions $ syncNodeConfig isTxOutDisabled' = isTxOutEnabled . sioTxOut . dncInsertOptions $ syncNodeConfig - isTxOutBootstrap' = isTxOutBootstrap . sioTxOut . dncInsertOptions $ syncNodeConfig - isTxOutPrune' = isTxOutPrune . sioTxOut . dncInsertOptions $ syncNodeConfig + isTxOutConsumedBootstrap' = isTxOutConsumedBootstrap . sioTxOut . dncInsertOptions $ syncNodeConfig + isTxOutConsumedPrune' = isTxOutConsumedPrune . sioTxOut . dncInsertOptions $ syncNodeConfig isTxOutConsumed' = isTxOutConsumed . sioTxOut . dncInsertOptions $ syncNodeConfig cover 5 "tx out enabled" isTxOutEnabled' cover 5 "tx out disabled" isTxOutDisabled' - cover 5 "tx out bootstrap" isTxOutBootstrap' - cover 5 "tx out prune" isTxOutPrune' + cover 5 "tx out bootstrap" isTxOutConsumedBootstrap' + cover 5 "tx out prune" isTxOutConsumedPrune' cover 5 "tx out consumed" isTxOutConsumed' diff --git a/cardano-db-tool/app/cardano-db-tool.hs b/cardano-db-tool/app/cardano-db-tool.hs index d4d6c1b60..285e15cfa 100644 --- a/cardano-db-tool/app/cardano-db-tool.hs +++ b/cardano-db-tool/app/cardano-db-tool.hs @@ -35,22 +35,22 @@ main = do data Command = CmdCreateMigration !MigrationDir - | CmdReport !Report - | CmdRollback !SlotNo + | CmdReport !Report !TxOutTableType + | CmdRollback !SlotNo !TxOutTableType | CmdRunMigrations !MigrationDir !Bool !Bool !(Maybe LogFileDir) - | CmdTxOutMigration - | CmdUtxoSetAtBlock !Word64 + | CmdTxOutMigration !TxOutTableType + | CmdUtxoSetAtBlock !Word64 !TxOutTableType | CmdPrepareSnapshot !PrepareSnapshotArgs - | CmdValidateDb - | CmdValidateAddressBalance !LedgerValidationParams + | CmdValidateDb !TxOutTableType + | CmdValidateAddressBalance !LedgerValidationParams !TxOutTableType | CmdVersion runCommand :: Command -> IO () runCommand cmd = case cmd of CmdCreateMigration mdir -> runCreateMigration mdir - CmdReport report -> runReport report - CmdRollback slotNo -> runRollback slotNo + CmdReport report txOutAddressType -> runReport report txOutAddressType + CmdRollback slotNo txOutAddressType -> runRollback slotNo txOutAddressType CmdRunMigrations mdir forceIndexes mockFix mldir -> do pgConfig <- runOrThrowIODb (readPGPass PGPassDefaultEnv) unofficial <- snd <$> runMigrations pgConfig False mdir mldir Initial @@ -63,12 +63,12 @@ runCommand cmd = when mockFix $ void $ runMigrations pgConfig False mdir mldir Fix - CmdTxOutMigration -> do - runWithConnectionNoLogging PGPassDefaultEnv $ migrateTxOut Nothing - CmdUtxoSetAtBlock blkid -> utxoSetAtSlot blkid + CmdTxOutMigration txOutTableType -> do + runWithConnectionNoLogging PGPassDefaultEnv $ migrateTxOut Nothing txOutTableType + CmdUtxoSetAtBlock blkid txOutAddressType -> utxoSetAtSlot txOutAddressType blkid CmdPrepareSnapshot pargs -> runPrepareSnapshot pargs - CmdValidateDb -> runDbValidation - CmdValidateAddressBalance params -> runLedgerValidation params + CmdValidateDb txOutAddressType -> runDbValidation txOutAddressType + CmdValidateAddressBalance params txOutAddressType -> runLedgerValidation params txOutAddressType CmdVersion -> runVersionCommand runCreateMigration :: MigrationDir -> IO () @@ -78,9 +78,9 @@ runCreateMigration mdir = do Nothing -> putStrLn "No migration needed." Just fp -> putStrLn $ "New migration '" ++ fp ++ "' created." -runRollback :: SlotNo -> IO () -runRollback slotNo = - print =<< runDbNoLoggingEnv (deleteBlocksSlotNoNoTrace slotNo) +runRollback :: SlotNo -> TxOutTableType -> IO () +runRollback slotNo txOutTableType = + print =<< runDbNoLoggingEnv (deleteBlocksSlotNoNoTrace txOutTableType slotNo) runVersionCommand :: IO () runVersionCommand = do @@ -114,7 +114,7 @@ pCommand = (Opt.progDesc "Create a database migration (only really used by devs).") , Opt.command "report" $ Opt.info - (CmdReport <$> pReport) + (CmdReport <$> pReport <*> pTxOutTableType) (Opt.progDesc "Run a report using data from the database.") , Opt.command "rollback" $ Opt.info @@ -133,7 +133,7 @@ pCommand = ) , Opt.command "tx_out-migration" $ Opt.info - (pure CmdTxOutMigration) + (CmdTxOutMigration <$> pTxOutTableType) ( Opt.progDesc $ mconcat [ "Runs the tx_out migration, which adds a new field" @@ -149,11 +149,11 @@ pCommand = (Opt.progDesc "Prepare to create a snapshot pair") , Opt.command "validate" $ Opt.info - (pure CmdValidateDb) + (CmdValidateDb <$> pTxOutTableType) (Opt.progDesc "Run validation checks against the database.") , Opt.command "validate-address-balance" $ Opt.info - (CmdValidateAddressBalance <$> pValidateLedgerParams) + (CmdValidateAddressBalance <$> pValidateLedgerParams <*> pTxOutTableType) (Opt.progDesc "Run validation checks against the database and the ledger Utxo set.") , Opt.command "version" $ Opt.info @@ -180,6 +180,7 @@ pCommand = ( Opt.long "slot" <> Opt.help "The slot number to roll back to." ) + <*> pTxOutTableType pUtxoSetAtBlock :: Parser Command pUtxoSetAtBlock = @@ -188,6 +189,7 @@ pCommand = ( Opt.long "slot-no" <> Opt.help "The SlotNo." ) + <*> pTxOutTableType pPrepareSnapshot :: Parser Command pPrepareSnapshot = @@ -243,6 +245,15 @@ pMockFix = ) ) +pTxOutTableType :: Parser TxOutTableType +pTxOutTableType = + Opt.flag + TxOutCore + TxOutVariantAddress + ( Opt.long "use-tx-out-address" + <> Opt.help "Use the TxOut address variant schema" + ) + pValidateLedgerParams :: Parser LedgerValidationParams pValidateLedgerParams = LedgerValidationParams diff --git a/cardano-db-tool/src/Cardano/DbTool/Report.hs b/cardano-db-tool/src/Cardano/DbTool/Report.hs index 77693e6dd..d65eb16e8 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Report.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Report.hs @@ -4,6 +4,7 @@ module Cardano.DbTool.Report ( runReport, ) where +import Cardano.Db (TxOutTableType) import Cardano.DbTool.Report.Balance (reportBalance) import Cardano.DbTool.Report.StakeReward ( reportEpochStakeRewards, @@ -22,12 +23,12 @@ data Report | ReportLatestRewards [Text] | ReportTransactions [Text] -runReport :: Report -> IO () -runReport report = do +runReport :: Report -> TxOutTableType -> IO () +runReport report txOutTableType = do assertFullySynced case report of ReportAllRewards sas -> mapM_ reportStakeRewardHistory sas - ReportBalance sas -> reportBalance sas + ReportBalance sas -> reportBalance txOutTableType sas ReportEpochRewards ep sas -> reportEpochStakeRewards ep sas ReportLatestRewards sas -> reportLatestStakeRewards sas - ReportTransactions sas -> reportTransactions sas + ReportTransactions sas -> reportTransactions txOutTableType sas diff --git a/cardano-db-tool/src/Cardano/DbTool/Report/Balance.hs b/cardano-db-tool/src/Cardano/DbTool/Report/Balance.hs index 307e9cefc..7d76ac838 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Report/Balance.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Report/Balance.hs @@ -7,6 +7,8 @@ module Cardano.DbTool.Report.Balance ( ) where import Cardano.Db +import qualified Cardano.Db.Schema.Core.TxOut as C +import qualified Cardano.Db.Schema.Variant.TxOut as V import Cardano.DbTool.Report.Display import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Reader (ReaderT) @@ -38,9 +40,9 @@ import Database.Esqueleto.Experimental ( {- HLINT ignore "Redundant ^." -} {- HLINT ignore "Fuse on/on" -} -reportBalance :: [Text] -> IO () -reportBalance saddr = do - xs <- catMaybes <$> runDbNoLoggingEnv (mapM queryStakeAddressBalance saddr) +reportBalance :: TxOutTableType -> [Text] -> IO () +reportBalance txOutTableType saddr = do + xs <- catMaybes <$> runDbNoLoggingEnv (mapM (queryStakeAddressBalance txOutTableType) saddr) renderBalances xs -- ------------------------------------------------------------------------------------------------- @@ -57,8 +59,8 @@ data Balance = Balance , balTotal :: !Ada } -queryStakeAddressBalance :: MonadIO m => Text -> ReaderT SqlBackend m (Maybe Balance) -queryStakeAddressBalance address = do +queryStakeAddressBalance :: MonadIO m => TxOutTableType -> Text -> ReaderT SqlBackend m (Maybe Balance) +queryStakeAddressBalance txOutTableType address = do mSaId <- queryStakeAddressId case mSaId of Nothing -> pure Nothing @@ -92,17 +94,26 @@ queryStakeAddressBalance address = do } queryInputs :: MonadIO m => StakeAddressId -> ReaderT SqlBackend m Ada - queryInputs saId = do - res <- select $ do - txo <- from $ table @TxOut - where_ (txo ^. TxOutStakeAddressId ==. just (val saId)) - pure (sum_ (txo ^. TxOutValue)) - pure $ unValueSumAda (listToMaybe res) + queryInputs saId = case txOutTableType of + TxOutCore -> do + res <- select $ do + txo <- from $ table @C.TxOut + where_ (txo ^. C.TxOutStakeAddressId ==. just (val saId)) + pure (sum_ (txo ^. C.TxOutValue)) + pure $ unValueSumAda (listToMaybe res) + TxOutVariantAddress -> do + res <- select $ do + (txo :& addr) <- + from + $ table @V.TxOut + `innerJoin` table @V.Address + `on` (\(txo :& addr) -> txo ^. V.TxOutAddressId ==. addr ^. V.AddressId) + where_ (addr ^. V.AddressStakeAddressId ==. just (val saId)) + pure (sum_ (txo ^. V.TxOutValue)) + pure $ unValueSumAda (listToMaybe res) queryRewardsSum :: MonadIO m => StakeAddressId -> ReaderT SqlBackend m Ada queryRewardsSum saId = do - -- This query does not run unless we are pretty close to the chain tip. - -- Therefore to get current rewards, we limit the cacluation to current epoch minus 2. currentEpoch <- queryLatestEpochNo res <- select $ do rwd <- from $ table @Reward @@ -120,18 +131,33 @@ queryStakeAddressBalance address = do pure $ unValueSumAda (listToMaybe res) queryOutputs :: MonadIO m => StakeAddressId -> ReaderT SqlBackend m (Ada, Ada, Ada) - queryOutputs saId = do - res <- select $ do - (txOut :& tx :& _txIn) <- - from - $ table @TxOut - `innerJoin` table @Tx - `on` (\(txOut :& tx) -> txOut ^. TxOutTxId ==. tx ^. TxId) - `innerJoin` table @TxIn - `on` (\(txOut :& tx :& txIn) -> txIn ^. TxInTxOutId ==. tx ^. TxId &&. txIn ^. TxInTxOutIndex ==. txOut ^. TxOutIndex) - where_ (txOut ^. TxOutStakeAddressId ==. just (val saId)) - pure (sum_ (txOut ^. TxOutValue), sum_ (tx ^. TxFee), sum_ (tx ^. TxDeposit)) - pure $ maybe (0, 0, 0) convert (listToMaybe res) + queryOutputs saId = case txOutTableType of + TxOutCore -> do + res <- select $ do + (txOut :& tx :& _txIn) <- + from + $ table @C.TxOut + `innerJoin` table @Tx + `on` (\(txOut :& tx) -> txOut ^. C.TxOutTxId ==. tx ^. TxId) + `innerJoin` table @TxIn + `on` (\(txOut :& tx :& txIn) -> txIn ^. TxInTxOutId ==. tx ^. TxId &&. txIn ^. TxInTxOutIndex ==. txOut ^. C.TxOutIndex) + where_ (txOut ^. C.TxOutStakeAddressId ==. just (val saId)) + pure (sum_ (txOut ^. C.TxOutValue), sum_ (tx ^. TxFee), sum_ (tx ^. TxDeposit)) + pure $ maybe (0, 0, 0) convert (listToMaybe res) + TxOutVariantAddress -> do + res <- select $ do + (txOut :& addr :& tx :& _txIn) <- + from + $ table @V.TxOut + `innerJoin` table @V.Address + `on` (\(txOut :& addr) -> txOut ^. V.TxOutAddressId ==. addr ^. V.AddressId) + `innerJoin` table @Tx + `on` (\(txOut :& _addr :& tx) -> txOut ^. V.TxOutTxId ==. tx ^. TxId) + `innerJoin` table @TxIn + `on` (\(txOut :& _addr :& tx :& txIn) -> txIn ^. TxInTxOutId ==. tx ^. TxId &&. txIn ^. TxInTxOutIndex ==. txOut ^. V.TxOutIndex) + where_ (addr ^. V.AddressStakeAddressId ==. just (val saId)) + pure (sum_ (txOut ^. V.TxOutValue), sum_ (tx ^. TxFee), sum_ (tx ^. TxDeposit)) + pure $ maybe (0, 0, 0) convert (listToMaybe res) convert :: (Value (Maybe Micro), Value (Maybe Micro), Value (Maybe Micro)) -> (Ada, Ada, Ada) convert (Value mval, Value mfee, Value mdep) = diff --git a/cardano-db-tool/src/Cardano/DbTool/Report/Transactions.hs b/cardano-db-tool/src/Cardano/DbTool/Report/Transactions.hs index 3bd8a404a..1deb1bdbe 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Report/Transactions.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Report/Transactions.hs @@ -1,12 +1,24 @@ -{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Cardano.DbTool.Report.Transactions ( reportTransactions, ) where import Cardano.Db +import qualified Cardano.Db.Schema.Core.TxOut as C +import qualified Cardano.Db.Schema.Variant.TxOut as V import Cardano.DbTool.Report.Display import Cardano.Prelude (textShow) import Control.Monad (forM_) @@ -41,11 +53,11 @@ import Database.Esqueleto.Experimental ( {- HLINT ignore "Redundant ^." -} {- HLINT ignore "Fuse on/on" -} -reportTransactions :: [Text] -> IO () -reportTransactions addrs = +reportTransactions :: TxOutTableType -> [Text] -> IO () +reportTransactions txOutTableType addrs = forM_ addrs $ \saddr -> do Text.putStrLn $ "\nTransactions for: " <> saddr <> "\n" - xs <- runDbNoLoggingEnv (queryStakeAddressTransactions saddr) + xs <- runDbNoLoggingEnv (queryStakeAddressTransactions txOutTableType saddr) renderTransactions $ coaleseTxs xs -- ------------------------------------------------------------------------------------------------- @@ -73,8 +85,8 @@ instance Ord Transaction where GT -> GT EQ -> compare (trDirection tra) (trDirection trb) -queryStakeAddressTransactions :: MonadIO m => Text -> ReaderT SqlBackend m [Transaction] -queryStakeAddressTransactions address = do +queryStakeAddressTransactions :: MonadIO m => TxOutTableType -> Text -> ReaderT SqlBackend m [Transaction] +queryStakeAddressTransactions txOutTableType address = do mSaId <- queryStakeAddressId case mSaId of Nothing -> pure [] @@ -90,24 +102,42 @@ queryStakeAddressTransactions address = do queryTransactions :: MonadIO m => StakeAddressId -> ReaderT SqlBackend m [Transaction] queryTransactions saId = do - inputs <- queryInputs saId - outputs <- queryOutputs saId + inputs <- queryInputs txOutTableType saId + outputs <- queryOutputs txOutTableType saId pure $ List.sort (inputs ++ outputs) -queryInputs :: MonadIO m => StakeAddressId -> ReaderT SqlBackend m [Transaction] -queryInputs saId = do +queryInputs :: + MonadIO m => + TxOutTableType -> + StakeAddressId -> + ReaderT SqlBackend m [Transaction] +queryInputs txOutTableType saId = do -- Standard UTxO inputs. - res1 <- select $ do - (tx :& txOut :& blk) <- - from - $ table @Tx - `innerJoin` table @TxOut - `on` (\(tx :& txOut) -> txOut ^. TxOutTxId ==. tx ^. TxId) - `innerJoin` table @Block - `on` (\(tx :& _txOut :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) - where_ (txOut ^. TxOutStakeAddressId ==. just (val saId)) - pure (tx ^. TxHash, blk ^. BlockTime, txOut ^. TxOutValue) - + res1 <- case txOutTableType of + -- get the StakeAddressId from the Core TxOut table + TxOutCore -> select $ do + (tx :& txOut :& blk) <- + from + $ table @Tx + `innerJoin` table @C.TxOut + `on` (\(tx :& txOut) -> txOut ^. C.TxOutTxId ==. tx ^. TxId) + `innerJoin` table @Block + `on` (\(tx :& _txOut :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) + where_ (txOut ^. C.TxOutStakeAddressId ==. just (val saId)) + pure (tx ^. TxHash, blk ^. BlockTime, txOut ^. C.TxOutValue) + -- get the StakeAddressId from the Variant TxOut table + TxOutVariantAddress -> select $ do + (tx :& txOut :& addr :& blk) <- + from + $ table @Tx + `innerJoin` table @V.TxOut + `on` (\(tx :& txOut) -> txOut ^. V.TxOutTxId ==. tx ^. TxId) + `innerJoin` table @V.Address + `on` (\(_tx :& txOut :& addr) -> txOut ^. V.TxOutAddressId ==. addr ^. V.AddressId) + `innerJoin` table @Block + `on` (\(tx :& _txOut :& _addr :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) + where_ (addr ^. V.AddressStakeAddressId ==. just (val saId)) + pure (tx ^. TxHash, blk ^. BlockTime, txOut ^. V.TxOutValue) -- Reward withdrawals. res2 <- select $ do (tx :& blk :& wdrl) <- @@ -147,23 +177,41 @@ sumAmounts = Incoming -> acc + trAmount tr Outgoing -> acc - trAmount tr -queryOutputs :: MonadIO m => StakeAddressId -> ReaderT SqlBackend m [Transaction] -queryOutputs saId = do - res <- select $ do - (txOut :& _txInTx :& _txIn :& txOutTx :& blk) <- - from - $ table @TxOut - `innerJoin` table @Tx - `on` (\(txOut :& txInTx) -> txOut ^. TxOutTxId ==. txInTx ^. TxId) - `innerJoin` table @TxIn - `on` (\(txOut :& txInTx :& txIn) -> txIn ^. TxInTxOutId ==. txInTx ^. TxId &&. txIn ^. TxInTxOutIndex ==. txOut ^. TxOutIndex) - `innerJoin` table @Tx - `on` (\(_txOut :& _txInTx :& txIn :& txOutTx) -> txOutTx ^. TxId ==. txIn ^. TxInTxInId) - `innerJoin` table @Block - `on` (\(_txOut :& _txInTx :& _txIn :& txOutTx :& blk) -> txOutTx ^. TxBlockId ==. blk ^. BlockId) +queryOutputs :: MonadIO m => TxOutTableType -> StakeAddressId -> ReaderT SqlBackend m [Transaction] +queryOutputs txOutTableType saId = do + res <- case txOutTableType of + TxOutCore -> select $ do + (txOut :& _txInTx :& _txIn :& txOutTx :& blk) <- + from + $ table @C.TxOut + `innerJoin` table @Tx + `on` (\(txOut :& txInTx) -> txOut ^. C.TxOutTxId ==. txInTx ^. TxId) + `innerJoin` table @TxIn + `on` (\(txOut :& txInTx :& txIn) -> txIn ^. TxInTxOutId ==. txInTx ^. TxId &&. txIn ^. TxInTxOutIndex ==. txOut ^. C.TxOutIndex) + `innerJoin` table @Tx + `on` (\(_txOut :& _txInTx :& txIn :& txOutTx) -> txOutTx ^. TxId ==. txIn ^. TxInTxInId) + `innerJoin` table @Block + `on` (\(_txOut :& _txInTx :& _txIn :& txOutTx :& blk) -> txOutTx ^. TxBlockId ==. blk ^. BlockId) + + where_ (txOut ^. C.TxOutStakeAddressId ==. just (val saId)) + pure (txOutTx ^. TxHash, blk ^. BlockTime, txOut ^. C.TxOutValue) + TxOutVariantAddress -> select $ do + (txOut :& addr :& _txInTx :& _txIn :& txOutTx :& blk) <- + from + $ table @V.TxOut + `innerJoin` table @V.Address + `on` (\(txOut :& addr) -> txOut ^. V.TxOutAddressId ==. addr ^. V.AddressId) + `innerJoin` table @Tx + `on` (\(txOut :& _addr :& txInTx) -> txOut ^. V.TxOutTxId ==. txInTx ^. TxId) + `innerJoin` table @TxIn + `on` (\(txOut :& _addr :& txInTx :& txIn) -> txIn ^. TxInTxOutId ==. txInTx ^. TxId &&. txIn ^. TxInTxOutIndex ==. txOut ^. V.TxOutIndex) + `innerJoin` table @Tx + `on` (\(_txOut :& _addr :& _txInTx :& txIn :& txOutTx) -> txOutTx ^. TxId ==. txIn ^. TxInTxInId) + `innerJoin` table @Block + `on` (\(_txOut :& _addr :& _txInTx :& _txIn :& txOutTx :& blk) -> txOutTx ^. TxBlockId ==. blk ^. BlockId) - where_ (txOut ^. TxOutStakeAddressId ==. just (val saId)) - pure (txOutTx ^. TxHash, blk ^. BlockTime, txOut ^. TxOutValue) + where_ (addr ^. V.AddressStakeAddressId ==. just (val saId)) + pure (txOutTx ^. TxHash, blk ^. BlockTime, txOut ^. V.TxOutValue) pure . groupOutputs $ map (convertTx Outgoing) res where diff --git a/cardano-db-tool/src/Cardano/DbTool/UtxoSet.hs b/cardano-db-tool/src/Cardano/DbTool/UtxoSet.hs index 4bd57cc09..0f1db6346 100644 --- a/cardano-db-tool/src/Cardano/DbTool/UtxoSet.hs +++ b/cardano-db-tool/src/Cardano/DbTool/UtxoSet.hs @@ -7,8 +7,9 @@ module Cardano.DbTool.UtxoSet ( import Cardano.Chain.Common (decodeAddressBase58, isRedeemAddress) import Cardano.Db +import qualified Cardano.Db.Schema.Core.TxOut as C +import qualified Cardano.Db.Schema.Variant.TxOut as V import Cardano.Prelude (textShow) -import Data.ByteString.Char8 (ByteString) import qualified Data.List as List import qualified Data.Map.Strict as Map import Data.Text (Text) @@ -19,9 +20,9 @@ import Data.Word (Word64) import System.Exit (exitSuccess) import System.IO (IOMode (..), withFile) -utxoSetAtSlot :: Word64 -> IO () -utxoSetAtSlot slotNo = do - (genesisSupply, utxoSet, fees, eUtcTime) <- queryAtSlot slotNo +utxoSetAtSlot :: TxOutTableType -> Word64 -> IO () +utxoSetAtSlot txOutTableType slotNo = do + (genesisSupply, utxoSet, fees, eUtcTime) <- queryAtSlot txOutTableType slotNo let supply = utxoSetSum utxoSet let aggregated = aggregateUtxos utxoSet @@ -58,14 +59,12 @@ utxoSetAtSlot slotNo = do writeUtxos ("utxo-reject-" ++ show slotNo ++ ".json") reject putStrLn "" --- ----------------------------------------------------------------------------- - -aggregateUtxos :: [(TxOut, Text, a)] -> [(Text, Word64)] +aggregateUtxos :: [UtxoQueryResult] -> [(Text, Word64)] aggregateUtxos xs = List.sortOn (Text.length . fst) . Map.toList . Map.fromListWith (+) - $ map (\(x, addr, _) -> (addr, unDbLovelace (txOutValue x))) xs + $ map (\result -> (utxoAddress result, getTxOutValue $ utxoTxOutW result)) xs isRedeemTextAddress :: Text -> Bool isRedeemTextAddress addr = @@ -83,13 +82,13 @@ partitionUtxos = accept (addr, _) = Text.length addr <= 180 && not (isRedeemTextAddress addr) -queryAtSlot :: Word64 -> IO (Ada, [(TxOut, Text, ByteString)], Ada, Either LookupFail UTCTime) -queryAtSlot slotNo = +queryAtSlot :: TxOutTableType -> Word64 -> IO (Ada, [UtxoQueryResult], Ada, Either LookupFail UTCTime) +queryAtSlot txOutTableType slotNo = -- Run the following queries in a single transaction. runDbNoLoggingEnv $ do (,,,) - <$> queryGenesisSupply - <*> queryUtxoAtSlotNo slotNo + <$> queryGenesisSupply txOutTableType + <*> queryUtxoAtSlotNo txOutTableType slotNo <*> queryFeesUpToSlotNo slotNo <*> querySlotUtcTime slotNo @@ -113,9 +112,14 @@ showUtxo (addr, value) = , " }" ] -utxoSetSum :: [(TxOut, b, a)] -> Ada +utxoSetSum :: [UtxoQueryResult] -> Ada utxoSetSum xs = - word64ToAda . sum $ map (\(txOut, _, _) -> unDbLovelace $ txOutValue txOut) xs + word64ToAda . sum $ map (getTxOutValue . utxoTxOutW) xs + +getTxOutValue :: TxOutW -> Word64 +getTxOutValue wrapper = case wrapper of + CTxOutW txOut -> unDbLovelace $ C.txOutValue txOut + VTxOutW txOut _ -> unDbLovelace $ V.txOutValue txOut writeUtxos :: FilePath -> [(Text, Word64)] -> IO () writeUtxos fname xs = do diff --git a/cardano-db-tool/src/Cardano/DbTool/Validate/BlockTxs.hs b/cardano-db-tool/src/Cardano/DbTool/Validate/BlockTxs.hs index 0956d197c..104909274 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Validate/BlockTxs.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Validate/BlockTxs.hs @@ -79,7 +79,7 @@ validateBlockCount (blockNo, txCountExpected) = do then Right () else Left $ ValidateError blockNo txCountActual txCountExpected --- This queries by BlockNo, the one in Cardano.Db.Query queries by BlockId. +-- This queries by BlockNo, the one in Cardano.Db.Operations.Core.Query queries by BlockId. queryBlockTxCount :: MonadIO m => Word64 -> ReaderT SqlBackend m Word64 queryBlockTxCount blockNo = do res <- select $ do diff --git a/cardano-db-tool/src/Cardano/DbTool/Validate/Ledger.hs b/cardano-db-tool/src/Cardano/DbTool/Validate/Ledger.hs index a9a6e23cb..0572e5fdb 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Validate/Ledger.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Validate/Ledger.hs @@ -29,17 +29,17 @@ data LedgerValidationParams = LedgerValidationParams , vpAddressUtxo :: !Text } -validateLedger :: LedgerValidationParams -> IO () -validateLedger params = +validateLedger :: LedgerValidationParams -> DB.TxOutTableType -> IO () +validateLedger params txOutTableType = withIOManager $ \_ -> do enc <- readSyncNodeConfig (vpConfigFile params) genCfg <- runOrThrowIO $ runExceptT $ readCardanoGenesisConfig enc ledgerFiles <- listLedgerStateFilesOrdered (vpLedgerStateDir params) slotNo <- SlotNo <$> DB.runDbNoLoggingEnv DB.queryLatestSlotNo - validate params genCfg slotNo ledgerFiles + validate params txOutTableType genCfg slotNo ledgerFiles -validate :: LedgerValidationParams -> GenesisConfig -> SlotNo -> [LedgerStateFile] -> IO () -validate params genCfg slotNo ledgerFiles = +validate :: LedgerValidationParams -> DB.TxOutTableType -> GenesisConfig -> SlotNo -> [LedgerStateFile] -> IO () +validate params txOutTableType genCfg slotNo ledgerFiles = go ledgerFiles True where go :: [LedgerStateFile] -> Bool -> IO () @@ -50,14 +50,14 @@ validate params genCfg slotNo ledgerFiles = then do -- TODO fix GenesisPoint. This is only used for logging Right state <- loadLedgerStateFromFile nullTracer (mkTopLevelConfig genCfg) False GenesisPoint ledgerFile - validateBalance ledgerSlot (vpAddressUtxo params) state + validateBalance txOutTableType ledgerSlot (vpAddressUtxo params) state else do when logFailure . putStrLn $ redText "Ledger is newer than DB. Trying an older ledger." go rest False -validateBalance :: SlotNo -> Text -> CardanoLedgerState -> IO () -validateBalance slotNo addr st = do - balanceDB <- DB.runDbNoLoggingEnv $ DB.queryAddressBalanceAtSlot addr (unSlotNo slotNo) +validateBalance :: DB.TxOutTableType -> SlotNo -> Text -> CardanoLedgerState -> IO () +validateBalance txOutTableType slotNo addr st = do + balanceDB <- DB.runDbNoLoggingEnv $ DB.queryAddressBalanceAtSlot txOutTableType addr (unSlotNo slotNo) let eiBalanceLedger = DB.word64ToAda <$> ledgerAddrBalance addr (ledgerState $ clsState st) case eiBalanceLedger of Left str -> putStrLn $ redText $ show str diff --git a/cardano-db-tool/src/Cardano/DbTool/Validate/TotalSupply.hs b/cardano-db-tool/src/Cardano/DbTool/Validate/TotalSupply.hs index 979f24cbc..b466587b6 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Validate/TotalSupply.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Validate/TotalSupply.hs @@ -10,27 +10,6 @@ import Cardano.DbTool.Validate.Util import Data.Word (Word64) import System.Random (randomRIO) --- | Validate that the total supply is decreasing. --- This is only true for the Byron error where transaction fees are burnt. -validateTotalSupplyDecreasing :: IO () -validateTotalSupplyDecreasing = do - test <- genTestParameters - - putStrF $ - "Total supply + fees + deposit - withdrawals at block " - ++ show (testBlockNo test) - ++ " is same as genesis supply: " - - accounting <- queryInitialSupply (testBlockNo test) - - let total = accSupply accounting + accFees accounting + accDeposit accounting - accWithdrawals accounting - - if genesisSupply test == total - then putStrLn $ greenText "ok" - else error $ redText (show (genesisSupply test) ++ " /= " ++ show total) - --- ----------------------------------------------------------------------------- - data Accounting = Accounting { accFees :: Ada , accDeposit :: Ada @@ -43,22 +22,41 @@ data TestParams = TestParams , genesisSupply :: Ada } -genTestParameters :: IO TestParams -genTestParameters = do +genTestParameters :: TxOutTableType -> IO TestParams +genTestParameters txOutTableType = do mlatest <- runDbNoLoggingEnv queryLatestBlockNo case mlatest of Nothing -> error "Cardano.DbTool.Validation: Empty database" Just latest -> TestParams <$> randomRIO (1, latest - 1) - <*> runDbNoLoggingEnv queryGenesisSupply + <*> runDbNoLoggingEnv (queryGenesisSupply txOutTableType) -queryInitialSupply :: Word64 -> IO Accounting -queryInitialSupply blkNo = +queryInitialSupply :: TxOutTableType -> Word64 -> IO Accounting +queryInitialSupply txOutTableType blkNo = -- Run all queries in a single transaction. runDbNoLoggingEnv $ Accounting <$> queryFeesUpToBlockNo blkNo <*> queryDepositUpToBlockNo blkNo <*> queryWithdrawalsUpToBlockNo blkNo - <*> fmap2 utxoSetSum queryUtxoAtBlockNo blkNo + <*> fmap2 utxoSetSum (queryUtxoAtBlockNo txOutTableType) blkNo + +-- | Validate that the total supply is decreasing. +-- This is only true for the Byron error where transaction fees are burnt. +validateTotalSupplyDecreasing :: TxOutTableType -> IO () +validateTotalSupplyDecreasing txOutTableType = do + test <- genTestParameters txOutTableType + + putStrF $ + "Total supply + fees + deposit - withdrawals at block " + ++ show (testBlockNo test) + ++ " is same as genesis supply: " + + accounting <- queryInitialSupply txOutTableType (testBlockNo test) + + let total = accSupply accounting + accFees accounting + accDeposit accounting - accWithdrawals accounting + + if genesisSupply test == total + then putStrLn $ greenText "ok" + else error $ redText (show (genesisSupply test) ++ " /= " ++ show total) diff --git a/cardano-db-tool/src/Cardano/DbTool/Validate/TxAccounting.hs b/cardano-db-tool/src/Cardano/DbTool/Validate/TxAccounting.hs index ab924c752..d229f045e 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Validate/TxAccounting.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Validate/TxAccounting.hs @@ -1,4 +1,7 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -8,6 +11,8 @@ module Cardano.DbTool.Validate.TxAccounting ( ) where import Cardano.Db +import qualified Cardano.Db.Schema.Core.TxOut as C +import qualified Cardano.Db.Schema.Variant.TxOut as V import Cardano.DbTool.Validate.Util import Control.Monad (replicateM, when) import Control.Monad.IO.Class (MonadIO, liftIO) @@ -40,8 +45,8 @@ import qualified System.Random as Random {- HLINT ignore "Fuse on/on" -} -validateTxAccounting :: IO () -validateTxAccounting = do +validateTxAccounting :: TxOutTableType -> IO () +validateTxAccounting getTxOutTableType = do txIdRange <- runDbNoLoggingEnv queryTestTxIds putStrF $ "For " @@ -50,7 +55,7 @@ validateTxAccounting = do ++ show (snd txIdRange) ++ " accounting is: " ids <- randomTxIds testCount txIdRange - res <- runExceptT $ traverse validateAccounting ids + res <- runExceptT $ traverse (validateAccounting getTxOutTableType) ids case res of Left err -> error $ redText (reportError err) Right _ -> putStrLn $ greenText "ok" @@ -65,8 +70,8 @@ data ValidateError = ValidateError , veFee :: !Ada , veDeposit :: !Int64 , veWithdrawal :: !Ada - , inputs :: ![TxOut] - , outputs :: ![TxOut] + , inputs :: ![TxOutW] + , outputs :: ![TxOutW] } randomTxIds :: Int -> (Word64, Word64) -> IO [Word64] @@ -95,40 +100,49 @@ reportError ve = , "]" ] where - showTxOuts :: [TxOut] -> String + showTxOuts :: [TxOutW] -> String showTxOuts = List.intercalate "," . map showTxOut - showTxOut :: TxOut -> String - showTxOut txo = - mconcat - [ "TxId " - , show (unTxId $ txOutTxId txo) - , " Value " - , show (word64ToAda . unDbLovelace $ txOutValue txo) - ] +showTxOut :: TxOutW -> String +showTxOut txo = + mconcat + [ "TxId " + , show (unTxId txId) + , " Value " + , show (word64ToAda . unDbLovelace $ value) + ] + where + (txId, value) = case txo of + CTxOutW cTxOut -> (C.txOutTxId cTxOut, C.txOutValue cTxOut) + VTxOutW vTxOut _ -> (V.txOutTxId vTxOut, V.txOutValue vTxOut) -- For a given TxId, validate the input/output accounting. -validateAccounting :: Word64 -> ExceptT ValidateError IO () -validateAccounting txId = do +validateAccounting :: TxOutTableType -> Word64 -> ExceptT ValidateError IO () +validateAccounting txOutTableType txId = do (fee, deposit) <- liftIO $ runDbNoLoggingEnv (queryTxFeeDeposit txId) withdrawal <- liftIO $ runDbNoLoggingEnv (queryTxWithdrawal txId) - ins <- liftIO $ runDbNoLoggingEnv (queryTxInputs txId) - outs <- liftIO $ runDbNoLoggingEnv (queryTxOutputs txId) + ins <- liftIO $ runDbNoLoggingEnv (queryTxInputs txOutTableType txId) + outs <- liftIO $ runDbNoLoggingEnv (queryTxOutputs txOutTableType txId) -- A refund is a negative deposit. when (deposit >= 0 && sumValues ins + withdrawal /= fee + adaDeposit deposit + sumValues outs) $ left (ValidateError txId fee deposit withdrawal ins outs) when (deposit < 0 && sumValues ins + adaRefund deposit + withdrawal /= fee + sumValues outs) $ left (ValidateError txId fee deposit withdrawal ins outs) where - sumValues :: [TxOut] -> Ada - sumValues txs = word64ToAda $ sum (map (unDbLovelace . txOutValue) txs) - adaDeposit :: Int64 -> Ada adaDeposit = word64ToAda . fromIntegral adaRefund :: Int64 -> Ada adaRefund = word64ToAda . fromIntegral . negate +sumValues :: [TxOutW] -> Ada +sumValues = word64ToAda . sum . map txOutValue + where + txOutValue = + unDbLovelace . \case + CTxOutW cTxOut -> C.txOutValue cTxOut + VTxOutW vTxOut _ -> V.txOutValue vTxOut + -- ------------------------------------------------------------------------------------------------- queryTestTxIds :: MonadIO m => ReaderT SqlBackend m (Word64, Word64) @@ -153,29 +167,39 @@ queryTxFeeDeposit txId = do convert :: (Value DbLovelace, Value (Maybe Int64)) -> (Ada, Int64) convert (Value (DbLovelace w64), d) = (word64ToAda w64, fromMaybe 0 (unValue d)) -queryTxInputs :: MonadIO m => Word64 -> ReaderT SqlBackend m [TxOut] -queryTxInputs txId = do +queryTxInputs :: MonadIO m => TxOutTableType -> Word64 -> ReaderT SqlBackend m [TxOutW] +queryTxInputs txOutTableType txId = case txOutTableType of + TxOutCore -> map CTxOutW <$> queryInputsBody @'TxOutCore txId + TxOutVariantAddress -> map (`VTxOutW` Nothing) <$> queryInputsBody @'TxOutVariantAddress txId + +queryInputsBody :: forall a m. (MonadIO m, TxOutFields a) => Word64 -> ReaderT SqlBackend m [TxOutTable a] +queryInputsBody txId = do res <- select $ do (tx :& txin :& txout) <- from $ table @Tx `innerJoin` table @TxIn `on` (\(tx :& txin) -> tx ^. TxId ==. txin ^. TxInTxInId) - `innerJoin` table @TxOut - `on` (\(_tx :& txin :& txout) -> txin ^. TxInTxOutId ==. txout ^. TxOutTxId) + `innerJoin` table @(TxOutTable a) + `on` (\(_tx :& txin :& txout) -> txin ^. TxInTxOutId ==. txout ^. txOutTxIdField @a) where_ (tx ^. TxId ==. val (toSqlKey $ fromIntegral txId)) - where_ (txout ^. TxOutIndex ==. txin ^. TxInTxOutIndex) + where_ (txout ^. txOutIndexField @a ==. txin ^. TxInTxOutIndex) pure txout pure $ entityVal <$> res -queryTxOutputs :: MonadIO m => Word64 -> ReaderT SqlBackend m [TxOut] -queryTxOutputs txId = do +queryTxOutputs :: MonadIO m => TxOutTableType -> Word64 -> ReaderT SqlBackend m [TxOutW] +queryTxOutputs txOutTableType txId = case txOutTableType of + TxOutCore -> map CTxOutW <$> queryTxOutputsBody @'TxOutCore txId + TxOutVariantAddress -> map (`VTxOutW` Nothing) <$> queryTxOutputsBody @'TxOutVariantAddress txId + +queryTxOutputsBody :: forall a m. (MonadIO m, TxOutFields a) => Word64 -> ReaderT SqlBackend m [TxOutTable a] +queryTxOutputsBody txId = do res <- select $ do (tx :& txout) <- from $ table @Tx - `innerJoin` table @TxOut - `on` (\(tx :& txout) -> tx ^. TxId ==. txout ^. TxOutTxId) + `innerJoin` table @(TxOutTable a) + `on` (\(tx :& txout) -> tx ^. TxId ==. txout ^. txOutTxIdField @a) where_ (tx ^. TxId ==. val (toSqlKey $ fromIntegral txId)) pure txout pure $ entityVal <$> res diff --git a/cardano-db-tool/src/Cardano/DbTool/Validation.hs b/cardano-db-tool/src/Cardano/DbTool/Validation.hs index 3814c5278..78d23a01b 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Validation.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Validation.hs @@ -4,6 +4,7 @@ module Cardano.DbTool.Validation ( runLedgerValidation, ) where +import Cardano.Db (TxOutTableType) import Cardano.DbTool.Validate.AdaPots (validateSumAdaPots) import Cardano.DbTool.Validate.BlockProperties (validateBlockProperties) import Cardano.DbTool.Validate.BlockTxs (validateEpochBlockTxs) @@ -14,12 +15,12 @@ import Cardano.DbTool.Validate.TotalSupply (validateTotalSupplyDecreasing) import Cardano.DbTool.Validate.TxAccounting (validateTxAccounting) import Cardano.DbTool.Validate.Withdrawal (validateWithdrawals) -runDbValidation :: IO () -runDbValidation = do +runDbValidation :: TxOutTableType -> IO () +runDbValidation txOutTableType = do fastValidations - slowValidations + slowValidations txOutTableType -runLedgerValidation :: LedgerValidationParams -> IO () +runLedgerValidation :: LedgerValidationParams -> TxOutTableType -> IO () runLedgerValidation = validateLedger @@ -31,10 +32,10 @@ fastValidations = do validateBlockProperties validateSumAdaPots -slowValidations :: IO () -slowValidations = do - validateTxAccounting +slowValidations :: TxOutTableType -> IO () +slowValidations txOutTableType = do + validateTxAccounting txOutTableType validateWithdrawals validateEpochTable validateEpochBlockTxs - validateTotalSupplyDecreasing + validateTotalSupplyDecreasing txOutTableType diff --git a/cardano-db/cardano-db.cabal b/cardano-db/cardano-db.cabal index e9efb77fd..9b709d85b 100644 --- a/cardano-db/cardano-db.cabal +++ b/cardano-db/cardano-db.cabal @@ -30,31 +30,36 @@ library -Wunused-packages exposed-modules: Cardano.Db - Cardano.Db.Old.V13_0 - - other-modules: Cardano.Db.Delete - Cardano.Db.Error - Cardano.Db.Migration.Extra.CosnumedTxOut.Queries - Cardano.Db.Migration.Extra.CosnumedTxOut.Schema - Cardano.Db.Migration.Extra.JsonbInSchemaQueries - Cardano.Db.Insert - Cardano.Db.AlterTable - Cardano.Db.PGConfig + Cardano.Db.Schema.Core.TxOut + Cardano.Db.Schema.Variant.TxOut + Cardano.Db.Version.V13_0 + + other-modules: Cardano.Db.Error + Cardano.Db.Git.RevFromGit + Cardano.Db.Git.Version Cardano.Db.Migration Cardano.Db.Migration.Haskell Cardano.Db.Migration.Version - Cardano.Db.MinId - Cardano.Db.Multiplex - Cardano.Db.Old.V13_0.Schema - Cardano.Db.Old.V13_0.Query - Cardano.Db.Query + Cardano.Db.Operations.Core.AlterTable + Cardano.Db.Operations.Core.Delete + Cardano.Db.Operations.Core.Insert + Cardano.Db.Operations.Core.MinId + Cardano.Db.Operations.Core.Query + Cardano.Db.Operations.Core.QueryHelper + Cardano.Db.Operations.Types + Cardano.Db.Operations.Variant.ConsumedTxOut + Cardano.Db.Operations.Variant.JsonbQuery + Cardano.Db.Operations.Variant.TxOutDelete + Cardano.Db.Operations.Variant.TxOutInsert + Cardano.Db.Operations.Variant.TxOutQuery + Cardano.Db.PGConfig Cardano.Db.Run - Cardano.Db.RevFromGit - Cardano.Db.Schema - Cardano.Db.Schema.Types + Cardano.Db.Schema.BaseSchema Cardano.Db.Schema.Orphans + Cardano.Db.Schema.Types Cardano.Db.Types - Cardano.Db.Version + 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.hs b/cardano-db/src/Cardano/Db.hs index 6934c72a7..f3c241357 100644 --- a/cardano-db/src/Cardano/Db.hs +++ b/cardano-db/src/Cardano/Db.hs @@ -5,28 +5,37 @@ module Cardano.Db ( Block (..), Tx (..), TxIn (..), - TxOut (..), gitRev, - migrateTxOut, - queryTxConsumedColumnExists, - queryTxOutConsumedNullCount, - queryTxOutConsumedCount, + -- CTX.migrateTxOut, + -- CTX.runExtraMigrations, + -- CTX.queryTxConsumedColumnExists, + -- CTX.queryTxOutConsumedNullCount, + -- CTX.queryTxOutConsumedCount, + -- CTX.querySetNullTxOut, ) where -import Cardano.Db.AlterTable as X -import Cardano.Db.Delete as X import Cardano.Db.Error as X -import Cardano.Db.Insert as X +import Cardano.Db.Git.Version (gitRev) import Cardano.Db.Migration as X -import Cardano.Db.Migration.Extra.CosnumedTxOut.Queries (migrateTxOut, queryTxConsumedColumnExists, queryTxOutConsumedCount, queryTxOutConsumedNullCount) -import Cardano.Db.Migration.Extra.JsonbInSchemaQueries as X import Cardano.Db.Migration.Version as X -import Cardano.Db.MinId as X -import Cardano.Db.Multiplex as X +import Cardano.Db.Operations.Core.AlterTable as X +import Cardano.Db.Operations.Core.Delete as X +import Cardano.Db.Operations.Core.Insert as X +import Cardano.Db.Operations.Core.MinId as X +import Cardano.Db.Operations.Core.Query as X +import Cardano.Db.Operations.Core.QueryHelper as X +import Cardano.Db.Operations.Types as X + +-- import qualified Cardano.Db.Operations.Variant.ConsumedTxOut as CTX +import Cardano.Db.Operations.Variant.ConsumedTxOut as X + +-- (migrateTxOut, queryTxConsumedColumnExists, queryTxOutConsumedCount, queryTxOutConsumedNullCount, runExtraMigrations, querySetNullTxOut) +import Cardano.Db.Operations.Variant.JsonbQuery as X +import Cardano.Db.Operations.Variant.TxOutDelete as X +import Cardano.Db.Operations.Variant.TxOutInsert as X +import Cardano.Db.Operations.Variant.TxOutQuery as X import Cardano.Db.PGConfig as X -import Cardano.Db.Query as X import Cardano.Db.Run as X -import Cardano.Db.Schema as X +import Cardano.Db.Schema.BaseSchema as X import Cardano.Db.Schema.Types as X import Cardano.Db.Types as X -import Cardano.Db.Version (gitRev) diff --git a/cardano-db/src/Cardano/Db/Error.hs b/cardano-db/src/Cardano/Db/Error.hs index 4a57a6752..b98f6bd92 100644 --- a/cardano-db/src/Cardano/Db/Error.hs +++ b/cardano-db/src/Cardano/Db/Error.hs @@ -10,7 +10,7 @@ module Cardano.Db.Error ( ) where import Cardano.BM.Trace (Trace, logError) -import Cardano.Db.Schema +import Cardano.Db.Schema.BaseSchema import Cardano.Prelude (throwIO) import Control.Exception (Exception) import qualified Data.ByteString.Base16 as Base16 @@ -35,6 +35,7 @@ data LookupFail | DBExtraMigration !String | DBPruneConsumed !String | DBRJsonbInSchema !String + | DBTxOutVariant !String deriving (Eq, Generic) instance Exception LookupFail @@ -56,6 +57,7 @@ instance Show LookupFail where DBExtraMigration e -> "DBExtraMigration : " <> e DBPruneConsumed e -> "DBExtraMigration" <> e DBRJsonbInSchema e -> "DBRJsonbInSchema" <> e + DBTxOutVariant e -> "DbTxOutVariant" <> e base16encode :: ByteString -> Text base16encode = Text.decodeUtf8 . Base16.encode diff --git a/cardano-db/src/Cardano/Db/RevFromGit.hs b/cardano-db/src/Cardano/Db/Git/RevFromGit.hs similarity index 97% rename from cardano-db/src/Cardano/Db/RevFromGit.hs rename to cardano-db/src/Cardano/Db/Git/RevFromGit.hs index 172cdddcc..85a1fc00c 100644 --- a/cardano-db/src/Cardano/Db/RevFromGit.hs +++ b/cardano-db/src/Cardano/Db/Git/RevFromGit.hs @@ -1,4 +1,4 @@ -module Cardano.Db.RevFromGit ( +module Cardano.Db.Git.RevFromGit ( gitRevFromGit, ) where diff --git a/cardano-db/src/Cardano/Db/Version.hs b/cardano-db/src/Cardano/Db/Git/Version.hs similarity index 93% rename from cardano-db/src/Cardano/Db/Version.hs rename to cardano-db/src/Cardano/Db/Git/Version.hs index 599e4810c..4a0e8a7af 100644 --- a/cardano-db/src/Cardano/Db/Version.hs +++ b/cardano-db/src/Cardano/Db/Git/Version.hs @@ -2,11 +2,11 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} -module Cardano.Db.Version ( +module Cardano.Db.Git.Version ( gitRev, ) where -import Cardano.Db.RevFromGit (gitRevFromGit) +import Cardano.Db.Git.RevFromGit (gitRevFromGit) import Data.FileEmbed (dummySpaceWith) import Data.Text (Text) import qualified Data.Text as Text diff --git a/cardano-db/src/Cardano/Db/Migration.hs b/cardano-db/src/Cardano/Db/Migration.hs index 4d3a26925..c91fcb53b 100644 --- a/cardano-db/src/Cardano/Db/Migration.hs +++ b/cardano-db/src/Cardano/Db/Migration.hs @@ -28,10 +28,10 @@ import Cardano.BM.Trace (Trace) import Cardano.Crypto.Hash (Blake2b_256, ByteString, Hash, hashToStringAsHex, hashWith) import Cardano.Db.Migration.Haskell import Cardano.Db.Migration.Version +import Cardano.Db.Operations.Core.Query import Cardano.Db.PGConfig -import Cardano.Db.Query import Cardano.Db.Run -import Cardano.Db.Schema +import Cardano.Db.Schema.BaseSchema import Cardano.Prelude (Typeable, textShow) import Control.Exception (Exception, SomeException, handle) import Control.Monad.Extra @@ -238,7 +238,7 @@ createMigration source (MigrationDir migdir) = do create :: ReaderT SqlBackend (NoLoggingT IO) (Maybe (MigrationVersion, Text)) create = do ver <- getSchemaVersion - statements <- getMigration migrateCardanoDb + statements <- getMigration migrateBaseCardanoDb if null statements then pure Nothing else do diff --git a/cardano-db/src/Cardano/Db/Migration/Extra/CosnumedTxOut/Queries.hs b/cardano-db/src/Cardano/Db/Migration/Extra/CosnumedTxOut/Queries.hs index fa29ef0d2..3cf6dbac7 100644 --- a/cardano-db/src/Cardano/Db/Migration/Extra/CosnumedTxOut/Queries.hs +++ b/cardano-db/src/Cardano/Db/Migration/Extra/CosnumedTxOut/Queries.hs @@ -145,7 +145,7 @@ queryWrongConsumedBy :: MonadIO m => ReaderT SqlBackend m Word64 queryWrongConsumedBy = do res <- select $ do txOut <- from $ table @TxOut - where_ (just (txOut ^. TxOutTxId) E.==. txOut ^. TxOutConsumedByTxId) + where_ (just (txOut ^. TxOutTxId) ==. txOut ^. TxOutConsumedByTxId) pure countRows pure $ maybe 0 unValue (listToMaybe res) diff --git a/cardano-db/src/Cardano/Db/Migration/Extra/CosnumedTxOut/Schema.hs b/cardano-db/src/Cardano/Db/Migration/Extra/CosnumedTxOut/Schema.hs deleted file mode 100644 index 2d7796be6..000000000 --- a/cardano-db/src/Cardano/Db/Migration/Extra/CosnumedTxOut/Schema.hs +++ /dev/null @@ -1,932 +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.Migration.Extra.CosnumedTxOut.Schema where - -import Cardano.Db.Schema.Orphans () -import Cardano.Db.Schema.Types ( - PoolUrl, - ) -import Cardano.Db.Types ( - DbInt65, - DbLovelace, - DbWord64, - ScriptPurpose, - ScriptType, - SyncState, - ) -import Data.ByteString.Char8 (ByteString) -import Data.Int (Int64) -import Data.Text (Text) -import Data.Time.Clock (UTCTime) -import Data.WideWord.Word128 (Word128) -import Data.Word (Word16, Word64) -import Database.Persist.Class (Unique) -import Database.Persist.Documentation (deriveShowFields, document, (#), (--^)) -import Database.Persist.EntityDef.Internal (EntityDef (..)) - --- Do not use explicit imports from this module as the imports can change --- from version to version due to changes to the TH code in Persistent. -import Database.Persist.TH - --- In the schema definition we need to match Haskell types with with the --- custom type defined in PostgreSQL (via 'DOMAIN' statements). For the --- time being the Haskell types will be simple Haskell types like --- 'ByteString' and 'Word64'. - --- We use camelCase here in the Haskell schema definition and 'persistLowerCase' --- specifies that all the table and column names are converted to lower snake case. - -share - [ mkPersist sqlSettings - , mkMigrate "migrateCardanoDb" - , mkEntityDefList "entityDefs" - , deriveShowFields - ] - [persistLowerCase| - - -- Schema versioning has three stages to best allow handling of schema migrations. - -- Stage 1: Set up PostgreSQL data types (using SQL 'DOMAIN' statements). - -- Stage 2: Persistent generated migrations. - -- Stage 3: Set up 'VIEW' tables (for use by other languages and applications). - -- This table should have a single row. - SchemaVersion - stageOne Int - stageTwo Int - stageThree Int - deriving Eq - - PoolHash - hashRaw ByteString sqltype=hash28type - view Text - UniquePoolHash hashRaw - - 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 - - -- Each table has autogenerated primary key named 'id', the Haskell type - -- of which is (for instance for this table) 'BlockId'. This specific - -- primary key Haskell type can be used in a type-safe way in the rest - -- of the schema definition. - -- All NULL-able fields other than 'epochNo' are NULL for EBBs, whereas 'epochNo' is - -- only NULL for the genesis block. - 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 noreference - 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 - - Tx - hash ByteString sqltype=hash32type - blockId BlockId noreference -- 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 - - ReverseIndex - blockId BlockId noreference - minIds Text - - StakeAddress -- Can be an address of a script hash - hashRaw ByteString sqltype=addr29type - view Text - scriptHash ByteString Maybe sqltype=hash28type - UniqueStakeAddress hashRaw - - TxOut - txId TxId noreference - index Word64 sqltype=txindex - address Text Maybe - addressHasScript Bool - paymentCred ByteString Maybe sqltype=hash28type - stakeAddressId StakeAddressId Maybe noreference - value DbLovelace sqltype=lovelace - dataHash ByteString Maybe sqltype=hash32type - inlineDatumId DatumId Maybe noreference - referenceScriptId ScriptId Maybe noreference - consumedByTxId TxId Maybe noreference - UniqueTxout txId index -- The (tx_id, index) pair must be unique. - - CollateralTxOut - txId TxId noreference -- This type is the primary key for the 'tx' table. - index Word64 sqltype=txindex - address Text - addressHasScript Bool - paymentCred ByteString Maybe sqltype=hash28type - stakeAddressId StakeAddressId Maybe noreference - value DbLovelace sqltype=lovelace - dataHash ByteString Maybe sqltype=hash32type - multiAssetsDescr Text - inlineDatumId DatumId Maybe noreference - referenceScriptId ScriptId Maybe noreference - - TxIn - txInId TxId noreference -- The transaction where this is used as an input. - txOutId TxId noreference -- The transaction where this was created as an output. - txOutIndex Word64 sqltype=txindex - redeemerId RedeemerId Maybe noreference - - CollateralTxIn - txInId TxId noreference -- The transaction where this is used as an input. - txOutId TxId noreference -- The transaction where this was created as an output. - txOutIndex Word64 sqltype=txindex - - ReferenceTxIn - txInId TxId noreference -- The transaction where this is used as an input. - txOutId TxId noreference -- The transaction where this was created as an output. - txOutIndex Word64 sqltype=txindex - - -- A table containing metadata about the chain. There will probably only ever be one - -- row in this table. - Meta - startTime UTCTime sqltype=timestamp - networkName Text - version Text - UniqueMeta startTime - - -- The Epoch table is an aggregation of data in the 'Block' table, but is kept in this form - -- because having it as a 'VIEW' is incredibly slow and inefficient. - - -- The 'outsum' type in the PostgreSQL world is 'bigint >= 0' so it will error out if an - -- overflow (sum of tx outputs in an epoch) is detected. 'maxBound :: Int` is big enough to - -- hold 204 times the total Lovelace distribution. The chance of that much being transacted - -- in a single epoch is relatively low. - Epoch - outSum Word128 sqltype=word128type - fees DbLovelace sqltype=lovelace - txCount Word64 sqltype=word31type - blkCount Word64 sqltype=word31type - no Word64 sqltype=word31type - startTime UTCTime sqltype=timestamp - endTime UTCTime sqltype=timestamp - UniqueEpoch no - deriving Eq Show - - -- A table with all the different types of total balances. - -- This is only populated for the Shelley and later eras, and only on epoch boundaries. - -- The treasury and rewards fields will be correct for the whole epoch, but all other - -- fields change block by block. - AdaPots - slotNo Word64 sqltype=word63type - epochNo Word64 sqltype=word31type - treasury DbLovelace sqltype=lovelace - reserves DbLovelace sqltype=lovelace - rewards DbLovelace sqltype=lovelace - utxo DbLovelace sqltype=lovelace - deposits DbLovelace sqltype=lovelace - fees DbLovelace sqltype=lovelace - blockId BlockId noreference - deriving Eq - - PoolMetadataRef - poolId PoolHashId noreference - url PoolUrl sqltype=varchar - hash ByteString sqltype=hash32type - registeredTxId TxId noreference -- Only used for rollback. - UniquePoolMetadataRef poolId url hash - - PoolUpdate - hashId PoolHashId noreference - certIndex Word16 - vrfKeyHash ByteString sqltype=hash32type - pledge DbLovelace sqltype=lovelace - rewardAddrId StakeAddressId noreference - activeEpochNo Word64 - metaId PoolMetadataRefId Maybe noreference - margin Double -- sqltype=percentage???? - fixedCost DbLovelace sqltype=lovelace - registeredTxId TxId noreference -- Slot number in which the pool was registered. - - -- A Pool can have more than one owner, so we have a PoolOwner table. - PoolOwner - addrId StakeAddressId noreference - poolUpdateId PoolUpdateId noreference - - PoolRetire - hashId PoolHashId noreference - certIndex Word16 - announcedTxId TxId noreference -- Slot number in which the pool announced it was retiring. - retiringEpoch Word64 sqltype=word31type -- Epoch number in which the pool will retire. - - PoolRelay - updateId PoolUpdateId noreference - ipv4 Text Maybe - ipv6 Text Maybe - dnsName Text Maybe - dnsSrvName Text Maybe - port Word16 Maybe - - StakeRegistration - addrId StakeAddressId noreference - certIndex Word16 - epochNo Word64 sqltype=word31type - txId TxId noreference - - -- When was a staking key/script deregistered - StakeDeregistration - addrId StakeAddressId noreference - certIndex Word16 - epochNo Word64 sqltype=word31type - txId TxId noreference - redeemerId RedeemerId Maybe noreference - - Delegation - addrId StakeAddressId noreference - certIndex Word16 - poolHashId PoolHashId noreference - activeEpochNo Word64 - txId TxId noreference - slotNo Word64 sqltype=word63type - redeemerId RedeemerId Maybe noreference - - TxMetadata - key DbWord64 sqltype=word64type - json Text Maybe - bytes ByteString sqltype=bytea - txId TxId noreference - - -- ----------------------------------------------------------------------------------------------- - - Withdrawal - addrId StakeAddressId noreference - amount DbLovelace sqltype=lovelace - redeemerId RedeemerId Maybe noreference - txId TxId noreference - - -- This table should never get rolled back. - EpochStake - addrId StakeAddressId noreference - poolId PoolHashId noreference - amount DbLovelace sqltype=lovelace - epochNo Word64 sqltype=word31type - UniqueStake epochNo addrId poolId - - Treasury - addrId StakeAddressId noreference - certIndex Word16 - amount DbInt65 sqltype=int65type - txId TxId noreference - - Reserve - addrId StakeAddressId noreference - certIndex Word16 - amount DbInt65 sqltype=int65type - txId TxId noreference - - PotTransfer - certIndex Word16 - treasury DbInt65 sqltype=int65type - reserves DbInt65 sqltype=int65type - txId TxId noreference - - EpochSyncTime - no Word64 - seconds Word64 sqltype=word63type - state SyncState sqltype=syncstatetype - UniqueEpochSyncTime no - - -- ----------------------------------------------------------------------------------------------- - -- Multi Asset related tables. - - MultiAsset - policy ByteString sqltype=hash28type - name ByteString sqltype=asset32type - fingerprint Text - UniqueMultiAsset policy name - - MaTxMint - ident MultiAssetId noreference - quantity DbInt65 sqltype=int65type - txId TxId noreference - - MaTxOut - ident MultiAssetId noreference - quantity DbWord64 sqltype=word64type - txOutId TxOutId - - -- Unit step is in picosends, and `maxBound :: Int64` picoseconds is over 100 days, so using - -- Word64/word63type is safe here. Similarly, `maxBound :: Int64` if unit step would be an - -- *enormous* amount a memory which would cost a fortune. - Redeemer - txId TxId noreference - unitMem Word64 sqltype=word63type - unitSteps Word64 sqltype=word63type - fee DbLovelace Maybe sqltype=lovelace - purpose ScriptPurpose sqltype=scriptpurposetype - index Word64 sqltype=word31type - scriptHash ByteString Maybe sqltype=hash28type - redeemerDataId RedeemerDataId noreference - - Script - txId TxId noreference - hash ByteString sqltype=hash28type - type ScriptType sqltype=scripttype - json Text Maybe - bytes ByteString Maybe sqltype=bytea - serialisedSize Word64 Maybe sqltype=word31type - UniqueScript hash - - Datum - hash ByteString sqltype=hash32type - txId TxId noreference - value Text Maybe - bytes ByteString sqltype=bytea - UniqueDatum hash - - RedeemerData - hash ByteString sqltype=hash32type - txId TxId noreference - value Text Maybe - bytes ByteString sqltype=bytea - UniqueRedeemerData hash - - ExtraKeyWitness - hash ByteString sqltype=hash28type - txId TxId noreference - - ParamProposal - epochNo Word64 sqltype=word31type - key ByteString sqltype=hash28type - minFeeA Word64 Maybe sqltype=word64type - minFeeB Word64 Maybe sqltype=word64type - maxBlockSize Word64 Maybe sqltype=word64type - maxTxSize Word64 Maybe sqltype=word64type - maxBhSize Word64 Maybe sqltype=word64type - keyDeposit DbLovelace Maybe sqltype=lovelace - poolDeposit DbLovelace Maybe sqltype=lovelace - maxEpoch Word64 Maybe sqltype=word64type - optimalPoolCount Word64 Maybe sqltype=word64type - influence Double Maybe -- sqltype=rational - monetaryExpandRate Double Maybe -- sqltype=interval - treasuryGrowthRate Double Maybe -- sqltype=interval - decentralisation Double Maybe -- sqltype=interval - entropy ByteString Maybe sqltype=hash32type - protocolMajor Word16 Maybe sqltype=word31type - protocolMinor Word16 Maybe sqltype=word31type - minUtxoValue DbLovelace Maybe sqltype=lovelace - minPoolCost DbLovelace Maybe sqltype=lovelace - - coinsPerUtxoSize DbLovelace Maybe sqltype=lovelace - costModelId CostModelId Maybe noreference - priceMem Double Maybe -- sqltype=rational - priceStep Double Maybe -- sqltype=rational - maxTxExMem DbWord64 Maybe sqltype=word64type - maxTxExSteps DbWord64 Maybe sqltype=word64type - maxBlockExMem DbWord64 Maybe sqltype=word64type - maxBlockExSteps DbWord64 Maybe sqltype=word64type - maxValSize DbWord64 Maybe sqltype=word64type - collateralPercent Word16 Maybe sqltype=word31type - maxCollateralInputs Word16 Maybe sqltype=word31type - - registeredTxId TxId noreference - - EpochParam - epochNo Word64 sqltype=word31type - minFeeA Word64 sqltype=word31type - minFeeB Word64 sqltype=word31type - maxBlockSize Word64 sqltype=word31type - maxTxSize Word64 sqltype=word31type - maxBhSize Word64 sqltype=word31type - keyDeposit DbLovelace sqltype=lovelace - poolDeposit DbLovelace sqltype=lovelace - maxEpoch Word64 sqltype=word31type - optimalPoolCount Word64 sqltype=word31type - influence Double -- sqltype=rational - monetaryExpandRate Double -- sqltype=interval - treasuryGrowthRate Double -- sqltype=interval - decentralisation Double -- sqltype=interval - extraEntropy ByteString Maybe sqltype=hash32type - protocolMajor Word16 sqltype=word31type - protocolMinor Word16 sqltype=word31type - minUtxoValue DbLovelace sqltype=lovelace - minPoolCost DbLovelace sqltype=lovelace - - nonce ByteString Maybe sqltype=hash32type - - coinsPerUtxoSize DbLovelace Maybe sqltype=lovelace - costModelId CostModelId Maybe noreference - priceMem Double Maybe -- sqltype=rational - priceStep Double Maybe -- sqltype=rational - maxTxExMem DbWord64 Maybe sqltype=word64type - maxTxExSteps DbWord64 Maybe sqltype=word64type - maxBlockExMem DbWord64 Maybe sqltype=word64type - maxBlockExSteps DbWord64 Maybe sqltype=word64type - maxValSize DbWord64 Maybe sqltype=word64type - collateralPercent Word16 Maybe sqltype=word31type - maxCollateralInputs Word16 Maybe sqltype=word31type - - blockId BlockId noreference -- The first block where these parameters are valid. - - CostModel - hash ByteString sqltype=hash32type - costs Text - UniqueCostModel hash - - -- ----------------------------------------------------------------------------------------------- - -- Pool offchain (ie not on the blockchain) data. - - OffChainPoolData - poolId PoolHashId noreference - tickerName Text - hash ByteString sqltype=hash32type - json Text - bytes ByteString sqltype=bytea - pmrId PoolMetadataRefId noreference - UniqueOffChainPoolData poolId hash - deriving Show - - -- The pool metadata fetch error. We duplicate the poolId for easy access. - -- TODO(KS): Debatable whether we need to persist this between migrations! - - OffChainPoolFetchError - poolId PoolHashId noreference - fetchTime UTCTime sqltype=timestamp - pmrId PoolMetadataRefId noreference - fetchError Text - retryCount Word sqltype=word31type - UniqueOffChainPoolFetchError poolId fetchTime retryCount - deriving Show - - -------------------------------------------------------------------------- - -- A table containing a managed list of reserved ticker names. - -- For now they are grouped under the specific hash of the pool. - ReservedPoolTicker - name Text - poolHash ByteString sqltype=hash28type - UniqueReservedPoolTicker name - - -- A table containing delisted pools. - DelistedPool - hashRaw ByteString sqltype=hash28type - UniqueDelistedPool hashRaw - - |] - -deriving instance Eq (Unique EpochSyncTime) - -schemaDocs :: [EntityDef] -schemaDocs = - document entityDefs $ do - SchemaVersion --^ do - "The version of the database schema. Schema versioning is split into three stages as detailed\ - \ below. This table should only ever have a single row." - SchemaVersionStageOne # "Set up PostgreSQL data types (using SQL 'DOMAIN' statements)." - SchemaVersionStageTwo # "Persistent generated migrations." - SchemaVersionStageThree # "Set up database views, indices etc." - - PoolHash --^ do - "A table for every unique pool key hash. The `id` field of this table is used as foreign keys in other tables.\ - \ The existance of an entry doesn't mean the pool is registered or in fact that is was ever registered." - PoolHashHashRaw # "The raw bytes of the pool hash." - PoolHashView # "The Bech32 encoding of the pool hash." - - SlotLeader --^ do - "Every unique slot leader (ie an entity that mines a block). It could be a pool or a leader defined in genesis." - SlotLeaderHash # "The hash of of the block producer identifier." - SlotLeaderPoolHashId # "If the slot leader is a pool, an index into the `PoolHash` table." - SlotLeaderDescription # "An auto-generated description of the slot leader." - - Block --^ do - "A table for blocks on the chain." - BlockHash # "The hash identifier of the block." - BlockEpochNo # "The epoch number." - BlockSlotNo # "The slot number." - BlockEpochSlotNo # "The slot number within an epoch (resets to zero at the start of each epoch)." - BlockBlockNo # "The block number." - BlockPreviousId # "The Block table index of the previous block." - BlockSlotLeaderId # "The SlotLeader table index of the creator of this block." - BlockSize # "The block size (in bytes). Note, this size value is not expected to be the same as the sum of the tx sizes due to the fact that txs being stored in segwit format and oddities in the CBOR encoding." - BlockTime # "The block time (UTCTime)." - BlockTxCount # "The number of transactions in this block." - BlockProtoMajor # "The block's major protocol number." - BlockProtoMinor # "The block's major protocol number." - -- Shelley specific - BlockVrfKey # "The VRF key of the creator of this block." - BlockOpCert # "The hash of the operational certificate of the block producer." - BlockOpCertCounter # "The value of the counter used to produce the operational certificate." - - Tx --^ do - "A table for transactions within a block on the chain." - TxHash # "The hash identifier of the transaction." - TxBlockId # "The Block table index of the block that contains this transaction." - TxBlockIndex # "The index of this transaction with the block (zero based)." - TxOutSum # "The sum of the transaction outputs (in Lovelace)." - TxFee # "The fees paid for this transaction." - TxDeposit # "Deposit (or deposit refund) in this transaction. Deposits are positive, refunds negative." - TxSize # "The size of the transaction in bytes." - TxInvalidBefore # "Transaction in invalid before this slot number." - TxInvalidHereafter # "Transaction in invalid at or after this slot number." - TxValidContract # "False if the contract is invalid. True if the contract is valid or there is no contract." - TxScriptSize # "The sum of the script sizes (in bytes) of scripts in the transaction." - - ReverseIndex --^ do - "A table for reverse indexes for the minimum input output and multi asset output related with\ - \ this block. New in v13.1" - ReverseIndexBlockId # "The Block table index related with these indexes" - ReverseIndexMinIds # "The Reverse indexes associated with this block, as Text separated by :" - - StakeAddress --^ do - "A table of unique stake addresses. Can be an actual address or a script hash. \ - \ The existance of an entry doesn't mean the address is registered or in fact that is was ever registered." - StakeAddressHashRaw # "The raw bytes of the stake address hash." - StakeAddressView # "The Bech32 encoded version of the stake address." - StakeAddressScriptHash # "The script hash, in case this address is locked by a script." - - TxOut --^ do - "A table for transaction outputs." - TxOutTxId # "The Tx table index of the transaction that contains this transaction output." - TxOutIndex # "The index of this transaction output with the transaction." - TxOutAddress # "The human readable encoding of the output address. Will be Base58 for Byron era addresses and Bech32 for Shelley era." - TxOutAddressHasScript # "Flag which shows if this address is locked by a script." - TxOutPaymentCred # "The payment credential part of the Shelley address. (NULL for Byron addresses). For a script-locked address, this is the script hash." - TxOutStakeAddressId # "The StakeAddress table index for the stake address part of the Shelley address. (NULL for Byron addresses)." - TxOutValue # "The output value (in Lovelace) of the transaction output." - TxOutDataHash # "The hash of the transaction output datum. (NULL for Txs without scripts)." - TxOutInlineDatumId # "The inline datum of the output, if it has one. New in v13." - TxOutReferenceScriptId # "The reference script of the output, if it has one. New in v13." - - CollateralTxOut --^ do - "A table for transaction collateral outputs. New in v13." - CollateralTxOutTxId # "The Tx table index of the transaction that contains this transaction output." - CollateralTxOutIndex # "The index of this transaction output with the transaction." - CollateralTxOutAddress # "The human readable encoding of the output address. Will be Base58 for Byron era addresses and Bech32 for Shelley era." - CollateralTxOutAddressHasScript # "Flag which shows if this address is locked by a script." - CollateralTxOutPaymentCred # "The payment credential part of the Shelley address. (NULL for Byron addresses). For a script-locked address, this is the script hash." - CollateralTxOutStakeAddressId # "The StakeAddress table index for the stake address part of the Shelley address. (NULL for Byron addresses)." - CollateralTxOutValue # "The output value (in Lovelace) of the transaction output." - CollateralTxOutDataHash # "The hash of the transaction output datum. (NULL for Txs without scripts)." - CollateralTxOutMultiAssetsDescr # "This is a description of the multiassets in collateral output. Since the output is not really created, we don't need to add them in separate tables." - CollateralTxOutInlineDatumId # "The inline datum of the output, if it has one. New in v13." - CollateralTxOutReferenceScriptId # "The reference script of the output, if it has one. New in v13." - - TxIn --^ do - "A table for transaction inputs." - TxInTxInId # "The Tx table index of the transaction that contains this transaction input." - TxInTxOutId # "The Tx table index of the transaction that contains the referenced transaction output." - TxInTxOutIndex # "The index within the transaction outputs." - TxInRedeemerId # "The Redeemer table index which is used to validate this input." - - CollateralTxIn --^ do - "A table for transaction collateral inputs." - CollateralTxInTxInId # "The Tx table index of the transaction that contains this transaction input" - CollateralTxInTxOutId # "The Tx table index of the transaction that contains the referenced transaction output." - CollateralTxInTxOutIndex # "The index within the transaction outputs." - - ReferenceTxIn --^ do - "A table for reference transaction inputs. New in v13." - ReferenceTxInTxInId # "The Tx table index of the transaction that contains this transaction input" - ReferenceTxInTxOutId # "The Tx table index of the transaction that contains the referenced output." - ReferenceTxInTxOutIndex # "The index within the transaction outputs." - - Meta --^ do - "A table containing metadata about the chain. There will probably only ever be one row in this table." - MetaStartTime # "The start time of the network." - MetaNetworkName # "The network name." - - Epoch --^ do - "Aggregation of data within an epoch." - EpochOutSum # "The sum of the transaction output values (in Lovelace) in this epoch." - EpochFees # "The sum of the fees (in Lovelace) in this epoch." - EpochTxCount # "The number of transactions in this epoch." - EpochBlkCount # "The number of blocks in this epoch." - EpochNo # "The epoch number." - EpochStartTime # "The epoch start time." - EpochEndTime # "The epoch end time." - - AdaPots --^ do - "A table with all the different types of total balances (Shelley only).\n\ - \The treasury and rewards fields will be correct for the whole epoch, but all other \ - \fields change block by block." - AdaPotsSlotNo # "The slot number where this AdaPots snapshot was taken." - AdaPotsEpochNo # "The epoch number where this AdaPots snapshot was taken." - AdaPotsTreasury # "The amount (in Lovelace) in the treasury pot." - AdaPotsReserves # "The amount (in Lovelace) in the reserves pot." - AdaPotsRewards # "The amount (in Lovelace) in the rewards pot." - AdaPotsUtxo # "The amount (in Lovelace) in the UTxO set." - AdaPotsDeposits # "The amount (in Lovelace) in the deposit pot." - AdaPotsFees # "The amount (in Lovelace) in the fee pot." - AdaPotsBlockId # "The Block table index of the block for which this snapshot was taken." - - PoolMetadataRef --^ do - "An on-chain reference to off-chain pool metadata." - PoolMetadataRefPoolId # "The PoolHash table index of the pool for this reference." - PoolMetadataRefUrl # "The URL for the location of the off-chain data." - PoolMetadataRefHash # "The expected hash for the off-chain data." - PoolMetadataRefRegisteredTxId # "The Tx table index of the transaction in which provided this metadata reference." - - PoolUpdate --^ do - "An on-chain pool update." - PoolUpdateHashId # "The PoolHash table index of the pool this update refers to." - PoolUpdateCertIndex # "The index of this pool update within the certificates of this transaction." - PoolUpdateVrfKeyHash # "The hash of the pool's VRF key." - PoolUpdatePledge # "The amount (in Lovelace) the pool owner pledges to the pool." - PoolUpdateRewardAddrId # "The StakeAddress table index of this pool's rewards address. New in v13: Replaced reward_addr." - PoolUpdateActiveEpochNo # "The epoch number where this update becomes active." - PoolUpdateMetaId # "The PoolMetadataRef table index this pool update refers to." - PoolUpdateMargin # "The margin (as a percentage) this pool charges." - PoolUpdateFixedCost # "The fixed per epoch fee (in ADA) this pool charges." - PoolUpdateRegisteredTxId # "The Tx table index of the transaction in which provided this pool update." - - PoolOwner --^ do - "A table containing pool owners." - PoolOwnerAddrId # "The StakeAddress table index for the pool owner's stake address." - PoolOwnerPoolUpdateId # "The PoolUpdate table index for the pool. New in v13." - - PoolRetire --^ do - "A table containing information about pools retiring." - PoolRetireHashId # "The PoolHash table index of the pool this retirement refers to." - PoolRetireCertIndex # "The index of this pool retirement within the certificates of this transaction." - PoolRetireAnnouncedTxId # "The Tx table index of the transaction where this pool retirement was announced." - PoolRetireRetiringEpoch # "The epoch where this pool retires." - - PoolRelay --^ do - PoolRelayUpdateId # "The PoolUpdate table index this PoolRelay entry refers to." - PoolRelayIpv4 # "The IPv4 address of the relay (NULLable)." - PoolRelayIpv6 # "The IPv6 address of the relay (NULLable)." - PoolRelayDnsName # "The DNS name of the relay (NULLable)." - PoolRelayDnsSrvName # "The DNS service name of the relay (NULLable)." - PoolRelayPort # "The port number of relay (NULLable)." - - StakeRegistration --^ do - "A table containing stake address registrations." - StakeRegistrationAddrId # "The StakeAddress table index for the stake address." - StakeRegistrationCertIndex # "The index of this stake registration within the certificates of this transaction." - StakeRegistrationEpochNo # "The epoch in which the registration took place." - StakeRegistrationTxId # "The Tx table index of the transaction where this stake address was registered." - - StakeDeregistration --^ do - "A table containing stake address deregistrations." - StakeDeregistrationAddrId # "The StakeAddress table index for the stake address." - StakeDeregistrationCertIndex # "The index of this stake deregistration within the certificates of this transaction." - StakeDeregistrationEpochNo # "The epoch in which the deregistration took place." - StakeDeregistrationTxId # "The Tx table index of the transaction where this stake address was deregistered." - StakeDeregistrationRedeemerId # "The Redeemer table index that is related with this certificate." - - Delegation --^ do - "A table containing delegations from a stake address to a stake pool." - DelegationAddrId # "The StakeAddress table index for the stake address." - DelegationCertIndex # "The index of this delegation within the certificates of this transaction." - DelegationPoolHashId # "The PoolHash table index for the pool being delegated to." - DelegationActiveEpochNo # "The epoch number where this delegation becomes active." - DelegationTxId # "The Tx table index of the transaction that contained this delegation." - DelegationSlotNo # "The slot number of the block that contained this delegation." - DelegationRedeemerId # "The Redeemer table index that is related with this certificate." - - TxMetadata --^ do - "A table for metadata attached to a transaction." - TxMetadataKey # "The metadata key (a Word64/unsigned 64 bit number)." - TxMetadataJson # "The JSON payload if it can be decoded as JSON." - TxMetadataBytes # "The raw bytes of the payload." - TxMetadataTxId # "The Tx table index of the transaction where this metadata was included." - - Withdrawal --^ do - "A table for withdrawals from a reward account." - WithdrawalAddrId # "The StakeAddress table index for the stake address for which the withdrawal is for." - WithdrawalAmount # "The withdrawal amount (in Lovelace)." - WithdrawalTxId # "The Tx table index for the transaction that contains this withdrawal." - WithdrawalRedeemerId # "The Redeemer table index that is related with this withdrawal." - - EpochStake --^ do - "A table containing the epoch stake distribution for each epoch. This is inserted incrementally in the first blocks of the epoch.\ - \ The stake distribution is extracted from the `set` snapshot of the ledger. See Shelley specs Sec. 11.2 for more details." - EpochStakeAddrId # "The StakeAddress table index for the stake address for this EpochStake entry." - EpochStakePoolId # "The PoolHash table index for the pool this entry is delegated to." - EpochStakeAmount # "The amount (in Lovelace) being staked." - EpochStakeEpochNo # "The epoch number." - - Treasury --^ do - "A table for payments from the treasury to a StakeAddress. Note: Before protocol version 5.0\ - \ (Alonzo) if more than one payment was made to a stake address in a single epoch, only the\ - \ last payment was kept and earlier ones removed. For protocol version 5.0 and later, they\ - \ are summed and produce a single reward with type `treasury`." - TreasuryAddrId # "The StakeAddress table index for the stake address for this Treasury entry." - TreasuryCertIndex # "The index of this payment certificate within the certificates of this transaction." - TreasuryAmount # "The payment amount (in Lovelace)." - TreasuryTxId # "The Tx table index for the transaction that contains this payment." - - Reserve --^ do - "A table for payments from the reserves to a StakeAddress. Note: Before protocol version 5.0\ - \ (Alonzo) if more than one payment was made to a stake address in a single epoch, only the\ - \ last payment was kept and earlier ones removed. For protocol version 5.0 and later, they\ - \ are summed and produce a single reward with type `reserves`" - ReserveAddrId # "The StakeAddress table index for the stake address for this Treasury entry." - ReserveCertIndex # "The index of this payment certificate within the certificates of this transaction." - ReserveAmount # "The payment amount (in Lovelace)." - ReserveTxId # "The Tx table index for the transaction that contains this payment." - - PotTransfer --^ do - "A table containing transfers between the reserves pot and the treasury pot." - PotTransferCertIndex # "The index of this transfer certificate within the certificates of this transaction." - PotTransferTreasury # "The amount (in Lovelace) the treasury balance changes by." - PotTransferReserves # "The amount (in Lovelace) the reserves balance changes by." - PotTransferTxId # "The Tx table index for the transaction that contains this transfer." - - EpochSyncTime --^ do - "A table containing the time required to fully sync an epoch." - EpochSyncTimeNo # "The epoch number for this sync time." - EpochSyncTimeSeconds - # "The time (in seconds) required to sync this epoch (may be NULL for an epoch\ - \ that was already partially synced when `db-sync` was started)." - EpochSyncTimeState # "The sync state when the sync time is recorded (either 'lagging' or 'following')." - - MultiAsset --^ do - "A table containing all the unique policy/name pairs along with a CIP14 asset fingerprint" - MultiAssetPolicy # "The MultiAsset policy hash." - MultiAssetName # "The MultiAsset name." - MultiAssetFingerprint # "The CIP14 fingerprint for the MultiAsset." - - MaTxMint --^ do - "A table containing Multi-Asset mint events." - MaTxMintIdent # "The MultiAsset table index specifying the asset." - MaTxMintQuantity # "The amount of the Multi Asset to mint (can be negative to \"burn\" assets)." - MaTxMintTxId # "The Tx table index for the transaction that contains this minting event." - - MaTxOut --^ do - "A table containing Multi-Asset transaction outputs." - MaTxOutIdent # "The MultiAsset table index specifying the asset." - MaTxOutQuantity # "The Multi Asset transaction output amount (denominated in the Multi Asset)." - MaTxOutTxOutId # "The TxOut table index for the transaction that this Multi Asset transaction output." - - Redeemer --^ do - "A table containing redeemers. A redeemer is provided for all items that are validated by a script." - RedeemerTxId # "The Tx table index that contains this redeemer." - RedeemerUnitMem # "The budget in Memory to run a script." - RedeemerUnitSteps # "The budget in Cpu steps to run a script." - RedeemerFee - # "The budget in fees to run a script. The fees depend on the ExUnits and the current prices.\ - \ Is null when --disable-ledger is enabled. New in v13: became nullable." - RedeemerPurpose # "What kind pf validation this redeemer is used for. It can be one of 'spend', 'mint', 'cert', 'reward'." - RedeemerIndex # "The index of the redeemer pointer in the transaction." - RedeemerScriptHash # "The script hash this redeemer is used for." - RedeemerRedeemerDataId # "The data related to this redeemer. New in v13: renamed from datum_id." - - Script --^ do - "A table containing scripts available, found in witnesses, inlined in outputs (reference outputs) or auxdata of transactions." - ScriptTxId # "The Tx table index for the transaction where this script first became available." - ScriptHash # "The Hash of the Script." - ScriptType # "The type of the script. This is currenttly either 'timelock' or 'plutus'." - ScriptJson # "JSON representation of the timelock script, null for other script types" - ScriptBytes # "CBOR encoded plutus script data, null for other script types" - ScriptSerialisedSize # "The size of the CBOR serialised script, if it is a Plutus script." - - Datum --^ do - "A table containing Plutus Datum, found in witnesses or inlined in outputs" - DatumHash # "The Hash of the Datum" - DatumTxId # "The Tx table index for the transaction where this script first became available." - DatumValue # "The actual data in JSON format (detailed schema)" - DatumBytes # "The actual data in CBOR format" - - RedeemerData --^ do - "A table containing Plutus Redeemer Data. These are always referenced by at least one redeemer. New in v13: split from datum table." - RedeemerDataHash # "The Hash of the Plutus Data" - RedeemerDataTxId # "The Tx table index for the transaction where this script first became available." - RedeemerDataValue # "The actual data in JSON format (detailed schema)" - RedeemerDataBytes # "The actual data in CBOR format" - - ExtraKeyWitness --^ do - "A table containing transaction extra key witness hashes." - ExtraKeyWitnessHash # "The hash of the witness." - ExtraKeyWitnessTxId # "The id of the tx this witness belongs to." - - ParamProposal --^ do - "A table containing block chain parameter change proposals." - ParamProposalEpochNo # "The epoch for which this parameter proposal in intended to become active." - ParamProposalKey # "The hash of the crypto key used to sign this proposal." - ParamProposalMinFeeA # "The 'a' parameter to calculate the minimum transaction fee." - ParamProposalMinFeeB # "The 'b' parameter to calculate the minimum transaction fee." - ParamProposalMaxBlockSize # "The maximum block size (in bytes)." - ParamProposalMaxTxSize # "The maximum transaction size (in bytes)." - ParamProposalMaxBhSize # "The maximum block header size (in bytes)." - ParamProposalKeyDeposit # "The amount (in Lovelace) require for a deposit to register a StakeAddress." - ParamProposalPoolDeposit # "The amount (in Lovelace) require for a deposit to register a stake pool." - ParamProposalMaxEpoch # "The maximum number of epochs in the future that a pool retirement is allowed to be scheduled for." - ParamProposalOptimalPoolCount # "The optimal number of stake pools." - ParamProposalInfluence # "The influence of the pledge on a stake pool's probability on minting a block." - ParamProposalMonetaryExpandRate # "The monetary expansion rate." - ParamProposalTreasuryGrowthRate # "The treasury growth rate." - ParamProposalDecentralisation # "The decentralisation parameter (1 fully centralised, 0 fully decentralised)." - ParamProposalEntropy # "The 32 byte string of extra random-ness to be added into the protocol's entropy pool." - ParamProposalProtocolMajor # "The protocol major number." - ParamProposalProtocolMinor # "The protocol minor number." - ParamProposalMinUtxoValue # "The minimum value of a UTxO entry." - ParamProposalMinPoolCost # "The minimum pool cost." - ParamProposalCoinsPerUtxoSize # "For Alonzo this is the cost per UTxO word. For Babbage and later per UTxO byte. New in v13: Renamed from coins_per_utxo_word." - ParamProposalCostModelId # "The CostModel table index for the proposal." - ParamProposalPriceMem # "The per word cost of script memory usage." - ParamProposalPriceStep # "The cost of script execution step usage." - ParamProposalMaxTxExMem # "The maximum number of execution memory allowed to be used in a single transaction." - ParamProposalMaxTxExSteps # "The maximum number of execution steps allowed to be used in a single transaction." - ParamProposalMaxBlockExMem # "The maximum number of execution memory allowed to be used in a single block." - ParamProposalMaxBlockExSteps # "The maximum number of execution steps allowed to be used in a single block." - ParamProposalMaxValSize # "The maximum Val size." - ParamProposalCollateralPercent # "The percentage of the txfee which must be provided as collateral when including non-native scripts." - ParamProposalMaxCollateralInputs # "The maximum number of collateral inputs allowed in a transaction." - ParamProposalRegisteredTxId # "The Tx table index for the transaction that contains this parameter proposal." - - EpochParam --^ do - "The accepted protocol parameters for an epoch." - EpochParamEpochNo # "The first epoch for which these parameters are valid." - EpochParamMinFeeA # "The 'a' parameter to calculate the minimum transaction fee." - EpochParamMinFeeB # "The 'b' parameter to calculate the minimum transaction fee." - EpochParamMaxBlockSize # "The maximum block size (in bytes)." - EpochParamMaxTxSize # "The maximum transaction size (in bytes)." - EpochParamMaxBhSize # "The maximum block header size (in bytes)." - EpochParamKeyDeposit # "The amount (in Lovelace) require for a deposit to register a StakeAddress." - EpochParamPoolDeposit # "The amount (in Lovelace) require for a deposit to register a stake pool." - EpochParamMaxEpoch # "The maximum number of epochs in the future that a pool retirement is allowed to be scheduled for." - EpochParamOptimalPoolCount # "The optimal number of stake pools." - EpochParamInfluence # "The influence of the pledge on a stake pool's probability on minting a block." - EpochParamMonetaryExpandRate # "The monetary expansion rate." - EpochParamTreasuryGrowthRate # "The treasury growth rate." - EpochParamDecentralisation # "The decentralisation parameter (1 fully centralised, 0 fully decentralised)." - EpochParamExtraEntropy # "The 32 byte string of extra random-ness to be added into the protocol's entropy pool. New in v13: renamed from entopy." - EpochParamProtocolMajor # "The protocol major number." - EpochParamProtocolMinor # "The protocol minor number." - EpochParamMinUtxoValue # "The minimum value of a UTxO entry." - EpochParamMinPoolCost # "The minimum pool cost." - EpochParamNonce # "The nonce value for this epoch." - EpochParamCoinsPerUtxoSize # "For Alonzo this is the cost per UTxO word. For Babbage and later per UTxO byte. New in v13: Renamed from coins_per_utxo_word." - EpochParamCostModelId # "The CostModel table index for the params." - EpochParamPriceMem # "The per word cost of script memory usage." - EpochParamPriceStep # "The cost of script execution step usage." - EpochParamMaxTxExMem # "The maximum number of execution memory allowed to be used in a single transaction." - EpochParamMaxTxExSteps # "The maximum number of execution steps allowed to be used in a single transaction." - EpochParamMaxBlockExMem # "The maximum number of execution memory allowed to be used in a single block." - EpochParamMaxBlockExSteps # "The maximum number of execution steps allowed to be used in a single block." - EpochParamMaxValSize # "The maximum Val size." - EpochParamCollateralPercent # "The percentage of the txfee which must be provided as collateral when including non-native scripts." - EpochParamMaxCollateralInputs # "The maximum number of collateral inputs allowed in a transaction." - EpochParamBlockId # "The Block table index for the first block where these parameters are valid." - - CostModel --^ do - "CostModel for EpochParam and ParamProposal." - CostModelHash # "The hash of cost model. It ensures uniqueness of entries. New in v13." - CostModelCosts # "The actual costs formatted as json." - - OffChainPoolData --^ do - "The pool offchain (ie not on chain) for a stake pool." - OffChainPoolDataPoolId # "The PoolHash table index for the pool this offchain data refers." - OffChainPoolDataTickerName # "The pool's ticker name (as many as 5 characters)." - OffChainPoolDataHash # "The hash of the offchain data." - OffChainPoolDataJson # "The payload as JSON." - OffChainPoolDataBytes # "The raw bytes of the payload." - OffChainPoolDataPmrId # "The PoolMetadataRef table index for this offchain data." - - OffChainPoolFetchError --^ do - "A table containing pool offchain data fetch errors." - OffChainPoolFetchErrorPoolId # "The PoolHash table index for the pool this offchain fetch error refers." - OffChainPoolFetchErrorFetchTime # "The UTC time stamp of the error." - OffChainPoolFetchErrorPmrId # "The PoolMetadataRef table index for this offchain data." - OffChainPoolFetchErrorFetchError # "The text of the error." - OffChainPoolFetchErrorRetryCount # "The number of retries." - - ReservedPoolTicker --^ do - "A table containing a managed list of reserved ticker names." - ReservedPoolTickerName # "The ticker name." - ReservedPoolTickerPoolHash # "The hash of the pool that owns this ticker." - - DelistedPool --^ do - "A table containing pools that have been delisted." - DelistedPoolHashRaw # "The pool hash" diff --git a/cardano-db/src/Cardano/Db/MinId.hs b/cardano-db/src/Cardano/Db/MinId.hs deleted file mode 100644 index 4f7c45423..000000000 --- a/cardano-db/src/Cardano/Db/MinId.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - -module Cardano.Db.MinId where - -import Cardano.Db.Schema -import Cardano.Prelude -import qualified Data.Text as Text -import Database.Persist.Sql (SqlBackend, ToBackendKey, fromSqlKey, toSqlKey) - -data MinIds = MinIds - { minTxInId :: Maybe TxInId - , minTxOutId :: Maybe TxOutId - , minMaTxOutId :: Maybe MaTxOutId - } - -instance Monoid MinIds where - mempty = MinIds Nothing Nothing Nothing - -instance Semigroup MinIds where - mn1 <> mn2 = - MinIds - { minTxInId = minJust (minTxInId mn1) (minTxInId mn2) - , minTxOutId = minJust (minTxOutId mn1) (minTxOutId mn2) - , minMaTxOutId = minJust (minMaTxOutId mn1) (minMaTxOutId mn2) - } - -textToMinId :: Text -> Maybe MinIds -textToMinId txt = - case Text.split (== ':') txt of - [tminTxInId, tminTxOutId, tminMaTxOutId] -> - Just $ - MinIds - { minTxInId = toSqlKey <$> readKey tminTxInId - , minTxOutId = toSqlKey <$> readKey tminTxOutId - , minMaTxOutId = toSqlKey <$> readKey tminMaTxOutId - } - _ -> Nothing - where - readKey :: Text -> Maybe Int64 - readKey "" = Nothing - readKey str = readMaybe (Text.unpack str) - -minIdsToText :: MinIds -> Text -minIdsToText minIds = - Text.intercalate - ":" - [ fromKey $ minTxInId minIds - , fromKey $ minTxOutId minIds - , fromKey $ minMaTxOutId minIds - ] - where - fromKey :: ToBackendKey SqlBackend record => Maybe (Key record) -> Text - fromKey Nothing = "" - fromKey (Just k) = textShow $ fromSqlKey k - -minJust :: Ord a => Maybe a -> Maybe a -> Maybe a -minJust (Just a) (Just b) = Just $ min a b -minJust (Just a) _ = Just a -minJust _ x = x diff --git a/cardano-db/src/Cardano/Db/Multiplex.hs b/cardano-db/src/Cardano/Db/Multiplex.hs deleted file mode 100644 index d90b070fe..000000000 --- a/cardano-db/src/Cardano/Db/Multiplex.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} - -module Cardano.Db.Multiplex ( - insertTxOutPlex, - insertManyTxOutPlex, - updateListTxOutConsumedByTxId, - setNullTxOut, - runExtraMigrations, - ExtraCons.deleteConsumedTxOut, - ExtraCons.queryWrongConsumedBy, -) where - -import Cardano.BM.Trace (Trace, logInfo) -import Cardano.Db.Error (LookupFail (..), logAndThrowIO) -import Cardano.Db.Insert -import qualified Cardano.Db.Migration.Extra.CosnumedTxOut.Queries as ExtraCons -import qualified Cardano.Db.Migration.Extra.CosnumedTxOut.Schema as ExtraCons -import Cardano.Db.Query (queryAllExtraMigrations) -import Cardano.Db.Schema -import Cardano.Db.Types (ExtraMigration (..), PruneConsumeMigration (..), wasPruneTxOutPreviouslySet) -import Control.Exception (throw) -import Control.Monad (unless, void) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad.Trans.Reader (ReaderT) -import Data.Text (Text) -import Data.Word (Word64) -import Database.Persist.Sql (SqlBackend, ToBackendKey (..)) - -insertTxOutPlex :: - (MonadBaseControl IO m, MonadIO m) => - Bool -> - Bool -> - TxOut -> - ReaderT SqlBackend m () -insertTxOutPlex hasConsMigration disInOut txOut = do - case (hasConsMigration, disInOut) of - (_, True) -> pure () - (False, _) -> - void $ insertTxOut txOut - (True, _) -> - void $ ExtraCons.insertTxOutExtra (toExtraTxOut txOut) - -insertManyTxOutPlex :: (MonadBaseControl IO m, MonadIO m) => Bool -> Bool -> [TxOut] -> ReaderT SqlBackend m [TxOutId] -insertManyTxOutPlex hasConsMigration disInOut txOuts = - case (hasConsMigration, disInOut) of - (_, True) -> pure [] - (False, _) -> - insertManyTxOut txOuts - (True, _) -> - fmap changeKey <$> ExtraCons.insertManyTxOutExtra (toExtraTxOut <$> txOuts) - -changeKey :: - ( ToBackendKey SqlBackend record1 - , ToBackendKey SqlBackend record2 - ) => - Key record1 -> - Key record2 -changeKey = fromBackendKey . toBackendKey - -toExtraTxOut :: TxOut -> ExtraCons.TxOut -toExtraTxOut txOut = - ExtraCons.TxOut - { ExtraCons.txOutTxId = changeKey $ txOutTxId txOut - , ExtraCons.txOutIndex = txOutIndex txOut - , ExtraCons.txOutAddress = txOutAddress txOut - , ExtraCons.txOutAddressHasScript = txOutAddressHasScript txOut - , ExtraCons.txOutPaymentCred = txOutPaymentCred txOut - , ExtraCons.txOutStakeAddressId = changeKey <$> txOutStakeAddressId txOut - , ExtraCons.txOutValue = txOutValue txOut - , ExtraCons.txOutDataHash = txOutDataHash txOut - , ExtraCons.txOutInlineDatumId = changeKey <$> txOutInlineDatumId txOut - , ExtraCons.txOutReferenceScriptId = changeKey <$> txOutReferenceScriptId txOut - , ExtraCons.txOutConsumedByTxId = Nothing - } - -updateListTxOutConsumedByTxId :: MonadIO m => [(TxOutId, TxId)] -> ReaderT SqlBackend m () -updateListTxOutConsumedByTxId ls = do - ExtraCons.queryUpdateListTxOutConsumedByTxId (f <$> ls) - where - f (txOutId, txInId) = (changeKey txOutId, changeKey txInId) - -setNullTxOut :: MonadIO m => Trace IO Text -> Maybe TxId -> ReaderT SqlBackend m () -setNullTxOut trce mMinTxInId = - ExtraCons.querySetNullTxOut trce (changeKey <$> mMinTxInId) - -runExtraMigrations :: (MonadBaseControl IO m, MonadIO m) => Trace IO Text -> Word64 -> PruneConsumeMigration -> ReaderT SqlBackend m () -runExtraMigrations trce blockNoDiff PruneConsumeMigration {..} = do - hasConsumedField <- ExtraCons.queryTxConsumedColumnExists - ems <- queryAllExtraMigrations - let wPruneTxOutPreviouslySet = wasPruneTxOutPreviouslySet ems - -- first check if pruneTxOut flag is missing and it has previously been used - case (pcmPruneTxOut, wPruneTxOutPreviouslySet) of - (False, True) -> - throw $ - DBExtraMigration - ( "If --prune-tx-out flag is enabled and then db-sync is stopped all future executions of db-sync " - <> "should still have this flag activated. Otherwise, it is considered bad usage and can cause crashes." - ) - _ -> do - case (hasConsumedField, pcmConsumeOrPruneTxOut, pcmPruneTxOut) of - (False, False, False) -> do - liftIO $ logInfo trce "No extra migration specified" - (True, True, False) -> do - liftIO $ logInfo trce "Extra migration consumed_tx_out already executed" - (True, False, False) -> liftIO $ logAndThrowIO trce migratedButNotSet - (False, True, False) -> do - liftIO $ logInfo trce "Running extra migration consumed_tx_out" - ExtraCons.migrateTxOut (Just trce) - (False, _, True) -> do - shouldInsertToMigrationTable - ExtraCons.deleteAndUpdateConsumedTxOut trce blockNoDiff - (True, _, True) -> do - shouldInsertToMigrationTable - liftIO $ logInfo trce "Running extra migration prune tx_out" - ExtraCons.deleteConsumedTxOut trce blockNoDiff - where - migratedButNotSet = "consumed-tx-out or prune-tx-out is not set, but consumed migration is found." - -- if PruneTxOutFlagPreviouslySet isn't already set then set it. - shouldInsertToMigrationTable :: (MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m () - shouldInsertToMigrationTable = do - unless wPruneTxOutPreviouslySet $ insertExtraMigration PruneTxOutFlagPreviouslySet diff --git a/cardano-db/src/Cardano/Db/Old/V13_0.hs b/cardano-db/src/Cardano/Db/Old/V13_0.hs deleted file mode 100644 index fa3368a87..000000000 --- a/cardano-db/src/Cardano/Db/Old/V13_0.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Cardano.Db.Old.V13_0 ( - module X, -) where - -import Cardano.Db.Old.V13_0.Query as X -import Cardano.Db.Old.V13_0.Schema as X diff --git a/cardano-db/src/Cardano/Db/AlterTable.hs b/cardano-db/src/Cardano/Db/Operations/Core/AlterTable.hs similarity index 98% rename from cardano-db/src/Cardano/Db/AlterTable.hs rename to cardano-db/src/Cardano/Db/Operations/Core/AlterTable.hs index f7165f754..3523c6138 100644 --- a/cardano-db/src/Cardano/Db/AlterTable.hs +++ b/cardano-db/src/Cardano/Db/Operations/Core/AlterTable.hs @@ -5,7 +5,7 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-unused-local-binds #-} -module Cardano.Db.AlterTable ( +module Cardano.Db.Operations.Core.AlterTable ( AlterTable (..), DbAlterTableException (..), ManualDbConstraints (..), diff --git a/cardano-db/src/Cardano/Db/Delete.hs b/cardano-db/src/Cardano/Db/Operations/Core/Delete.hs similarity index 74% rename from cardano-db/src/Cardano/Db/Delete.hs rename to cardano-db/src/Cardano/Db/Operations/Core/Delete.hs index d26a32e65..d59446d57 100644 --- a/cardano-db/src/Cardano/Db/Delete.hs +++ b/cardano-db/src/Cardano/Db/Operations/Core/Delete.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} @@ -6,7 +8,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} -module Cardano.Db.Delete ( +module Cardano.Db.Operations.Core.Delete ( deleteBlocksSlotNo, deleteBlocksSlotNoNoTrace, deleteDelistedPool, @@ -18,15 +20,17 @@ module Cardano.Db.Delete ( deleteRewardRest, deletePoolStat, deleteAdaPots, - deleteTxOut, -- for testing queryFirstAndDeleteAfter, ) where import Cardano.BM.Trace (Trace, logWarning, nullTracer) -import Cardano.Db.MinId -import Cardano.Db.Query hiding (isJust) -import Cardano.Db.Schema +import Cardano.Db.Operations.Core.MinId (MinIds (..), MinIdsWrapper (..), completeMinId, textToMinIds) +import Cardano.Db.Operations.Core.Query +import Cardano.Db.Operations.Types (TxOutTableType (..)) +import Cardano.Db.Schema.BaseSchema +import qualified Cardano.Db.Schema.Core.TxOut as C +import qualified Cardano.Db.Schema.Variant.TxOut as V import Cardano.Prelude (Int64) import Cardano.Slotting.Slot (SlotNo (..)) import Control.Monad (void) @@ -40,7 +44,6 @@ import Data.Word (Word64) import Database.Esqueleto.Experimental (PersistEntity, PersistField, persistIdField) import Database.Persist.Class.PersistQuery (deleteWhere) import Database.Persist.Sql ( - Filter, PersistEntityBackend, SqlBackend, delete, @@ -52,34 +55,34 @@ import Database.Persist.Sql ( (>=.), ) -deleteBlocksSlotNoNoTrace :: MonadIO m => SlotNo -> ReaderT SqlBackend m Bool +deleteBlocksSlotNoNoTrace :: MonadIO m => TxOutTableType -> SlotNo -> ReaderT SqlBackend m Bool deleteBlocksSlotNoNoTrace = deleteBlocksSlotNo nullTracer -- | Delete a block if it exists. Returns 'True' if it did exist and has been -- deleted and 'False' if it did not exist. -deleteBlocksSlotNo :: MonadIO m => Trace IO Text -> SlotNo -> ReaderT SqlBackend m Bool -deleteBlocksSlotNo trce (SlotNo slotNo) = do +deleteBlocksSlotNo :: MonadIO m => Trace IO Text -> TxOutTableType -> SlotNo -> ReaderT SqlBackend m Bool +deleteBlocksSlotNo trce txOutTableType (SlotNo slotNo) = do mBlockId <- queryBlockSlotNo slotNo case mBlockId of Nothing -> pure False Just blockId -> do - void $ deleteBlocksBlockId trce blockId + void $ deleteBlocksBlockId trce txOutTableType blockId pure True -deleteBlocksBlockIdNotrace :: MonadIO m => BlockId -> ReaderT SqlBackend m () -deleteBlocksBlockIdNotrace = void . deleteBlocksBlockId nullTracer +deleteBlocksBlockIdNotrace :: MonadIO m => TxOutTableType -> BlockId -> ReaderT SqlBackend m () +deleteBlocksBlockIdNotrace txOutTableType = void . deleteBlocksBlockId nullTracer txOutTableType -- | Delete starting from a 'BlockId'. -deleteBlocksBlockId :: MonadIO m => Trace IO Text -> BlockId -> ReaderT SqlBackend m (Maybe TxId, Int64) -deleteBlocksBlockId trce blockId = do - mMinIds <- fmap (textToMinId =<<) <$> queryReverseIndexBlockId blockId +deleteBlocksBlockId :: MonadIO m => Trace IO Text -> TxOutTableType -> BlockId -> ReaderT SqlBackend m (Maybe TxId, Int64) +deleteBlocksBlockId trce txOutTableType blockId = do + mMinIds <- fmap (textToMinIds txOutTableType =<<) <$> queryReverseIndexBlockId blockId (cminIds, completed) <- findMinIdsRec mMinIds mempty mTxId <- queryMinRefId TxBlockId blockId minIds <- if completed then pure cminIds else completeMinId mTxId cminIds blockCountInt <- deleteTablesAfterBlockId blockId mTxId minIds pure (mTxId, blockCountInt) where - findMinIdsRec :: MonadIO m => [Maybe MinIds] -> MinIds -> ReaderT SqlBackend m (MinIds, Bool) + findMinIdsRec :: MonadIO m => [Maybe MinIdsWrapper] -> MinIdsWrapper -> ReaderT SqlBackend m (MinIdsWrapper, Bool) findMinIdsRec [] minIds = pure (minIds, True) findMinIdsRec (mMinIds : rest) minIds = case mMinIds of @@ -95,22 +98,14 @@ deleteBlocksBlockId trce blockId = do then pure (minIds', True) else findMinIdsRec rest minIds' - isComplete (MinIds m1 m2 m3) = isJust m1 && isJust m2 && isJust m3 + isComplete minIdsW = case minIdsW of + CMinIdsWrapper (MinIds m1 m2 m3) -> isJust m1 && isJust m2 && isJust m3 + VMinIdsWrapper (MinIds m1 m2 m3) -> isJust m1 && isJust m2 && isJust m3 -completeMinId :: MonadIO m => Maybe TxId -> MinIds -> ReaderT SqlBackend m MinIds -completeMinId mTxId minIds = do - case mTxId of - Nothing -> pure mempty - Just txId -> do - mTxInId <- whenNothingQueryMinRefId (minTxInId minIds) TxInTxInId txId - mTxOutId <- whenNothingQueryMinRefId (minTxOutId minIds) TxOutTxId txId - mMaTxOutId <- case mTxOutId of - Nothing -> pure Nothing - Just txOutId -> whenNothingQueryMinRefId (minMaTxOutId minIds) MaTxOutTxOutId txOutId - pure $ MinIds mTxInId mTxOutId mMaTxOutId +-- (MinIds m1 m2 m3) isJust m1 && isJust m2 && isJust m3 -deleteTablesAfterBlockId :: MonadIO m => BlockId -> Maybe TxId -> MinIds -> ReaderT SqlBackend m Int64 -deleteTablesAfterBlockId blkId mtxId minIds = do +deleteTablesAfterBlockId :: MonadIO m => BlockId -> Maybe TxId -> MinIdsWrapper -> ReaderT SqlBackend m Int64 +deleteTablesAfterBlockId blkId mtxId minIdsW = do deleteWhere [AdaPotsBlockId >=. blkId] deleteWhere [ReverseIndexBlockId >=. blkId] deleteWhere [EpochParamBlockId >=. blkId] @@ -127,14 +122,20 @@ deleteTablesAfterBlockId blkId mtxId minIds = do queryFirstAndDeleteAfter OffChainVoteDataVotingAnchorId vaId queryFirstAndDeleteAfter OffChainVoteFetchErrorVotingAnchorId vaId deleteWhere [VotingAnchorId >=. vaId] - deleteTablesAfterTxId mtxId (minTxInId minIds) (minTxOutId minIds) (minMaTxOutId minIds) + deleteTablesAfterTxId mtxId minIdsW deleteWhereCount [BlockId >=. blkId] -deleteTablesAfterTxId :: MonadIO m => Maybe TxId -> Maybe TxInId -> Maybe TxOutId -> Maybe MaTxOutId -> ReaderT SqlBackend m () -deleteTablesAfterTxId mtxId mtxInId mtxOutId mmaTxOutId = do - whenJust mtxInId $ \txInId -> deleteWhere [TxInId >=. txInId] - whenJust mmaTxOutId $ \maTxOutId -> deleteWhere [MaTxOutId >=. maTxOutId] - whenJust mtxOutId $ \txOutId -> deleteWhere [TxOutId >=. txOutId] +deleteTablesAfterTxId :: (MonadIO m) => Maybe TxId -> MinIdsWrapper -> ReaderT SqlBackend m () +deleteTablesAfterTxId mtxId minIdsW = do + case minIdsW of + CMinIdsWrapper (MinIds mtxInId mtxOutId mmaTxOutId) -> do + whenJust mtxInId $ \txInId -> deleteWhere [TxInId >=. txInId] + whenJust mtxOutId $ \txOutId -> deleteWhere [C.TxOutId >=. txOutId] + whenJust mmaTxOutId $ \maTxOutId -> deleteWhere [C.MaTxOutId >=. maTxOutId] + VMinIdsWrapper (MinIds mtxInId mtxOutId mmaTxOutId) -> do + whenJust mtxInId $ \txInId -> deleteWhere [TxInId >=. txInId] + whenJust mtxOutId $ \txOutId -> deleteWhere [V.TxOutId >=. txOutId] + whenJust mmaTxOutId $ \maTxOutId -> deleteWhere [V.MaTxOutId >=. maTxOutId] whenJust mtxId $ \txId -> do queryFirstAndDeleteAfter CollateralTxOutTxId txId @@ -210,27 +211,15 @@ deleteDelistedPool poolHash = do mapM_ delete keys pure $ not (null keys) -whenNothingQueryMinRefId :: - forall m record field. - (MonadIO m, PersistEntity record, PersistField field) => - Maybe (Key record) -> - EntityField record field -> - field -> - ReaderT SqlBackend m (Maybe (Key record)) -whenNothingQueryMinRefId mKey efield field = do - case mKey of - Just k -> pure $ Just k - Nothing -> queryMinRefId efield field - -- | Delete a block if it exists. Returns 'True' if it did exist and has been -- deleted and 'False' if it did not exist. -deleteBlock :: MonadIO m => Block -> ReaderT SqlBackend m Bool -deleteBlock block = do +deleteBlock :: MonadIO m => TxOutTableType -> Block -> ReaderT SqlBackend m Bool +deleteBlock txOutTableType block = do mBlockId <- listToMaybe <$> selectKeysList [BlockHash ==. blockHash block] [] case mBlockId of Nothing -> pure False Just blockId -> do - void $ deleteBlocksBlockId nullTracer blockId + void $ deleteBlocksBlockId nullTracer txOutTableType blockId pure True deleteEpochRows :: MonadIO m => Word64 -> ReaderT SqlBackend m () @@ -252,6 +241,3 @@ deletePoolStat epochNum = do deleteAdaPots :: MonadIO m => BlockId -> ReaderT SqlBackend m () deleteAdaPots blkId = do deleteWhere [AdaPotsBlockId ==. blkId] - -deleteTxOut :: MonadIO m => ReaderT SqlBackend m Int64 -deleteTxOut = deleteWhereCount ([] :: [Filter TxOut]) diff --git a/cardano-db/src/Cardano/Db/Insert.hs b/cardano-db/src/Cardano/Db/Operations/Core/Insert.hs similarity index 97% rename from cardano-db/src/Cardano/Db/Insert.hs rename to cardano-db/src/Cardano/Db/Operations/Core/Insert.hs index 78c120d2a..f937bf696 100644 --- a/cardano-db/src/Cardano/Db/Insert.hs +++ b/cardano-db/src/Cardano/Db/Operations/Core/Insert.hs @@ -6,7 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module Cardano.Db.Insert ( +module Cardano.Db.Operations.Core.Insert ( insertAdaPots, insertBlock, insertCollateralTxIn, @@ -22,7 +22,6 @@ module Cardano.Db.Insert ( insertManyDrepDistr, insertManyTxIn, insertMaTxMint, - insertManyMaTxOut, insertMeta, insertMultiAssetUnchecked, insertParamProposal, @@ -45,10 +44,7 @@ module Cardano.Db.Insert ( insertTxIn, insertManyTxMint, insertManyTxMetadata, - insertTxOut, insertCollateralTxOut, - insertManyTxOut, - insertAddressDetail, insertWithdrawal, insertRedeemer, insertCostModel, @@ -101,8 +97,8 @@ module Cardano.Db.Insert ( insertBlockChecked, ) where -import Cardano.Db.Query -import Cardano.Db.Schema +import Cardano.Db.Operations.Core.Query +import Cardano.Db.Schema.BaseSchema import Cardano.Db.Types import Cardano.Prelude (textShow) import Control.Exception.Lifted (Exception, handle, throwIO) @@ -236,9 +232,6 @@ insertManyTxIn = insertMany' "Many TxIn" insertMaTxMint :: (MonadBaseControl IO m, MonadIO m) => MaTxMint -> ReaderT SqlBackend m MaTxMintId insertMaTxMint = insertUnchecked "insertMaTxMint" -insertManyMaTxOut :: (MonadBaseControl IO m, MonadIO m) => [MaTxOut] -> ReaderT SqlBackend m [MaTxOutId] -insertManyMaTxOut = insertMany' "Many MaTxOut" - insertMeta :: (MonadBaseControl IO m, MonadIO m) => Meta -> ReaderT SqlBackend m MetaId insertMeta = insertCheckUnique "Meta" @@ -305,18 +298,9 @@ insertManyTxMint = insertMany' "TxMint" insertTxCBOR :: (MonadBaseControl IO m, MonadIO m) => TxCbor -> ReaderT SqlBackend m TxCborId insertTxCBOR = insertUnchecked "TxCBOR" -insertTxOut :: (MonadBaseControl IO m, MonadIO m) => TxOut -> ReaderT SqlBackend m TxOutId -insertTxOut = insertUnchecked "TxOut" - insertCollateralTxOut :: (MonadBaseControl IO m, MonadIO m) => CollateralTxOut -> ReaderT SqlBackend m CollateralTxOutId insertCollateralTxOut = insertUnchecked "CollateralTxOut" -insertManyTxOut :: (MonadBaseControl IO m, MonadIO m) => [TxOut] -> ReaderT SqlBackend m [TxOutId] -insertManyTxOut = insertMany' "TxOut" - -insertAddressDetail :: (MonadBaseControl IO m, MonadIO m) => AddressDetail -> ReaderT SqlBackend m AddressDetailId -insertAddressDetail = insertUnchecked "insertAddressDetail" - insertWithdrawal :: (MonadBaseControl IO m, MonadIO m) => Withdrawal -> ReaderT SqlBackend m WithdrawalId insertWithdrawal = insertUnchecked "Withdrawal" diff --git a/cardano-db/src/Cardano/Db/Operations/Core/MinId.hs b/cardano-db/src/Cardano/Db/Operations/Core/MinId.hs new file mode 100644 index 000000000..127f7e0a1 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Operations/Core/MinId.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Cardano.Db.Operations.Core.MinId where + +import Cardano.Db.Operations.Core.Query (queryMinRefId) +import Cardano.Db.Operations.Types (MaTxOutFields (..), TxOutFields (..), TxOutTableType (..)) +import Cardano.Db.Schema.BaseSchema +import qualified Cardano.Db.Schema.Core.TxOut as C +import qualified Cardano.Db.Schema.Variant.TxOut as V +import Cardano.Prelude +import qualified Data.Text as Text +import Database.Persist.Sql (PersistEntity, PersistField, SqlBackend, fromSqlKey, toSqlKey) + +data MinIds (a :: TxOutTableType) = MinIds + { minTxInId :: Maybe TxInId + , minTxOutId :: Maybe (TxOutIdFor a) + , minMaTxOutId :: Maybe (MaTxOutIdFor a) + } + +instance (TxOutFields a, MaTxOutFields a, Ord (TxOutIdFor a), Ord (MaTxOutIdFor a)) => Monoid (MinIds a) where + mempty = MinIds Nothing Nothing Nothing + +instance (TxOutFields a, MaTxOutFields a, Ord (TxOutIdFor a), Ord (MaTxOutIdFor a)) => Semigroup (MinIds a) where + mn1 <> mn2 = + MinIds + { minTxInId = minJust (minTxInId mn1) (minTxInId mn2) + , minTxOutId = minJust (minTxOutId mn1) (minTxOutId mn2) + , minMaTxOutId = minJust (minMaTxOutId mn1) (minMaTxOutId mn2) + } + +data MinIdsWrapper + = CMinIdsWrapper (MinIds 'TxOutCore) + | VMinIdsWrapper (MinIds 'TxOutVariantAddress) + +instance Monoid MinIdsWrapper where + mempty = CMinIdsWrapper mempty -- or VMinIdsWrapper mempty, depending on your preference + +instance Semigroup MinIdsWrapper where + (CMinIdsWrapper a) <> (CMinIdsWrapper b) = CMinIdsWrapper (a <> b) + (VMinIdsWrapper a) <> (VMinIdsWrapper b) = VMinIdsWrapper (a <> b) + _ <> b = b -- If types don't match, return the second argument which is a no-op + +minIdsToText :: MinIdsWrapper -> Text +minIdsToText (CMinIdsWrapper minIds) = minIdsCoreToText minIds +minIdsToText (VMinIdsWrapper minIds) = minIdsVariantToText minIds + +textToMinIds :: TxOutTableType -> Text -> Maybe MinIdsWrapper +textToMinIds txOutTableType txt = + case txOutTableType of + TxOutCore -> CMinIdsWrapper <$> textToMinIdsCore txt + TxOutVariantAddress -> VMinIdsWrapper <$> textToMinIdsVariant txt + +minIdsCoreToText :: MinIds 'TxOutCore -> Text +minIdsCoreToText minIds = + Text.intercalate + ":" + [ maybe "" (Text.pack . show . fromSqlKey) $ minTxInId minIds + , maybe "" (Text.pack . show . fromSqlKey) $ minTxOutId minIds + , maybe "" (Text.pack . show . fromSqlKey) $ minMaTxOutId minIds + ] + +minIdsVariantToText :: MinIds 'TxOutVariantAddress -> Text +minIdsVariantToText minIds = + Text.intercalate + ":" + [ maybe "" (Text.pack . show . fromSqlKey) $ minTxInId minIds + , maybe "" (Text.pack . show) $ minTxOutId minIds + , maybe "" (Text.pack . show . fromSqlKey) $ minMaTxOutId minIds + ] + +textToMinIdsCore :: Text -> Maybe (MinIds 'TxOutCore) +textToMinIdsCore txt = + case Text.split (== ':') txt of + [tminTxInId, tminTxOutId, tminMaTxOutId] -> + Just $ + MinIds + { minTxInId = toSqlKey <$> readMaybe (Text.unpack tminTxInId) + , minTxOutId = toSqlKey <$> readMaybe (Text.unpack tminTxOutId) + , minMaTxOutId = toSqlKey <$> readMaybe (Text.unpack tminMaTxOutId) + } + _otherwise -> Nothing + +textToMinIdsVariant :: Text -> Maybe (MinIds 'TxOutVariantAddress) +textToMinIdsVariant txt = + case Text.split (== ':') txt of + [tminTxInId, tminTxOutId, tminMaTxOutId] -> + Just $ + MinIds + { minTxInId = toSqlKey <$> readMaybe (Text.unpack tminTxInId) + , minTxOutId = readMaybe (Text.unpack tminTxOutId) + , minMaTxOutId = toSqlKey <$> readMaybe (Text.unpack tminMaTxOutId) + } + _otherwise -> Nothing + +minJust :: (Ord a) => Maybe a -> Maybe a -> Maybe a +minJust Nothing y = y +minJust x Nothing = x +minJust (Just x) (Just y) = Just (min x y) + +-------------------------------------------------------------------------------- +-- CompleteMinId +-------------------------------------------------------------------------------- +-- example use case would be: `result <- completeMinId @'TxOutCore mTxId minIds` +completeMinId :: + (MonadIO m) => + Maybe TxId -> + MinIdsWrapper -> + ReaderT SqlBackend m MinIdsWrapper +completeMinId mTxId mIdW = case mIdW of + CMinIdsWrapper minIds -> CMinIdsWrapper <$> completeMinIdCore mTxId minIds + VMinIdsWrapper minIds -> VMinIdsWrapper <$> completeMinIdVariant mTxId minIds + +completeMinIdCore :: MonadIO m => Maybe TxId -> MinIds 'TxOutCore -> ReaderT SqlBackend m (MinIds 'TxOutCore) +completeMinIdCore mTxId minIds = do + case mTxId of + Nothing -> pure mempty + Just txId -> do + mTxInId <- whenNothingQueryMinRefId (minTxInId minIds) TxInTxInId txId + mTxOutId <- whenNothingQueryMinRefId (minTxOutId minIds) C.TxOutTxId txId + mMaTxOutId <- case mTxOutId of + Nothing -> pure Nothing + Just txOutId -> whenNothingQueryMinRefId (minMaTxOutId minIds) C.MaTxOutTxOutId txOutId + pure $ + MinIds + { minTxInId = mTxInId + , minTxOutId = mTxOutId + , minMaTxOutId = mMaTxOutId + } + +completeMinIdVariant :: MonadIO m => Maybe TxId -> MinIds 'TxOutVariantAddress -> ReaderT SqlBackend m (MinIds 'TxOutVariantAddress) +completeMinIdVariant mTxId minIds = do + case mTxId of + Nothing -> pure mempty + Just txId -> do + mTxInId <- whenNothingQueryMinRefId (minTxInId minIds) TxInTxInId txId + mTxOutId <- whenNothingQueryMinRefId (minTxOutId minIds) V.TxOutTxId txId + mMaTxOutId <- case mTxOutId of + Nothing -> pure Nothing + Just txOutId -> whenNothingQueryMinRefId (minMaTxOutId minIds) V.MaTxOutTxOutId txOutId + pure $ + MinIds + { minTxInId = mTxInId + , minTxOutId = mTxOutId + , minMaTxOutId = mMaTxOutId + } + +whenNothingQueryMinRefId :: + forall m record field. + (MonadIO m, PersistEntity record, PersistField field) => + Maybe (Key record) -> + EntityField record field -> + field -> + ReaderT SqlBackend m (Maybe (Key record)) +whenNothingQueryMinRefId mKey efield field = do + case mKey of + Just k -> pure $ Just k + Nothing -> queryMinRefId efield field diff --git a/cardano-db/src/Cardano/Db/Query.hs b/cardano-db/src/Cardano/Db/Operations/Core/Query.hs similarity index 75% rename from cardano-db/src/Cardano/Db/Query.hs rename to cardano-db/src/Cardano/Db/Operations/Core/Query.hs index ed846ccd0..0ec15a8df 100644 --- a/cardano-db/src/Cardano/Db/Query.hs +++ b/cardano-db/src/Cardano/Db/Operations/Core/Query.hs @@ -1,11 +1,10 @@ {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module Cardano.Db.Query ( +module Cardano.Db.Operations.Core.Query ( LookupFail (..), -- queries used by db-sync queryBlockCount, @@ -22,8 +21,6 @@ module Cardano.Db.Query ( queryCurrentEpochNo, queryNormalEpochRewardCount, queryGenesis, - queryGenesisSupply, - queryShelleyGenesisSupply, queryLatestBlock, queryLatestPoints, queryLatestEpochNo, @@ -37,14 +34,8 @@ module Cardano.Db.Query ( queryRedeemerData, querySlotHash, queryMultiAssetId, - queryTotalSupply, queryTxCount, queryTxId, - queryTxOutId, - queryTxOutValue, - queryTxOutIdValue, - queryTxOutCredentials, - queryAddressDetailId, queryEpochFromNum, queryEpochStakeCount, queryForEpochId, @@ -85,24 +76,18 @@ module Cardano.Db.Query ( queryFeesUpToBlockNo, queryFeesUpToSlotNo, queryLatestCachedEpochNo, - queryTxOutCount, queryLatestBlockNo, querySlotNosGreaterThan, querySlotNos, querySlotUtcTime, - queryUtxoAtBlockNo, - queryUtxoAtSlotNo, queryWithdrawalsUpToBlockNo, queryAdaPots, - queryAddressBalanceAtSlot, -- queries used only in tests - queryAddressOutputs, queryRewardCount, queryRewardRestCount, queryTxInCount, queryEpochCount, queryCostModel, - queryScriptOutputs, queryTxInRedeemer, queryTxInFailedTx, queryInvalidTx, @@ -113,25 +98,13 @@ module Cardano.Db.Query ( querySchemaVersion, queryPreviousSlotNo, queryMinBlock, - queryTxOutUnspentCount, -- utils - entityPair, - isJust, listToMaybe, - maybeToEither, - unBlockId, - unTxId, - unTxInId, - unTxOutId, - unValue2, - unValue3, - unValue4, - unValue5, - unValueSumAda, ) where import Cardano.Db.Error -import Cardano.Db.Schema +import Cardano.Db.Operations.Core.QueryHelper (defaultUTCTime, isJust, maybeToEither, unValue2, unValue3, unValue5, unValueSumAda) +import Cardano.Db.Schema.BaseSchema import Cardano.Db.Types import Cardano.Ledger.BaseTypes (CertIx (..), TxIx (..)) import Cardano.Ledger.Credential (Ptr (..)) @@ -140,7 +113,6 @@ import Control.Monad.Extra (join, whenJust) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Reader (ReaderT) import Data.ByteString.Char8 (ByteString) -import Data.Fixed (Micro) import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import Data.Ratio (numerator) import Data.Text (Text, unpack) @@ -152,10 +124,7 @@ import Database.Esqueleto.Experimental ( PersistEntity, PersistField, SqlBackend, - SqlExpr, - SqlQuery, Value (Value, unValue), - ValueList, asc, count, countRows, @@ -171,17 +140,13 @@ import Database.Esqueleto.Experimental ( limit, max_, min_, - notExists, - not_, on, orderBy, persistIdField, select, selectOne, - subList_select, sum_, table, - unSqlBackendKey, val, valList, where_, @@ -193,7 +158,6 @@ import Database.Esqueleto.Experimental ( (>=.), (?.), (^.), - (||.), type (:&) ((:&)), ) import Database.Persist.Class.PersistQuery (selectList) @@ -311,8 +275,6 @@ queryBlockId hash = do pure $ blk ^. BlockId pure $ maybeToEither (DbLookupBlockHash hash) unValue (listToMaybe res) ------------------------------------------------------------------------------------------------ - -- | Calculate the Epoch table entry for the specified epoch. -- When syncing the chain or filling an empty table, this is called at each epoch boundary to -- calculate the Epoch entry for the last epoch. @@ -416,11 +378,6 @@ emptyEpoch epochNum = , epochEndTime = defaultUTCTime } -defaultUTCTime :: UTCTime -defaultUTCTime = read "2000-01-01 00:00:00.000000 UTC" - ------------------------------------------------------------------------------------------------ - queryCurrentEpochNo :: MonadIO m => ReaderT SqlBackend m (Maybe Word64) queryCurrentEpochNo = do res <- select $ do @@ -450,38 +407,6 @@ queryGenesis = do [blk] -> pure $ Right (unValue blk) _ -> pure $ Left DBMultipleGenesis --- | Return the total Genesis coin supply. -queryGenesisSupply :: MonadIO m => ReaderT SqlBackend m Ada -queryGenesisSupply = do - res <- select $ do - (_tx :& txOut :& blk) <- - from - $ table @Tx - `innerJoin` table @TxOut - `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. TxOutTxId) - `innerJoin` table @Block - `on` (\(tx :& _txOut :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) - where_ (isNothing $ blk ^. BlockPreviousId) - pure $ sum_ (txOut ^. TxOutValue) - pure $ unValueSumAda (listToMaybe res) - --- | Return the total Shelley Genesis coin supply. The Shelley Genesis Block --- is the unique which has a non-null PreviousId, but has null Epoch. -queryShelleyGenesisSupply :: MonadIO m => ReaderT SqlBackend m Ada -queryShelleyGenesisSupply = do - res <- select $ do - (txOut :& _tx :& blk) <- - from - $ table @TxOut - `innerJoin` table @Tx - `on` (\(txOut :& tx) -> tx ^. TxId ==. txOut ^. TxOutTxId) - `innerJoin` table @Block - `on` (\(_txOut :& tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) - where_ (isJust $ blk ^. BlockPreviousId) - where_ (isNothing $ blk ^. BlockEpochNo) - pure $ sum_ (txOut ^. TxOutValue) - pure $ unValueSumAda (listToMaybe res) - -- | Get the latest block. queryLatestBlock :: MonadIO m => ReaderT SqlBackend m (Maybe Block) queryLatestBlock = do @@ -602,17 +527,6 @@ queryCountSlotNo = do pure countRows pure $ maybe 0 unValue (listToMaybe res) --- | Get the current total supply of Lovelace. This only returns the on-chain supply which --- does not include staking rewards that have not yet been withdrawn. Before wihdrawal --- rewards are part of the ledger state and hence not on chain. -queryTotalSupply :: MonadIO m => ReaderT SqlBackend m Ada -queryTotalSupply = do - res <- select $ do - txOut <- from $ table @TxOut - txOutUnspentP txOut - pure $ sum_ (txOut ^. TxOutValue) - pure $ unValueSumAda (listToMaybe res) - -- | Count the number of transactions in the Tx table. queryTxCount :: MonadIO m => ReaderT SqlBackend m Word queryTxCount = do @@ -630,66 +544,6 @@ queryTxId hash = do pure (tx ^. TxId) pure $ maybeToEither (DbLookupTxHash hash) unValue (listToMaybe res) --- | Like 'queryTxId' but also return the 'TxOutId' -queryTxOutId :: MonadIO m => (ByteString, Word64) -> ReaderT SqlBackend m (Either LookupFail (TxId, TxOutId)) -queryTxOutId (hash, index) = do - res <- select $ do - (tx :& txOut) <- - from - $ table @Tx - `innerJoin` table @TxOut - `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. TxOutTxId) - where_ (txOut ^. TxOutIndex ==. val index &&. tx ^. TxHash ==. val hash) - pure (txOut ^. TxOutTxId, txOut ^. TxOutId) - pure $ maybeToEither (DbLookupTxHash hash) unValue2 (listToMaybe res) - --- | Like 'queryTxId' but also return the 'TxOutIdValue' -queryTxOutValue :: MonadIO m => (ByteString, Word64) -> ReaderT SqlBackend m (Either LookupFail (TxId, DbLovelace)) -queryTxOutValue (hash, index) = do - res <- select $ do - (tx :& txOut) <- - from - $ table @Tx - `innerJoin` table @TxOut - `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. TxOutTxId) - where_ (txOut ^. TxOutIndex ==. val index &&. tx ^. TxHash ==. val hash) - pure (txOut ^. TxOutTxId, txOut ^. TxOutValue) - pure $ maybeToEither (DbLookupTxHash hash) unValue2 (listToMaybe res) - --- | Like 'queryTxOutId' but also return the 'TxOutIdValue' -queryTxOutIdValue :: MonadIO m => (ByteString, Word64) -> ReaderT SqlBackend m (Either LookupFail (TxId, TxOutId, DbLovelace)) -queryTxOutIdValue (hash, index) = do - res <- select $ do - (tx :& txOut) <- - from - $ table @Tx - `innerJoin` table @TxOut - `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. TxOutTxId) - where_ (txOut ^. TxOutIndex ==. val index &&. tx ^. TxHash ==. val hash) - pure (txOut ^. TxOutTxId, txOut ^. TxOutId, txOut ^. TxOutValue) - pure $ maybeToEither (DbLookupTxHash hash) unValue3 (listToMaybe res) - --- | Give a (tx hash, index) pair, return the TxOut Credentials. -queryTxOutCredentials :: MonadIO m => (ByteString, Word64) -> ReaderT SqlBackend m (Either LookupFail (Maybe ByteString, Bool)) -queryTxOutCredentials (hash, index) = do - res <- select $ do - (tx :& txOut) <- - from - $ table @Tx - `innerJoin` table @TxOut - `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. TxOutTxId) - where_ (txOut ^. TxOutIndex ==. val index &&. tx ^. TxHash ==. val hash) - pure (txOut ^. TxOutPaymentCred, txOut ^. TxOutAddressHasScript) - pure $ maybeToEither (DbLookupTxHash hash) unValue2 (listToMaybe res) - -queryAddressDetailId :: MonadIO m => ByteString -> ReaderT SqlBackend m (Maybe AddressDetailId) -queryAddressDetailId addrRaw = do - res <- select $ do - addr <- from $ table @AddressDetail - where_ (addr ^. AddressDetailAddressRaw ==. val addrRaw) - pure (addr ^. AddressDetailId) - pure $ unValue <$> listToMaybe res - queryEpochStakeCount :: MonadIO m => Word64 -> ReaderT SqlBackend m Word64 queryEpochStakeCount epoch = do res <- select $ do @@ -1201,22 +1055,6 @@ querySlotUtcTime slotNo = do pure (blk ^. BlockTime) pure $ maybe (Left $ DbLookupSlotNo slotNo) (Right . unValue) (listToMaybe le) -queryUtxoAtBlockNo :: MonadIO m => Word64 -> ReaderT SqlBackend m [(TxOut, Text, ByteString)] -queryUtxoAtBlockNo blkNo = do - eblkId <- select $ do - blk <- from $ table @Block - where_ (blk ^. BlockBlockNo ==. just (val blkNo)) - pure (blk ^. BlockId) - maybe (pure []) (queryUtxoAtBlockId . unValue) (listToMaybe eblkId) - -queryUtxoAtSlotNo :: MonadIO m => Word64 -> ReaderT SqlBackend m [(TxOut, Text, ByteString)] -queryUtxoAtSlotNo slotNo = do - eblkId <- select $ do - blk <- from $ table @Block - where_ (blk ^. BlockSlotNo ==. just (val slotNo)) - pure (blk ^. BlockId) - maybe (pure []) (queryUtxoAtBlockId . unValue) (listToMaybe eblkId) - queryWithdrawalsUpToBlockNo :: MonadIO m => Word64 -> ReaderT SqlBackend m Ada queryWithdrawalsUpToBlockNo blkNo = do res <- select $ do @@ -1239,93 +1077,10 @@ queryAdaPots blkId = do pure adaPots pure $ fmap entityVal (listToMaybe res) --- | Get the UTxO set after the specified 'BlockId' has been applied to the chain. --- Not exported because 'BlockId' to 'BlockHash' relationship may not be the same --- across machines. -queryUtxoAtBlockId :: MonadIO m => BlockId -> ReaderT SqlBackend m [(TxOut, Text, ByteString)] -queryUtxoAtBlockId blkid = do - outputs <- select $ do - (txout :& address :& _txin :& _tx1 :& blk :& tx2) <- - from - $ table @TxOut - `innerJoin` table @AddressDetail - `on` (\(txout :& address) -> txout ^. TxOutAddressDetailId ==. just (address ^. AddressDetailId)) - `leftJoin` table @TxIn - `on` ( \(txout :& _ :& txin) -> - (just (txout ^. TxOutTxId) ==. txin ?. TxInTxOutId) - &&. (just (txout ^. TxOutIndex) ==. txin ?. TxInTxOutIndex) - ) - `leftJoin` table @Tx - `on` (\(_txout :& _ :& txin :& tx1) -> txin ?. TxInTxInId ==. tx1 ?. TxId) - `leftJoin` table @Block - `on` (\(_txout :& _ :& _txin :& tx1 :& blk) -> tx1 ?. TxBlockId ==. blk ?. BlockId) - `leftJoin` table @Tx - `on` (\(txout :& _ :& _ :& _ :& _ :& tx2) -> just (txout ^. TxOutTxId) ==. tx2 ?. TxId) - - where_ $ - (txout ^. TxOutTxId `in_` txLessEqual blkid) - &&. (isNothing (blk ?. BlockBlockNo) ||. (blk ?. BlockId >. just (val blkid))) - pure (txout, address ^. AddressDetailAddress, tx2 ?. TxHash) - pure $ mapMaybe convert outputs - where - convert :: (Entity TxOut, Value Text, Value (Maybe ByteString)) -> Maybe (TxOut, Text, ByteString) - convert = \case - (out, addr, Value (Just hash')) -> Just (entityVal out, unValue addr, hash') - (_, _, Value Nothing) -> Nothing - -queryAddressBalanceAtSlot :: MonadIO m => Text -> Word64 -> ReaderT SqlBackend m Ada -queryAddressBalanceAtSlot addr slotNo = do - eblkId <- select $ do - blk <- from (table @Block) - where_ (blk ^. BlockSlotNo ==. just (val slotNo)) - pure (blk ^. BlockId) - maybe (pure 0) (queryAddressBalanceAtBlockId . unValue) (listToMaybe eblkId) - where - queryAddressBalanceAtBlockId :: MonadIO m => BlockId -> ReaderT SqlBackend m Ada - queryAddressBalanceAtBlockId blkid = do - -- tx1 refers to the tx of the input spending this output (if it is ever spent) - -- tx2 refers to the tx of the output - res <- select $ do - (txout :& address :& _ :& _ :& blk :& _) <- - from - $ table @TxOut - `innerJoin` table @AddressDetail - `on` (\(txout :& address) -> txout ^. TxOutAddressDetailId ==. just (address ^. AddressDetailId)) - `leftJoin` table @TxIn - `on` (\(txout :& _ :& txin) -> just (txout ^. TxOutTxId) ==. txin ?. TxInTxOutId) - `leftJoin` table @Tx - `on` (\(_ :& _ :& txin :& tx1) -> txin ?. TxInTxInId ==. tx1 ?. TxId) - `leftJoin` table @Block - `on` (\(_ :& _ :& _ :& tx1 :& blk) -> tx1 ?. TxBlockId ==. blk ?. BlockId) - `leftJoin` table @Tx - `on` (\(txout :& _ :& _ :& _ :& _ :& tx2) -> just (txout ^. TxOutTxId) ==. tx2 ?. TxId) - where_ $ - (txout ^. TxOutTxId `in_` txLessEqual blkid) - &&. (isNothing (blk ?. BlockBlockNo) ||. (blk ?. BlockId >. just (val blkid))) - where_ (address ^. AddressDetailAddress ==. val addr) - pure $ sum_ (txout ^. TxOutValue) - pure $ unValueSumAda (listToMaybe res) - {----------------------- Queries use in tests ------------------------} -queryAddressOutputs :: MonadIO m => ByteString -> ReaderT SqlBackend m DbLovelace -queryAddressOutputs addr = do - res <- select $ do - (txout :& address) <- - from - $ table @TxOut - `innerJoin` table @AddressDetail - `on` (\(txout :& address) -> txout ^. TxOutAddressDetailId ==. just (address ^. AddressDetailId)) - where_ (address ^. AddressDetailAddressRaw ==. val addr) - pure $ sum_ (txout ^. TxOutValue) - pure $ convert (listToMaybe res) - where - convert v = case unValue <$> v of - Just (Just x) -> x - _otherwise -> DbLovelace 0 - queryRewardCount :: MonadIO m => ReaderT SqlBackend m Word64 queryRewardCount = do res <- select $ do @@ -1346,29 +1101,10 @@ queryTxInCount = do res <- select $ from (table @TxIn) >> pure countRows pure $ maybe 0 unValue (listToMaybe res) --- | Count the number of transaction outputs in the TxOut table. -queryTxOutCount :: MonadIO m => ReaderT SqlBackend m Word -queryTxOutCount = do - res <- select $ from (table @TxOut) >> pure countRows - pure $ maybe 0 unValue (listToMaybe res) - queryCostModel :: MonadIO m => ReaderT SqlBackend m [CostModelId] queryCostModel = fmap entityKey <$> selectList [] [Asc CostModelId] -queryScriptOutputs :: MonadIO m => ReaderT SqlBackend m [TxOut] -queryScriptOutputs = do - res <- select $ do - (_ :& address) <- - from - $ table @TxOut - `innerJoin` table @AddressDetail - `on` (\(txout :& address) -> txout ^. TxOutAddressDetailId ==. just (address ^. AddressDetailId)) - tx_out <- from $ table @TxOut - where_ (address ^. AddressDetailHasScript ==. val True) - pure tx_out - pure $ entityVal <$> res - queryTxInRedeemer :: MonadIO m => ReaderT SqlBackend m [TxIn] queryTxInRedeemer = do res <- select $ do @@ -1460,94 +1196,3 @@ queryMinBlock = do limit 1 pure $ blk ^. BlockId pure $ unValue <$> listToMaybe res - -queryTxOutUnspentCount :: MonadIO m => ReaderT SqlBackend m Word64 -queryTxOutUnspentCount = do - res <- select $ do - txOut <- from $ table @TxOut - txOutUnspentP txOut - pure countRows - pure $ maybe 0 unValue (listToMaybe res) - --- ----------------------------------------------------------------------------- --- SqlQuery predicates - --- Filter out 'Nothing' from a 'Maybe a'. -isJust :: PersistField a => SqlExpr (Value (Maybe a)) -> SqlExpr (Value Bool) -isJust = not_ . isNothing - --- A predicate that filters out spent 'TxOut' entries. -{-# INLINEABLE txOutUnspentP #-} -txOutUnspentP :: SqlExpr (Entity TxOut) -> SqlQuery () -txOutUnspentP txOut = - where_ . notExists $ - from (table @TxIn) >>= \txIn -> - where_ - ( txOut - ^. TxOutTxId - ==. txIn - ^. TxInTxOutId - &&. txOut - ^. TxOutIndex - ==. txIn - ^. TxInTxOutIndex - ) - --- every tx made before or at the snapshot time -txLessEqual :: BlockId -> SqlExpr (ValueList TxId) -txLessEqual blkid = - subList_select $ - from (table @Tx) >>= \tx -> do - where_ $ tx ^. TxBlockId `in_` blockLessEqual - pure $ tx ^. TxId - where - -- every block made before or at the snapshot time - blockLessEqual :: SqlExpr (ValueList BlockId) - blockLessEqual = - subList_select $ - from (table @Block) >>= \blk -> do - where_ $ blk ^. BlockId <=. val blkid - pure $ blk ^. BlockId - --- | Get the UTxO set after the specified 'BlockNo' has been applied to the chain. --- Unfortunately the 'sum_' operation above returns a 'PersistRational' so we need --- to un-wibble it. -unValueSumAda :: Maybe (Value (Maybe Micro)) -> Ada -unValueSumAda mvm = - case fmap unValue mvm of - Just (Just x) -> lovelaceToAda x - _ -> Ada 0 - --- ----------------------------------------------------------------------------- - -entityPair :: Entity a -> (Key a, a) -entityPair e = - (entityKey e, entityVal e) - -maybeToEither :: e -> (a -> b) -> Maybe a -> Either e b -maybeToEither e f = - maybe (Left e) (Right . f) - -unBlockId :: BlockId -> Word64 -unBlockId = fromIntegral . unSqlBackendKey . unBlockKey - -unTxId :: TxId -> Word64 -unTxId = fromIntegral . unSqlBackendKey . unTxKey - -unTxInId :: TxInId -> Word64 -unTxInId = fromIntegral . unSqlBackendKey . unTxInKey - -unTxOutId :: TxOutId -> Word64 -unTxOutId = fromIntegral . unSqlBackendKey . unTxOutKey - -unValue2 :: (Value a, Value b) -> (a, b) -unValue2 (a, b) = (unValue a, unValue b) - -unValue3 :: (Value a, Value b, Value c) -> (a, b, c) -unValue3 (a, b, c) = (unValue a, unValue b, unValue c) - -unValue4 :: (Value a, Value b, Value c, Value d) -> (a, b, c, d) -unValue4 (a, b, c, d) = (unValue a, unValue b, unValue c, unValue d) - -unValue5 :: (Value a, Value b, Value c, Value d, Value e) -> (a, b, c, d, e) -unValue5 (a, b, c, d, e) = (unValue a, unValue b, unValue c, unValue d, unValue e) diff --git a/cardano-db/src/Cardano/Db/Operations/Core/QueryHelper.hs b/cardano-db/src/Cardano/Db/Operations/Core/QueryHelper.hs new file mode 100644 index 000000000..b16dfa9df --- /dev/null +++ b/cardano-db/src/Cardano/Db/Operations/Core/QueryHelper.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.Db.Operations.Core.QueryHelper where + +import Cardano.Db.Schema.BaseSchema +import Cardano.Db.Types +import Data.Fixed (Micro) +import Data.Time.Clock (UTCTime) +import Data.Word (Word64) +import Database.Esqueleto.Experimental ( + Entity (..), + PersistField, + SqlExpr, + Value (unValue), + ValueList, + from, + in_, + isNothing, + not_, + subList_select, + table, + unSqlBackendKey, + val, + where_, + (<=.), + (^.), + ) + +-- Filter out 'Nothing' from a 'Maybe a'. +isJust :: PersistField a => SqlExpr (Value (Maybe a)) -> SqlExpr (Value Bool) +isJust = not_ . isNothing + +-- every tx made before or at the snapshot time +txLessEqual :: BlockId -> SqlExpr (ValueList TxId) +txLessEqual blkid = + subList_select $ + from (table @Tx) >>= \tx -> do + where_ $ tx ^. TxBlockId `in_` blockLessEqual + pure $ tx ^. TxId + where + -- every block made before or at the snapshot time + blockLessEqual :: SqlExpr (ValueList BlockId) + blockLessEqual = + subList_select $ + from (table @Block) >>= \blk -> do + where_ $ blk ^. BlockId <=. val blkid + pure $ blk ^. BlockId + +maybeToEither :: e -> (a -> b) -> Maybe a -> Either e b +maybeToEither e f = maybe (Left e) (Right . f) + +-- | Get the UTxO set after the specified 'BlockNo' has been applied to the chain. +-- Unfortunately the 'sum_' operation above returns a 'PersistRational' so we need +-- to un-wibble it. +unValueSumAda :: Maybe (Value (Maybe Micro)) -> Ada +unValueSumAda mvm = + case fmap unValue mvm of + Just (Just x) -> lovelaceToAda x + _otherwise -> Ada 0 + +entityPair :: Entity a -> (Key a, a) +entityPair e = + (entityKey e, entityVal e) + +unBlockId :: BlockId -> Word64 +unBlockId = fromIntegral . unSqlBackendKey . unBlockKey + +unTxId :: TxId -> Word64 +unTxId = fromIntegral . unSqlBackendKey . unTxKey + +unTxInId :: TxInId -> Word64 +unTxInId = fromIntegral . unSqlBackendKey . unTxInKey + +defaultUTCTime :: UTCTime +defaultUTCTime = read "2000-01-01 00:00:00.000000 UTC" + +unValue2 :: (Value a, Value b) -> (a, b) +unValue2 (a, b) = (unValue a, unValue b) + +unValue3 :: (Value a, Value b, Value c) -> (a, b, c) +unValue3 (a, b, c) = (unValue a, unValue b, unValue c) + +unValue4 :: (Value a, Value b, Value c, Value d) -> (a, b, c, d) +unValue4 (a, b, c, d) = (unValue a, unValue b, unValue c, unValue d) + +unValue5 :: (Value a, Value b, Value c, Value d, Value e) -> (a, b, c, d, e) +unValue5 (a, b, c, d, e) = (unValue a, unValue b, unValue c, unValue d, unValue e) diff --git a/cardano-db/src/Cardano/Db/Operations/Types.hs b/cardano-db/src/Cardano/Db/Operations/Types.hs new file mode 100644 index 000000000..98d60cbf7 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Operations/Types.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilyDependencies #-} + +module Cardano.Db.Operations.Types where + +import Cardano.Db.Schema.BaseSchema +import qualified Cardano.Db.Schema.Core.TxOut as C +import qualified Cardano.Db.Schema.Variant.TxOut as V +import Cardano.Db.Types (DbLovelace (..), DbWord64) +import Cardano.Prelude (ByteString, Text, Word64, mapMaybe) +import Data.Kind (Type) +import Database.Esqueleto.Experimental (PersistEntity (..)) +import Database.Persist.Sql (PersistField) + +data TxOutTableType = TxOutCore | TxOutVariantAddress + deriving (Eq, Show) + +-- | A wrapper for TxOut that allows us to handle both Core and Variant TxOuts +data TxOutW + = CTxOutW !C.TxOut + | VTxOutW !V.TxOut !(Maybe V.Address) + +-- Pattern synonyms for easier construction +pattern CoreTxOut :: C.TxOut -> TxOutW +pattern CoreTxOut txOut = CTxOutW txOut + +pattern VariantTxOutWithAddr :: V.TxOut -> V.Address -> TxOutW +pattern VariantTxOutWithAddr txOut address = VTxOutW txOut (Just address) + +pattern VariantTxOutNoAddr :: V.TxOut -> Maybe V.Address -> TxOutW +pattern VariantTxOutNoAddr txOut maybeAddress = VTxOutW txOut maybeAddress + +-- | A wrapper for TxOutId +data TxOutIdW + = CTxOutIdW !C.TxOutId + | VTxOutIdW !V.TxOutId + deriving (Show) + +-- Pattern synonyms for easier construction +pattern CoreTxOutId :: C.TxOutId -> TxOutIdW +pattern CoreTxOutId txOutId = CTxOutIdW txOutId + +pattern VariantTxOutId :: V.TxOutId -> TxOutIdW +pattern VariantTxOutId txOutId = VTxOutIdW txOutId + +-- | A wrapper for MaTxOut +data MaTxOutW + = CMaTxOutW !C.MaTxOut + | VMaTxOutW !V.MaTxOut + deriving (Show) + +pattern CoreMaTxOut :: C.MaTxOut -> MaTxOutW +pattern CoreMaTxOut maTxOut = CMaTxOutW maTxOut + +pattern VariantMaTxOut :: V.MaTxOut -> MaTxOutW +pattern VariantMaTxOut maTxOut = VMaTxOutW maTxOut + +-- | A wrapper for MaTxOut +data MaTxOutIdW + = CMaTxOutIdW !C.MaTxOutId + | VMaTxOutIdW !V.MaTxOutId + deriving (Show) + +pattern CoreMaTxOutId :: C.MaTxOutId -> MaTxOutIdW +pattern CoreMaTxOutId maTxOutId = CMaTxOutIdW maTxOutId + +pattern VariantMaTxOutId :: V.MaTxOutId -> MaTxOutIdW +pattern VariantMaTxOutId maTxOutId = VMaTxOutIdW maTxOutId + +-- | UtxoQueryResult which has utxoAddress that can come from Core or Variant TxOut +data UtxoQueryResult = UtxoQueryResult + { utxoTxOutW :: TxOutW + , utxoAddress :: Text + , utxoTxHash :: ByteString + } + +-------------------------------------------------------------------------------- +-- TxOut fields for a given TxOutTableType +-------------------------------------------------------------------------------- +class (PersistEntity (TxOutTable a), PersistField (TxOutIdFor a)) => TxOutFields (a :: TxOutTableType) where + type TxOutTable a :: Type + type TxOutIdFor a :: Type + txOutTxIdField :: EntityField (TxOutTable a) TxId + txOutIndexField :: EntityField (TxOutTable a) Word64 + txOutValueField :: EntityField (TxOutTable a) DbLovelace + txOutIdField :: EntityField (TxOutTable a) (TxOutIdFor a) + txOutDataHashField :: EntityField (TxOutTable a) (Maybe ByteString) + txOutInlineDatumIdField :: EntityField (TxOutTable a) (Maybe DatumId) + txOutReferenceScriptIdField :: EntityField (TxOutTable a) (Maybe ScriptId) + txOutConsumedByTxIdField :: EntityField (TxOutTable a) (Maybe TxId) + +-------------------------------------------------------------------------------- +-- Multi-asset fields for a given TxOutTableType +-------------------------------------------------------------------------------- +class (PersistEntity (MaTxOutTable a)) => MaTxOutFields (a :: TxOutTableType) where + type MaTxOutTable a :: Type + type MaTxOutIdFor a :: Type + maTxOutTxOutIdField :: EntityField (MaTxOutTable a) (TxOutIdFor a) + maTxOutIdentField :: EntityField (MaTxOutTable a) MultiAssetId + maTxOutQuantityField :: EntityField (MaTxOutTable a) DbWord64 + +-------------------------------------------------------------------------------- +-- Address-related fields for TxOutVariantAddress only +-------------------------------------------------------------------------------- +class AddressFields (a :: TxOutTableType) where + type AddressTable a :: Type + type AddressIdFor a :: Type + addressField :: EntityField (AddressTable a) Text + addressRawField :: EntityField (AddressTable a) ByteString + addressHasScriptField :: EntityField (AddressTable a) Bool + addressPaymentCredField :: EntityField (AddressTable a) (Maybe ByteString) + addressStakeAddressIdField :: EntityField (AddressTable a) (Maybe StakeAddressId) + addressIdField :: EntityField (AddressTable a) (AddressIdFor a) + +-------------------------------------------------------------------------------- +-- Instances for TxOutCore +-------------------------------------------------------------------------------- +instance TxOutFields 'TxOutCore where + type TxOutTable 'TxOutCore = C.TxOut + type TxOutIdFor 'TxOutCore = C.TxOutId + txOutTxIdField = C.TxOutTxId + txOutIndexField = C.TxOutIndex + txOutValueField = C.TxOutValue + txOutIdField = C.TxOutId + txOutDataHashField = C.TxOutDataHash + txOutInlineDatumIdField = C.TxOutInlineDatumId + txOutReferenceScriptIdField = C.TxOutReferenceScriptId + txOutConsumedByTxIdField = C.TxOutConsumedByTxId + +instance MaTxOutFields 'TxOutCore where + type MaTxOutTable 'TxOutCore = C.MaTxOut + type MaTxOutIdFor 'TxOutCore = C.MaTxOutId + maTxOutTxOutIdField = C.MaTxOutTxOutId + maTxOutIdentField = C.MaTxOutIdent + maTxOutQuantityField = C.MaTxOutQuantity + +-------------------------------------------------------------------------------- +-- Instances for TxOutVariantAddress +-------------------------------------------------------------------------------- +instance TxOutFields 'TxOutVariantAddress where + type TxOutTable 'TxOutVariantAddress = V.TxOut + type TxOutIdFor 'TxOutVariantAddress = V.TxOutId + txOutTxIdField = V.TxOutTxId + txOutIndexField = V.TxOutIndex + txOutValueField = V.TxOutValue + txOutIdField = V.TxOutId + txOutDataHashField = V.TxOutDataHash + txOutInlineDatumIdField = V.TxOutInlineDatumId + txOutReferenceScriptIdField = V.TxOutReferenceScriptId + txOutConsumedByTxIdField = V.TxOutConsumedByTxId + +instance MaTxOutFields 'TxOutVariantAddress where + type MaTxOutTable 'TxOutVariantAddress = V.MaTxOut + type MaTxOutIdFor 'TxOutVariantAddress = V.MaTxOutId + maTxOutTxOutIdField = V.MaTxOutTxOutId + maTxOutIdentField = V.MaTxOutIdent + maTxOutQuantityField = V.MaTxOutQuantity + +instance AddressFields 'TxOutVariantAddress where + type AddressTable 'TxOutVariantAddress = V.Address + type AddressIdFor 'TxOutVariantAddress = V.AddressId + addressField = V.AddressAddress + addressRawField = V.AddressRaw + addressHasScriptField = V.AddressHasScript + addressPaymentCredField = V.AddressPaymentCred + addressStakeAddressIdField = V.AddressStakeAddressId + addressIdField = V.AddressId + +-------------------------------------------------------------------------------- +-- Helper functions +-------------------------------------------------------------------------------- +extractCoreTxOut :: TxOutW -> C.TxOut +extractCoreTxOut (CTxOutW txOut) = txOut +-- this will never error as we can only have either CoreTxOut or VariantTxOut +extractCoreTxOut (VTxOutW _ _) = error "Unexpected VTxOut in CoreTxOut list" + +extractVariantTxOut :: TxOutW -> V.TxOut +extractVariantTxOut (VTxOutW txOut _) = txOut +-- this will never error as we can only have either CoreTxOut or VariantTxOut +extractVariantTxOut (CTxOutW _) = error "Unexpected CTxOut in VariantTxOut list" + +extractVariantAddress :: TxOutW -> Maybe V.Address +extractVariantAddress (VTxOutW _ address) = address +-- this will never error as we can only have either CoreTxOut or VariantTxOut +extractVariantAddress (CTxOutW _) = error "Unexpected CTxOut in VariantTxOut list" + +convertTxOutIdCore :: [TxOutIdW] -> [C.TxOutId] +convertTxOutIdCore = mapMaybe unwrapCore + where + unwrapCore (CTxOutIdW txOutid) = Just txOutid + unwrapCore _ = Nothing + +convertTxOutIdVariant :: [TxOutIdW] -> [V.TxOutId] +convertTxOutIdVariant = mapMaybe unwrapVariant + where + unwrapVariant (VTxOutIdW txOutid) = Just txOutid + unwrapVariant _ = Nothing + +convertMaTxOutIdCore :: [MaTxOutIdW] -> [C.MaTxOutId] +convertMaTxOutIdCore = mapMaybe unwrapCore + where + unwrapCore (CMaTxOutIdW maTxOutId) = Just maTxOutId + unwrapCore _ = Nothing + +convertMaTxOutIdVariant :: [MaTxOutIdW] -> [V.MaTxOutId] +convertMaTxOutIdVariant = mapMaybe unwrapVariant + where + unwrapVariant (VMaTxOutIdW maTxOutId) = Just maTxOutId + unwrapVariant _ = Nothing diff --git a/cardano-db/src/Cardano/Db/Operations/Variant/ConsumedTxOut.hs b/cardano-db/src/Cardano/Db/Operations/Variant/ConsumedTxOut.hs new file mode 100644 index 000000000..31d03d4bf --- /dev/null +++ b/cardano-db/src/Cardano/Db/Operations/Variant/ConsumedTxOut.hs @@ -0,0 +1,486 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.Db.Operations.Variant.ConsumedTxOut where + +import Cardano.BM.Trace (Trace, logError, logInfo, logWarning) +import Cardano.Db.Error (LookupFail (..), logAndThrowIO) +import Cardano.Db.Operations.Core.Insert (insertExtraMigration) +import Cardano.Db.Operations.Core.Query (listToMaybe, queryAllExtraMigrations, queryBlockHeight, queryBlockNo, queryMaxRefId) +import Cardano.Db.Operations.Core.QueryHelper (isJust) +import Cardano.Db.Operations.Types (TxOutFields (..), TxOutIdW (..), TxOutTable, TxOutTableType (..)) +import Cardano.Db.Schema.BaseSchema +import qualified Cardano.Db.Schema.Core.TxOut as C +import qualified Cardano.Db.Schema.Variant.TxOut as V +import Cardano.Db.Types (ExtraMigration (..), PruneConsumeMigration (..), wasPruneTxOutPreviouslySet) +import Cardano.Prelude (textShow) +import Control.Exception (throw) +import Control.Exception.Lifted (handle, throwIO) +import Control.Monad.Extra (unless, when, whenJust) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Monad.Trans.Reader (ReaderT) +import Data.Text (Text) +import Data.Word (Word64) +import Database.Esqueleto.Experimental hiding (update, (<=.), (=.), (==.)) +import qualified Database.Esqueleto.Experimental as E +import Database.Persist ((<=.), (=.), (==.)) +import Database.Persist.Class (update) +import Database.Persist.Sql (deleteWhereCount) +import Database.PostgreSQL.Simple (SqlError) + +pageSize :: Word64 +pageSize = 100_000 + +data ConsumedTriplet = ConsumedTriplet + { ctTxOutTxId :: TxId -- The txId of the txOut + , ctTxOutIndex :: Word64 -- Tx index of the txOut + , ctTxInTxId :: TxId -- The txId of the txId + } + +-------------------------------------------------------------------------------------------------- +-- Queries +-------------------------------------------------------------------------------------------------- +queryUpdateListTxOutConsumedByTxId :: MonadIO m => [(TxOutIdW, TxId)] -> ReaderT SqlBackend m () +queryUpdateListTxOutConsumedByTxId ls = do + mapM_ (uncurry updateTxOutConsumedByTxId) ls + +queryTxConsumedColumnExists :: MonadIO m => ReaderT SqlBackend m Bool +queryTxConsumedColumnExists = do + columnExists :: [Text] <- + fmap unSingle + <$> rawSql + ( mconcat + [ "SELECT column_name FROM information_schema.columns " + , "WHERE table_name='tx_out' and column_name='consumed_by_tx_id'" + ] + ) + [] + pure (not $ null columnExists) + +-- | This is a count of the null consumed_by_tx_id +queryTxOutConsumedNullCount :: TxOutTableType -> MonadIO m => ReaderT SqlBackend m Word64 +queryTxOutConsumedNullCount = \case + TxOutCore -> query @'TxOutCore + TxOutVariantAddress -> query @'TxOutVariantAddress + where + query :: + forall (a :: TxOutTableType) m. + (MonadIO m, TxOutFields a) => + ReaderT SqlBackend m Word64 + query = do + res <- select $ do + txOut <- from $ table @(TxOutTable a) + where_ (isNothing $ txOut ^. txOutConsumedByTxIdField @a) + pure countRows + pure $ maybe 0 unValue (listToMaybe res) + +queryTxOutConsumedCount :: TxOutTableType -> MonadIO m => ReaderT SqlBackend m Word64 +queryTxOutConsumedCount = \case + TxOutCore -> query @'TxOutCore + TxOutVariantAddress -> query @'TxOutVariantAddress + where + query :: + forall (a :: TxOutTableType) m. + (MonadIO m, TxOutFields a) => + ReaderT SqlBackend m Word64 + query = do + res <- select $ do + txOut <- from $ table @(TxOutTable a) + where_ (not_ $ isNothing $ txOut ^. txOutConsumedByTxIdField @a) + pure countRows + pure $ maybe 0 unValue (listToMaybe res) + +querySetNullTxOut :: MonadIO m => Trace IO Text -> TxOutTableType -> Maybe TxId -> ReaderT SqlBackend m () +querySetNullTxOut trce txOutTableType mMinTxId = do + whenJust mMinTxId $ \txId -> do + txOutIds <- getTxOutConsumedAfter txOutTableType txId + mapM_ (setNullTxOutConsumedAfter txOutTableType) txOutIds + let updatedEntries = length txOutIds + liftIO $ logInfo trce $ "Set to null " <> textShow updatedEntries <> " tx_out.consumed_by_tx_id" + +-- TODO: cmdv need to fix the raw execute +createConsumedTxOut :: + forall m. + ( MonadBaseControl IO m + , MonadIO m + ) => + ReaderT SqlBackend m () +createConsumedTxOut = do + handle exceptHandler $ + rawExecute + "ALTER TABLE tx_out ADD COLUMN consumed_by_tx_id INT8 NULL" + [] + handle exceptHandler $ + rawExecute + "CREATE INDEX IF NOT EXISTS idx_tx_out_consumed_by_tx_id ON tx_out (consumed_by_tx_id)" + [] + handle exceptHandler $ + rawExecute + "ALTER TABLE ma_tx_out ADD CONSTRAINT ma_tx_out_tx_out_id_fkey FOREIGN KEY(tx_out_id) REFERENCES tx_out(id) ON DELETE CASCADE ON UPDATE RESTRICT" + [] + where + exceptHandler :: SqlError -> ReaderT SqlBackend m a + exceptHandler e = + liftIO $ throwIO (DBPruneConsumed $ show e) + +_validateMigration :: MonadIO m => Trace IO Text -> TxOutTableType -> ReaderT SqlBackend m Bool +_validateMigration trce txOutTableType = do + _migrated <- queryTxConsumedColumnExists + -- unless migrated $ runMigration + txInCount <- countTxIn + consumedTxOut <- countConsumed txOutTableType + if txInCount > consumedTxOut + then do + liftIO $ + logWarning trce $ + mconcat + [ "Found incomplete TxOut migration. There are" + , textShow txInCount + , " TxIn, but only" + , textShow consumedTxOut + , " consumed TxOut" + ] + pure False + else + if txInCount == consumedTxOut + then do + liftIO $ logInfo trce "Found complete TxOut migration" + pure True + else do + liftIO $ + logError trce $ + mconcat + [ "The impossible happened! There are" + , textShow txInCount + , " TxIn, but " + , textShow consumedTxOut + , " consumed TxOut" + ] + pure False + +updateListTxOutConsumedByTxId :: MonadIO m => [(TxOutIdW, TxId)] -> ReaderT SqlBackend m () +updateListTxOutConsumedByTxId ls = do + queryUpdateListTxOutConsumedByTxId ls + +runExtraMigrations :: (MonadBaseControl IO m, MonadIO m) => Trace IO Text -> TxOutTableType -> Word64 -> PruneConsumeMigration -> ReaderT SqlBackend m () +runExtraMigrations trce txOutTableType blockNoDiff PruneConsumeMigration {..} = do + hasConsumedField <- queryTxConsumedColumnExists + ems <- queryAllExtraMigrations + let wPruneTxOutPreviouslySet = wasPruneTxOutPreviouslySet ems + -- first check if pruneTxOut flag is missing and it has previously been used + case (pcmPruneTxOut, wPruneTxOutPreviouslySet) of + (False, True) -> + throw $ + DBExtraMigration + ( "If --prune-tx-out flag is enabled and then db-sync is stopped all future executions of db-sync " + <> "should still have this flag activated. Otherwise, it is considered bad usage and can cause crashes." + ) + _ -> do + case (hasConsumedField, pcmConsumeOrPruneTxOut, pcmPruneTxOut) of + (False, False, False) -> do + liftIO $ logInfo trce "No extra migration specified" + (True, True, False) -> do + liftIO $ logInfo trce "Extra migration consumed_tx_out already executed" + (True, False, False) -> liftIO $ logAndThrowIO trce migratedButNotSet + (False, True, False) -> do + liftIO $ logInfo trce "Running extra migration consumed_tx_out" + migrateTxOut (Just trce) txOutTableType + (False, _, True) -> do + shouldInsertToMigrationTable + deleteAndUpdateConsumedTxOut trce txOutTableType blockNoDiff + (True, _, True) -> do + shouldInsertToMigrationTable + liftIO $ logInfo trce "Running extra migration prune tx_out" + deleteConsumedTxOut trce txOutTableType blockNoDiff + where + migratedButNotSet = "consumed-tx-out or prune-tx-out is not set, but consumed migration is found." + -- if PruneTxOutFlagPreviouslySet isn't already set then set it. + shouldInsertToMigrationTable :: (MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m () + shouldInsertToMigrationTable = do + unless wPruneTxOutPreviouslySet $ insertExtraMigration PruneTxOutFlagPreviouslySet + +queryWrongConsumedBy :: TxOutTableType -> MonadIO m => ReaderT SqlBackend m Word64 +queryWrongConsumedBy = \case + TxOutCore -> query @'TxOutCore + TxOutVariantAddress -> query @'TxOutVariantAddress + where + query :: + forall (a :: TxOutTableType) m. + (MonadIO m, TxOutFields a) => + ReaderT SqlBackend m Word64 + query = do + res <- select $ do + txOut <- from $ table @(TxOutTable a) + where_ (just (txOut ^. txOutTxIdField @a) E.==. txOut ^. txOutConsumedByTxIdField @a) + pure countRows + pure $ maybe 0 unValue (listToMaybe res) + +-------------------------------------------------------------------------------------------------- +-- Updates +-------------------------------------------------------------------------------------------------- +updateTxOutConsumedByTxId :: MonadIO m => TxOutIdW -> TxId -> ReaderT SqlBackend m () +updateTxOutConsumedByTxId txOutId txId = + case txOutId of + CTxOutIdW txOutId' -> update txOutId' [C.TxOutConsumedByTxId =. Just txId] + VTxOutIdW txOutId' -> update txOutId' [V.TxOutConsumedByTxId =. Just txId] + +-- | This requires an index at TxOutConsumedByTxId. +getTxOutConsumedAfter :: MonadIO m => TxOutTableType -> TxId -> ReaderT SqlBackend m [TxOutIdW] +getTxOutConsumedAfter txOutTableType txId = + case txOutTableType of + TxOutCore -> wrapTxOutIds CTxOutIdW (queryConsumedTxOutIds @'TxOutCore txId) + TxOutVariantAddress -> wrapTxOutIds VTxOutIdW (queryConsumedTxOutIds @'TxOutVariantAddress txId) + where + wrapTxOutIds constructor = fmap (map constructor) + + queryConsumedTxOutIds :: + forall a m. + (TxOutFields a, MonadIO m) => + TxId -> + ReaderT SqlBackend m [TxOutIdFor a] + queryConsumedTxOutIds txId' = do + res <- select $ do + txOut <- from $ table @(TxOutTable a) + where_ (txOut ^. txOutConsumedByTxIdField @a >=. just (val txId')) + pure $ txOut ^. txOutIdField @a + pure $ map unValue res + +-- | This requires an index at TxOutConsumedByTxId. +setNullTxOutConsumedAfter :: MonadIO m => TxOutTableType -> TxOutIdW -> ReaderT SqlBackend m () +setNullTxOutConsumedAfter txOutTableType txOutId = + case txOutTableType of + TxOutCore -> setNull + TxOutVariantAddress -> setNull + where + setNull :: + (MonadIO m) => + ReaderT SqlBackend m () + setNull = do + case txOutId of + CTxOutIdW txOutId' -> update txOutId' [C.TxOutConsumedByTxId =. Nothing] + VTxOutIdW txOutId' -> update txOutId' [V.TxOutConsumedByTxId =. Nothing] + +migrateTxOut :: + ( MonadBaseControl IO m + , MonadIO m + ) => + Maybe (Trace IO Text) -> + TxOutTableType -> + ReaderT SqlBackend m () +migrateTxOut mTrace txOutTableType = do + _ <- createConsumedTxOut + migrateNextPage 0 + where + migrateNextPage :: MonadIO m => Word64 -> ReaderT SqlBackend m () + migrateNextPage offst = do + whenJust mTrace $ \trce -> + liftIO $ logInfo trce $ "Handling input offset " <> textShow offst + page <- getInputPage offst pageSize + updatePageEntries txOutTableType page + when (fromIntegral (length page) == pageSize) $ + migrateNextPage $! + offst + + pageSize + +-------------------------------------------------------------------------------------------------- +-- Delete + Update +-------------------------------------------------------------------------------------------------- + +deleteAndUpdateConsumedTxOut :: + forall m. + (MonadIO m, MonadBaseControl IO m) => + Trace IO Text -> + TxOutTableType -> + Word64 -> + ReaderT SqlBackend m () +deleteAndUpdateConsumedTxOut trce txOutTableType blockNoDiff = do + maxTxId <- findMaxTxInId blockNoDiff + case maxTxId of + Left errMsg -> do + liftIO $ logInfo trce $ "No tx_out were deleted as no blocks found: " <> errMsg + liftIO $ logInfo trce "Now Running extra migration prune tx_out" + migrateTxOut (Just trce) txOutTableType + Right mTxId -> do + migrateNextPage mTxId False 0 + where + migrateNextPage :: TxId -> Bool -> Word64 -> ReaderT SqlBackend m () + migrateNextPage maxTxId ranCreateConsumedTxOut offst = do + pageEntries <- getInputPage offst pageSize + resPageEntries <- splitAndProcessPageEntries trce txOutTableType ranCreateConsumedTxOut maxTxId pageEntries + when (fromIntegral (length pageEntries) == pageSize) $ + migrateNextPage maxTxId resPageEntries $! + offst + + pageSize + +-- Split the page entries by maxTxInId and process +splitAndProcessPageEntries :: + forall m. + (MonadIO m, MonadBaseControl IO m) => + Trace IO Text -> + TxOutTableType -> + Bool -> + TxId -> + [ConsumedTriplet] -> + ReaderT SqlBackend m Bool +splitAndProcessPageEntries trce txOutTableType ranCreateConsumedTxOut maxTxId pageEntries = do + let entriesSplit = span (\tr -> ctTxInTxId tr <= maxTxId) pageEntries + case entriesSplit of + ([], []) -> do + shouldCreateConsumedTxOut trce ranCreateConsumedTxOut + pure True + -- the whole list is less that maxTxInId + (xs, []) -> do + deletePageEntries txOutTableType xs + pure False + -- the whole list is greater that maxTxInId + ([], ys) -> do + shouldCreateConsumedTxOut trce ranCreateConsumedTxOut + updatePageEntries txOutTableType ys + pure True + -- the list has both bellow and above maxTxInId + (xs, ys) -> do + deletePageEntries txOutTableType xs + shouldCreateConsumedTxOut trce ranCreateConsumedTxOut + updatePageEntries txOutTableType ys + pure True + +-- | Update +updatePageEntries :: + MonadIO m => + TxOutTableType -> + [ConsumedTriplet] -> + ReaderT SqlBackend m () +updatePageEntries txOutTableType = mapM_ (updateTxOutConsumedByTxIdUnique txOutTableType) + +updateTxOutConsumedByTxIdUnique :: MonadIO m => TxOutTableType -> ConsumedTriplet -> ReaderT SqlBackend m () +updateTxOutConsumedByTxIdUnique txOutTableType ConsumedTriplet {ctTxOutTxId, ctTxOutIndex, ctTxInTxId} = + case txOutTableType of + TxOutCore -> updateWhere [C.TxOutTxId ==. ctTxOutTxId, C.TxOutIndex ==. ctTxOutIndex] [C.TxOutConsumedByTxId =. Just ctTxInTxId] + TxOutVariantAddress -> updateWhere [V.TxOutTxId ==. ctTxOutTxId, V.TxOutIndex ==. ctTxOutIndex] [V.TxOutConsumedByTxId =. Just ctTxInTxId] + +-- | Delete +-- this builds up a single delete query using the pageEntries list +deletePageEntries :: + MonadIO m => + TxOutTableType -> + [ConsumedTriplet] -> + ReaderT SqlBackend m () +deletePageEntries txOutTableType = mapM_ (\ConsumedTriplet {ctTxOutTxId, ctTxOutIndex} -> deleteTxOutConsumed txOutTableType ctTxOutTxId ctTxOutIndex) + +deleteTxOutConsumed :: MonadIO m => TxOutTableType -> TxId -> Word64 -> ReaderT SqlBackend m () +deleteTxOutConsumed txOutTableType txOutId index = case txOutTableType of + TxOutCore -> deleteWhere [C.TxOutTxId ==. txOutId, C.TxOutIndex ==. index] + TxOutVariantAddress -> deleteWhere [V.TxOutTxId ==. txOutId, V.TxOutIndex ==. index] + +shouldCreateConsumedTxOut :: + (MonadIO m, MonadBaseControl IO m) => + Trace IO Text -> + Bool -> + ReaderT SqlBackend m () +shouldCreateConsumedTxOut trce rcc = + unless rcc $ do + liftIO $ logInfo trce "Created ConsumedTxOut when handling page entries." + createConsumedTxOut + +-------------------------------------------------------------------------------------------------- +-- Delete +-------------------------------------------------------------------------------------------------- +deleteConsumedTxOut :: + forall m. + MonadIO m => + Trace IO Text -> + TxOutTableType -> + Word64 -> + ReaderT SqlBackend m () +deleteConsumedTxOut trce txOutTableType blockNoDiff = do + maxTxInId <- findMaxTxInId blockNoDiff + case maxTxInId of + Left errMsg -> liftIO $ logInfo trce $ "No tx_out was deleted: " <> errMsg + Right mxtid -> deleteConsumedBeforeTx trce txOutTableType mxtid + +deleteConsumedBeforeTx :: MonadIO m => Trace IO Text -> TxOutTableType -> TxId -> ReaderT SqlBackend m () +deleteConsumedBeforeTx trce txOutTableType txId = do + countDeleted <- case txOutTableType of + TxOutCore -> deleteWhereCount [C.TxOutConsumedByTxId <=. Just txId] + TxOutVariantAddress -> deleteWhereCount [V.TxOutConsumedByTxId <=. Just txId] + liftIO $ logInfo trce $ "Deleted " <> textShow countDeleted <> " tx_out" + +-------------------------------------------------------------------------------------------------- +-- Helpers +-------------------------------------------------------------------------------------------------- +findMaxTxInId :: forall m. MonadIO m => Word64 -> ReaderT SqlBackend m (Either Text TxId) +findMaxTxInId blockNoDiff = do + mBlockHeight <- queryBlockHeight + maybe (pure $ Left "No blocks found") findConsumed mBlockHeight + where + findConsumed :: Word64 -> ReaderT SqlBackend m (Either Text TxId) + findConsumed tipBlockNo = do + if tipBlockNo <= blockNoDiff + then pure $ Left $ "Tip blockNo is " <> textShow tipBlockNo + else do + mBlockId <- queryBlockNo $ tipBlockNo - blockNoDiff + maybe + (pure $ Left $ "BlockNo hole found at " <> textShow (tipBlockNo - blockNoDiff)) + findConsumedBeforeBlock + mBlockId + + findConsumedBeforeBlock :: BlockId -> ReaderT SqlBackend m (Either Text TxId) + findConsumedBeforeBlock blockId = do + mTxId <- queryMaxRefId TxBlockId blockId False + case mTxId of + Nothing -> pure $ Left $ "No txs found before " <> textShow blockId + Just txId -> pure $ Right txId + +getInputPage :: MonadIO m => Word64 -> Word64 -> ReaderT SqlBackend m [ConsumedTriplet] +getInputPage offs pgSize = do + res <- select $ do + txIn <- from $ table @TxIn + limit (fromIntegral pgSize) + offset (fromIntegral offs) + orderBy [asc (txIn ^. TxInId)] + pure txIn + pure $ convert <$> res + where + convert txIn = + ConsumedTriplet + { ctTxOutTxId = txInTxOutId (entityVal txIn) + , ctTxOutIndex = txInTxOutIndex (entityVal txIn) + , ctTxInTxId = txInTxInId (entityVal txIn) + } + +countTxIn :: MonadIO m => ReaderT SqlBackend m Word64 +countTxIn = do + res <- select $ do + _ <- from $ table @TxIn + pure countRows + pure $ maybe 0 unValue (listToMaybe res) + +countConsumed :: + MonadIO m => + TxOutTableType -> + ReaderT SqlBackend m Word64 +countConsumed = \case + TxOutCore -> query @'TxOutCore + TxOutVariantAddress -> query @'TxOutVariantAddress + where + query :: + forall (a :: TxOutTableType) m. + (MonadIO m, TxOutFields a) => + ReaderT SqlBackend m Word64 + query = do + res <- select $ do + txOut <- from $ table @(TxOutTable a) + where_ (isJust $ txOut ^. txOutConsumedByTxIdField @a) + pure countRows + pure $ maybe 0 unValue (listToMaybe res) diff --git a/cardano-db/src/Cardano/Db/Migration/Extra/JsonbInSchemaQueries.hs b/cardano-db/src/Cardano/Db/Operations/Variant/JsonbQuery.hs similarity index 98% rename from cardano-db/src/Cardano/Db/Migration/Extra/JsonbInSchemaQueries.hs rename to cardano-db/src/Cardano/Db/Operations/Variant/JsonbQuery.hs index 12ab82847..e8b3862d9 100644 --- a/cardano-db/src/Cardano/Db/Migration/Extra/JsonbInSchemaQueries.hs +++ b/cardano-db/src/Cardano/Db/Operations/Variant/JsonbQuery.hs @@ -3,7 +3,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -module Cardano.Db.Migration.Extra.JsonbInSchemaQueries where +module Cardano.Db.Operations.Variant.JsonbQuery where import Cardano.Db.Error (LookupFail (..)) import Control.Exception.Lifted (handle, throwIO) diff --git a/cardano-db/src/Cardano/Db/Operations/Variant/TxOutDelete.hs b/cardano-db/src/Cardano/Db/Operations/Variant/TxOutDelete.hs new file mode 100644 index 000000000..39e714d14 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Operations/Variant/TxOutDelete.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cardano.Db.Operations.Variant.TxOutDelete where + +import Cardano.Db.Operations.Types (TxOutTableType (..)) +import qualified Cardano.Db.Schema.Core.TxOut as C +import qualified Cardano.Db.Schema.Variant.TxOut as V +import Cardano.Prelude (Int64) +import Control.Monad.Extra (whenJust) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Reader (ReaderT) +import Database.Persist.Class.PersistQuery (deleteWhere) +import Database.Persist.Sql ( + Filter, + SqlBackend, + deleteWhereCount, + (>=.), + ) + +-------------------------------------------------------------------------------- +-- Delete +-------------------------------------------------------------------------------- +deleteCoreTxOutTablesAfterTxId :: MonadIO m => Maybe C.TxOutId -> Maybe C.MaTxOutId -> ReaderT SqlBackend m () +deleteCoreTxOutTablesAfterTxId mtxOutId mmaTxOutId = do + whenJust mmaTxOutId $ \maTxOutId -> deleteWhere [C.MaTxOutId >=. maTxOutId] + whenJust mtxOutId $ \txOutId -> deleteWhere [C.TxOutId >=. txOutId] + +-- TODO: cmdv: probably won't need to remove the addressId here but have it just incase +deleteVariantTxOutTablesAfterTxId :: MonadIO m => Maybe V.TxOutId -> Maybe V.MaTxOutId -> Maybe V.AddressId -> ReaderT SqlBackend m () +deleteVariantTxOutTablesAfterTxId mtxOutId mmaTxOutId mAddrId = do + whenJust mmaTxOutId $ \maTxOutId -> deleteWhere [V.MaTxOutId >=. maTxOutId] + whenJust mtxOutId $ \txOutId -> deleteWhere [V.TxOutId >=. txOutId] + whenJust mAddrId $ \addrId -> deleteWhere [V.AddressId >=. addrId] + +deleteTxOut :: MonadIO m => TxOutTableType -> ReaderT SqlBackend m Int64 +deleteTxOut = \case + TxOutCore -> deleteWhereCount ([] :: [Filter C.TxOut]) + TxOutVariantAddress -> deleteWhereCount ([] :: [Filter V.TxOut]) diff --git a/cardano-db/src/Cardano/Db/Operations/Variant/TxOutInsert.hs b/cardano-db/src/Cardano/Db/Operations/Variant/TxOutInsert.hs new file mode 100644 index 000000000..f33a6b243 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Operations/Variant/TxOutInsert.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-} + +module Cardano.Db.Operations.Variant.TxOutInsert where + +import Cardano.Db.Operations.Core.Insert (insertMany', insertUnchecked) +import Cardano.Db.Operations.Types (MaTxOutIdW (..), MaTxOutW (..), TxOutIdW (..), TxOutW (..)) +import qualified Cardano.Db.Schema.Core.TxOut as C +import qualified Cardano.Db.Schema.Variant.TxOut as V +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Monad.Trans.Reader (ReaderT) +import Database.Persist.Sql ( + SqlBackend, + ) + +-------------------------------------------------------------------------------- +-- insertManyTxOut - Insert a list of TxOut into the database. +-------------------------------------------------------------------------------- +insertManyTxOut :: + (MonadBaseControl IO m, MonadIO m) => + Bool -> + [TxOutW] -> + ReaderT SqlBackend m [TxOutIdW] +insertManyTxOut disInOut txOutWs = do + if disInOut + then pure [] + else case txOutWs of + [] -> pure [] + txOuts@(txOutW : _) -> + case txOutW of + CTxOutW _ -> do + vals <- insertMany' "insertManyTxOutC" (map extractCoreTxOut txOuts) + pure $ map CTxOutIdW vals + VTxOutW _ _ -> do + vals <- insertMany' "insertManyTxOutV" (map extractVariantTxOut txOuts) + pure $ map VTxOutIdW vals + where + extractCoreTxOut :: TxOutW -> C.TxOut + extractCoreTxOut (CTxOutW txOut) = txOut + extractCoreTxOut (VTxOutW _ _) = error "Unexpected VTxOutW in CoreTxOut list" + + extractVariantTxOut :: TxOutW -> V.TxOut + extractVariantTxOut (VTxOutW txOut _) = txOut + extractVariantTxOut (CTxOutW _) = error "Unexpected CTxOutW in VariantTxOut list" + +-------------------------------------------------------------------------------- +-- insertTxOut - Insert a TxOut into the database. +-------------------------------------------------------------------------------- +insertTxOut :: (MonadBaseControl IO m, MonadIO m) => TxOutW -> ReaderT SqlBackend m TxOutIdW +insertTxOut txOutW = do + case txOutW of + CTxOutW txOut -> do + val <- insertUnchecked "insertTxOutC" txOut + pure $ CTxOutIdW val + VTxOutW txOut _ -> do + val <- insertUnchecked "insertTxOutV" txOut + pure $ VTxOutIdW val + +-------------------------------------------------------------------------------- +-- insertAddress - Insert a Address into the database. +-------------------------------------------------------------------------------- +insertAddress :: (MonadBaseControl IO m, MonadIO m) => V.Address -> ReaderT SqlBackend m V.AddressId +insertAddress = insertUnchecked "insertAddress" + +-------------------------------------------------------------------------------- +-- insertManyMaTxOut - Insert a list of MultiAsset TxOut into the database. +-------------------------------------------------------------------------------- +insertManyMaTxOut :: (MonadBaseControl IO m, MonadIO m) => [MaTxOutW] -> ReaderT SqlBackend m [MaTxOutIdW] +insertManyMaTxOut maTxOutWs = do + case maTxOutWs of + [] -> pure [] + maTxOuts@(maTxOutW : _) -> + case maTxOutW of + CMaTxOutW _ -> do + vals <- insertMany' "Many Variant MaTxOut" (map extractCoreMaTxOut maTxOuts) + pure $ map CMaTxOutIdW vals + VMaTxOutW _ -> do + vals <- insertMany' "Many Variant MaTxOut" (map extractVariantMaTxOut maTxOuts) + pure $ map VMaTxOutIdW vals + where + extractCoreMaTxOut :: MaTxOutW -> C.MaTxOut + extractCoreMaTxOut (CMaTxOutW maTxOut) = maTxOut + extractCoreMaTxOut (VMaTxOutW _) = error "Unexpected VMaTxOutW in CoreMaTxOut list" + + extractVariantMaTxOut :: MaTxOutW -> V.MaTxOut + extractVariantMaTxOut (VMaTxOutW maTxOut) = maTxOut + extractVariantMaTxOut (CMaTxOutW _) = error "Unexpected CMaTxOutW in VariantMaTxOut list" diff --git a/cardano-db/src/Cardano/Db/Operations/Variant/TxOutQuery.hs b/cardano-db/src/Cardano/Db/Operations/Variant/TxOutQuery.hs new file mode 100644 index 000000000..f78cf93dd --- /dev/null +++ b/cardano-db/src/Cardano/Db/Operations/Variant/TxOutQuery.hs @@ -0,0 +1,576 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Cardano.Db.Operations.Variant.TxOutQuery where + +import Cardano.Db.Error (LookupFail (..)) +import Cardano.Db.Operations.Core.QueryHelper (isJust, maybeToEither, txLessEqual, unValue2, unValue3, unValueSumAda) +import Cardano.Db.Operations.Types (TxOutFields (..), TxOutIdW (..), TxOutTableType (..), TxOutW (..), UtxoQueryResult (..)) +import Cardano.Db.Schema.BaseSchema +import qualified Cardano.Db.Schema.Core.TxOut as C +import qualified Cardano.Db.Schema.Variant.TxOut as V +import Cardano.Db.Types (Ada, DbLovelace (..)) +import Cardano.Prelude (Bifunctor (second), ByteString, ReaderT, Text, Word64, listToMaybe, mapMaybe) +import Control.Monad.IO.Class (MonadIO) +import Database.Esqueleto.Experimental ( + Entity (..), + SqlBackend, + SqlExpr, + SqlQuery, + Value (..), + countRows, + from, + in_, + innerJoin, + isNothing, + just, + leftJoin, + notExists, + on, + select, + sum_, + table, + val, + where_, + (&&.), + (==.), + (>.), + (?.), + (^.), + (||.), + type (:&) ((:&)), + ) + +{- HLINT ignore "Fuse on/on" -} +{- HLINT ignore "Redundant ^." -} + +-- Some Queries can accept TxOutTableType as a parameter, whilst others that return a TxOut related value can't +-- as they wiil either deal with Core or Variant TxOut/Address types. +-- These types also need to be handled at the call site. + +-------------------------------------------------------------------------------- +-- queryTxOutValue +-------------------------------------------------------------------------------- + +-- | Like 'queryTxId' but also return the 'TxOutIdValue' of the transaction output. +queryTxOutValue :: + MonadIO m => + TxOutTableType -> + (ByteString, Word64) -> + ReaderT SqlBackend m (Either LookupFail (TxId, DbLovelace)) +queryTxOutValue txOutTableType hashIndex = + case txOutTableType of + TxOutCore -> queryTxOutValue' @'TxOutCore hashIndex + TxOutVariantAddress -> queryTxOutValue' @'TxOutVariantAddress hashIndex + where + queryTxOutValue' :: + forall (a :: TxOutTableType) m. + (MonadIO m, TxOutFields a) => + (ByteString, Word64) -> + ReaderT SqlBackend m (Either LookupFail (TxId, DbLovelace)) + queryTxOutValue' (hash, index) = do + res <- select $ do + (tx :& txOut) <- + from + $ table @Tx + `innerJoin` table @(TxOutTable a) + `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. txOutTxIdField @a) + where_ (txOut ^. txOutIndexField @a ==. val index &&. tx ^. TxHash ==. val hash) + pure (txOut ^. txOutTxIdField @a, txOut ^. txOutValueField @a) + pure $ maybeToEither (DbLookupTxHash hash) unValue2 (listToMaybe res) + +-------------------------------------------------------------------------------- +-- queryTxOutId +-------------------------------------------------------------------------------- + +-- | Like 'queryTxId' but also return the 'TxOutId' of the transaction output. +queryTxOutId :: + MonadIO m => + TxOutTableType -> + (ByteString, Word64) -> + ReaderT SqlBackend m (Either LookupFail (TxId, TxOutIdW)) +queryTxOutId txOutTableType hashIndex = + case txOutTableType of + TxOutCore -> wrapTxOutId CTxOutIdW (queryTxOutId' @'TxOutCore hashIndex) + TxOutVariantAddress -> wrapTxOutId VTxOutIdW (queryTxOutId' @'TxOutVariantAddress hashIndex) + where + wrapTxOutId constructor = fmap (fmap (second constructor)) + + queryTxOutId' :: + forall a m. + (TxOutFields a, MonadIO m) => + (ByteString, Word64) -> + ReaderT SqlBackend m (Either LookupFail (TxId, TxOutIdFor a)) + queryTxOutId' (hash, index) = do + res <- select $ do + (tx :& txOut) <- + from + $ table @Tx + `innerJoin` table @(TxOutTable a) + `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. txOutTxIdField @a) + where_ (txOut ^. txOutIndexField @a ==. val index &&. tx ^. TxHash ==. val hash) + pure (txOut ^. txOutTxIdField @a, txOut ^. txOutIdField @a) + pure $ maybeToEither (DbLookupTxHash hash) unValue2 (listToMaybe res) + +-------------------------------------------------------------------------------- +-- queryTxOutIdValue +-------------------------------------------------------------------------------- + +-- | Like 'queryTxOutId' but also return the 'TxOutIdValue' +queryTxOutIdValue :: + (MonadIO m) => + TxOutTableType -> + (ByteString, Word64) -> + ReaderT SqlBackend m (Either LookupFail (TxId, TxOutIdW, DbLovelace)) +queryTxOutIdValue getTxOutTableType hashIndex = do + case getTxOutTableType of + TxOutCore -> wrapTxOutId CTxOutIdW (queryTxOutIdValue' @'TxOutCore hashIndex) + TxOutVariantAddress -> wrapTxOutId VTxOutIdW (queryTxOutIdValue' @'TxOutVariantAddress hashIndex) + where + wrapTxOutId constructor = + fmap (fmap (\(txId, txOutId, lovelace) -> (txId, constructor txOutId, lovelace))) + + queryTxOutIdValue' :: + forall (a :: TxOutTableType) m. + (MonadIO m, TxOutFields a) => + (ByteString, Word64) -> + ReaderT SqlBackend m (Either LookupFail (TxId, TxOutIdFor a, DbLovelace)) + queryTxOutIdValue' (hash, index) = do + res <- select $ do + (tx :& txOut) <- + from + $ table @Tx + `innerJoin` table @(TxOutTable a) + `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. txOutTxIdField @a) + where_ (txOut ^. txOutIndexField @a ==. val index &&. tx ^. TxHash ==. val hash) + pure (txOut ^. txOutTxIdField @a, txOut ^. txOutIdField @a, txOut ^. txOutValueField @a) + pure $ maybeToEither (DbLookupTxHash hash) unValue3 (listToMaybe res) + +-------------------------------------------------------------------------------- +-- queryTxOutIdValue +-------------------------------------------------------------------------------- + +-- | Give a (tx hash, index) pair, return the TxOut Credentials. +queryTxOutCredentials :: + MonadIO m => + TxOutTableType -> + (ByteString, Word64) -> + ReaderT SqlBackend m (Either LookupFail (Maybe ByteString, Bool)) +queryTxOutCredentials txOutTableType (hash, index) = + case txOutTableType of + TxOutCore -> queryTxOutCredentialsCore (hash, index) + TxOutVariantAddress -> queryTxOutCredentialsVariant (hash, index) + +queryTxOutCredentialsCore :: MonadIO m => (ByteString, Word64) -> ReaderT SqlBackend m (Either LookupFail (Maybe ByteString, Bool)) +queryTxOutCredentialsCore (hash, index) = do + res <- select $ do + (tx :& txOut) <- + from + $ table @Tx + `innerJoin` table @C.TxOut + `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. C.TxOutTxId) + where_ (txOut ^. C.TxOutIndex ==. val index &&. tx ^. TxHash ==. val hash) + pure (txOut ^. C.TxOutPaymentCred, txOut ^. C.TxOutAddressHasScript) + pure $ maybeToEither (DbLookupTxHash hash) unValue2 (listToMaybe res) + +queryTxOutCredentialsVariant :: MonadIO m => (ByteString, Word64) -> ReaderT SqlBackend m (Either LookupFail (Maybe ByteString, Bool)) +queryTxOutCredentialsVariant (hash, index) = do + res <- select $ do + (tx :& txOut :& address) <- + from + $ ( table @Tx + `innerJoin` table @V.TxOut + `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. V.TxOutTxId) + ) + `innerJoin` table @V.Address + `on` (\((_ :& txOut) :& address) -> txOut ^. V.TxOutAddressId ==. address ^. V.AddressId) + where_ (txOut ^. V.TxOutIndex ==. val index &&. tx ^. TxHash ==. val hash) + pure (address ^. V.AddressPaymentCred, address ^. V.AddressHasScript) + pure $ maybeToEither (DbLookupTxHash hash) unValue2 (listToMaybe res) + +-------------------------------------------------------------------------------- +-- queryUtxoAtBlockNo +-------------------------------------------------------------------------------- +queryUtxoAtBlockNo :: MonadIO m => TxOutTableType -> Word64 -> ReaderT SqlBackend m [UtxoQueryResult] +queryUtxoAtBlockNo txOutTableType blkNo = do + eblkId <- select $ do + blk <- from $ table @Block + where_ (blk ^. BlockBlockNo ==. just (val blkNo)) + pure (blk ^. BlockId) + maybe (pure []) (queryUtxoAtBlockId txOutTableType . unValue) (listToMaybe eblkId) + +-------------------------------------------------------------------------------- +-- queryUtxoAtSlotNo +-------------------------------------------------------------------------------- +queryUtxoAtSlotNo :: MonadIO m => TxOutTableType -> Word64 -> ReaderT SqlBackend m [UtxoQueryResult] +queryUtxoAtSlotNo txOutTableType slotNo = do + eblkId <- select $ do + blk <- from $ table @Block + where_ (blk ^. BlockSlotNo ==. just (val slotNo)) + pure (blk ^. BlockId) + maybe (pure []) (queryUtxoAtBlockId txOutTableType . unValue) (listToMaybe eblkId) + +-------------------------------------------------------------------------------- +-- queryUtxoAtBlockId +-------------------------------------------------------------------------------- +queryUtxoAtBlockId :: MonadIO m => TxOutTableType -> BlockId -> ReaderT SqlBackend m [UtxoQueryResult] +queryUtxoAtBlockId txOutTableType blkid = + case txOutTableType of + TxOutCore -> queryUtxoAtBlockIdCore blkid + TxOutVariantAddress -> queryUtxoAtBlockIdVariant blkid + +queryUtxoAtBlockIdCore :: MonadIO m => BlockId -> ReaderT SqlBackend m [UtxoQueryResult] +queryUtxoAtBlockIdCore blkid = do + outputs <- select $ do + (txout :& _txin :& _tx1 :& blk :& tx2) <- + from + $ table @C.TxOut + `leftJoin` table @TxIn + `on` ( \(txout :& txin) -> + (just (txout ^. C.TxOutTxId) ==. txin ?. TxInTxOutId) + &&. (just (txout ^. C.TxOutIndex) ==. txin ?. TxInTxOutIndex) + ) + `leftJoin` table @Tx + `on` (\(_txout :& txin :& tx1) -> txin ?. TxInTxInId ==. tx1 ?. TxId) + `leftJoin` table @Block + `on` (\(_txout :& _txin :& tx1 :& blk) -> tx1 ?. TxBlockId ==. blk ?. BlockId) + `leftJoin` table @Tx + `on` (\(txout :& _ :& _ :& _ :& tx2) -> just (txout ^. C.TxOutTxId) ==. tx2 ?. TxId) + + where_ $ + (txout ^. C.TxOutTxId `in_` txLessEqual blkid) + &&. (isNothing (blk ?. BlockBlockNo) ||. (blk ?. BlockId >. just (val blkid))) + pure (txout, txout ^. C.TxOutAddress, tx2 ?. TxHash) + pure $ mapMaybe convertCore outputs + +queryUtxoAtBlockIdVariant :: MonadIO m => BlockId -> ReaderT SqlBackend m [UtxoQueryResult] +queryUtxoAtBlockIdVariant blkid = do + outputs <- select $ do + (txout :& _txin :& _tx1 :& blk :& tx2 :& address) <- + from + $ table @V.TxOut + `leftJoin` table @TxIn + `on` ( \(txout :& txin) -> + (just (txout ^. V.TxOutTxId) ==. txin ?. TxInTxOutId) + &&. (just (txout ^. V.TxOutIndex) ==. txin ?. TxInTxOutIndex) + ) + `leftJoin` table @Tx + `on` (\(_txout :& txin :& tx1) -> txin ?. TxInTxInId ==. tx1 ?. TxId) + `leftJoin` table @Block + `on` (\(_txout :& _txin :& tx1 :& blk) -> tx1 ?. TxBlockId ==. blk ?. BlockId) + `leftJoin` table @Tx + `on` (\(txout :& _ :& _ :& _ :& tx2) -> just (txout ^. V.TxOutTxId) ==. tx2 ?. TxId) + `innerJoin` table @V.Address + `on` (\(txout :& _ :& _ :& _ :& _ :& address) -> txout ^. V.TxOutAddressId ==. address ^. V.AddressId) + + where_ $ + (txout ^. V.TxOutTxId `in_` txLessEqual blkid) + &&. (isNothing (blk ?. BlockBlockNo) ||. (blk ?. BlockId >. just (val blkid))) + pure (txout, address, tx2 ?. TxHash) + pure $ mapMaybe convertVariant outputs + +convertCore :: (Entity C.TxOut, Value Text, Value (Maybe ByteString)) -> Maybe UtxoQueryResult +convertCore (out, Value address, Value (Just hash')) = + Just $ + UtxoQueryResult + { utxoTxOutW = CTxOutW $ entityVal out + , utxoAddress = address + , utxoTxHash = hash' + } +convertCore _ = Nothing + +convertVariant :: (Entity V.TxOut, Entity V.Address, Value (Maybe ByteString)) -> Maybe UtxoQueryResult +convertVariant (out, address, Value (Just hash')) = + Just $ + UtxoQueryResult + { utxoTxOutW = VTxOutW (entityVal out) (Just (entityVal address)) + , utxoAddress = V.addressAddress $ entityVal address + , utxoTxHash = hash' + } +convertVariant _ = Nothing + +-------------------------------------------------------------------------------- +-- queryAddressBalanceAtSlot +-------------------------------------------------------------------------------- +queryAddressBalanceAtSlot :: MonadIO m => TxOutTableType -> Text -> Word64 -> ReaderT SqlBackend m Ada +queryAddressBalanceAtSlot txOutTableType addr slotNo = do + eblkId <- select $ do + blk <- from (table @Block) + where_ (blk ^. BlockSlotNo ==. just (val slotNo)) + pure (blk ^. BlockId) + maybe (pure 0) (queryAddressBalanceAtBlockId . unValue) (listToMaybe eblkId) + where + queryAddressBalanceAtBlockId :: MonadIO m => BlockId -> ReaderT SqlBackend m Ada + queryAddressBalanceAtBlockId blkid = do + -- tx1 refers to the tx of the input spending this output (if it is ever spent) + -- tx2 refers to the tx of the output + case txOutTableType of + TxOutCore -> do + res <- select $ do + (txout :& _ :& _ :& blk :& _) <- + from + $ table @C.TxOut + `leftJoin` table @TxIn + `on` (\(txout :& txin) -> just (txout ^. C.TxOutTxId) ==. txin ?. TxInTxOutId) + `leftJoin` table @Tx + `on` (\(_ :& txin :& tx1) -> txin ?. TxInTxInId ==. tx1 ?. TxId) + `leftJoin` table @Block + `on` (\(_ :& _ :& tx1 :& blk) -> tx1 ?. TxBlockId ==. blk ?. BlockId) + `leftJoin` table @Tx + `on` (\(txout :& _ :& _ :& _ :& tx2) -> just (txout ^. C.TxOutTxId) ==. tx2 ?. TxId) + where_ $ + (txout ^. C.TxOutTxId `in_` txLessEqual blkid) + &&. (isNothing (blk ?. BlockBlockNo) ||. (blk ?. BlockId >. just (val blkid))) + where_ (txout ^. C.TxOutAddress ==. val addr) + pure $ sum_ (txout ^. C.TxOutValue) + pure $ unValueSumAda (listToMaybe res) + TxOutVariantAddress -> do + res <- select $ do + (txout :& _ :& _ :& blk :& _ :& address) <- + from + $ table @V.TxOut + `leftJoin` table @TxIn + `on` (\(txout :& txin) -> just (txout ^. V.TxOutTxId) ==. txin ?. TxInTxOutId) + `leftJoin` table @Tx + `on` (\(_ :& txin :& tx1) -> txin ?. TxInTxInId ==. tx1 ?. TxId) + `leftJoin` table @Block + `on` (\(_ :& _ :& tx1 :& blk) -> tx1 ?. TxBlockId ==. blk ?. BlockId) + `leftJoin` table @Tx + `on` (\(txout :& _ :& _ :& _ :& tx2) -> just (txout ^. V.TxOutTxId) ==. tx2 ?. TxId) + `innerJoin` table @V.Address + `on` (\(txout :& _ :& _ :& _ :& _ :& address) -> txout ^. V.TxOutAddressId ==. address ^. V.AddressId) + where_ $ + (txout ^. V.TxOutTxId `in_` txLessEqual blkid) + &&. (isNothing (blk ?. BlockBlockNo) ||. (blk ?. BlockId >. just (val blkid))) + where_ (address ^. V.AddressAddress ==. val addr) + pure $ sum_ (txout ^. V.TxOutValue) + pure $ unValueSumAda (listToMaybe res) + +-------------------------------------------------------------------------------- +-- queryScriptOutputs +-------------------------------------------------------------------------------- +queryScriptOutputs :: MonadIO m => TxOutTableType -> ReaderT SqlBackend m [TxOutW] +queryScriptOutputs txOutTableType = + case txOutTableType of + TxOutCore -> fmap (map CTxOutW) queryScriptOutputsCore + TxOutVariantAddress -> queryScriptOutputsVariant + +queryScriptOutputsCore :: MonadIO m => ReaderT SqlBackend m [C.TxOut] +queryScriptOutputsCore = do + res <- select $ do + tx_out <- from $ table @C.TxOut + where_ (tx_out ^. C.TxOutAddressHasScript ==. val True) + pure tx_out + pure $ entityVal <$> res + +queryScriptOutputsVariant :: MonadIO m => ReaderT SqlBackend m [TxOutW] +queryScriptOutputsVariant = do + res <- select $ do + address <- from $ table @V.Address + tx_out <- from $ table @V.TxOut + where_ (address ^. V.AddressHasScript ==. val True) + where_ (tx_out ^. V.TxOutAddressId ==. address ^. V.AddressId) + pure (tx_out, address) + pure $ map (uncurry combineToWrapper) res + where + combineToWrapper :: Entity V.TxOut -> Entity V.Address -> TxOutW + combineToWrapper txOut address = + VTxOutW (entityVal txOut) (Just (entityVal address)) + +-------------------------------------------------------------------------------- +-- ADDRESS QUERIES +-------------------------------------------------------------------------------- +queryAddressId :: MonadIO m => ByteString -> ReaderT SqlBackend m (Maybe V.AddressId) +queryAddressId addrRaw = do + res <- select $ do + addr <- from $ table @V.Address + where_ (addr ^. V.AddressRaw ==. val addrRaw) + pure (addr ^. V.AddressId) + pure $ unValue <$> listToMaybe res + +queryAddressById :: MonadIO m => V.AddressId -> ReaderT SqlBackend m (Maybe V.Address) +queryAddressById addrId = do + res <- select $ do + addr <- from $ table @V.Address + where_ (addr ^. V.AddressId ==. val addrId) + pure addr + pure $ entityVal <$> listToMaybe res + +-------------------------------------------------------------------------------- +-- queryAddressOutputs +-------------------------------------------------------------------------------- +queryAddressOutputs :: MonadIO m => TxOutTableType -> Text -> ReaderT SqlBackend m DbLovelace +queryAddressOutputs txOutTableType addr = do + res <- case txOutTableType of + TxOutCore -> select $ do + txout <- from $ table @C.TxOut + where_ (txout ^. C.TxOutAddress ==. val addr) + pure $ sum_ (txout ^. C.TxOutValue) + TxOutVariantAddress -> select $ do + address <- from $ table @V.Address + txout <- from $ table @V.TxOut + where_ (address ^. V.AddressAddress ==. val addr) + where_ (txout ^. V.TxOutAddressId ==. address ^. V.AddressId) + pure $ sum_ (txout ^. V.TxOutValue) + pure $ convert (listToMaybe res) + where + convert v = case unValue <$> v of + Just (Just x) -> x + _otherwise -> DbLovelace 0 + +-------------------------------------------------------------------------------- +-- queryTotalSupply +-------------------------------------------------------------------------------- + +-- | Get the current total supply of Lovelace. This only returns the on-chain supply which +-- does not include staking rewards that have not yet been withdrawn. Before wihdrawal +-- rewards are part of the ledger state and hence not on chain. +queryTotalSupply :: + (MonadIO m) => + TxOutTableType -> + ReaderT SqlBackend m Ada +queryTotalSupply txOutTableType = + case txOutTableType of + TxOutCore -> query @'TxOutCore + TxOutVariantAddress -> query @'TxOutVariantAddress + where + query :: + forall (a :: TxOutTableType) m. + (MonadIO m, TxOutFields a) => + ReaderT SqlBackend m Ada + query = do + res <- select $ do + txOut <- from $ table @(TxOutTable a) + txOutUnspentP @a txOut + pure $ sum_ (txOut ^. txOutValueField @a) + pure $ unValueSumAda (listToMaybe res) + +-------------------------------------------------------------------------------- +-- queryGenesisSupply +-------------------------------------------------------------------------------- + +-- | Return the total Genesis coin supply. +queryGenesisSupply :: + (MonadIO m) => + TxOutTableType -> + ReaderT SqlBackend m Ada +queryGenesisSupply txOutTableType = + case txOutTableType of + TxOutCore -> query @'TxOutCore + TxOutVariantAddress -> query @'TxOutVariantAddress + where + query :: + forall (a :: TxOutTableType) m. + (MonadIO m, TxOutFields a) => + ReaderT SqlBackend m Ada + query = do + res <- select $ do + (_tx :& txOut :& blk) <- + from + $ table @Tx + `innerJoin` table @(TxOutTable a) + `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. txOutTxIdField @a) + `innerJoin` table @Block + `on` (\(tx :& _txOut :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) + where_ (isNothing $ blk ^. BlockPreviousId) + pure $ sum_ (txOut ^. txOutValueField @a) + pure $ unValueSumAda (listToMaybe res) + +-------------------------------------------------------------------------------- +-- queryShelleyGenesisSupply +-------------------------------------------------------------------------------- + +-- | Return the total Shelley Genesis coin supply. The Shelley Genesis Block +-- is the unique which has a non-null PreviousId, but has null Epoch. +queryShelleyGenesisSupply :: MonadIO m => TxOutTableType -> ReaderT SqlBackend m Ada +queryShelleyGenesisSupply txOutTableType = + case txOutTableType of + TxOutCore -> query @'TxOutCore + TxOutVariantAddress -> query @'TxOutVariantAddress + where + query :: + forall (a :: TxOutTableType) m. + (MonadIO m, TxOutFields a) => + ReaderT SqlBackend m Ada + query = do + res <- select $ do + (txOut :& _tx :& blk) <- + from + $ table @(TxOutTable a) + `innerJoin` table @Tx + `on` (\(txOut :& tx) -> tx ^. TxId ==. txOut ^. txOutTxIdField @a) + `innerJoin` table @Block + `on` (\(_txOut :& tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) + where_ (isJust $ blk ^. BlockPreviousId) + where_ (isNothing $ blk ^. BlockEpochNo) + pure $ sum_ (txOut ^. txOutValueField @a) + pure $ unValueSumAda (listToMaybe res) + +-------------------------------------------------------------------------------- +-- Helper Functions +-------------------------------------------------------------------------------- + +-- | Count the number of transaction outputs in the TxOut table. +queryTxOutCount :: + MonadIO m => + TxOutTableType -> + ReaderT SqlBackend m Word +queryTxOutCount txOutTableType = do + case txOutTableType of + TxOutCore -> query @'TxOutCore + TxOutVariantAddress -> query @'TxOutVariantAddress + where + query :: + forall (a :: TxOutTableType) m. + (MonadIO m, TxOutFields a) => + ReaderT SqlBackend m Word + query = do + res <- select $ from (table @(TxOutTable a)) >> pure countRows + pure $ maybe 0 unValue (listToMaybe res) + +queryTxOutUnspentCount :: + MonadIO m => + TxOutTableType -> + ReaderT SqlBackend m Word64 +queryTxOutUnspentCount txOutTableType = + case txOutTableType of + TxOutCore -> query @'TxOutCore + TxOutVariantAddress -> query @'TxOutVariantAddress + where + query :: + forall (a :: TxOutTableType) m. + (MonadIO m, TxOutFields a) => + ReaderT SqlBackend m Word64 + query = do + res <- select $ do + txOut <- from $ table @(TxOutTable a) + txOutUnspentP @a txOut + pure countRows + pure $ maybe 0 unValue (listToMaybe res) + +-- A predicate that filters out spent 'TxOut' entries. +{-# INLINEABLE txOutUnspentP #-} +txOutUnspentP :: forall a. TxOutFields a => SqlExpr (Entity (TxOutTable a)) -> SqlQuery () +txOutUnspentP txOut = + where_ . notExists $ + from (table @TxIn) >>= \txIn -> + where_ + ( txOut + ^. txOutTxIdField @a + ==. txIn + ^. TxInTxOutId + &&. txOut + ^. txOutIndexField @a + ==. txIn + ^. TxInTxOutIndex + ) diff --git a/cardano-db/src/Cardano/Db/Schema.hs b/cardano-db/src/Cardano/Db/Schema/BaseSchema.hs similarity index 95% rename from cardano-db/src/Cardano/Db/Schema.hs rename to cardano-db/src/Cardano/Db/Schema/BaseSchema.hs index aa02ba579..41240348b 100644 --- a/cardano-db/src/Cardano/Db/Schema.hs +++ b/cardano-db/src/Cardano/Db/Schema/BaseSchema.hs @@ -16,7 +16,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -module Cardano.Db.Schema where +module Cardano.Db.Schema.BaseSchema where import Cardano.Db.Schema.Orphans () import Cardano.Db.Schema.Types ( @@ -60,7 +60,7 @@ import Database.Persist.TH share [ mkPersist sqlSettings - , mkMigrate "migrateCardanoDb" + , mkMigrate "migrateBaseCardanoDb" , mkEntityDefList "entityDefs" , deriveShowFields ] @@ -148,20 +148,6 @@ share scriptHash ByteString Maybe sqltype=hash28type UniqueStakeAddress hashRaw - TxOut - txId TxId noreference - index Word64 sqltype=txindex - address Text Maybe - addressHasScript Bool - paymentCred ByteString Maybe sqltype=hash28type - stakeAddressId StakeAddressId Maybe noreference - value DbLovelace sqltype=lovelace - dataHash ByteString Maybe sqltype=hash32type - inlineDatumId DatumId Maybe noreference - referenceScriptId ScriptId Maybe noreference - addressDetailId AddressDetailId Maybe noreference - UniqueTxout txId index -- The (tx_id, index) pair must be unique. - CollateralTxOut txId TxId noreference -- This type is the primary key for the 'tx' table. index Word64 sqltype=txindex @@ -175,13 +161,6 @@ share inlineDatumId DatumId Maybe noreference referenceScriptId ScriptId Maybe noreference - AddressDetail - address Text - addressRaw ByteString - hasScript Bool - paymentCred ByteString Maybe sqltype=hash28type - stakeAddressId StakeAddressId Maybe noreference - TxIn txInId TxId noreference -- The transaction where this is used as an input. txOutId TxId noreference -- The transaction where this was created as an output. @@ -395,11 +374,6 @@ share quantity DbInt65 sqltype=int65type txId TxId noreference - MaTxOut - ident MultiAssetId noreference - quantity DbWord64 sqltype=word64type - txOutId TxOutId noreference - -- Unit step is in picosends, and `maxBound :: Int64` picoseconds is over 100 days, so using -- Word64/word63type is safe here. Similarly, `maxBound :: Int64` if unit step would be an -- *enormous* amount a memory which would cost a fortune. @@ -861,20 +835,6 @@ schemaDocs = StakeAddressView # "The Bech32 encoded version of the stake address." StakeAddressScriptHash # "The script hash, in case this address is locked by a script." - TxOut --^ do - "A table for transaction outputs." - TxOutTxId # "The Tx table index of the transaction that contains this transaction output." - TxOutIndex # "The index of this transaction output with the transaction." - TxOutAddress # "The human readable encoding of the output address. Will be Base58 for Byron era addresses and Bech32 for Shelley era." - TxOutAddressHasScript # "Flag which shows if this address is locked by a script." - TxOutPaymentCred # "The payment credential part of the Shelley address. (NULL for Byron addresses). For a script-locked address, this is the script hash." - TxOutStakeAddressId # "The StakeAddress table index for the stake address part of the Shelley address. (NULL for Byron addresses)." - TxOutValue # "The output value (in Lovelace) of the transaction output." - TxOutDataHash # "The hash of the transaction output datum. (NULL for Txs without scripts)." - TxOutInlineDatumId # "The inline datum of the output, if it has one. New in v13." - TxOutReferenceScriptId # "The reference script of the output, if it has one. New in v13." - TxOutAddressDetailId # "The human readable encoding of the output address. It is Base58 for Byron era addresses and Bech32 for Shelley era." - CollateralTxOut --^ do "A table for transaction collateral outputs. New in v13." CollateralTxOutTxId # "The Tx table index of the transaction that contains this transaction output." @@ -889,14 +849,6 @@ schemaDocs = CollateralTxOutInlineDatumId # "The inline datum of the output, if it has one. New in v13." CollateralTxOutReferenceScriptId # "The reference script of the output, if it has one. New in v13." - AddressDetail --^ do - "A table for addresses that appear in outputs." - AddressDetailAddress # "The human readable encoding of the output address. Will be Base58 for Byron era addresses and Bech32 for Shelley era." - AddressDetailAddressRaw # "The raw binary address." - AddressDetailHasScript # "Flag which shows if this address is locked by a script." - AddressDetailPaymentCred # "The payment credential part of the Shelley address. (NULL for Byron addresses). For a script-locked address, this is the script hash." - AddressDetailStakeAddressId # "The StakeAddress table index for the stake address part of the Shelley address. (NULL for Byron addresses)." - TxIn --^ do "A table for transaction inputs." TxInTxInId # "The Tx table index of the transaction that contains this transaction input." @@ -1117,12 +1069,6 @@ schemaDocs = MaTxMintQuantity # "The amount of the Multi Asset to mint (can be negative to \"burn\" assets)." MaTxMintTxId # "The Tx table index for the transaction that contains this minting event." - MaTxOut --^ do - "A table containing Multi-Asset transaction outputs." - MaTxOutIdent # "The MultiAsset table index specifying the asset." - MaTxOutQuantity # "The Multi Asset transaction output amount (denominated in the Multi Asset)." - MaTxOutTxOutId # "The TxOut table index for the transaction that this Multi Asset transaction output." - Redeemer --^ do "A table containing redeemers. A redeemer is provided for all items that are validated by a script." RedeemerTxId # "The Tx table index that contains this redeemer." diff --git a/cardano-db/src/Cardano/Db/Schema/Core/TxOut.hs b/cardano-db/src/Cardano/Db/Schema/Core/TxOut.hs new file mode 100644 index 000000000..79858e6dd --- /dev/null +++ b/cardano-db/src/Cardano/Db/Schema/Core/TxOut.hs @@ -0,0 +1,86 @@ +{-# 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.Schema.Core.TxOut where + +import Cardano.Db.Schema.BaseSchema (DatumId, MultiAssetId, ScriptId, StakeAddressId, TxId) +import Cardano.Db.Types (DbLovelace, DbWord64) +import Data.ByteString.Char8 (ByteString) +import Data.Text (Text) +import Data.Word (Word64) +import Database.Persist.Documentation (deriveShowFields, document, (#), (--^)) +import Database.Persist.EntityDef.Internal (EntityDef (..)) +import Database.Persist.TH + +share + [ mkPersist sqlSettings + , mkMigrate "migrateCoreTxOutCardanoDb" + , mkEntityDefList "entityDefs" + , deriveShowFields + ] + [persistLowerCase| +---------------------------------------------- +-- Bassic Address TxOut +---------------------------------------------- + TxOut + address Text + addressHasScript Bool + dataHash ByteString Maybe sqltype=hash32type + consumedByTxId TxId Maybe noreference + index Word64 sqltype=txindex + inlineDatumId DatumId Maybe noreference + paymentCred ByteString Maybe sqltype=hash28type + referenceScriptId ScriptId Maybe noreference + stakeAddressId StakeAddressId Maybe noreference + txId TxId noreference + value DbLovelace sqltype=lovelace + UniqueTxout txId index -- The (tx_id, index) pair must be unique. + +---------------------------------------------- +-- MultiAsset +---------------------------------------------- + MaTxOut + ident MultiAssetId noreference + quantity DbWord64 sqltype=word64type + txOutId TxOutId noreference + deriving Show + +|] + +schemaDocs :: [EntityDef] +schemaDocs = + document entityDefs $ do + TxOut --^ do + "A table for transaction outputs." + TxOutAddress # "The human readable encoding of the output address. Will be Base58 for Byron era addresses and Bech32 for Shelley era." + TxOutAddressHasScript # "Flag which shows if this address is locked by a script." + TxOutDataHash # "The hash of the transaction output datum. (NULL for Txs without scripts)." + TxOutIndex # "The index of this transaction output with the transaction." + TxOutInlineDatumId # "The inline datum of the output, if it has one. New in v13." + TxOutPaymentCred # "The payment credential part of the Shelley address. (NULL for Byron addresses). For a script-locked address, this is the script hash." + TxOutReferenceScriptId # "The reference script of the output, if it has one. New in v13." + TxOutStakeAddressId # "The StakeAddress table index for the stake address part of the Shelley address. (NULL for Byron addresses)." + TxOutValue # "The output value (in Lovelace) of the transaction output." + + TxOutTxId # "The Tx table index of the transaction that contains this transaction output." + + MaTxOut --^ do + "A table containing Multi-Asset transaction outputs." + MaTxOutIdent # "The MultiAsset table index specifying the asset." + MaTxOutQuantity # "The Multi Asset transaction output amount (denominated in the Multi Asset)." + MaTxOutTxOutId # "The TxOut table index for the transaction that this Multi Asset transaction output." diff --git a/cardano-db/src/Cardano/Db/Schema/CoreSchema.hs b/cardano-db/src/Cardano/Db/Schema/CoreSchema.hs new file mode 100644 index 000000000..8ab13404a --- /dev/null +++ b/cardano-db/src/Cardano/Db/Schema/CoreSchema.hs @@ -0,0 +1 @@ +module Cardano.Db.Schema.CoreSchema where diff --git a/cardano-db/src/Cardano/Db/Schema/Variant/TxOut.hs b/cardano-db/src/Cardano/Db/Schema/Variant/TxOut.hs new file mode 100644 index 000000000..49681418e --- /dev/null +++ b/cardano-db/src/Cardano/Db/Schema/Variant/TxOut.hs @@ -0,0 +1,93 @@ +{-# 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.Schema.Variant.TxOut where + +import Cardano.Db.Schema.BaseSchema (DatumId, MultiAssetId, ScriptId, StakeAddressId, TxId) +import Cardano.Db.Types (DbLovelace, DbWord64) +import Data.ByteString.Char8 (ByteString) +import Data.Text (Text) +import Data.Word (Word64) +import Database.Persist.Documentation (deriveShowFields, document, (#), (--^)) +import Database.Persist.EntityDef.Internal (EntityDef (..)) +import Database.Persist.TH + +share + [ mkPersist sqlSettings + , mkMigrate "migrateVariantAddressCardanoDb" + , mkEntityDefList "entityDefs" + , deriveShowFields + ] + [persistLowerCase| +---------------------------------------------- +-- Variant Address TxOut +---------------------------------------------- + TxOut + addressId AddressId noreference + consumedByTxId TxId Maybe noreference + dataHash ByteString Maybe sqltype=hash32type + index Word64 sqltype=txindex + inlineDatumId DatumId Maybe noreference + referenceScriptId ScriptId Maybe noreference + txId TxId noreference + value DbLovelace sqltype=lovelace + UniqueTxout txId index -- The (tx_id, index) pair must be unique. + + Address + address Text + raw ByteString + hasScript Bool + paymentCred ByteString Maybe sqltype=hash28type + stakeAddressId StakeAddressId Maybe noreference + +---------------------------------------------- +-- MultiAsset +---------------------------------------------- + MaTxOut + ident MultiAssetId noreference + quantity DbWord64 sqltype=word64type + txOutId TxOutId noreference + deriving Show +|] + +schemaDocs :: [EntityDef] +schemaDocs = + document entityDefs $ do + TxOut --^ do + "A table for transaction outputs." + TxOutAddressId # "The human readable encoding of the output address. It is Base58 for Byron era addresses and Bech32 for Shelley era." + TxOutDataHash # "The hash of the transaction output datum. (NULL for Txs without scripts)." + TxOutIndex # "The index of this transaction output with the transaction." + TxOutInlineDatumId # "The inline datum of the output, if it has one. New in v13." + TxOutReferenceScriptId # "The reference script of the output, if it has one. New in v13." + TxOutValue # "The output value (in Lovelace) of the transaction output." + TxOutTxId # "The Tx table index of the transaction that contains this transaction output." + + Address --^ do + "A table for addresses that appear in outputs." + AddressAddress # "The human readable encoding of the output address. Will be Base58 for Byron era addresses and Bech32 for Shelley era." + AddressRaw # "The raw binary address." + AddressHasScript # "Flag which shows if this address is locked by a script." + AddressPaymentCred # "The payment credential part of the Shelley address. (NULL for Byron addresses). For a script-locked address, this is the script hash." + AddressStakeAddressId # "The StakeAddress table index for the stake address part of the Shelley address. (NULL for Byron addresses)." + + MaTxOut --^ do + "A table containing Multi-Asset transaction outputs." + MaTxOutIdent # "The MultiAsset table index specifying the asset." + MaTxOutQuantity # "The Multi Asset transaction output amount (denominated in the Multi Asset)." + MaTxOutTxOutId # "The TxOut table index for the transaction that this Multi Asset transaction output." diff --git a/cardano-db/src/Cardano/Db/Version/V13_0.hs b/cardano-db/src/Cardano/Db/Version/V13_0.hs new file mode 100644 index 000000000..b3b6e7969 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Version/V13_0.hs @@ -0,0 +1,6 @@ +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/Old/V13_0/Query.hs b/cardano-db/src/Cardano/Db/Version/V13_0/Query.hs similarity index 98% rename from cardano-db/src/Cardano/Db/Old/V13_0/Query.hs rename to cardano-db/src/Cardano/Db/Version/V13_0/Query.hs index 87696e98d..8463e72fd 100644 --- a/cardano-db/src/Cardano/Db/Old/V13_0/Query.hs +++ b/cardano-db/src/Cardano/Db/Version/V13_0/Query.hs @@ -4,7 +4,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module Cardano.Db.Old.V13_0.Query ( +module Cardano.Db.Version.V13_0.Query ( queryDatum, queryDatumPage, queryDatumCount, @@ -22,8 +22,8 @@ module Cardano.Db.Old.V13_0.Query ( updateScriptBytes, ) where -import Cardano.Db.Old.V13_0.Schema 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) diff --git a/cardano-db/src/Cardano/Db/Old/V13_0/Schema.hs b/cardano-db/src/Cardano/Db/Version/V13_0/Schema.hs similarity index 98% rename from cardano-db/src/Cardano/Db/Old/V13_0/Schema.hs rename to cardano-db/src/Cardano/Db/Version/V13_0/Schema.hs index a6baf21c6..d0efe77b6 100644 --- a/cardano-db/src/Cardano/Db/Old/V13_0/Schema.hs +++ b/cardano-db/src/Cardano/Db/Version/V13_0/Schema.hs @@ -16,7 +16,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -module Cardano.Db.Old.V13_0.Schema where +module Cardano.Db.Version.V13_0.Schema where import Cardano.Db.Schema.Orphans () import Cardano.Db.Types (DbLovelace, DbWord64, ScriptType) diff --git a/cardano-db/test/Test/IO/Cardano/Db/Insert.hs b/cardano-db/test/Test/IO/Cardano/Db/Insert.hs index da9b1d2a4..616a585cb 100644 --- a/cardano-db/test/Test/IO/Cardano/Db/Insert.hs +++ b/cardano-db/test/Test/IO/Cardano/Db/Insert.hs @@ -31,8 +31,8 @@ insertZeroTest = deleteAllBlocks -- Delete the blocks if they exist. slid <- insertSlotLeader testSlotLeader - void $ deleteBlock (blockOne slid) - void $ deleteBlock (blockZero slid) + void $ deleteBlock TxOutCore (blockOne slid) + void $ deleteBlock TxOutCore (blockZero slid) -- Insert the same block twice. The first should be successful (resulting -- in a 'Right') and the second should return the same value in a 'Left'. bid0 <- insertBlockChecked (blockZero slid) @@ -45,7 +45,7 @@ insertFirstTest = deleteAllBlocks -- Delete the block if it exists. slid <- insertSlotLeader testSlotLeader - void $ deleteBlock (blockOne slid) + void $ deleteBlock TxOutCore (blockOne slid) -- Insert the same block twice. bid0 <- insertBlockChecked (blockZero slid) bid1 <- insertBlockChecked $ (\b -> b {blockPreviousId = Just bid0}) (blockOne slid) diff --git a/cardano-db/test/Test/IO/Cardano/Db/Rollback.hs b/cardano-db/test/Test/IO/Cardano/Db/Rollback.hs index 21f1a235b..b4133bd92 100644 --- a/cardano-db/test/Test/IO/Cardano/Db/Rollback.hs +++ b/cardano-db/test/Test/IO/Cardano/Db/Rollback.hs @@ -4,6 +4,8 @@ #if __GLASGOW_HASKELL__ >= 908 {-# OPTIONS_GHC -Wno-x-partial #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} #endif module Test.IO.Cardano.Db.Rollback ( @@ -18,9 +20,6 @@ import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Reader (ReaderT) import Data.Word (Word64) import Database.Persist.Sql (SqlBackend) - --- import Test.Tasty.HUnit (testCase) - import Test.IO.Cardano.Db.Util import Test.Tasty (TestTree, testGroup) @@ -45,20 +44,20 @@ _rollbackTest = assertBool ("Block count before rollback is " ++ show beforeBlocks ++ " but should be 10.") $ beforeBlocks == 10 beforeTxCount <- queryTxCount assertBool ("Tx count before rollback is " ++ show beforeTxCount ++ " but should be 9.") $ beforeTxCount == 9 - beforeTxOutCount <- queryTxOutCount + beforeTxOutCount <- queryTxOutCount TxOutCore assertBool ("TxOut count before rollback is " ++ show beforeTxOutCount ++ " but should be 2.") $ beforeTxOutCount == 2 beforeTxInCount <- queryTxInCount assertBool ("TxIn count before rollback is " ++ show beforeTxInCount ++ " but should be 1.") $ beforeTxInCount == 1 -- Rollback a set of blocks. latestSlotNo <- queryLatestSlotNo Just pSlotNo <- queryWalkChain 5 latestSlotNo - void $ deleteBlocksSlotNoNoTrace (SlotNo pSlotNo) + void $ deleteBlocksSlotNoNoTrace TxOutCore (SlotNo pSlotNo) -- Assert the expected final state. afterBlocks <- queryBlockCount assertBool ("Block count after rollback is " ++ show afterBlocks ++ " but should be 10") $ afterBlocks == 4 afterTxCount <- queryTxCount assertBool ("Tx count after rollback is " ++ show afterTxCount ++ " but should be 10") $ afterTxCount == 1 - afterTxOutCount <- queryTxOutCount + afterTxOutCount <- queryTxOutCount TxOutCore assertBool ("TxOut count after rollback is " ++ show afterTxOutCount ++ " but should be 1.") $ afterTxOutCount == 1 afterTxInCount <- queryTxInCount assertBool ("TxIn count after rollback is " ++ show afterTxInCount ++ " but should be 0.") $ afterTxInCount == 0 @@ -133,7 +132,7 @@ createAndInsertBlocks blockCount = 0 (DbLovelace 0) - void $ insertTxOut (mkTxOut blkId txId) + void $ insertTxOut (mkTxOutCore blkId txId) pure $ Just txId case (indx, mTxOutId) of (8, Just txOutId) -> do @@ -142,6 +141,6 @@ createAndInsertBlocks blockCount = txId <- head <$> mapM insertTx (mkTxs blkId 8) void $ insertTxIn (TxIn txId txOutId 0 Nothing) - void $ insertTxOut (mkTxOut blkId txId) - _ -> pure () + void $ insertTxOut (mkTxOutCore blkId txId) + _otherwise -> pure () pure (indx + 1, Just blkId, newMTxOutId) diff --git a/cardano-db/test/Test/IO/Cardano/Db/TotalSupply.hs b/cardano-db/test/Test/IO/Cardano/Db/TotalSupply.hs index 2cf0f431c..0a7ac3dc4 100644 --- a/cardano-db/test/Test/IO/Cardano/Db/TotalSupply.hs +++ b/cardano-db/test/Test/IO/Cardano/Db/TotalSupply.hs @@ -3,6 +3,8 @@ #if __GLASGOW_HASKELL__ >= 908 {-# OPTIONS_GHC -Wno-x-partial #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} #endif module Test.IO.Cardano.Db.TotalSupply ( @@ -10,6 +12,7 @@ module Test.IO.Cardano.Db.TotalSupply ( ) where import Cardano.Db +import qualified Cardano.Db.Schema.Core.TxOut as C import qualified Data.Text as Text import Test.IO.Cardano.Db.Util import Test.Tasty (TestTree, testGroup) @@ -32,10 +35,10 @@ initialSupplyTest = slid <- insertSlotLeader testSlotLeader bid0 <- insertBlock (mkBlock 0 slid) (tx0Ids :: [TxId]) <- mapM insertTx $ mkTxs bid0 4 - mapM_ (insertTxOut . mkTxOut bid0) tx0Ids + mapM_ (insertTxOut . mkTxOutCore bid0) tx0Ids count <- queryBlockCount assertBool ("Block count should be 1, got " ++ show count) (count == 1) - supply0 <- queryTotalSupply + supply0 <- queryTotalSupply TxOutCore assertBool "Total supply should not be > 0" (supply0 > Ada 0) -- Spend from the Utxo set. @@ -60,18 +63,19 @@ initialSupplyTest = let addr = mkAddressHash bid1 tx1Id _ <- insertTxOut $ - TxOut - { txOutTxId = tx1Id - , txOutIndex = 0 - , txOutAddress = Just $ Text.pack addr - , txOutAddressHasScript = False - , txOutPaymentCred = Nothing - , txOutStakeAddressId = Nothing - , txOutValue = DbLovelace 500000000 - , txOutDataHash = Nothing - , txOutInlineDatumId = Nothing - , txOutReferenceScriptId = Nothing - , txOutAddressDetailId = Nothing - } - supply1 <- queryTotalSupply + CTxOutW $ + C.TxOut + { C.txOutTxId = tx1Id + , C.txOutIndex = 0 + , C.txOutAddress = Text.pack addr + , C.txOutAddressHasScript = False + , C.txOutPaymentCred = Nothing + , C.txOutStakeAddressId = Nothing + , C.txOutValue = DbLovelace 500000000 + , C.txOutDataHash = Nothing + , C.txOutInlineDatumId = Nothing + , C.txOutReferenceScriptId = Nothing + , C.txOutConsumedByTxId = Nothing + } + supply1 <- queryTotalSupply TxOutCore assertBool ("Total supply should be < " ++ show supply0) (supply1 < supply0) diff --git a/cardano-db/test/Test/IO/Cardano/Db/Util.hs b/cardano-db/test/Test/IO/Cardano/Db/Util.hs index 0c590e645..edb05dea2 100644 --- a/cardano-db/test/Test/IO/Cardano/Db/Util.hs +++ b/cardano-db/test/Test/IO/Cardano/Db/Util.hs @@ -10,13 +10,12 @@ module Test.IO.Cardano.Db.Util ( mkBlockHash, mkTxHash, mkTxs, - mkTxOut, + mkTxOutCore, testSlotLeader, - unBlockId, - unTxId, ) where import Cardano.Db +import qualified Cardano.Db.Schema.Core.TxOut as C import Control.Monad (unless) import Control.Monad.Extra (whenJust) import Control.Monad.IO.Class (MonadIO, liftIO) @@ -37,7 +36,7 @@ assertBool msg bool = deleteAllBlocks :: MonadIO m => ReaderT SqlBackend m () deleteAllBlocks = do mblkId <- queryMinBlock - whenJust mblkId deleteBlocksBlockIdNotrace + whenJust mblkId $ deleteBlocksBlockIdNotrace TxOutCore dummyUTCTime :: UTCTime dummyUTCTime = UTCTime (ModifiedJulianDay 0) 0 @@ -98,19 +97,20 @@ testSlotLeader :: SlotLeader testSlotLeader = SlotLeader (BS.pack . take 28 $ "test slot leader" ++ replicate 28 ' ') Nothing "Dummy test slot leader" -mkTxOut :: BlockId -> TxId -> TxOut -mkTxOut blkId txId = +mkTxOutCore :: BlockId -> TxId -> TxOutW +mkTxOutCore blkId txId = let addr = mkAddressHash blkId txId - in TxOut - { txOutTxId = txId - , txOutIndex = 0 - , txOutAddress = Just $ Text.pack addr - , txOutAddressHasScript = False - , txOutAddressDetailId = Nothing - , txOutPaymentCred = Nothing - , txOutStakeAddressId = Nothing - , txOutValue = DbLovelace 1000000000 - , txOutDataHash = Nothing - , txOutInlineDatumId = Nothing - , txOutReferenceScriptId = Nothing - } + in CTxOutW $ + C.TxOut + { C.txOutAddress = Text.pack addr + , C.txOutAddressHasScript = False + , C.txOutConsumedByTxId = Nothing + , C.txOutDataHash = Nothing + , C.txOutIndex = 0 + , C.txOutInlineDatumId = Nothing + , C.txOutPaymentCred = Nothing + , C.txOutReferenceScriptId = Nothing + , C.txOutStakeAddressId = Nothing + , C.txOutTxId = txId + , C.txOutValue = DbLovelace 1000000000 + } diff --git a/cardano-db/test/schema-rollback.hs b/cardano-db/test/schema-rollback.hs index eb006abcd..ccecf4127 100644 --- a/cardano-db/test/schema-rollback.hs +++ b/cardano-db/test/schema-rollback.hs @@ -91,7 +91,7 @@ findTablesWithDelete = . mapMaybe getTableName . mapMaybe removeCommentsAndEmpty . getDeleteAfterBlockNo - <$> BS.readFile "cardano-db/src/Cardano/Db/Delete.hs" + <$> BS.readFile "cardano-db/src/Cardano/Db/Operations/Core/Delete.hs" where getDeleteAfterBlockNo :: ByteString -> [ByteString] getDeleteAfterBlockNo = diff --git a/doc/configuration.md b/doc/configuration.md index d38d48de1..db3e86f91 100644 --- a/doc/configuration.md +++ b/doc/configuration.md @@ -196,10 +196,11 @@ Disables almost all data except `block` and `tx` tables. Tx Out Properties: -| Property | Type | Required | -| :---------------------------- | :-------- | :------- | -| [value](#value) | `string` | Optional | -| [force\_tx\_in](#force-tx-in) | `boolean` | Optional | +| Property | Type | Required | +| :------------------------------- | :-------- | :------- | +| [value](#value) | `string` | Optional | +| [force\_tx\_in](#force-tx-in) | `boolean` | Optional | +| [address\_table](#address-table) | `boolean` | Optional | #### Value @@ -270,6 +271,28 @@ can be changed. * Type: `boolean` + +### Address Table + +`tx_out.address_table` + + * Type: `boolean` + +This new variant representation introduces an additional `Address` table to normalize the address-related data. This change allows for more efficient storage and querying of address information, especially in cases where multiple transaction outputs (TxOuts) reference the same address. + +Key changes in the variant representation: + +1. New `address` table: + - Contains fields: `address`, `raw`, `has_script`, `payment_cred`, and `stake_address_id` + - Centralizes address information that was previously duplicated across multiple TxOuts + +2. Modified `tx_out` table: + - Replaces `address`, `address_has_script`, and `payment_cred` fields with a single `address_id` field + - `addressId` references the new `Address` table + + + + ## Ledger One of the db-sync features that uses the most resources is that it maintains a ledger state and diff --git a/doc/interesting-queries.md b/doc/interesting-queries.md index b8169c44a..b15c67946 100644 --- a/doc/interesting-queries.md +++ b/doc/interesting-queries.md @@ -629,4 +629,4 @@ them. --- -[Query.hs]: https://github.com/IntersectMBO/cardano-db-sync/blob/master/cardano-db/src/Cardano/Db/Query.hs +[Query.hs]: https://github.com/IntersectMBO/cardano-db-sync/blob/master/cardano-db/src/Cardano/Db/Operations/Core/Query.hs diff --git a/flake.nix b/flake.nix index a88898c91..87b676cf8 100644 --- a/flake.nix +++ b/flake.nix @@ -217,7 +217,7 @@ packages.cardano-db.package.extraSrcFiles = ["../config/pgpass-testnet"]; packages.cardano-db.components.tests.schema-rollback.extraSrcFiles = - [ "src/Cardano/Db/Schema.hs" "src/Cardano/Db/Delete.hs" ]; + [ "src/Cardano/Db/Schema.hs" "src/Cardano/Db/Operations/Core/Delete.hs" ]; packages.cardano-db.components.tests.test-db.extraSrcFiles = [ "../config/pgpass-mainnet" ]; packages.cardano-chain-gen.package.extraSrcFiles =