From 97930bdfa511b2cf76d00d57e707b5ebd672a9b3 Mon Sep 17 00:00:00 2001 From: Cmdv Date: Mon, 19 Aug 2024 17:55:57 +0100 Subject: [PATCH 1/6] 1333 - add new AddressDetail table for TxOut --- .../Cardano/Db/Mock/Unit/Alonzo/Config.hs | 1 + .../Cardano/Db/Mock/Unit/Alonzo/Plutus.hs | 2 +- .../Db/Mock/Unit/Babbage/Config/Parse.hs | 1 + .../Cardano/Db/Mock/Unit/Babbage/Plutus.hs | 2 +- .../Db/Mock/Unit/Conway/Config/Parse.hs | 1 + .../Cardano/Db/Mock/Unit/Conway/Plutus.hs | 2 +- .../test/Test/Cardano/Db/Mock/Validate.hs | 3 +- cardano-db-sync/src/Cardano/DbSync.hs | 1 + .../src/Cardano/DbSync/Api/Types.hs | 1 + .../src/Cardano/DbSync/Config/Types.hs | 22 ++++ .../src/Cardano/DbSync/Era/Byron/Genesis.hs | 107 ++++++++++++------ .../src/Cardano/DbSync/Era/Byron/Insert.hs | 72 +++++++++--- .../src/Cardano/DbSync/Era/Shelley/Genesis.hs | 68 ++++++++--- .../DbSync/Era/Universal/Insert/Grouped.hs | 1 + .../Cardano/DbSync/Era/Universal/Insert/Tx.hs | 75 +++++++++--- cardano-db-sync/test/Cardano/DbSync/Gen.hs | 1 + cardano-db-tool/src/Cardano/DbTool/UtxoSet.hs | 11 +- .../Cardano/DbTool/Validate/TotalSupply.hs | 1 + .../src/Cardano/DbTool/Validate/Util.hs | 6 - cardano-db/src/Cardano/Db/Insert.hs | 4 + .../Migration/Extra/CosnumedTxOut/Schema.hs | 2 +- cardano-db/src/Cardano/Db/Query.hs | 68 +++++++---- cardano-db/src/Cardano/Db/Schema.hs | 19 +++- cardano-db/src/Cardano/Db/Schema/Types.hs | 6 - .../test/Test/IO/Cardano/Db/TotalSupply.hs | 16 ++- cardano-db/test/Test/IO/Cardano/Db/Util.hs | 14 ++- 26 files changed, 380 insertions(+), 127 deletions(-) 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 a51330ddc..98dd3ce4e 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,6 +34,7 @@ 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 0b90722a1..c64f0ff0c 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 @@ -95,7 +95,7 @@ simpleScript = testLabel = "simpleScript-alonzo" getOutFields txOut = (DB.txOutAddress txOut, DB.txOutAddressHasScript txOut, DB.txOutValue txOut, DB.txOutDataHash txOut) expectedFields = - ( renderAddress alwaysSucceedsScriptAddr + ( Just $ 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/Parse.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Config/Parse.hs index 3c75ffcf8..d082c90fc 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,6 +34,7 @@ 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 6a452ea1b..02d2699fe 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 @@ -102,7 +102,7 @@ simpleScript = testLabel = "simpleScript" getOutFields txOut = (DB.txOutAddress txOut, DB.txOutAddressHasScript txOut, DB.txOutValue txOut, DB.txOutDataHash txOut) expectedFields = - ( renderAddress alwaysSucceedsScriptAddr + ( Just $ 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/Parse.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Config/Parse.hs index 50dedf206..f039ccb79 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,6 +104,7 @@ 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 8cd95e76c..175b54424 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 @@ -90,7 +90,7 @@ simpleScript = , DB.txOutDataHash txOut ) expectedFields = - ( renderAddress Examples.alwaysSucceedsScriptAddr + ( Just $ 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 9e1576055..06a3be995 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs @@ -44,7 +44,6 @@ module Test.Cardano.Db.Mock.Validate ( import Cardano.Db import qualified Cardano.Db as DB -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 @@ -212,7 +211,7 @@ assertAddrValues :: IO () assertAddrValues env ix expected sta = do addr <- assertRight $ resolveAddress ix sta - let address = Generic.renderAddress addr + let address = Ledger.serialiseAddr addr q = queryAddressOutputs address assertEqBackoff env q expected defaultDelays "Unexpected Balance" diff --git a/cardano-db-sync/src/Cardano/DbSync.hs b/cardano-db-sync/src/Cardano/DbSync.hs index 0a345f5d9..8bc941b70 100644 --- a/cardano-db-sync/src/Cardano/DbSync.hs +++ b/cardano-db-sync/src/Cardano/DbSync.hs @@ -278,6 +278,7 @@ extractSyncOptions snp aop snc = , ioPoolStats = isPoolStatsEnabled (sioPoolStats (dncInsertOptions snc)) , ioGov = useGovernance , ioRemoveJsonbFromSchema = isRemoveJsonbFromSchemaEnabled (sioRemoveJsonbFromSchema (dncInsertOptions snc)) + , ioAddressDetail = useAddressDetailTable (sioAddressDetail (dncInsertOptions snc)) } useLedger = sioLedger (dncInsertOptions snc) == LedgerEnable diff --git a/cardano-db-sync/src/Cardano/DbSync/Api/Types.hs b/cardano-db-sync/src/Cardano/DbSync/Api/Types.hs index b1b42ec8c..48de5c47d 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Api/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Api/Types.hs @@ -87,6 +87,7 @@ data InsertOptions = InsertOptions , ioPoolStats :: !Bool , ioGov :: !Bool , ioRemoveJsonbFromSchema :: !Bool + , ioAddressDetail :: !Bool } 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 5b18175c1..5eda68209 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs @@ -19,6 +19,7 @@ module Cardano.DbSync.Config.Types ( GenesisHashAlonzo (..), GenesisHashConway (..), RemoveJsonbFromSchemaConfig (..), + AddressDetailConfig (..), SyncNodeConfig (..), SyncPreConfig (..), SyncInsertConfig (..), @@ -183,6 +184,7 @@ data SyncInsertOptions = SyncInsertOptions , sioPoolStats :: PoolStatsConfig , sioJsonType :: JsonTypeConfig , sioRemoveJsonbFromSchema :: RemoveJsonbFromSchemaConfig + , sioAddressDetail :: AddressDetailConfig } deriving (Eq, Show) @@ -257,6 +259,11 @@ newtype RemoveJsonbFromSchemaConfig = RemoveJsonbFromSchemaConfig } deriving (Eq, Show) +newtype AddressDetailConfig = AddressDetailConfig + { useAddressDetailTable :: Bool + } + deriving (Eq, Show) + data JsonTypeConfig = JsonTypeText | JsonTypeJsonb @@ -439,6 +446,7 @@ 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) = @@ -481,6 +489,7 @@ 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 {..} = @@ -671,6 +680,15 @@ 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 ToJSON AddressDetailConfig where + toJSON = boolToEnableDisable . useAddressDetailTable + instance FromJSON OffchainPoolDataConfig where parseJSON = Aeson.withText "offchain_pool_data" $ \v -> case enableDisableToBool v of @@ -708,6 +726,7 @@ instance Default SyncInsertOptions where , sioPoolStats = PoolStatsConfig False , sioJsonType = JsonTypeText , sioRemoveJsonbFromSchema = RemoveJsonbFromSchemaConfig False + , sioAddressDetail = AddressDetailConfig False } fullInsertOptions :: SyncInsertOptions @@ -726,6 +745,7 @@ fullInsertOptions = , sioPoolStats = PoolStatsConfig True , sioJsonType = JsonTypeText , sioRemoveJsonbFromSchema = RemoveJsonbFromSchemaConfig False + , sioAddressDetail = AddressDetailConfig False } onlyUTxOInsertOptions :: SyncInsertOptions @@ -744,6 +764,7 @@ onlyUTxOInsertOptions = , sioPoolStats = PoolStatsConfig False , sioJsonType = JsonTypeText , sioRemoveJsonbFromSchema = RemoveJsonbFromSchemaConfig False + , sioAddressDetail = AddressDetailConfig False } onlyGovInsertOptions :: SyncInsertOptions @@ -770,6 +791,7 @@ disableAllInsertOptions = , sioGovernance = GovernanceConfig False , sioJsonType = JsonTypeText , sioRemoveJsonbFromSchema = RemoveJsonbFromSchemaConfig False + , sioAddressDetail = AddressDetailConfig False } boolToEnableDisable :: IsString s => Bool -> s 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 7ae3a0f4d..772da6e6f 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Genesis.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Genesis.hs @@ -11,13 +11,14 @@ module Cardano.DbSync.Era.Byron.Genesis ( ) where import Cardano.BM.Trace (Trace, logInfo) +import Cardano.Binary (serialize') import qualified Cardano.Chain.Common as Byron 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 Cardano.DbSync.Api -import Cardano.DbSync.Api.Types (SyncEnv (envBackend)) +import Cardano.DbSync.Api.Types (SyncEnv (..), SyncOptions (..), ioAddressDetail) import Cardano.DbSync.Config.Types import qualified Cardano.DbSync.Era.Byron.Util as Byron import Cardano.DbSync.Era.Util (liftLookupFail) @@ -104,7 +105,7 @@ insertValidateGenesisDist syncEnv (NetworkName networkName) cfg = do , DB.blockOpCert = Nothing , DB.blockOpCertCounter = Nothing } - mapM_ (insertTxOuts hasConsumed disInOut bid) $ genesisTxos cfg + mapM_ (insertTxOuts syncEnv hasConsumed disInOut bid) $ genesisTxos cfg liftIO . logInfo tracer $ "Initial genesis distribution populated. Hash " <> renderByteArray (configGenesisHash cfg) @@ -175,48 +176,86 @@ validateGenesisDistribution prunes disInOut tracer networkName cfg bid = insertTxOuts :: (MonadBaseControl IO m, MonadIO m) => + SyncEnv -> Bool -> Bool -> DB.BlockId -> (Byron.Address, Byron.Lovelace) -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertTxOuts hasConsumed disInOut blkId (address, value) = do +insertTxOuts syncEnv hasConsumed disInOut blkId (address, value) = do case txHashOfAddress address of Left err -> throwError err - Right val -> do + Right val -> lift $ do -- Each address/value pair of the initial coin distribution comes from an artifical transaction -- with a hash generated by hashing the address. - txId <- - lift $ - DB.insertTx $ - DB.Tx - { DB.txHash = Byron.unTxHash val - , DB.txBlockId = blkId - , DB.txBlockIndex = 0 - , DB.txOutSum = DB.DbLovelace (Byron.unsafeGetLovelace value) - , DB.txFee = DB.DbLovelace 0 - , DB.txDeposit = Just 0 - , DB.txSize = 0 -- Genesis distribution address to not have a size. - , DB.txInvalidHereafter = Nothing - , DB.txInvalidBefore = Nothing - , DB.txValidContract = True - , DB.txScriptSize = 0 - , DB.txTreasuryDonation = DB.DbLovelace 0 - } - lift $ - DB.insertTxOutPlex hasConsumed disInOut $ - DB.TxOut - { DB.txOutTxId = txId - , DB.txOutIndex = 0 - , DB.txOutAddress = 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 + txId <- do + DB.insertTx $ + DB.Tx + { DB.txHash = Byron.unTxHash val + , DB.txBlockId = blkId + , DB.txBlockIndex = 0 + , DB.txOutSum = DB.DbLovelace (Byron.unsafeGetLovelace value) + , DB.txFee = DB.DbLovelace 0 + , DB.txDeposit = Just 0 + , DB.txSize = 0 -- Genesis distribution address to not have a size. + , DB.txInvalidHereafter = Nothing + , DB.txInvalidBefore = Nothing + , DB.txValidContract = True + , 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 + } + where + insertAddressDetail :: + (MonadBaseControl IO m, MonadIO m) => + ReaderT SqlBackend m DB.AddressDetailId + insertAddressDetail = do + let addrRaw = serialize' address + mAddrId <- DB.queryAddressDetailId 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. + } + -- 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 6e5830285..38751ba54 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Insert.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Insert.hs @@ -312,7 +312,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 tracer (getHasConsumedOrPruneTxOut syncEnv) disInOut txId) [0 ..] (toList . Byron.txOutputs $ Byron.taTx tx) + lift $ zipWithM_ (insertTxOut syncEnv (getHasConsumedOrPruneTxOut syncEnv) disInOut txId) [0 ..] (toList . Byron.txOutputs $ Byron.taTx tx) unless (getSkipTxIn syncEnv) $ mapM_ (insertTxIn tracer txId) resolvedInputs whenConsumeOrPruneTxOut syncEnv $ @@ -336,27 +336,67 @@ insertByronTx' syncEnv blkId tx blockIndex = do insertTxOut :: (MonadBaseControl IO m, MonadIO m) => - Trace IO Text -> + SyncEnv -> Bool -> Bool -> DB.TxId -> Word32 -> Byron.TxOut -> ReaderT SqlBackend m () -insertTxOut _tracer hasConsumed bootStrap txId index txout = - DB.insertTxOutPlex hasConsumed bootStrap $ - DB.TxOut - { DB.txOutTxId = txId - , DB.txOutIndex = fromIntegral index - , DB.txOutAddress = 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 - } +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 + } + where + insertAddressDetail :: + (MonadBaseControl IO m, MonadIO m) => + ReaderT SqlBackend m DB.AddressDetailId + insertAddressDetail = do + let addrRaw = serialize' (Byron.txOutAddress txout) + mAddrId <- DB.queryAddressDetailId 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. + } + -- this address is already in the database, so we can just return the id to be linked to the txOut. + Just addrId -> pure addrId insertTxIn :: (MonadBaseControl IO m, MonadIO m) => 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 72e31479c..0de7ec583 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs @@ -14,7 +14,7 @@ module Cardano.DbSync.Era.Shelley.Genesis ( import Cardano.BM.Trace (Trace, logError, logInfo) import qualified Cardano.Db as DB import Cardano.DbSync.Api -import Cardano.DbSync.Api.Types (SyncEnv (..)) +import Cardano.DbSync.Api.Types (InsertOptions (..), SyncEnv (..), SyncOptions (..)) import Cardano.DbSync.Cache (tryUpdateCacheTx) import Cardano.DbSync.Cache.Types (CacheStatus (..), useNoCache) import qualified Cardano.DbSync.Era.Shelley.Generic.Util as Generic @@ -24,6 +24,7 @@ import Cardano.DbSync.Era.Universal.Insert.Pool (insertPoolRegister) import Cardano.DbSync.Era.Util (liftLookupFail) import Cardano.DbSync.Error import Cardano.DbSync.Util +import Cardano.Ledger.Address (serialiseAddr) import qualified Cardano.Ledger.Coin as Ledger import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Credential (Credential (KeyHashObj)) @@ -248,23 +249,62 @@ insertTxOuts syncEnv trce hasConsumed disInOut blkId (TxIn txInId _, txOut) = do tryUpdateCacheTx (envCache syncEnv) txInId txId _ <- insertStakeAddressRefIfMissing trce useNoCache (txOut ^. Core.addrTxOutL) - DB.insertTxOutPlex hasConsumed disInOut $ - DB.TxOut - { DB.txOutTxId = txId - , DB.txOutIndex = 0 - , DB.txOutAddress = Generic.renderAddress addr - , 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 - } + -- 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) + } where addr = txOut ^. Core.addrTxOutL hasScript = maybe False Generic.hasCredScript (Generic.getPaymentCred addr) + insertAddressDetail :: + (MonadBaseControl IO m, MonadIO m) => + ReaderT SqlBackend m DB.AddressDetailId + insertAddressDetail = do + let addrRaw = serialiseAddr addr + mAddrId <- DB.queryAddressDetailId 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 + } + -- this address is already in the database, so we can just return the id to be linked to the txOut. + Just addrId -> pure addrId + -- Insert pools and delegations coming from Genesis. insertStaking :: (MonadBaseControl IO m, MonadIO m) => 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 403338f8b..ba4dcbe65 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 @@ -62,6 +62,7 @@ data MissingMaTxOut = MissingMaTxOut data ExtendedTxOut = ExtendedTxOut { etoTxHash :: !ByteString , etoTxOut :: !DB.TxOut + , etoPaymentCred :: !(Maybe ByteString) } data ExtendedTxIn = ExtendedTxIn 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 e7b14850f..bf98c8e53 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 @@ -46,6 +46,7 @@ import Cardano.DbSync.Error import Cardano.DbSync.Ledger.Types (ApplyResult (..), getGovExpiresAt, lookupDepositsMap) import Cardano.DbSync.Util import Cardano.DbSync.Util.Cbor (serialiseTxMetadataToCbor) +import qualified Cardano.Ledger.Address as Ledger import Cardano.Ledger.BaseTypes import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Mary.Value (AssetName (..), MultiAsset (..), PolicyID (..)) @@ -222,26 +223,72 @@ insertTxOut tracer cache iopts (txId, txHash) (Generic.TxOut index addr value ma whenFalseEmpty (ioPlutusExtra iopts) Nothing $ whenMaybe mScript $ lift . insertScript tracer txId - let !txOut = - DB.TxOut - { DB.txOutTxId = txId - , DB.txOutIndex = index - , DB.txOutAddress = Generic.renderAddress addr - , DB.txOutAddressHasScript = hasScript - , DB.txOutPaymentCred = Generic.maybePaymentCred addr - , DB.txOutStakeAddressId = mSaId - , DB.txOutValue = Generic.coinToDbLovelace value - , DB.txOutDataHash = Generic.dataHashToBytes <$> Generic.getTxOutDatumHash dt - , DB.txOutInlineDatumId = mDatumId - , DB.txOutReferenceScriptId = mScriptId - } - let !eutxo = ExtendedTxOut txHash txOut + !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 + } + -- TODO: Unsure about what we should return here for eutxo + let !eutxo = ExtendedTxOut txHash txOut (if ioAddressDetail iopts then Generic.maybePaymentCred addr else Nothing) !maTxOuts <- whenFalseMempty (ioMultiAssets iopts) $ insertMaTxOuts tracer cache maMap pure (eutxo, maTxOuts) where hasScript :: Bool hasScript = maybe False Generic.hasCredScript (Generic.getPaymentCred addr) + addrText :: Text + addrText = Generic.renderAddress addr + +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 + 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 + } + Just addrId -> pure addrId + where + addrRaw = Ledger.serialiseAddr address + insertTxMetadata :: (MonadBaseControl IO m, MonadIO m) => Trace IO Text -> diff --git a/cardano-db-sync/test/Cardano/DbSync/Gen.hs b/cardano-db-sync/test/Cardano/DbSync/Gen.hs index d680a976e..2c146b48b 100644 --- a/cardano-db-sync/test/Cardano/DbSync/Gen.hs +++ b/cardano-db-sync/test/Cardano/DbSync/Gen.hs @@ -130,6 +130,7 @@ syncInsertOptions = <*> (PoolStatsConfig <$> Gen.bool) <*> Gen.element [JsonTypeText, JsonTypeJsonb, JsonTypeDisable] <*> (RemoveJsonbFromSchemaConfig <$> Gen.bool) + <*> (AddressDetailConfig <$> Gen.bool) txOutConfig :: Gen TxOutConfig txOutConfig = diff --git a/cardano-db-tool/src/Cardano/DbTool/UtxoSet.hs b/cardano-db-tool/src/Cardano/DbTool/UtxoSet.hs index 6611e6f9a..4bd57cc09 100644 --- a/cardano-db-tool/src/Cardano/DbTool/UtxoSet.hs +++ b/cardano-db-tool/src/Cardano/DbTool/UtxoSet.hs @@ -2,6 +2,7 @@ module Cardano.DbTool.UtxoSet ( utxoSetAtSlot, + utxoSetSum, ) where import Cardano.Chain.Common (decodeAddressBase58, isRedeemAddress) @@ -59,12 +60,12 @@ utxoSetAtSlot slotNo = do -- ----------------------------------------------------------------------------- -aggregateUtxos :: [(TxOut, a)] -> [(Text, Word64)] +aggregateUtxos :: [(TxOut, Text, a)] -> [(Text, Word64)] aggregateUtxos xs = List.sortOn (Text.length . fst) . Map.toList . Map.fromListWith (+) - $ map (\(x, _) -> (txOutAddress x, unDbLovelace (txOutValue x))) xs + $ map (\(x, addr, _) -> (addr, unDbLovelace (txOutValue x))) xs isRedeemTextAddress :: Text -> Bool isRedeemTextAddress addr = @@ -82,7 +83,7 @@ partitionUtxos = accept (addr, _) = Text.length addr <= 180 && not (isRedeemTextAddress addr) -queryAtSlot :: Word64 -> IO (Ada, [(TxOut, ByteString)], Ada, Either LookupFail UTCTime) +queryAtSlot :: Word64 -> IO (Ada, [(TxOut, Text, ByteString)], Ada, Either LookupFail UTCTime) queryAtSlot slotNo = -- Run the following queries in a single transaction. runDbNoLoggingEnv $ do @@ -112,9 +113,9 @@ showUtxo (addr, value) = , " }" ] -utxoSetSum :: [(TxOut, a)] -> Ada +utxoSetSum :: [(TxOut, b, a)] -> Ada utxoSetSum xs = - word64ToAda . sum $ map (unDbLovelace . txOutValue . fst) xs + word64ToAda . sum $ map (\(txOut, _, _) -> unDbLovelace $ txOutValue txOut) xs writeUtxos :: FilePath -> [(Text, Word64)] -> IO () writeUtxos fname xs = do diff --git a/cardano-db-tool/src/Cardano/DbTool/Validate/TotalSupply.hs b/cardano-db-tool/src/Cardano/DbTool/Validate/TotalSupply.hs index fa0c7453e..979f24cbc 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Validate/TotalSupply.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Validate/TotalSupply.hs @@ -5,6 +5,7 @@ module Cardano.DbTool.Validate.TotalSupply ( ) where import Cardano.Db +import Cardano.DbTool.UtxoSet (utxoSetSum) import Cardano.DbTool.Validate.Util import Data.Word (Word64) import System.Random (randomRIO) diff --git a/cardano-db-tool/src/Cardano/DbTool/Validate/Util.hs b/cardano-db-tool/src/Cardano/DbTool/Validate/Util.hs index 27b58c9e2..ae9024b84 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Validate/Util.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Validate/Util.hs @@ -6,10 +6,8 @@ module Cardano.DbTool.Validate.Util ( greenText, redText, putStrF, - utxoSetSum, ) where -import Cardano.Db import System.Console.ANSI (setSGRCode) import System.Console.ANSI.Types ( Color (..), @@ -39,7 +37,3 @@ redText s = codeRed ++ s ++ codeReset putStrF :: String -> IO () putStrF s = putStr s >> hFlush stdout - -utxoSetSum :: [(TxOut, a)] -> Ada -utxoSetSum xs = - word64ToAda . sum $ map (unDbLovelace . txOutValue . fst) xs diff --git a/cardano-db/src/Cardano/Db/Insert.hs b/cardano-db/src/Cardano/Db/Insert.hs index 46f337d91..78c120d2a 100644 --- a/cardano-db/src/Cardano/Db/Insert.hs +++ b/cardano-db/src/Cardano/Db/Insert.hs @@ -48,6 +48,7 @@ module Cardano.Db.Insert ( insertTxOut, insertCollateralTxOut, insertManyTxOut, + insertAddressDetail, insertWithdrawal, insertRedeemer, insertCostModel, @@ -313,6 +314,9 @@ 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/Migration/Extra/CosnumedTxOut/Schema.hs b/cardano-db/src/Cardano/Db/Migration/Extra/CosnumedTxOut/Schema.hs index dca739477..2d7796be6 100644 --- a/cardano-db/src/Cardano/Db/Migration/Extra/CosnumedTxOut/Schema.hs +++ b/cardano-db/src/Cardano/Db/Migration/Extra/CosnumedTxOut/Schema.hs @@ -138,7 +138,7 @@ share TxOut txId TxId noreference index Word64 sqltype=txindex - address Text + address Text Maybe addressHasScript Bool paymentCred ByteString Maybe sqltype=hash28type stakeAddressId StakeAddressId Maybe noreference diff --git a/cardano-db/src/Cardano/Db/Query.hs b/cardano-db/src/Cardano/Db/Query.hs index b576a57e7..ed846ccd0 100644 --- a/cardano-db/src/Cardano/Db/Query.hs +++ b/cardano-db/src/Cardano/Db/Query.hs @@ -44,6 +44,7 @@ module Cardano.Db.Query ( queryTxOutValue, queryTxOutIdValue, queryTxOutCredentials, + queryAddressDetailId, queryEpochFromNum, queryEpochStakeCount, queryForEpochId, @@ -681,6 +682,14 @@ queryTxOutCredentials (hash, index) = do 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 @@ -1192,7 +1201,7 @@ querySlotUtcTime slotNo = do pure (blk ^. BlockTime) pure $ maybe (Left $ DbLookupSlotNo slotNo) (Right . unValue) (listToMaybe le) -queryUtxoAtBlockNo :: MonadIO m => Word64 -> ReaderT SqlBackend m [(TxOut, ByteString)] +queryUtxoAtBlockNo :: MonadIO m => Word64 -> ReaderT SqlBackend m [(TxOut, Text, ByteString)] queryUtxoAtBlockNo blkNo = do eblkId <- select $ do blk <- from $ table @Block @@ -1200,7 +1209,7 @@ queryUtxoAtBlockNo blkNo = do pure (blk ^. BlockId) maybe (pure []) (queryUtxoAtBlockId . unValue) (listToMaybe eblkId) -queryUtxoAtSlotNo :: MonadIO m => Word64 -> ReaderT SqlBackend m [(TxOut, ByteString)] +queryUtxoAtSlotNo :: MonadIO m => Word64 -> ReaderT SqlBackend m [(TxOut, Text, ByteString)] queryUtxoAtSlotNo slotNo = do eblkId <- select $ do blk <- from $ table @Block @@ -1233,34 +1242,36 @@ queryAdaPots blkId = do -- | 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, ByteString)] +queryUtxoAtBlockId :: MonadIO m => BlockId -> ReaderT SqlBackend m [(TxOut, Text, ByteString)] queryUtxoAtBlockId blkid = do outputs <- select $ do - (txout :& _txin :& _tx1 :& blk :& tx2) <- + (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) -> + `on` ( \(txout :& _ :& txin) -> (just (txout ^. TxOutTxId) ==. txin ?. TxInTxOutId) &&. (just (txout ^. TxOutIndex) ==. txin ?. TxInTxOutIndex) ) `leftJoin` table @Tx - `on` (\(_txout :& txin :& tx1) -> txin ?. TxInTxInId ==. tx1 ?. TxId) + `on` (\(_txout :& _ :& txin :& tx1) -> txin ?. TxInTxInId ==. tx1 ?. TxId) `leftJoin` table @Block - `on` (\(_txout :& _txin :& tx1 :& blk) -> tx1 ?. TxBlockId ==. blk ?. BlockId) + `on` (\(_txout :& _ :& _txin :& tx1 :& blk) -> tx1 ?. TxBlockId ==. blk ?. BlockId) `leftJoin` table @Tx - `on` (\(txout :& _ :& _ :& _ :& tx2) -> just (txout ^. TxOutTxId) ==. tx2 ?. TxId) + `on` (\(txout :& _ :& _ :& _ :& _ :& tx2) -> just (txout ^. TxOutTxId) ==. tx2 ?. TxId) where_ $ (txout ^. TxOutTxId `in_` txLessEqual blkid) &&. (isNothing (blk ?. BlockBlockNo) ||. (blk ?. BlockId >. just (val blkid))) - pure (txout, tx2 ?. TxHash) + pure (txout, address ^. AddressDetailAddress, tx2 ?. TxHash) pure $ mapMaybe convert outputs where - convert :: (Entity TxOut, Value (Maybe ByteString)) -> Maybe (TxOut, ByteString) + convert :: (Entity TxOut, Value Text, Value (Maybe ByteString)) -> Maybe (TxOut, Text, ByteString) convert = \case - (out, Value (Just hash')) -> Just (entityVal out, hash') - (_, Value Nothing) -> Nothing + (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 @@ -1275,21 +1286,23 @@ queryAddressBalanceAtSlot addr slotNo = 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 :& _ :& _ :& blk :& _) <- + (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) + `on` (\(txout :& _ :& txin) -> just (txout ^. TxOutTxId) ==. txin ?. TxInTxOutId) `leftJoin` table @Tx - `on` (\(_ :& txin :& tx1) -> txin ?. TxInTxInId ==. tx1 ?. TxId) + `on` (\(_ :& _ :& txin :& tx1) -> txin ?. TxInTxInId ==. tx1 ?. TxId) `leftJoin` table @Block - `on` (\(_ :& _ :& tx1 :& blk) -> tx1 ?. TxBlockId ==. blk ?. BlockId) + `on` (\(_ :& _ :& _ :& tx1 :& blk) -> tx1 ?. TxBlockId ==. blk ?. BlockId) `leftJoin` table @Tx - `on` (\(txout :& _ :& _ :& _ :& tx2) -> just (txout ^. TxOutTxId) ==. tx2 ?. TxId) + `on` (\(txout :& _ :& _ :& _ :& _ :& tx2) -> just (txout ^. TxOutTxId) ==. tx2 ?. TxId) where_ $ (txout ^. TxOutTxId `in_` txLessEqual blkid) &&. (isNothing (blk ?. BlockBlockNo) ||. (blk ?. BlockId >. just (val blkid))) - where_ (txout ^. TxOutAddress ==. val addr) + where_ (address ^. AddressDetailAddress ==. val addr) pure $ sum_ (txout ^. TxOutValue) pure $ unValueSumAda (listToMaybe res) @@ -1297,17 +1310,21 @@ queryAddressBalanceAtSlot addr slotNo = do Queries use in tests ------------------------} -queryAddressOutputs :: MonadIO m => Text -> ReaderT SqlBackend m DbLovelace +queryAddressOutputs :: MonadIO m => ByteString -> ReaderT SqlBackend m DbLovelace queryAddressOutputs addr = do res <- select $ do - txout <- from $ table @TxOut - where_ (txout ^. TxOutAddress ==. val addr) + (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 - _ -> DbLovelace 0 + _otherwise -> DbLovelace 0 queryRewardCount :: MonadIO m => ReaderT SqlBackend m Word64 queryRewardCount = do @@ -1342,8 +1359,13 @@ queryCostModel = 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_ (tx_out ^. TxOutAddressHasScript ==. val True) + where_ (address ^. AddressDetailHasScript ==. val True) pure tx_out pure $ entityVal <$> res diff --git a/cardano-db/src/Cardano/Db/Schema.hs b/cardano-db/src/Cardano/Db/Schema.hs index cf91a5c17..aa02ba579 100644 --- a/cardano-db/src/Cardano/Db/Schema.hs +++ b/cardano-db/src/Cardano/Db/Schema.hs @@ -151,7 +151,7 @@ share TxOut txId TxId noreference index Word64 sqltype=txindex - address Text + address Text Maybe addressHasScript Bool paymentCred ByteString Maybe sqltype=hash28type stakeAddressId StakeAddressId Maybe noreference @@ -159,6 +159,7 @@ share 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 @@ -174,6 +175,13 @@ 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. @@ -865,6 +873,7 @@ schemaDocs = 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." @@ -880,6 +889,14 @@ 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." diff --git a/cardano-db/src/Cardano/Db/Schema/Types.hs b/cardano-db/src/Cardano/Db/Schema/Types.hs index 19e201774..9395ed55b 100644 --- a/cardano-db/src/Cardano/Db/Schema/Types.hs +++ b/cardano-db/src/Cardano/Db/Schema/Types.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DerivingVia #-} module Cardano.Db.Schema.Types ( - Address (..), AddressHash (..), PaymentAddrHash (..), PoolMetaHash (..), @@ -14,11 +13,6 @@ import Data.Text (Text) import GHC.Generics (Generic) import Quiet (Quiet (..)) -newtype Address -- Length of 28/56/94 bytes enforced by Postgres. - = Address {unAddress :: ByteString} - deriving (Generic) - deriving (Read, Show) via (Quiet Address) - newtype AddressHash -- Length (28 bytes) enforced by Postgres = AddressHash {unAddressHash :: ByteString} deriving (Generic) diff --git a/cardano-db/test/Test/IO/Cardano/Db/TotalSupply.hs b/cardano-db/test/Test/IO/Cardano/Db/TotalSupply.hs index 586675e41..2cf0f431c 100644 --- a/cardano-db/test/Test/IO/Cardano/Db/TotalSupply.hs +++ b/cardano-db/test/Test/IO/Cardano/Db/TotalSupply.hs @@ -58,6 +58,20 @@ initialSupplyTest = } _ <- insertTxIn (TxIn tx1Id (head tx0Ids) 0 Nothing) let addr = mkAddressHash bid1 tx1Id - _ <- insertTxOut $ TxOut tx1Id 0 (Text.pack addr) False Nothing Nothing (DbLovelace 500000000) Nothing Nothing Nothing + _ <- + 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 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 bdd6910b5..0c590e645 100644 --- a/cardano-db/test/Test/IO/Cardano/Db/Util.hs +++ b/cardano-db/test/Test/IO/Cardano/Db/Util.hs @@ -101,4 +101,16 @@ testSlotLeader = mkTxOut :: BlockId -> TxId -> TxOut mkTxOut blkId txId = let addr = mkAddressHash blkId txId - in TxOut txId 0 (Text.pack addr) False Nothing Nothing (DbLovelace 1000000000) Nothing Nothing Nothing + 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 + } From 421611f0e11b48536d67a0748fd978a26bcc443b Mon Sep 17 00:00:00 2001 From: Cmdv Date: Tue, 20 Aug 2024 22:51:51 +0100 Subject: [PATCH 2/6] Add variant for TxOut Modified-by: Cmdv --- .../test/Test/Cardano/Db/Mock/Config.hs | 34 +- .../Cardano/Db/Mock/Unit/Alonzo/Config.hs | 1 - .../Cardano/Db/Mock/Unit/Alonzo/Plutus.hs | 23 +- .../Config/MigrateConsumedPruneTxOut.hs | 52 +- .../Db/Mock/Unit/Babbage/Config/Parse.hs | 1 - .../Cardano/Db/Mock/Unit/Babbage/Plutus.hs | 28 +- .../Config/MigrateConsumedPruneTxOut.hs | 50 +- .../Db/Mock/Unit/Conway/Config/Parse.hs | 1 - .../Cardano/Db/Mock/Unit/Conway/Plutus.hs | 30 +- .../test/Test/Cardano/Db/Mock/Validate.hs | 20 +- cardano-db-sync/src/Cardano/DbSync.hs | 26 +- cardano-db-sync/src/Cardano/DbSync/Api.hs | 13 +- .../src/Cardano/DbSync/Api/Ledger.hs | 10 +- .../src/Cardano/DbSync/Api/Types.hs | 2 +- .../src/Cardano/DbSync/Config/Types.hs | 126 +-- cardano-db-sync/src/Cardano/DbSync/Default.hs | 3 +- .../src/Cardano/DbSync/Era/Byron/Genesis.hs | 138 +-- .../src/Cardano/DbSync/Era/Byron/Insert.hs | 123 +-- .../src/Cardano/DbSync/Era/Shelley/Genesis.hs | 128 +-- .../src/Cardano/DbSync/Era/Shelley/Query.hs | 26 +- .../DbSync/Era/Universal/Insert/Grouped.hs | 138 ++- .../DbSync/Era/Universal/Insert/Other.hs | 9 +- .../Cardano/DbSync/Era/Universal/Insert/Tx.hs | 106 +- .../src/Cardano/DbSync/Fix/ConsumedBy.hs | 25 +- .../src/Cardano/DbSync/Fix/PlutusDataBytes.hs | 2 +- .../src/Cardano/DbSync/Fix/PlutusScripts.hs | 2 +- .../src/Cardano/DbSync/Rollback.hs | 11 +- cardano-db-sync/src/Cardano/DbSync/Sync.hs | 9 +- cardano-db-sync/test/Cardano/DbSync/Gen.hs | 12 +- cardano-db-sync/test/Cardano/DbSyncTest.hs | 16 +- cardano-db-tool/app/cardano-db-tool.hs | 51 +- cardano-db-tool/src/Cardano/DbTool/Report.hs | 9 +- .../src/Cardano/DbTool/Report/Balance.hs | 76 +- .../src/Cardano/DbTool/Report/Transactions.hs | 122 ++- cardano-db-tool/src/Cardano/DbTool/UtxoSet.hs | 32 +- .../src/Cardano/DbTool/Validate/BlockTxs.hs | 2 +- .../src/Cardano/DbTool/Validate/Ledger.hs | 18 +- .../Cardano/DbTool/Validate/TotalSupply.hs | 52 +- .../Cardano/DbTool/Validate/TxAccounting.hs | 84 +- .../src/Cardano/DbTool/Validation.hs | 17 +- cardano-db/cardano-db.cabal | 43 +- cardano-db/src/Cardano/Db.hs | 39 +- cardano-db/src/Cardano/Db/Error.hs | 4 +- .../src/Cardano/Db/{ => Git}/RevFromGit.hs | 2 +- .../src/Cardano/Db/{ => Git}/Version.hs | 4 +- cardano-db/src/Cardano/Db/Migration.hs | 6 +- .../Migration/Extra/CosnumedTxOut/Queries.hs | 2 +- .../Migration/Extra/CosnumedTxOut/Schema.hs | 932 ------------------ cardano-db/src/Cardano/Db/MinId.hs | 60 -- cardano-db/src/Cardano/Db/Multiplex.hs | 125 --- cardano-db/src/Cardano/Db/Old/V13_0.hs | 6 - .../Db/{ => Operations/Core}/AlterTable.hs | 2 +- .../Db/{ => Operations/Core}/Delete.hs | 94 +- .../Db/{ => Operations/Core}/Insert.hs | 22 +- .../src/Cardano/Db/Operations/Core/MinId.hs | 165 ++++ .../Cardano/Db/{ => Operations/Core}/Query.hs | 361 +------ .../Cardano/Db/Operations/Core/QueryHelper.hs | 90 ++ cardano-db/src/Cardano/Db/Operations/Types.hs | 215 ++++ .../Db/Operations/Variant/ConsumedTxOut.hs | 486 +++++++++ .../Variant/JsonbQuery.hs} | 2 +- .../Db/Operations/Variant/TxOutDelete.hs | 41 + .../Db/Operations/Variant/TxOutInsert.hs | 92 ++ .../Db/Operations/Variant/TxOutQuery.hs | 576 +++++++++++ .../Db/{Schema.hs => Schema/BaseSchema.hs} | 58 +- .../src/Cardano/Db/Schema/Core/TxOut.hs | 86 ++ .../src/Cardano/Db/Schema/CoreSchema.hs | 1 + .../src/Cardano/Db/Schema/Variant/TxOut.hs | 93 ++ cardano-db/src/Cardano/Db/Version/V13_0.hs | 6 + .../Db/{Old => Version}/V13_0/Query.hs | 4 +- .../Db/{Old => Version}/V13_0/Schema.hs | 2 +- cardano-db/test/Test/IO/Cardano/Db/Insert.hs | 6 +- .../test/Test/IO/Cardano/Db/Rollback.hs | 17 +- .../test/Test/IO/Cardano/Db/TotalSupply.hs | 36 +- cardano-db/test/Test/IO/Cardano/Db/Util.hs | 38 +- cardano-db/test/schema-rollback.hs | 2 +- doc/configuration.md | 31 +- doc/interesting-queries.md | 2 +- flake.nix | 2 +- 78 files changed, 3020 insertions(+), 2361 deletions(-) rename cardano-db/src/Cardano/Db/{ => Git}/RevFromGit.hs (97%) rename cardano-db/src/Cardano/Db/{ => Git}/Version.hs (93%) delete mode 100644 cardano-db/src/Cardano/Db/Migration/Extra/CosnumedTxOut/Schema.hs delete mode 100644 cardano-db/src/Cardano/Db/MinId.hs delete mode 100644 cardano-db/src/Cardano/Db/Multiplex.hs delete mode 100644 cardano-db/src/Cardano/Db/Old/V13_0.hs rename cardano-db/src/Cardano/Db/{ => Operations/Core}/AlterTable.hs (98%) rename cardano-db/src/Cardano/Db/{ => Operations/Core}/Delete.hs (74%) rename cardano-db/src/Cardano/Db/{ => Operations/Core}/Insert.hs (97%) create mode 100644 cardano-db/src/Cardano/Db/Operations/Core/MinId.hs rename cardano-db/src/Cardano/Db/{ => Operations/Core}/Query.hs (75%) create mode 100644 cardano-db/src/Cardano/Db/Operations/Core/QueryHelper.hs create mode 100644 cardano-db/src/Cardano/Db/Operations/Types.hs create mode 100644 cardano-db/src/Cardano/Db/Operations/Variant/ConsumedTxOut.hs rename cardano-db/src/Cardano/Db/{Migration/Extra/JsonbInSchemaQueries.hs => Operations/Variant/JsonbQuery.hs} (98%) create mode 100644 cardano-db/src/Cardano/Db/Operations/Variant/TxOutDelete.hs create mode 100644 cardano-db/src/Cardano/Db/Operations/Variant/TxOutInsert.hs create mode 100644 cardano-db/src/Cardano/Db/Operations/Variant/TxOutQuery.hs rename cardano-db/src/Cardano/Db/{Schema.hs => Schema/BaseSchema.hs} (95%) create mode 100644 cardano-db/src/Cardano/Db/Schema/Core/TxOut.hs create mode 100644 cardano-db/src/Cardano/Db/Schema/CoreSchema.hs create mode 100644 cardano-db/src/Cardano/Db/Schema/Variant/TxOut.hs create mode 100644 cardano-db/src/Cardano/Db/Version/V13_0.hs rename cardano-db/src/Cardano/Db/{Old => Version}/V13_0/Query.hs (98%) rename cardano-db/src/Cardano/Db/{Old => Version}/V13_0/Schema.hs (98%) 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 = From 7fa6d9662f4e28e827ab4674e7637940ac669ffa Mon Sep 17 00:00:00 2001 From: Cmdv Date: Wed, 11 Sep 2024 17:21:23 +0100 Subject: [PATCH 3/6] update tests for txout variants and running txout migrations --- .../Cardano/Db/Mock/Unit/Alonzo/Plutus.hs | 2 +- .../Config/MigrateConsumedPruneTxOut.hs | 2 +- cardano-db-sync/src/Cardano/DbSync/Api.hs | 1 + .../src/Cardano/DbSync/Config/Types.hs | 3 +- .../src/Cardano/DbSync/Era/Shelley/Query.hs | 10 +- .../src/Cardano/DbSync/Fix/ConsumedBy.hs | 4 +- .../test/Cardano/DbSync/Config/TypesTest.hs | 8 +- cardano-db-tool/app/cardano-db-tool.hs | 2 +- .../src/Cardano/DbTool/Validate/BlockTxs.hs | 2 +- cardano-db/app/gen-schema-docs.hs | 2 +- cardano-db/cardano-db.cabal | 22 +- cardano-db/src/Cardano/Db.hs | 32 +- cardano-db/src/Cardano/Db/Migration.hs | 8 +- .../Migration/Extra/CosnumedTxOut/Queries.hs | 381 ------------------ .../Db/Operations/{Core => }/AlterTable.hs | 2 +- .../Db/Operations/{Core => }/Delete.hs | 6 +- .../Db/Operations/{Core => }/Insert.hs | 9 +- .../{Variant => Other}/ConsumedTxOut.hs | 299 ++++++++------ .../{Variant => Other}/JsonbQuery.hs | 2 +- .../Db/Operations/{Core => Other}/MinId.hs | 4 +- .../Cardano/Db/Operations/{Core => }/Query.hs | 4 +- .../Db/Operations/{Core => }/QueryHelper.hs | 2 +- .../{Variant => TxOut}/TxOutDelete.hs | 8 +- .../{Variant => TxOut}/TxOutInsert.hs | 4 +- .../{Variant => TxOut}/TxOutQuery.hs | 4 +- cardano-db/src/Cardano/Db/Operations/Types.hs | 8 + .../src/Cardano/Db/Schema/CoreSchema.hs | 1 - cardano-db/src/Cardano/Db/Types.hs | 33 +- cardano-db/test/schema-rollback.hs | 4 +- doc/interesting-queries.md | 2 +- flake.nix | 2 +- schema/migration-2-0044-20240912.sql | 21 + scripts/run-everything-tmux.sh | 39 ++ 33 files changed, 348 insertions(+), 585 deletions(-) delete mode 100644 cardano-db/src/Cardano/Db/Migration/Extra/CosnumedTxOut/Queries.hs rename cardano-db/src/Cardano/Db/Operations/{Core => }/AlterTable.hs (98%) rename cardano-db/src/Cardano/Db/Operations/{Core => }/Delete.hs (98%) rename cardano-db/src/Cardano/Db/Operations/{Core => }/Insert.hs (99%) rename cardano-db/src/Cardano/Db/Operations/{Variant => Other}/ConsumedTxOut.hs (73%) rename cardano-db/src/Cardano/Db/Operations/{Variant => Other}/JsonbQuery.hs (98%) rename cardano-db/src/Cardano/Db/Operations/{Core => Other}/MinId.hs (98%) rename cardano-db/src/Cardano/Db/Operations/{Core => }/Query.hs (99%) rename cardano-db/src/Cardano/Db/Operations/{Core => }/QueryHelper.hs (98%) rename cardano-db/src/Cardano/Db/Operations/{Variant => TxOut}/TxOutDelete.hs (81%) rename cardano-db/src/Cardano/Db/Operations/{Variant => TxOut}/TxOutInsert.hs (96%) rename cardano-db/src/Cardano/Db/Operations/{Variant => TxOut}/TxOutQuery.hs (99%) delete mode 100644 cardano-db/src/Cardano/Db/Schema/CoreSchema.hs create mode 100644 schema/migration-2-0044-20240912.sql create mode 100755 scripts/run-everything-tmux.sh 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 290bbd0a5..c066fc90c 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 @@ -110,7 +110,7 @@ simpleScript = , V.txOutValue txout , V.txOutDataHash txout ) - Nothing -> error "AlonzosimpleScript: expected an address" + Nothing -> error "AlonzoSimpleScript: expected an address" expectedFields = ( renderAddress alwaysSucceedsScriptAddr , True 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 1bcf65e97..1bae7c3aa 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 @@ -112,7 +112,7 @@ basicPrune = do pruneWithSimpleRollback :: IOManager -> [(Text, Text)] -> Assertion pruneWithSimpleRollback = - withCustomConfig cmdLineArgs Nothing conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do + withCustomConfigAndLogs cmdLineArgs Nothing conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do let txOutTableType = txOutTableTypeFromConfig dbSync -- Forge some blocks blk0 <- forgeNext interpreter mockBlock0 diff --git a/cardano-db-sync/src/Cardano/DbSync/Api.hs b/cardano-db-sync/src/Cardano/DbSync/Api.hs index ea3fbb677..6a13a3a5e 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Api.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Api.hs @@ -168,6 +168,7 @@ initPruneConsumeMigration :: Bool -> Bool -> Bool -> Bool -> DB.PruneConsumeMigr initPruneConsumeMigration consumed pruneTxOut bootstrap forceTxIn' = DB.PruneConsumeMigration { DB.pcmPruneTxOut = pruneTxOut || bootstrap + , DB.pcmConsumedTxOut = consumed , DB.pcmConsumeOrPruneTxOut = consumed || pruneTxOut || bootstrap , DB.pcmSkipTxIn = not forceTxIn' && (consumed || pruneTxOut || bootstrap) } diff --git a/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs b/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs index 1c2c867bc..d55bfcaac 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs @@ -470,6 +470,7 @@ 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 @@ -562,8 +563,8 @@ instance ToJSON TxOutConfig where 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 + useAddress' <- obj .:? "use_address_table" .!= UseTxOutAddress False case val :: Text of "enable" -> pure (TxOutEnable useAddress') 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 1317b9604..51ad9952b 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Query.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Query.hs @@ -12,7 +12,7 @@ module Cardano.DbSync.Era.Shelley.Query ( ) where import Cardano.Db -import qualified Cardano.DbSync.Api as Db +import Cardano.DbSync.Api (getTxOutTableType) import Cardano.DbSync.Api.Types (SyncEnv) import qualified Cardano.DbSync.Era.Shelley.Generic as Generic import Cardano.DbSync.Util @@ -28,16 +28,16 @@ resolveStakeAddress addr = queryStakeAddress addr renderByteArray 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)) + queryTxOutId (getTxOutTableType syncEnv) (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)) + queryTxOutValue (getTxOutTableType syncEnv) (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)) + queryTxOutIdValue (getTxOutTableType syncEnv) (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)) + queryTxOutCredentials (getTxOutTableType syncEnv) (Generic.toTxHash txIn, fromIntegral (Generic.txInIndex txIn)) diff --git a/cardano-db-sync/src/Cardano/DbSync/Fix/ConsumedBy.hs b/cardano-db-sync/src/Cardano/DbSync/Fix/ConsumedBy.hs index dc8f2f15d..e340706e5 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Fix/ConsumedBy.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Fix/ConsumedBy.hs @@ -7,6 +7,8 @@ import qualified Cardano.Chain.Block as Byron hiding (blockHash) import qualified Cardano.Chain.UTxO as Byron import qualified Cardano.Crypto as Crypto (serializeCborHash) import qualified Cardano.Db as DB +import Cardano.DbSync.Api (getTrace, getTxOutTableType) +import Cardano.DbSync.Api.Types (SyncEnv) import Cardano.DbSync.Era.Byron.Insert import Cardano.DbSync.Era.Byron.Util (blockPayload, unTxHash) import Cardano.DbSync.Era.Util @@ -16,8 +18,6 @@ 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.TxOutIdW, DB.TxId) diff --git a/cardano-db-sync/test/Cardano/DbSync/Config/TypesTest.hs b/cardano-db-sync/test/Cardano/DbSync/Config/TypesTest.hs index 75b25e740..6bc15bea1 100644 --- a/cardano-db-sync/test/Cardano/DbSync/Config/TypesTest.hs +++ b/cardano-db-sync/test/Cardano/DbSync/Config/TypesTest.hs @@ -32,7 +32,6 @@ tests = prop_syncInsertConfigFromJSON :: Property prop_syncInsertConfigFromJSON = property $ do json <- forAll genDefaultJson - Aeson.fromJSON json === Aeson.Success (def :: SyncInsertConfig) prop_syncInsertConfigRoundtrip :: Property @@ -118,7 +117,9 @@ genDefaultJson = [ [aesonQQ| { "tx_out": { - "value": "enable" + "value": "enable", + "use_address_table": false, + "force_tx_in": false }, "ledger": "enable", "shelley": { @@ -148,7 +149,8 @@ genDefaultJson = , [aesonQQ| { "tx_out": { - "value": "enable" + "value": "enable", + "use_address_table": false }, "ledger": "enable", "shelley": { diff --git a/cardano-db-tool/app/cardano-db-tool.hs b/cardano-db-tool/app/cardano-db-tool.hs index 285e15cfa..16e2a9bf3 100644 --- a/cardano-db-tool/app/cardano-db-tool.hs +++ b/cardano-db-tool/app/cardano-db-tool.hs @@ -64,7 +64,7 @@ runCommand cmd = void $ runMigrations pgConfig False mdir mldir Fix CmdTxOutMigration txOutTableType -> do - runWithConnectionNoLogging PGPassDefaultEnv $ migrateTxOut Nothing txOutTableType + runWithConnectionNoLogging PGPassDefaultEnv $ migrateTxOutTests txOutTableType CmdUtxoSetAtBlock blkid txOutAddressType -> utxoSetAtSlot txOutAddressType blkid CmdPrepareSnapshot pargs -> runPrepareSnapshot pargs CmdValidateDb txOutAddressType -> runDbValidation txOutAddressType diff --git a/cardano-db-tool/src/Cardano/DbTool/Validate/BlockTxs.hs b/cardano-db-tool/src/Cardano/DbTool/Validate/BlockTxs.hs index 104909274..e4e0a9849 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.Operations.Core.Query queries by BlockId. +-- This queries by BlockNo, the one in Cardano.Db.Operations.Query queries by BlockId. queryBlockTxCount :: MonadIO m => Word64 -> ReaderT SqlBackend m Word64 queryBlockTxCount blockNo = do res <- select $ do diff --git a/cardano-db/app/gen-schema-docs.hs b/cardano-db/app/gen-schema-docs.hs index b787e5661..a931ddf3d 100644 --- a/cardano-db/app/gen-schema-docs.hs +++ b/cardano-db/app/gen-schema-docs.hs @@ -60,7 +60,7 @@ docHeader branchName = , "** which may not accurately reflect the version number)" ] , "\n" - , "**Note:** This file is auto-generated from the documentation in cardano-db/src/Cardano/Db/Schema.hs\ + , "**Note:** This file is auto-generated from the documentation in cardano-db/src/Cardano/Db/Schema/BaseSchema.hs\ \ by the command `cabal run -- gen-schema-docs doc/schema.md`. This document should only be updated\ \ during the release process and updated on the release branch." , "\n" diff --git a/cardano-db/cardano-db.cabal b/cardano-db/cardano-db.cabal index 9b709d85b..2cad675a9 100644 --- a/cardano-db/cardano-db.cabal +++ b/cardano-db/cardano-db.cabal @@ -40,18 +40,18 @@ library Cardano.Db.Migration Cardano.Db.Migration.Haskell Cardano.Db.Migration.Version - 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.AlterTable + Cardano.Db.Operations.Delete + Cardano.Db.Operations.Insert + Cardano.Db.Operations.Other.MinId + Cardano.Db.Operations.Query + Cardano.Db.Operations.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.Operations.Other.ConsumedTxOut + Cardano.Db.Operations.Other.JsonbQuery + Cardano.Db.Operations.TxOut.TxOutDelete + Cardano.Db.Operations.TxOut.TxOutInsert + Cardano.Db.Operations.TxOut.TxOutQuery Cardano.Db.PGConfig Cardano.Db.Run Cardano.Db.Schema.BaseSchema diff --git a/cardano-db/src/Cardano/Db.hs b/cardano-db/src/Cardano/Db.hs index f3c241357..630df6f2a 100644 --- a/cardano-db/src/Cardano/Db.hs +++ b/cardano-db/src/Cardano/Db.hs @@ -6,34 +6,24 @@ module Cardano.Db ( Tx (..), TxIn (..), gitRev, - -- CTX.migrateTxOut, - -- CTX.runExtraMigrations, - -- CTX.queryTxConsumedColumnExists, - -- CTX.queryTxOutConsumedNullCount, - -- CTX.queryTxOutConsumedCount, - -- CTX.querySetNullTxOut, ) where import Cardano.Db.Error as X import Cardano.Db.Git.Version (gitRev) import Cardano.Db.Migration as X import Cardano.Db.Migration.Version 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.AlterTable as X +import Cardano.Db.Operations.Delete as X +import Cardano.Db.Operations.Insert as X +import Cardano.Db.Operations.Other.ConsumedTxOut as X +import Cardano.Db.Operations.Other.JsonbQuery as X +import Cardano.Db.Operations.Other.MinId as X +import Cardano.Db.Operations.Query as X +import Cardano.Db.Operations.QueryHelper as X +import Cardano.Db.Operations.TxOut.TxOutDelete as X +import Cardano.Db.Operations.TxOut.TxOutInsert as X +import Cardano.Db.Operations.TxOut.TxOutQuery 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.Run as X import Cardano.Db.Schema.BaseSchema as X diff --git a/cardano-db/src/Cardano/Db/Migration.hs b/cardano-db/src/Cardano/Db/Migration.hs index c91fcb53b..ff2c57842 100644 --- a/cardano-db/src/Cardano/Db/Migration.hs +++ b/cardano-db/src/Cardano/Db/Migration.hs @@ -28,10 +28,11 @@ 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.Operations.Query import Cardano.Db.PGConfig import Cardano.Db.Run import Cardano.Db.Schema.BaseSchema +import Cardano.Db.Schema.Core.TxOut (migrateCoreTxOutCardanoDb) import Cardano.Prelude (Typeable, textShow) import Control.Exception (Exception, SomeException, handle) import Control.Monad.Extra @@ -238,7 +239,10 @@ createMigration source (MigrationDir migdir) = do create :: ReaderT SqlBackend (NoLoggingT IO) (Maybe (MigrationVersion, Text)) create = do ver <- getSchemaVersion - statements <- getMigration migrateBaseCardanoDb + -- here is the place to combine any "core" schemas to the base schema + statementsBase <- getMigration migrateBaseCardanoDb + statementsTxOut <- getMigration migrateCoreTxOutCardanoDb + let statements = statementsBase <> statementsTxOut 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 deleted file mode 100644 index 3cf6dbac7..000000000 --- a/cardano-db/src/Cardano/Db/Migration/Extra/CosnumedTxOut/Queries.hs +++ /dev/null @@ -1,381 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module Cardano.Db.Migration.Extra.CosnumedTxOut.Queries where - -import Cardano.BM.Trace (Trace, logError, logInfo, logWarning) -import Cardano.Db.Error (LookupFail (..)) -import Cardano.Db.Insert (insertMany', insertUnchecked) -import Cardano.Db.Migration.Extra.CosnumedTxOut.Schema -import Cardano.Db.Query (isJust, listToMaybe, queryBlockHeight, queryMaxRefId) -import Cardano.Prelude (textShow) -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 => [(TxOutId, 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 :: MonadIO m => ReaderT SqlBackend m Word64 -queryTxOutConsumedNullCount = do - res <- select $ do - txOut <- from $ table @TxOut - where_ (isNothing $ txOut ^. TxOutConsumedByTxId) - pure countRows - pure $ maybe 0 unValue (listToMaybe res) - -queryTxOutConsumedCount :: MonadIO m => ReaderT SqlBackend m Word64 -queryTxOutConsumedCount = do - res <- select $ do - txOut <- from $ table @TxOut - where_ (not_ $ isNothing $ txOut ^. TxOutConsumedByTxId) - pure countRows - pure $ maybe 0 unValue (listToMaybe res) - -querySetNullTxOut :: MonadIO m => Trace IO Text -> Maybe TxId -> ReaderT SqlBackend m () -querySetNullTxOut trce mMinTxId = do - whenJust mMinTxId $ \txId -> do - txOutIds <- getTxOutConsumedAfter txId - mapM_ setNullTxOutConsumedAfter txOutIds - let updatedEntries = length txOutIds - liftIO $ logInfo trce $ "Set to null " <> textShow updatedEntries <> " tx_out.consumed_by_tx_id" - -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 -> ReaderT SqlBackend m Bool -_validateMigration trce = do - _migrated <- queryTxConsumedColumnExists - -- unless migrated $ runMigration - txInCount <- countTxIn - consumedTxOut <- countConsumed - 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 - -queryWrongConsumedBy :: MonadIO m => ReaderT SqlBackend m Word64 -queryWrongConsumedBy = do - res <- select $ do - txOut <- from $ table @TxOut - where_ (just (txOut ^. TxOutTxId) ==. txOut ^. TxOutConsumedByTxId) - pure countRows - pure $ maybe 0 unValue (listToMaybe res) - --------------------------------------------------------------------------------------------------- --- Inserts --------------------------------------------------------------------------------------------------- -insertTxOutExtra :: (MonadBaseControl IO m, MonadIO m) => TxOut -> ReaderT SqlBackend m TxOutId -insertTxOutExtra = insertUnchecked "TxOutExtra" - -insertManyTxOutExtra :: (MonadBaseControl IO m, MonadIO m) => [TxOut] -> ReaderT SqlBackend m [TxOutId] -insertManyTxOutExtra = insertMany' "TxOut" - --------------------------------------------------------------------------------------------------- --- Updates --------------------------------------------------------------------------------------------------- -updateTxOutConsumedByTxId :: MonadIO m => TxOutId -> TxId -> ReaderT SqlBackend m () -updateTxOutConsumedByTxId txOutId txId = - update txOutId [TxOutConsumedByTxId =. Just txId] - --- | This requires an index at TxOutConsumedByTxId. -getTxOutConsumedAfter :: MonadIO m => TxId -> ReaderT SqlBackend m [TxOutId] -getTxOutConsumedAfter txId = do - res <- select $ do - txOut <- from $ table @TxOut - where_ (txOut ^. TxOutConsumedByTxId >=. just (val txId)) - pure $ txOut ^. persistIdField - pure $ unValue <$> res - --- | This requires an index at TxOutConsumedByTxId. -setNullTxOutConsumedAfter :: MonadIO m => TxOutId -> ReaderT SqlBackend m () -setNullTxOutConsumedAfter txOutId = do - update txOutId [TxOutConsumedByTxId =. Nothing] - -migrateTxOut :: - ( MonadBaseControl IO m - , MonadIO m - ) => - Maybe (Trace IO Text) -> - ReaderT SqlBackend m () -migrateTxOut mTrace = 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 page - when (fromIntegral (length page) == pageSize) $ - migrateNextPage $! - offst - + pageSize - --------------------------------------------------------------------------------------------------- --- Delete + Update --------------------------------------------------------------------------------------------------- - -deleteAndUpdateConsumedTxOut :: - forall m. - (MonadIO m, MonadBaseControl IO m) => - Trace IO Text -> - Word64 -> - ReaderT SqlBackend m () -deleteAndUpdateConsumedTxOut trce 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) - 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 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 -> - Bool -> - TxId -> - [ConsumedTriplet] -> - ReaderT SqlBackend m Bool -splitAndProcessPageEntries trce 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 xs - pure False - -- the whole list is greater that maxTxInId - ([], ys) -> do - shouldCreateConsumedTxOut trce ranCreateConsumedTxOut - updatePageEntries ys - pure True - -- the list has both bellow and above maxTxInId - (xs, ys) -> do - deletePageEntries xs - shouldCreateConsumedTxOut trce ranCreateConsumedTxOut - updatePageEntries ys - pure True - --- | Update -updatePageEntries :: - MonadIO m => - [ConsumedTriplet] -> - ReaderT SqlBackend m () -updatePageEntries = - mapM_ updateTxOutConsumedByTxIdUnique - -updateTxOutConsumedByTxIdUnique :: MonadIO m => ConsumedTriplet -> ReaderT SqlBackend m () -updateTxOutConsumedByTxIdUnique ConsumedTriplet {ctTxOutTxId, ctTxOutIndex, ctTxInTxId} = - updateWhere [TxOutTxId ==. ctTxOutTxId, TxOutIndex ==. ctTxOutIndex] [TxOutConsumedByTxId =. Just ctTxInTxId] - --- | Delete --- this builds up a single delete query using the pageEntries list -deletePageEntries :: - MonadIO m => - [ConsumedTriplet] -> - ReaderT SqlBackend m () -deletePageEntries = mapM_ (\ConsumedTriplet {ctTxOutTxId, ctTxOutIndex} -> deleteTxOutConsumed ctTxOutTxId ctTxOutIndex) - -deleteTxOutConsumed :: MonadIO m => TxId -> Word64 -> ReaderT SqlBackend m () -deleteTxOutConsumed txOutId index = - deleteWhere [TxOutTxId ==. txOutId, 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 -> - Word64 -> - ReaderT SqlBackend m () -deleteConsumedTxOut trce blockNoDiff = do - maxTxInId <- findMaxTxInId blockNoDiff - case maxTxInId of - Left errMsg -> liftIO $ logInfo trce $ "No tx_out was deleted: " <> errMsg - Right mxtid -> deleteConsumedBeforeTx trce mxtid - -deleteConsumedBeforeTx :: MonadIO m => Trace IO Text -> TxId -> ReaderT SqlBackend m () -deleteConsumedBeforeTx trce txId = do - countDeleted <- deleteWhereCount [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 - -queryBlockNo :: MonadIO m => Word64 -> ReaderT SqlBackend m (Maybe BlockId) -queryBlockNo blkNo = do - res <- select $ do - blk <- from $ table @Block - where_ (blk ^. BlockBlockNo E.==. just (val blkNo)) - pure (blk ^. BlockId) - pure $ fmap unValue (listToMaybe res) - -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 => ReaderT SqlBackend m Word64 -countConsumed = do - res <- select $ do - txOut <- from $ table @TxOut - where_ (isJust $ txOut ^. TxOutConsumedByTxId) - pure countRows - pure $ maybe 0 unValue (listToMaybe res) diff --git a/cardano-db/src/Cardano/Db/Operations/Core/AlterTable.hs b/cardano-db/src/Cardano/Db/Operations/AlterTable.hs similarity index 98% rename from cardano-db/src/Cardano/Db/Operations/Core/AlterTable.hs rename to cardano-db/src/Cardano/Db/Operations/AlterTable.hs index 3523c6138..adefd1de4 100644 --- a/cardano-db/src/Cardano/Db/Operations/Core/AlterTable.hs +++ b/cardano-db/src/Cardano/Db/Operations/AlterTable.hs @@ -5,7 +5,7 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-unused-local-binds #-} -module Cardano.Db.Operations.Core.AlterTable ( +module Cardano.Db.Operations.AlterTable ( AlterTable (..), DbAlterTableException (..), ManualDbConstraints (..), diff --git a/cardano-db/src/Cardano/Db/Operations/Core/Delete.hs b/cardano-db/src/Cardano/Db/Operations/Delete.hs similarity index 98% rename from cardano-db/src/Cardano/Db/Operations/Core/Delete.hs rename to cardano-db/src/Cardano/Db/Operations/Delete.hs index d59446d57..87179087c 100644 --- a/cardano-db/src/Cardano/Db/Operations/Core/Delete.hs +++ b/cardano-db/src/Cardano/Db/Operations/Delete.hs @@ -8,7 +8,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} -module Cardano.Db.Operations.Core.Delete ( +module Cardano.Db.Operations.Delete ( deleteBlocksSlotNo, deleteBlocksSlotNoNoTrace, deleteDelistedPool, @@ -25,8 +25,8 @@ module Cardano.Db.Operations.Core.Delete ( ) where import Cardano.BM.Trace (Trace, logWarning, nullTracer) -import Cardano.Db.Operations.Core.MinId (MinIds (..), MinIdsWrapper (..), completeMinId, textToMinIds) -import Cardano.Db.Operations.Core.Query +import Cardano.Db.Operations.Other.MinId (MinIds (..), MinIdsWrapper (..), completeMinId, textToMinIds) +import Cardano.Db.Operations.Query import Cardano.Db.Operations.Types (TxOutTableType (..)) import Cardano.Db.Schema.BaseSchema import qualified Cardano.Db.Schema.Core.TxOut as C diff --git a/cardano-db/src/Cardano/Db/Operations/Core/Insert.hs b/cardano-db/src/Cardano/Db/Operations/Insert.hs similarity index 99% rename from cardano-db/src/Cardano/Db/Operations/Core/Insert.hs rename to cardano-db/src/Cardano/Db/Operations/Insert.hs index f937bf696..c9933190f 100644 --- a/cardano-db/src/Cardano/Db/Operations/Core/Insert.hs +++ b/cardano-db/src/Cardano/Db/Operations/Insert.hs @@ -6,7 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module Cardano.Db.Operations.Core.Insert ( +module Cardano.Db.Operations.Insert ( insertAdaPots, insertBlock, insertCollateralTxIn, @@ -97,7 +97,7 @@ module Cardano.Db.Operations.Core.Insert ( insertBlockChecked, ) where -import Cardano.Db.Operations.Core.Query +import Cardano.Db.Operations.Query import Cardano.Db.Schema.BaseSchema import Cardano.Db.Types import Cardano.Prelude (textShow) @@ -494,8 +494,9 @@ insertAlwaysNoConfidence = do , drepHashHasScript = False } --- ----------------------------------------------------------------------------- - +-------------------------------------------------------------------------------- +-- Custom insert functions +-------------------------------------------------------------------------------- data DbInsertException = DbInsertException String SqlError deriving (Show) diff --git a/cardano-db/src/Cardano/Db/Operations/Variant/ConsumedTxOut.hs b/cardano-db/src/Cardano/Db/Operations/Other/ConsumedTxOut.hs similarity index 73% rename from cardano-db/src/Cardano/Db/Operations/Variant/ConsumedTxOut.hs rename to cardano-db/src/Cardano/Db/Operations/Other/ConsumedTxOut.hs index 31d03d4bf..ed90bd77b 100644 --- a/cardano-db/src/Cardano/Db/Operations/Variant/ConsumedTxOut.hs +++ b/cardano-db/src/Cardano/Db/Operations/Other/ConsumedTxOut.hs @@ -11,18 +11,18 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module Cardano.Db.Operations.Variant.ConsumedTxOut where +module Cardano.Db.Operations.Other.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.Operations.Insert (insertExtraMigration) +import Cardano.Db.Operations.Query (listToMaybe, queryAllExtraMigrations, queryBlockHeight, queryBlockNo, queryMaxRefId) +import Cardano.Db.Operations.QueryHelper (isJust) +import Cardano.Db.Operations.Types (TxOutFields (..), TxOutIdW (..), TxOutTable, TxOutTableType (..), isTxOutVariantAddress) 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.Db.Types (ExtraMigration (..), MigrationValues (..), PruneConsumeMigration (..), processMigrationValues) import Cardano.Prelude (textShow) import Control.Exception (throw) import Control.Exception.Lifted (handle, throwIO) @@ -31,6 +31,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Reader (ReaderT) import Data.Text (Text) +import qualified Data.Text as Text import Data.Word (Word64) import Database.Esqueleto.Experimental hiding (update, (<=.), (=.), (==.)) import qualified Database.Esqueleto.Experimental as E @@ -109,106 +110,51 @@ querySetNullTxOut trce txOutTableType mMinTxId = do 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 +runExtraMigrations trce txOutTableType blockNoDiff pcm = do ems <- queryAllExtraMigrations - let wPruneTxOutPreviouslySet = wasPruneTxOutPreviouslySet ems + let migrationValues = processMigrationValues ems pcm + -- Has the user given txout address config && the migration wasn't previously set + when (isTxOutVariantAddress txOutTableType && not (isTxOutAddressPreviouslySet migrationValues)) $ do + updateTxOutAndCreateAddress + insertExtraMigration TxOutAddressPreviouslySet + -- 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 + when (isPruneTxOutPreviouslySet migrationValues && not (pcmPruneTxOut pcm)) $ + 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." + handleMigration migrationValues + where + handleMigration :: (MonadBaseControl IO m, MonadIO m) => MigrationValues -> ReaderT SqlBackend m () + handleMigration migrationValues@MigrationValues {..} = do + let PruneConsumeMigration {..} = pruneConsumeMigration + case (isConsumeTxOutPreviouslySet, pcmConsumeOrPruneTxOut, pcmPruneTxOut) of + -- No Migration Needed (False, False, False) -> do - liftIO $ logInfo trce "No extra migration specified" + liftIO $ logInfo trce "runExtraMigrations: No extra migration specified" + -- Already migrated (True, True, False) -> do - liftIO $ logInfo trce "Extra migration consumed_tx_out already executed" - (True, False, False) -> liftIO $ logAndThrowIO trce migratedButNotSet + liftIO $ logInfo trce "runExtraMigrations: Extra migration consumed_tx_out already executed" + -- Invalid State + (True, False, False) -> liftIO $ logAndThrowIO trce "runExtraMigrations: consumed-tx-out or prune-tx-out is not set, but consumed migration is found." + -- Consume TxOut (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 + liftIO $ logInfo trce "runExtraMigrations: Running extra migration consumed_tx_out" + insertExtraMigration ConsumeTxOutPreviouslySet + migrateTxOut trce txOutTableType $ Just migrationValues + -- Prune TxOut + (_, _, True) -> do + unless isPruneTxOutPreviouslySet $ insertExtraMigration PruneTxOutFlagPreviouslySet + if isConsumeTxOutPreviouslySet + then do + liftIO $ logInfo trce "runExtraMigrations: Running extra migration prune tx_out" + deleteConsumedTxOut trce txOutTableType blockNoDiff + else deleteAndUpdateConsumedTxOut trce txOutTableType migrationValues blockNoDiff queryWrongConsumedBy :: TxOutTableType -> MonadIO m => ReaderT SqlBackend m Word64 queryWrongConsumedBy = \case @@ -271,46 +217,52 @@ setNullTxOutConsumedAfter txOutTableType txOutId = CTxOutIdW txOutId' -> update txOutId' [C.TxOutConsumedByTxId =. Nothing] VTxOutIdW txOutId' -> update txOutId' [V.TxOutConsumedByTxId =. Nothing] +migrateTxOutTests :: (MonadIO m, MonadBaseControl IO m) => TxOutTableType -> ReaderT SqlBackend m () +migrateTxOutTests txOutTableType = do + _ <- createConsumedTxOut + migrateNextPageTxOut Nothing txOutTableType 0 + migrateTxOut :: ( MonadBaseControl IO m , MonadIO m ) => - Maybe (Trace IO Text) -> + Trace IO Text -> TxOutTableType -> + Maybe MigrationValues -> ReaderT SqlBackend m () -migrateTxOut mTrace txOutTableType = do +migrateTxOut trce txOutTableType _mMvs = do + liftIO $ logInfo trce "migrateTxOut:" _ <- 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 + migrateNextPageTxOut (Just trce) txOutTableType 0 + +migrateNextPageTxOut :: MonadIO m => Maybe (Trace IO Text) -> TxOutTableType -> Word64 -> ReaderT SqlBackend m () +migrateNextPageTxOut mTrce txOutTableType offst = do + whenJust mTrce $ \trce -> + liftIO $ logInfo trce $ "Handling input offset " <> textShow offst + page <- getInputPage offst pageSize + updatePageEntries txOutTableType page + when (fromIntegral (length page) == pageSize) $ + migrateNextPageTxOut mTrce txOutTableType $! + (offst + pageSize) -------------------------------------------------------------------------------------------------- -- Delete + Update -------------------------------------------------------------------------------------------------- - deleteAndUpdateConsumedTxOut :: forall m. (MonadIO m, MonadBaseControl IO m) => Trace IO Text -> TxOutTableType -> + MigrationValues -> Word64 -> ReaderT SqlBackend m () -deleteAndUpdateConsumedTxOut trce txOutTableType blockNoDiff = do +deleteAndUpdateConsumedTxOut trce txOutTableType migrationValues 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 + migrateTxOut trce txOutTableType $ Just migrationValues Right mTxId -> do migrateNextPage mTxId False 0 where @@ -355,6 +307,16 @@ splitAndProcessPageEntries trce txOutTableType ranCreateConsumedTxOut maxTxId pa updatePageEntries txOutTableType ys pure True +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 + -- | Update updatePageEntries :: MonadIO m => @@ -369,7 +331,6 @@ updateTxOutConsumedByTxIdUnique txOutTableType ConsumedTriplet {ctTxOutTxId, ctT 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 => @@ -383,15 +344,75 @@ 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 -> +-------------------------------------------------------------------------------------------------- +-- Raw Queries +-------------------------------------------------------------------------------------------------- +createConsumedTxOut :: + forall m. + ( MonadBaseControl IO m + , MonadIO m + ) => ReaderT SqlBackend m () -shouldCreateConsumedTxOut trce rcc = - unless rcc $ do - liftIO $ logInfo trce "Created ConsumedTxOut when handling page entries." - createConsumedTxOut +createConsumedTxOut = do + handle exceptHandler $ rawExecute createIndex [] + handle exceptHandler $ rawExecute addConstraint [] + where + createIndex = + "CREATE INDEX IF NOT EXISTS idx_tx_out_consumed_by_tx_id ON tx_out (consumed_by_tx_id)" + + addConstraint = + ( Text.unlines + [ "do $$" + , "begin" + , " if not exists (" + , " select 1" + , " from information_schema.table_constraints" + , " where constraint_name = 'ma_tx_out_tx_out_id_fkey'" + , " and table_name = 'ma_tx_out'" + , " ) then" + , " execute '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';" + , " end if;" + , "end $$;" + ] + ) + + exceptHandler :: SqlError -> ReaderT SqlBackend m a + exceptHandler e = + liftIO $ throwIO (DBPruneConsumed $ show e) + +updateTxOutAndCreateAddress :: + forall m. + ( MonadBaseControl IO m + , MonadIO m + ) => + ReaderT SqlBackend m () +updateTxOutAndCreateAddress = do + handle exceptHandler $ rawExecute alterTxOutQuery [] + handle exceptHandler $ rawExecute createAddressTableQuery [] + where + alterTxOutQuery = + Text.unlines + [ "ALTER TABLE \"tx_out\"" + , " ADD COLUMN \"address_id\" INT8 NOT NULL," + , " DROP COLUMN \"address\"," + , " DROP COLUMN \"address_has_script\"," + , " DROP COLUMN \"payment_cred\"," + , " DROP COLUMN \"stake_address_id\"" + ] + createAddressTableQuery = + Text.unlines + [ "CREATE TABLE \"address\" (" + , " \"id\" SERIAL8 PRIMARY KEY UNIQUE," + , " \"address\" VARCHAR NOT NULL," + , " \"raw\" BYTEA NOT NULL," + , " \"has_script\" BOOLEAN NOT NULL," + , " \"payment_cred\" hash28type NULL," + , " \"stake_address_id\" INT8 NULL" + , ")" + ] + exceptHandler :: SqlError -> ReaderT SqlBackend m a + exceptHandler e = + liftIO $ throwIO (DBPruneConsumed $ show e) -------------------------------------------------------------------------------------------------- -- Delete @@ -484,3 +505,37 @@ countConsumed = \case where_ (isJust $ txOut ^. txOutConsumedByTxIdField @a) pure countRows pure $ maybe 0 unValue (listToMaybe res) + +_validateMigration :: MonadIO m => Trace IO Text -> TxOutTableType -> ReaderT SqlBackend m Bool +_validateMigration trce txOutTableType = do + _migrated <- queryTxConsumedColumnExists + 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 diff --git a/cardano-db/src/Cardano/Db/Operations/Variant/JsonbQuery.hs b/cardano-db/src/Cardano/Db/Operations/Other/JsonbQuery.hs similarity index 98% rename from cardano-db/src/Cardano/Db/Operations/Variant/JsonbQuery.hs rename to cardano-db/src/Cardano/Db/Operations/Other/JsonbQuery.hs index e8b3862d9..7ae86600b 100644 --- a/cardano-db/src/Cardano/Db/Operations/Variant/JsonbQuery.hs +++ b/cardano-db/src/Cardano/Db/Operations/Other/JsonbQuery.hs @@ -3,7 +3,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -module Cardano.Db.Operations.Variant.JsonbQuery where +module Cardano.Db.Operations.Other.JsonbQuery where import Cardano.Db.Error (LookupFail (..)) import Control.Exception.Lifted (handle, throwIO) diff --git a/cardano-db/src/Cardano/Db/Operations/Core/MinId.hs b/cardano-db/src/Cardano/Db/Operations/Other/MinId.hs similarity index 98% rename from cardano-db/src/Cardano/Db/Operations/Core/MinId.hs rename to cardano-db/src/Cardano/Db/Operations/Other/MinId.hs index 127f7e0a1..3c03942a7 100644 --- a/cardano-db/src/Cardano/Db/Operations/Core/MinId.hs +++ b/cardano-db/src/Cardano/Db/Operations/Other/MinId.hs @@ -8,9 +8,9 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-} -module Cardano.Db.Operations.Core.MinId where +module Cardano.Db.Operations.Other.MinId where -import Cardano.Db.Operations.Core.Query (queryMinRefId) +import Cardano.Db.Operations.Query (queryMinRefId) import Cardano.Db.Operations.Types (MaTxOutFields (..), TxOutFields (..), TxOutTableType (..)) import Cardano.Db.Schema.BaseSchema import qualified Cardano.Db.Schema.Core.TxOut as C diff --git a/cardano-db/src/Cardano/Db/Operations/Core/Query.hs b/cardano-db/src/Cardano/Db/Operations/Query.hs similarity index 99% rename from cardano-db/src/Cardano/Db/Operations/Core/Query.hs rename to cardano-db/src/Cardano/Db/Operations/Query.hs index 0ec15a8df..7b8934455 100644 --- a/cardano-db/src/Cardano/Db/Operations/Core/Query.hs +++ b/cardano-db/src/Cardano/Db/Operations/Query.hs @@ -4,7 +4,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module Cardano.Db.Operations.Core.Query ( +module Cardano.Db.Operations.Query ( LookupFail (..), -- queries used by db-sync queryBlockCount, @@ -103,7 +103,7 @@ module Cardano.Db.Operations.Core.Query ( ) where import Cardano.Db.Error -import Cardano.Db.Operations.Core.QueryHelper (defaultUTCTime, isJust, maybeToEither, unValue2, unValue3, unValue5, unValueSumAda) +import Cardano.Db.Operations.QueryHelper (defaultUTCTime, isJust, maybeToEither, unValue2, unValue3, unValue5, unValueSumAda) import Cardano.Db.Schema.BaseSchema import Cardano.Db.Types import Cardano.Ledger.BaseTypes (CertIx (..), TxIx (..)) diff --git a/cardano-db/src/Cardano/Db/Operations/Core/QueryHelper.hs b/cardano-db/src/Cardano/Db/Operations/QueryHelper.hs similarity index 98% rename from cardano-db/src/Cardano/Db/Operations/Core/QueryHelper.hs rename to cardano-db/src/Cardano/Db/Operations/QueryHelper.hs index b16dfa9df..64da0a70f 100644 --- a/cardano-db/src/Cardano/Db/Operations/Core/QueryHelper.hs +++ b/cardano-db/src/Cardano/Db/Operations/QueryHelper.hs @@ -3,7 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module Cardano.Db.Operations.Core.QueryHelper where +module Cardano.Db.Operations.QueryHelper where import Cardano.Db.Schema.BaseSchema import Cardano.Db.Types diff --git a/cardano-db/src/Cardano/Db/Operations/Variant/TxOutDelete.hs b/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutDelete.hs similarity index 81% rename from cardano-db/src/Cardano/Db/Operations/Variant/TxOutDelete.hs rename to cardano-db/src/Cardano/Db/Operations/TxOut/TxOutDelete.hs index 39e714d14..f17328aa4 100644 --- a/cardano-db/src/Cardano/Db/Operations/Variant/TxOutDelete.hs +++ b/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutDelete.hs @@ -3,7 +3,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -module Cardano.Db.Operations.Variant.TxOutDelete where +module Cardano.Db.Operations.TxOut.TxOutDelete where import Cardano.Db.Operations.Types (TxOutTableType (..)) import qualified Cardano.Db.Schema.Core.TxOut as C @@ -28,12 +28,10 @@ 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 +deleteVariantTxOutTablesAfterTxId :: MonadIO m => Maybe V.TxOutId -> Maybe V.MaTxOutId -> ReaderT SqlBackend m () +deleteVariantTxOutTablesAfterTxId mtxOutId mmaTxOutId = 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 diff --git a/cardano-db/src/Cardano/Db/Operations/Variant/TxOutInsert.hs b/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutInsert.hs similarity index 96% rename from cardano-db/src/Cardano/Db/Operations/Variant/TxOutInsert.hs rename to cardano-db/src/Cardano/Db/Operations/TxOut/TxOutInsert.hs index f33a6b243..ad9cb1239 100644 --- a/cardano-db/src/Cardano/Db/Operations/Variant/TxOutInsert.hs +++ b/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutInsert.hs @@ -5,9 +5,9 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-} -module Cardano.Db.Operations.Variant.TxOutInsert where +module Cardano.Db.Operations.TxOut.TxOutInsert where -import Cardano.Db.Operations.Core.Insert (insertMany', insertUnchecked) +import Cardano.Db.Operations.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 diff --git a/cardano-db/src/Cardano/Db/Operations/Variant/TxOutQuery.hs b/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutQuery.hs similarity index 99% rename from cardano-db/src/Cardano/Db/Operations/Variant/TxOutQuery.hs rename to cardano-db/src/Cardano/Db/Operations/TxOut/TxOutQuery.hs index f78cf93dd..d06f6c0df 100644 --- a/cardano-db/src/Cardano/Db/Operations/Variant/TxOutQuery.hs +++ b/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutQuery.hs @@ -11,10 +11,10 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -module Cardano.Db.Operations.Variant.TxOutQuery where +module Cardano.Db.Operations.TxOut.TxOutQuery where import Cardano.Db.Error (LookupFail (..)) -import Cardano.Db.Operations.Core.QueryHelper (isJust, maybeToEither, txLessEqual, unValue2, unValue3, unValueSumAda) +import Cardano.Db.Operations.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 diff --git a/cardano-db/src/Cardano/Db/Operations/Types.hs b/cardano-db/src/Cardano/Db/Operations/Types.hs index 98d60cbf7..7753742fd 100644 --- a/cardano-db/src/Cardano/Db/Operations/Types.hs +++ b/cardano-db/src/Cardano/Db/Operations/Types.hs @@ -213,3 +213,11 @@ convertMaTxOutIdVariant = mapMaybe unwrapVariant where unwrapVariant (VMaTxOutIdW maTxOutId) = Just maTxOutId unwrapVariant _ = Nothing + +isTxOutCore :: TxOutTableType -> Bool +isTxOutCore TxOutCore = True +isTxOutCore TxOutVariantAddress = False + +isTxOutVariantAddress :: TxOutTableType -> Bool +isTxOutVariantAddress TxOutVariantAddress = True +isTxOutVariantAddress TxOutCore = False diff --git a/cardano-db/src/Cardano/Db/Schema/CoreSchema.hs b/cardano-db/src/Cardano/Db/Schema/CoreSchema.hs deleted file mode 100644 index 8ab13404a..000000000 --- a/cardano-db/src/Cardano/Db/Schema/CoreSchema.hs +++ /dev/null @@ -1 +0,0 @@ -module Cardano.Db.Schema.CoreSchema where diff --git a/cardano-db/src/Cardano/Db/Types.hs b/cardano-db/src/Cardano/Db/Types.hs index 2567372d3..8735983fd 100644 --- a/cardano-db/src/Cardano/Db/Types.hs +++ b/cardano-db/src/Cardano/Db/Types.hs @@ -4,6 +4,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -23,14 +24,15 @@ module Cardano.Db.Types ( CertNo (..), PoolCert (..), ExtraMigration (..), + MigrationValues (..), VoteUrl (..), VoteMetaHash (..), Vote (..), VoterRole (..), GovActionType (..), BootstrapState (..), + processMigrationValues, isStakeDistrComplete, - wasPruneTxOutPreviouslySet, bootstrapState, extraDescription, deltaCoinToDbInt65, @@ -196,14 +198,32 @@ data ExtraMigration | PruneTxOutFlagPreviouslySet | BootstrapStarted | BootstrapFinished + | ConsumeTxOutPreviouslySet + | TxOutAddressPreviouslySet deriving (Eq, Show, Read) +data MigrationValues = MigrationValues + { isStakeDistrEnded :: !Bool + , isPruneTxOutPreviouslySet :: !Bool + , isConsumeTxOutPreviouslySet :: !Bool + , isTxOutAddressPreviouslySet :: !Bool + , pruneConsumeMigration :: !PruneConsumeMigration + } + deriving (Eq, Show) + +processMigrationValues :: [ExtraMigration] -> PruneConsumeMigration -> MigrationValues +processMigrationValues migrations pcm = + MigrationValues + { isStakeDistrEnded = StakeDistrEnded `elem` migrations + , isPruneTxOutPreviouslySet = PruneTxOutFlagPreviouslySet `elem` migrations + , isConsumeTxOutPreviouslySet = ConsumeTxOutPreviouslySet `elem` migrations + , isTxOutAddressPreviouslySet = TxOutAddressPreviouslySet `elem` migrations + , pruneConsumeMigration = pcm + } + isStakeDistrComplete :: [ExtraMigration] -> Bool isStakeDistrComplete = elem StakeDistrEnded -wasPruneTxOutPreviouslySet :: [ExtraMigration] -> Bool -wasPruneTxOutPreviouslySet = elem PruneTxOutFlagPreviouslySet - data BootstrapState = BootstrapNotStarted | BootstrapInProgress @@ -221,6 +241,7 @@ data PruneConsumeMigration = PruneConsumeMigration , -- we make the assumption that if the user is using prune flag -- they will also want consume automatically set for them. pcmConsumeOrPruneTxOut :: Bool + , pcmConsumedTxOut :: Bool , pcmSkipTxIn :: Bool } deriving (Eq, Show) @@ -236,6 +257,10 @@ extraDescription = \case "The bootstrap syncing is in progress" BootstrapFinished -> "The bootstrap is finalised" + ConsumeTxOutPreviouslySet -> + "The --consume-tx-out flag has previously been enabled" + TxOutAddressPreviouslySet -> + "The addition of a Address table for TxOuts was previously set" instance Ord PoolCert where compare a b = compare (pcCertNo a) (pcCertNo b) diff --git a/cardano-db/test/schema-rollback.hs b/cardano-db/test/schema-rollback.hs index ccecf4127..5e5ed7bef 100644 --- a/cardano-db/test/schema-rollback.hs +++ b/cardano-db/test/schema-rollback.hs @@ -41,7 +41,7 @@ main = do findTablesWithBlockNo :: IO [ByteString] findTablesWithBlockNo = do - xs <- mapMaybe removeCommentsAndEmpty . getSchema <$> BS.readFile "cardano-db/src/Cardano/Db/Schema.hs" + xs <- mapMaybe removeCommentsAndEmpty . getSchema <$> BS.readFile "cardano-db/src/Cardano/Db/Schema/BaseSchema.hs" when (length xs < 10) $ error $ "Expected at least 10 lines of schema definition, but got only " ++ show (length xs) @@ -91,7 +91,7 @@ findTablesWithDelete = . mapMaybe getTableName . mapMaybe removeCommentsAndEmpty . getDeleteAfterBlockNo - <$> BS.readFile "cardano-db/src/Cardano/Db/Operations/Core/Delete.hs" + <$> BS.readFile "cardano-db/src/Cardano/Db/Operations/Delete.hs" where getDeleteAfterBlockNo :: ByteString -> [ByteString] getDeleteAfterBlockNo = diff --git a/doc/interesting-queries.md b/doc/interesting-queries.md index b15c67946..2b3e7ec75 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/Operations/Core/Query.hs +[Query.hs]: https://github.com/IntersectMBO/cardano-db-sync/blob/master/cardano-db/src/Cardano/Db/Operations/Query.hs diff --git a/flake.nix b/flake.nix index 87b676cf8..9fd272eb9 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/Operations/Core/Delete.hs" ]; + [ "src/Cardano/Db/Schema.hs" "src/Cardano/Db/Operations/Delete.hs" ]; packages.cardano-db.components.tests.test-db.extraSrcFiles = [ "../config/pgpass-mainnet" ]; packages.cardano-chain-gen.package.extraSrcFiles = diff --git a/schema/migration-2-0044-20240912.sql b/schema/migration-2-0044-20240912.sql new file mode 100644 index 000000000..6ca15ae24 --- /dev/null +++ b/schema/migration-2-0044-20240912.sql @@ -0,0 +1,21 @@ +-- Persistent generated migration. + +CREATE FUNCTION migrate() RETURNS void AS $$ +DECLARE + next_version int ; +BEGIN + SELECT stage_two + 1 INTO next_version FROM schema_version ; + IF next_version = 44 THEN + -- EXECUTE 'ALTER TABLE "reward" ADD COLUMN "id" INT8 NOT NULL' ; + -- EXECUTE 'ALTER TABLE "reward_rest" ADD COLUMN "id" INT8 NOT NULL' ; + EXECUTE 'ALTER TABLE "tx_out" ADD COLUMN "consumed_by_tx_id" INT8 NULL' ; + -- Hand written SQL statements can be added here. + UPDATE schema_version SET stage_two = next_version ; + RAISE NOTICE 'DB has been migrated to stage_two version %', next_version ; + END IF ; +END ; +$$ LANGUAGE plpgsql ; + +SELECT migrate() ; + +DROP FUNCTION migrate() ; diff --git a/scripts/run-everything-tmux.sh b/scripts/run-everything-tmux.sh new file mode 100755 index 000000000..a4de0dab6 --- /dev/null +++ b/scripts/run-everything-tmux.sh @@ -0,0 +1,39 @@ +#!/usr/bin/env bash + +HOMEIOG=$HOME/Code/IOG + +dbsync="$(find $HOMEIOG/cardano-db-sync/ -name cardano-db-sync -type f)" + +session="IOHK" + +# Check if the session exists, discarding output +# We can check $? for the exit status (zero for success, non-zero for failure) +tmux has-session -t $session 2>/dev/null + +# if there is a session named IOHK then kill it +if [ $? = 1 ]; then + tmux kill-session -t $session + killall cardano-node +fi + +tmux new-session -d -s $session + +tmux rename-window $session +tmux split-window -h +# tmux split-window -v +# tmux split-window -v +# tmux select-layout tiled + +# Cardano Node +tmux send-keys -t 0 "cd $HOMEIOG/cardano-node/" 'C-m' +tmux send-keys -t 0 "cardano-node run --config $HOMEIOG/testnet/config.json --database-path $HOMEIOG/testnet/db/ --socket-path $HOMEIOG/testnet/db/node.socket --host-addr 0.0.0.0 --port 1337 --topology $HOMEIOG/testnet/topology.json" 'C-m' + +# Cardano DB-Sync +tmux send-keys -t 1 "cd $HOMEIOG/cardano-db-sync/" 'C-m'; sleep 3 +tmux send-keys -t 1 "export PGPASSFILE=$HOMEIOG/cardano-db-sync/config/pgpass-mainnet" 'C-m'; sleep 2 +# tmux send-keys -t 1 "$dbsync --config $HOMEIOG/testnet/db-sync-config.json --socket-path $HOMEIOG/testnet/db/node.socket --state-dir $HOMEIOG/testnet/ledger-state --schema-dir $HOMEIOG/cardano-db-sync/schema/ +RTS -p -hc -L200 -RTS" 'C-m' +tmux send-keys -t 1 "PGPASSFILE=$HOMEIOG/cardano-db-sync/config/pgpass-mainnet $dbsync --config $HOMEIOG/testnet/db-sync-config.json --socket-path $HOMEIOG/testnet/db/node.socket --state-dir $HOMEIOG/testnet/ledger-state --schema-dir $HOMEIOG/cardano-db-sync/schema/" 'C-m' + +tmux send-keys -t 0 "cd $HOMEIOG/" 'C-m' + +tmux attach-session -t $session From d4a5d9b8aa61b9a0be97eba1860ac6d29a867ccf Mon Sep 17 00:00:00 2001 From: Cmdv Date: Thu, 19 Sep 2024 10:25:39 +0100 Subject: [PATCH 4/6] additional work on txout address --- .../test/Test/Cardano/Db/Mock/Config.hs | 8 +- .../test/Test/Cardano/Db/Mock/Unit/Babbage.hs | 3 +- .../Config/MigrateConsumedPruneTxOut.hs | 16 --- .../test/Test/Cardano/Db/Mock/Unit/Conway.hs | 3 +- .../Config/MigrateConsumedPruneTxOut.hs | 22 ---- .../Cardano/Db/Mock/Unit/Conway/Plutus.hs | 1 + cardano-db-sync/src/Cardano/DbSync/Api.hs | 9 +- .../src/Cardano/DbSync/Era/Byron/Genesis.hs | 2 +- .../src/Cardano/DbSync/Era/Shelley/Genesis.hs | 2 - .../DbSync/Era/Universal/Insert/Grouped.hs | 1 - .../Cardano/DbSync/Era/Universal/Insert/Tx.hs | 4 +- .../Db/Operations/Other/ConsumedTxOut.hs | 110 ++++++------------ .../Cardano/Db/Operations/TxOut/TxOutQuery.hs | 8 -- cardano-db/src/Cardano/Db/Types.hs | 3 +- 14 files changed, 52 insertions(+), 140 deletions(-) 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 b4cc50219..268c85de5 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs @@ -304,19 +304,19 @@ mkConfigFile staticDir cliConfigFilename = configPruneForceTxIn :: SyncNodeConfig -> SyncNodeConfig configPruneForceTxIn cfg = do - cfg {dncInsertOptions = (dncInsertOptions cfg) {sioTxOut = TxOutPrune (ForceTxIn True)}} + cfg {dncInsertOptions = (dncInsertOptions cfg) {sioTxOut = TxOutConsumedPrune (ForceTxIn True) (UseTxOutAddress False)}} configPrune :: SyncNodeConfig -> SyncNodeConfig configPrune cfg = do - cfg {dncInsertOptions = (dncInsertOptions cfg) {sioTxOut = TxOutPrune (ForceTxIn False)}} + cfg {dncInsertOptions = (dncInsertOptions cfg) {sioTxOut = TxOutConsumedPrune (ForceTxIn False) (UseTxOutAddress False)}} configConsume :: SyncNodeConfig -> SyncNodeConfig configConsume cfg = do - cfg {dncInsertOptions = (dncInsertOptions cfg) {sioTxOut = TxOutConsumed (ForceTxIn False)}} + cfg {dncInsertOptions = (dncInsertOptions cfg) {sioTxOut = TxOutConsumed (ForceTxIn False) (UseTxOutAddress False)}} configBootstrap :: SyncNodeConfig -> SyncNodeConfig configBootstrap cfg = do - cfg {dncInsertOptions = (dncInsertOptions cfg) {sioTxOut = TxOutBootstrap (ForceTxIn False)}} + cfg {dncInsertOptions = (dncInsertOptions cfg) {sioTxOut = TxOutConsumedBootstrap (ForceTxIn False) (UseTxOutAddress False)}} configPlutusDisable :: SyncNodeConfig -> SyncNodeConfig configPlutusDisable cfg = do diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage.hs index d180fd572..4d36830e5 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage.hs @@ -35,8 +35,7 @@ unitTests iom knownMigrations = , testCase "insert config" Config.insertConfig , testGroup "consumed-tx-out and prune-tx-out" - [ test "flag check" MigrateConsumedPruneTxOut.txConsumedColumnCheck - , test "basic prune" MigrateConsumedPruneTxOut.basicPrune + [ test "basic prune" MigrateConsumedPruneTxOut.basicPrune , test "prune with simple rollback" MigrateConsumedPruneTxOut.pruneWithSimpleRollback , test "prune with full tx rollback" MigrateConsumedPruneTxOut.pruneWithFullTxRollback , test "pruning should keep some tx" MigrateConsumedPruneTxOut.pruningShouldKeepSomeTx 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 51245da52..954a424c1 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 @@ -6,7 +6,6 @@ #endif module Test.Cardano.Db.Mock.Unit.Babbage.Config.MigrateConsumedPruneTxOut ( - txConsumedColumnCheck, basicPrune, pruneWithSimpleRollback, pruneWithFullTxRollback, @@ -43,7 +42,6 @@ import Test.Cardano.Db.Mock.Config ( stopDBSync, txOutTableTypeFromConfig, withCustomConfig, - withCustomConfigAndDropDB, ) import Test.Cardano.Db.Mock.Examples (mockBlock0, mockBlock1) import Test.Cardano.Db.Mock.UnifiedApi ( @@ -60,20 +58,6 @@ import Test.Tasty.HUnit (Assertion) ------------------------------------------------------------------------------ -- Tests ------------------------------------------------------------------------------ -txConsumedColumnCheck :: IOManager -> [(Text, Text)] -> Assertion -txConsumedColumnCheck = do - withCustomConfigAndDropDB cmdLineArgs (Just configConsume) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 500 - - startDBSync dbSyncEnv - assertBlockNoBackoff dbSyncEnv 1 - assertEqQuery dbSyncEnv DB.queryTxConsumedColumnExists True "missing consumed_by_tx_id column when flag --consumed-tx-out active" - where - cmdLineArgs = initCommandLineArgs - testLabel = "configTxConsumedColumnCheck" - basicPrune :: IOManager -> [(Text, Text)] -> Assertion basicPrune = do withCustomConfig cmdLineArgs (Just configPruneForceTxIn) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway.hs index 335135dad..3832fef3d 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway.hs @@ -44,8 +44,7 @@ unitTests iom knownMigrations = ] , testGroup "tx-out" - [ test "consumed_by_tx_id column check" MigrateConsumedPruneTxOut.txConsumedColumnCheck - , test "basic prune" MigrateConsumedPruneTxOut.basicPrune + [ test "basic prune" MigrateConsumedPruneTxOut.basicPrune , test "prune with simple rollback" MigrateConsumedPruneTxOut.pruneWithSimpleRollback , test "prune with full tx rollback" MigrateConsumedPruneTxOut.pruneWithFullTxRollback , test "pruning should keep some tx" MigrateConsumedPruneTxOut.pruningShouldKeepSomeTx 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 42a3e18a0..debf685d1 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 @@ -6,7 +6,6 @@ #endif module Test.Cardano.Db.Mock.Unit.Conway.Config.MigrateConsumedPruneTxOut ( - txConsumedColumnCheck, basicPrune, pruneWithSimpleRollback, pruneWithFullTxRollback, @@ -38,27 +37,6 @@ import qualified Prelude ------------------------------------------------------------------------------ -- Tests ----------------------------------------------------------------------------- -txConsumedColumnCheck :: IOManager -> [(Text, Text)] -> Assertion -txConsumedColumnCheck = do - -- be mindful that you have to manually pass the ioManager + names - withCustomConfigAndDropDB cmdLineArgs (Just configConsume) conwayConfigDir testLabel $ - \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ - withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 500 0 - - assertBlockNoBackoff dbSync 1 - assertEqQuery - dbSync - DB.queryTxConsumedColumnExists - True - "missing consumed_by_tx_id column when tx-out = consumed" - where - cmdLineArgs = initCommandLineArgs - testLabel = "conwayTxConsumedColumnCheck" - basicPrune :: IOManager -> [(Text, Text)] -> Assertion basicPrune = do withCustomConfig args (Just configPruneForceTxIn) cfgDir testLabel $ \interpreter mockServer dbSync -> do 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 2299a069f..541786e3e 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 @@ -63,6 +63,7 @@ import Test.Cardano.Db.Mock.Config ( conwayConfigDir, initCommandLineArgs, startDBSync, + txOutTableTypeFromConfig, withCustomConfig, withFullConfig, withFullConfigAndDropDB, diff --git a/cardano-db-sync/src/Cardano/DbSync/Api.hs b/cardano-db-sync/src/Cardano/DbSync/Api.hs index 6a13a3a5e..66162924c 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Api.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Api.hs @@ -117,7 +117,7 @@ isConsistent env = do getIsConsumedFixed :: SyncEnv -> IO (Maybe Word64) getIsConsumedFixed env = - case (DB.pcmPruneTxOut pcm, DB.pcmConsumeOrPruneTxOut pcm) of + case (DB.pcmPruneTxOut pcm, DB.pcmConsumedTxOut pcm) of (False, True) -> Just <$> DB.runDbIohkNoLogging backend (Multiplex.queryWrongConsumedBy txOutTableType) _ -> pure Nothing where @@ -168,8 +168,7 @@ initPruneConsumeMigration :: Bool -> Bool -> Bool -> Bool -> DB.PruneConsumeMigr initPruneConsumeMigration consumed pruneTxOut bootstrap forceTxIn' = DB.PruneConsumeMigration { DB.pcmPruneTxOut = pruneTxOut || bootstrap - , DB.pcmConsumedTxOut = consumed - , DB.pcmConsumeOrPruneTxOut = consumed || pruneTxOut || bootstrap + , DB.pcmConsumedTxOut = consumed || pruneTxOut || bootstrap , DB.pcmSkipTxIn = not forceTxIn' && (consumed || pruneTxOut || bootstrap) } @@ -204,7 +203,7 @@ getPruneInterval syncEnv = 10 * getSecurityParam syncEnv whenConsumeOrPruneTxOut :: (MonadIO m) => SyncEnv -> m () -> m () whenConsumeOrPruneTxOut env = - when (DB.pcmConsumeOrPruneTxOut $ getPruneConsume env) + when (DB.pcmConsumedTxOut $ getPruneConsume env) whenPruneTxOut :: (MonadIO m) => SyncEnv -> m () -> m () whenPruneTxOut env = @@ -215,7 +214,7 @@ getTxOutTableType syncEnv = ioTxOutTableType . soptInsertOptions $ envOptions sy getHasConsumedOrPruneTxOut :: SyncEnv -> Bool getHasConsumedOrPruneTxOut = - DB.pcmConsumeOrPruneTxOut . getPruneConsume + DB.pcmConsumedTxOut . getPruneConsume getSkipTxIn :: SyncEnv -> Bool getSkipTxIn = 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 7189794b0..fb2583e46 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Genesis.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Genesis.hs @@ -112,7 +112,7 @@ insertValidateGenesisDist syncEnv (NetworkName networkName) cfg = do "Initial genesis distribution populated. Hash " <> renderByteArray (configGenesisHash cfg) - supply <- lift $ DB.queryGenesisSupply $ getTxOutTableType syncEnv + 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. 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 b12b71d12..1230080db 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs @@ -159,8 +159,6 @@ insertValidateGenesisDist syncEnv networkName cfg shelleyInitiation = do <> renderByteArray (configGenesisHash cfg) when hasStakes $ insertStaking tracer useNoCache bid cfg - 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 :: 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 4b3a7c7df..dc6b61234 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 @@ -64,7 +64,6 @@ data MissingMaTxOut = MissingMaTxOut data ExtendedTxOut = ExtendedTxOut { etoTxHash :: !ByteString , etoTxOut :: !DB.TxOutW - , etoPaymentCred :: !(Maybe ByteString) } data ExtendedTxIn = ExtendedTxIn 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 5afdbbbfa..e3b098f8d 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 @@ -260,8 +260,8 @@ insertTxOut tracer cache iopts (txId, txHash) (Generic.TxOut index addr value ma -- TODO: Unsure about what we should return here for eutxo let !eutxo = case ioTxOutTableType iopts of - DB.TxOutCore -> ExtendedTxOut txHash txOut Nothing - DB.TxOutVariantAddress -> ExtendedTxOut txHash txOut $ Generic.maybePaymentCred addr + DB.TxOutCore -> ExtendedTxOut txHash txOut + DB.TxOutVariantAddress -> ExtendedTxOut txHash txOut !maTxOuts <- whenFalseMempty (ioMultiAssets iopts) $ insertMaTxOuts tracer cache maMap pure (eutxo, maTxOuts) where diff --git a/cardano-db/src/Cardano/Db/Operations/Other/ConsumedTxOut.hs b/cardano-db/src/Cardano/Db/Operations/Other/ConsumedTxOut.hs index ed90bd77b..6cba99935 100644 --- a/cardano-db/src/Cardano/Db/Operations/Other/ConsumedTxOut.hs +++ b/cardano-db/src/Cardano/Db/Operations/Other/ConsumedTxOut.hs @@ -13,7 +13,7 @@ module Cardano.Db.Operations.Other.ConsumedTxOut where -import Cardano.BM.Trace (Trace, logError, logInfo, logWarning) +import Cardano.BM.Trace (Trace, logInfo) import Cardano.Db.Error (LookupFail (..), logAndThrowIO) import Cardano.Db.Operations.Insert (insertExtraMigration) import Cardano.Db.Operations.Query (listToMaybe, queryAllExtraMigrations, queryBlockHeight, queryBlockNo, queryMaxRefId) @@ -52,22 +52,6 @@ data ConsumedTriplet = ConsumedTriplet -------------------------------------------------------------------------------------------------- -- 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 @@ -112,12 +96,14 @@ querySetNullTxOut trce txOutTableType mMinTxId = do updateListTxOutConsumedByTxId :: MonadIO m => [(TxOutIdW, TxId)] -> ReaderT SqlBackend m () updateListTxOutConsumedByTxId ls = do - queryUpdateListTxOutConsumedByTxId ls + mapM_ (uncurry updateTxOutConsumedByTxId) ls runExtraMigrations :: (MonadBaseControl IO m, MonadIO m) => Trace IO Text -> TxOutTableType -> Word64 -> PruneConsumeMigration -> ReaderT SqlBackend m () runExtraMigrations trce txOutTableType blockNoDiff pcm = do ems <- queryAllExtraMigrations let migrationValues = processMigrationValues ems pcm + -- Make sure the config address_table is there if the migration wasn't previously set in teh db + when (not (isTxOutVariantAddress txOutTableType) && isTxOutAddressPreviouslySet migrationValues) $ throw $ DBExtraMigration "The configuration option 'tx_out.address_table' was previously set and the database updated. Unfortunately reverting this isn't possible." -- Has the user given txout address config && the migration wasn't previously set when (isTxOutVariantAddress txOutTableType && not (isTxOutAddressPreviouslySet migrationValues)) $ do updateTxOutAndCreateAddress @@ -133,7 +119,7 @@ runExtraMigrations trce txOutTableType blockNoDiff pcm = do handleMigration :: (MonadBaseControl IO m, MonadIO m) => MigrationValues -> ReaderT SqlBackend m () handleMigration migrationValues@MigrationValues {..} = do let PruneConsumeMigration {..} = pruneConsumeMigration - case (isConsumeTxOutPreviouslySet, pcmConsumeOrPruneTxOut, pcmPruneTxOut) of + case (isConsumeTxOutPreviouslySet, pcmConsumedTxOut, pcmPruneTxOut) of -- No Migration Needed (False, False, False) -> do liftIO $ logInfo trce "runExtraMigrations: No extra migration specified" @@ -219,7 +205,7 @@ setNullTxOutConsumedAfter txOutTableType txOutId = migrateTxOutTests :: (MonadIO m, MonadBaseControl IO m) => TxOutTableType -> ReaderT SqlBackend m () migrateTxOutTests txOutTableType = do - _ <- createConsumedTxOut + _ <- createConsumedIndexTxOut migrateNextPageTxOut Nothing txOutTableType 0 migrateTxOut :: @@ -232,7 +218,7 @@ migrateTxOut :: ReaderT SqlBackend m () migrateTxOut trce txOutTableType _mMvs = do liftIO $ logInfo trce "migrateTxOut:" - _ <- createConsumedTxOut + _ <- createConsumedIndexTxOut migrateNextPageTxOut (Just trce) txOutTableType 0 migrateNextPageTxOut :: MonadIO m => Maybe (Trace IO Text) -> TxOutTableType -> Word64 -> ReaderT SqlBackend m () @@ -315,7 +301,7 @@ shouldCreateConsumedTxOut :: shouldCreateConsumedTxOut trce rcc = unless rcc $ do liftIO $ logInfo trce "Created ConsumedTxOut when handling page entries." - createConsumedTxOut + createConsumedIndexTxOut -- | Update updatePageEntries :: @@ -347,34 +333,46 @@ deleteTxOutConsumed txOutTableType txOutId index = case txOutTableType of -------------------------------------------------------------------------------------------------- -- Raw Queries -------------------------------------------------------------------------------------------------- -createConsumedTxOut :: + +createConsumedIndexTxOut :: forall m. ( MonadBaseControl IO m , MonadIO m ) => ReaderT SqlBackend m () -createConsumedTxOut = do +createConsumedIndexTxOut = do handle exceptHandler $ rawExecute createIndex [] - handle exceptHandler $ rawExecute addConstraint [] where createIndex = "CREATE INDEX IF NOT EXISTS idx_tx_out_consumed_by_tx_id ON tx_out (consumed_by_tx_id)" + exceptHandler :: SqlError -> ReaderT SqlBackend m a + exceptHandler e = + liftIO $ throwIO (DBPruneConsumed $ show e) + +createConsumedConstraintTxOut :: + forall m. + ( MonadBaseControl IO m + , MonadIO m + ) => + ReaderT SqlBackend m () +createConsumedConstraintTxOut = do + handle exceptHandler $ rawExecute addConstraint [] + where addConstraint = - ( Text.unlines - [ "do $$" - , "begin" - , " if not exists (" - , " select 1" - , " from information_schema.table_constraints" - , " where constraint_name = 'ma_tx_out_tx_out_id_fkey'" - , " and table_name = 'ma_tx_out'" - , " ) then" - , " execute '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';" - , " end if;" - , "end $$;" - ] - ) + Text.unlines + [ "do $$" + , "begin" + , " if not exists (" + , " select 1" + , " from information_schema.table_constraints" + , " where constraint_name = 'ma_tx_out_tx_out_id_fkey'" + , " and table_name = 'ma_tx_out'" + , " ) then" + , " execute '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';" + , " end if;" + , "end $$;" + ] exceptHandler :: SqlError -> ReaderT SqlBackend m a exceptHandler e = @@ -505,37 +503,3 @@ countConsumed = \case where_ (isJust $ txOut ^. txOutConsumedByTxIdField @a) pure countRows pure $ maybe 0 unValue (listToMaybe res) - -_validateMigration :: MonadIO m => Trace IO Text -> TxOutTableType -> ReaderT SqlBackend m Bool -_validateMigration trce txOutTableType = do - _migrated <- queryTxConsumedColumnExists - 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 diff --git a/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutQuery.hs b/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutQuery.hs index d06f6c0df..3c873f394 100644 --- a/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutQuery.hs +++ b/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutQuery.hs @@ -398,14 +398,6 @@ queryAddressId addrRaw = do 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 -------------------------------------------------------------------------------- diff --git a/cardano-db/src/Cardano/Db/Types.hs b/cardano-db/src/Cardano/Db/Types.hs index 8735983fd..0d784c865 100644 --- a/cardano-db/src/Cardano/Db/Types.hs +++ b/cardano-db/src/Cardano/Db/Types.hs @@ -240,8 +240,7 @@ data PruneConsumeMigration = PruneConsumeMigration { pcmPruneTxOut :: Bool , -- we make the assumption that if the user is using prune flag -- they will also want consume automatically set for them. - pcmConsumeOrPruneTxOut :: Bool - , pcmConsumedTxOut :: Bool + pcmConsumedTxOut :: Bool , pcmSkipTxIn :: Bool } deriving (Eq, Show) From 1b5b4fa25c7a3cab7c147f1b4902355936475e34 Mon Sep 17 00:00:00 2001 From: Cmdv Date: Fri, 20 Sep 2024 11:06:04 +0100 Subject: [PATCH 5/6] add tests for using address table poop --- .../test/Test/Cardano/Db/Mock/Config.hs | 24 +- .../test/Test/Cardano/Db/Mock/Unit/Babbage.hs | 17 +- .../Config/MigrateConsumedPruneTxOut.hs | 123 +++++++-- .../test/Test/Cardano/Db/Mock/Unit/Conway.hs | 23 ++ .../Config/MigrateConsumedPruneTxOut.hs | 157 ++++++++++-- .../test/Test/Cardano/Db/Mock/Validate.hs | 7 +- cardano-db-sync/src/Cardano/DbSync.hs | 2 +- cardano-db-sync/src/Cardano/DbSync/Api.hs | 3 +- .../src/Cardano/DbSync/Config/Types.hs | 4 +- cardano-db-tool/app/cardano-db-tool.hs | 25 +- cardano-db/src/Cardano/Db/Migration.hs | 49 ++-- .../Db/Operations/Other/ConsumedTxOut.hs | 236 +++++++++++------- .../src/Cardano/Db/Operations/Other/MinId.hs | 1 - .../test/Test/IO/Cardano/Db/Migration.hs | 3 +- doc/configuration.md | 24 +- schema/migration-4-0001-20200702.sql | 11 +- schema/migration-4-0002-20200810.sql | 1 - schema/migration-4-0003-20210116.sql | 1 - 18 files changed, 511 insertions(+), 200 deletions(-) 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 268c85de5..eb692cf83 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs @@ -302,21 +302,21 @@ mkConfigFile :: FilePath -> FilePath -> ConfigFile mkConfigFile staticDir cliConfigFilename = ConfigFile $ staticDir cliConfigFilename -configPruneForceTxIn :: SyncNodeConfig -> SyncNodeConfig -configPruneForceTxIn cfg = do - cfg {dncInsertOptions = (dncInsertOptions cfg) {sioTxOut = TxOutConsumedPrune (ForceTxIn True) (UseTxOutAddress False)}} +configPruneForceTxIn :: Bool -> SyncNodeConfig -> SyncNodeConfig +configPruneForceTxIn useTxOutAddress cfg = do + cfg {dncInsertOptions = (dncInsertOptions cfg) {sioTxOut = TxOutConsumedPrune (ForceTxIn True) (UseTxOutAddress useTxOutAddress)}} -configPrune :: SyncNodeConfig -> SyncNodeConfig -configPrune cfg = do - cfg {dncInsertOptions = (dncInsertOptions cfg) {sioTxOut = TxOutConsumedPrune (ForceTxIn False) (UseTxOutAddress False)}} +configPrune :: Bool -> SyncNodeConfig -> SyncNodeConfig +configPrune useTxOutAddress cfg = do + cfg {dncInsertOptions = (dncInsertOptions cfg) {sioTxOut = TxOutConsumedPrune (ForceTxIn False) (UseTxOutAddress useTxOutAddress)}} -configConsume :: SyncNodeConfig -> SyncNodeConfig -configConsume cfg = do - cfg {dncInsertOptions = (dncInsertOptions cfg) {sioTxOut = TxOutConsumed (ForceTxIn False) (UseTxOutAddress False)}} +configConsume :: Bool -> SyncNodeConfig -> SyncNodeConfig +configConsume useTxOutAddress cfg = do + cfg {dncInsertOptions = (dncInsertOptions cfg) {sioTxOut = TxOutConsumed (ForceTxIn False) (UseTxOutAddress useTxOutAddress)}} -configBootstrap :: SyncNodeConfig -> SyncNodeConfig -configBootstrap cfg = do - cfg {dncInsertOptions = (dncInsertOptions cfg) {sioTxOut = TxOutConsumedBootstrap (ForceTxIn False) (UseTxOutAddress False)}} +configBootstrap :: Bool -> SyncNodeConfig -> SyncNodeConfig +configBootstrap useTxOutAddress cfg = do + cfg {dncInsertOptions = (dncInsertOptions cfg) {sioTxOut = TxOutConsumedBootstrap (ForceTxIn False) (UseTxOutAddress useTxOutAddress)}} configPlutusDisable :: SyncNodeConfig -> SyncNodeConfig configPlutusDisable cfg = do diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage.hs index 4d36830e5..07281e32c 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage.hs @@ -34,8 +34,9 @@ unitTests iom knownMigrations = [ testCase "default insert config" Config.defaultInsertConfig , testCase "insert config" Config.insertConfig , testGroup - "consumed-tx-out and prune-tx-out" + "tx-out" [ test "basic prune" MigrateConsumedPruneTxOut.basicPrune + , test "basic prune with address table" MigrateConsumedPruneTxOut.basicPruneWithAddress , test "prune with simple rollback" MigrateConsumedPruneTxOut.pruneWithSimpleRollback , test "prune with full tx rollback" MigrateConsumedPruneTxOut.pruneWithFullTxRollback , test "pruning should keep some tx" MigrateConsumedPruneTxOut.pruningShouldKeepSomeTx @@ -47,6 +48,20 @@ unitTests iom knownMigrations = , expectFailSilent "set prune flag, restart missing prune flag" $ MigrateConsumedPruneTxOut.pruneRestartMissingFlag iom knownMigrations , expectFailSilent "set bootstrap flag, restart missing bootstrap flag" $ MigrateConsumedPruneTxOut.bootstrapRestartMissingFlag iom knownMigrations ] + , testGroup + "tx-out using Address table" + [ test "basic prune with address table" MigrateConsumedPruneTxOut.basicPruneWithAddress + , test "prune with simple rollback with address table" MigrateConsumedPruneTxOut.pruneWithSimpleRollbackWithAddress + , test "prune with full tx rollback with address table" MigrateConsumedPruneTxOut.pruneWithFullTxRollbackWithAddress + , test "pruning should keep some tx with address table" MigrateConsumedPruneTxOut.pruningShouldKeepSomeTxWithAddress + , test "prune and rollback one block with address table" MigrateConsumedPruneTxOut.pruneAndRollBackOneBlockWithAddress + , test "no pruning and rollback with address table" MigrateConsumedPruneTxOut.noPruneAndRollBackWithAddress + , test "prune same block with address table" MigrateConsumedPruneTxOut.pruneSameBlockWithAddress + , test "no pruning same block with address table" MigrateConsumedPruneTxOut.noPruneSameBlockWithAddress + , expectFailSilent "restart with new consumed set to false, with address table" $ MigrateConsumedPruneTxOut.migrateAndPruneRestartWithAddress iom knownMigrations + , expectFailSilent "set prune flag, restart missing prune flag, with address table" $ MigrateConsumedPruneTxOut.pruneRestartMissingFlagWithAddress iom knownMigrations + , expectFailSilent "set bootstrap flag, restart missing bootstrap flag, with address table" $ MigrateConsumedPruneTxOut.bootstrapRestartMissingFlagWithAddress iom knownMigrations + ] ] , testGroup "simple" 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 954a424c1..6f385c06f 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 @@ -7,16 +7,27 @@ module Test.Cardano.Db.Mock.Unit.Babbage.Config.MigrateConsumedPruneTxOut ( basicPrune, + basicPruneWithAddress, pruneWithSimpleRollback, + pruneWithSimpleRollbackWithAddress, pruneWithFullTxRollback, + pruneWithFullTxRollbackWithAddress, pruningShouldKeepSomeTx, + pruningShouldKeepSomeTxWithAddress, pruneAndRollBackOneBlock, + pruneAndRollBackOneBlockWithAddress, noPruneAndRollBack, + noPruneAndRollBackWithAddress, pruneSameBlock, + pruneSameBlockWithAddress, noPruneSameBlock, + noPruneSameBlockWithAddress, migrateAndPruneRestart, + migrateAndPruneRestartWithAddress, pruneRestartMissingFlag, + pruneRestartMissingFlagWithAddress, bootstrapRestartMissingFlag, + bootstrapRestartMissingFlagWithAddress, ) where import Cardano.Db (TxOutTableType (..)) @@ -41,7 +52,7 @@ import Test.Cardano.Db.Mock.Config ( startDBSync, stopDBSync, txOutTableTypeFromConfig, - withCustomConfig, + withCustomConfigAndDropDB, ) import Test.Cardano.Db.Mock.Examples (mockBlock0, mockBlock1) import Test.Cardano.Db.Mock.UnifiedApi ( @@ -59,8 +70,14 @@ import Test.Tasty.HUnit (Assertion) -- Tests ------------------------------------------------------------------------------ basicPrune :: IOManager -> [(Text, Text)] -> Assertion -basicPrune = do - withCustomConfig cmdLineArgs (Just configPruneForceTxIn) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do +basicPrune = peformBasicPrune False + +basicPruneWithAddress :: IOManager -> [(Text, Text)] -> Assertion +basicPruneWithAddress = peformBasicPrune True + +peformBasicPrune :: Bool -> IOManager -> [(Text, Text)] -> Assertion +peformBasicPrune useTxOutAddress = do + withCustomConfigAndDropDB cmdLineArgs (Just $ configPruneForceTxIn useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do let txOutTableType = txOutTableTypeFromConfig dbSyncEnv startDBSync dbSyncEnv -- add 50 block @@ -84,8 +101,14 @@ basicPrune = do testLabel = "configPrune" pruneWithSimpleRollback :: IOManager -> [(Text, Text)] -> Assertion -pruneWithSimpleRollback = do - withCustomConfig cmdLineArgs (Just configPruneForceTxIn) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do +pruneWithSimpleRollback = peformPruneWithSimpleRollback False + +pruneWithSimpleRollbackWithAddress :: IOManager -> [(Text, Text)] -> Assertion +pruneWithSimpleRollbackWithAddress = peformPruneWithSimpleRollback True + +peformPruneWithSimpleRollback :: Bool -> IOManager -> [(Text, Text)] -> Assertion +peformPruneWithSimpleRollback useTxOutAddress = do + withCustomConfigAndDropDB cmdLineArgs (Just $ configPruneForceTxIn useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do let txOutTableType = txOutTableTypeFromConfig dbSyncEnv blk0 <- forgeNext interpreter mockBlock0 blk1 <- forgeNext interpreter mockBlock1 @@ -110,8 +133,14 @@ pruneWithSimpleRollback = do testLabel = "configPruneSimpleRollback" pruneWithFullTxRollback :: IOManager -> [(Text, Text)] -> Assertion -pruneWithFullTxRollback = do - withCustomConfig cmdLineArgs (Just configPruneForceTxIn) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do +pruneWithFullTxRollback = performPruneWithFullTxRollback False + +pruneWithFullTxRollbackWithAddress :: IOManager -> [(Text, Text)] -> Assertion +pruneWithFullTxRollbackWithAddress = performPruneWithFullTxRollback True + +performPruneWithFullTxRollback :: Bool -> IOManager -> [(Text, Text)] -> Assertion +performPruneWithFullTxRollback useTxOutAddress = do + withCustomConfigAndDropDB cmdLineArgs (Just $ configPruneForceTxIn useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do let txOutTableType = txOutTableTypeFromConfig dbSyncEnv startDBSync dbSyncEnv blk0 <- forgeNextFindLeaderAndSubmit interpreter mockServer [] @@ -140,8 +169,14 @@ pruneWithFullTxRollback = do -- The tx in the last, 2 x securityParam worth of blocks should not be pruned. -- In these tests, 2 x securityParam = 20 blocks. pruningShouldKeepSomeTx :: IOManager -> [(Text, Text)] -> Assertion -pruningShouldKeepSomeTx = do - withCustomConfig cmdLineArgs (Just configPrune) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do +pruningShouldKeepSomeTx = performPruningShouldKeepSomeTx False + +pruningShouldKeepSomeTxWithAddress :: IOManager -> [(Text, Text)] -> Assertion +pruningShouldKeepSomeTxWithAddress = performPruningShouldKeepSomeTx True + +performPruningShouldKeepSomeTx :: Bool -> IOManager -> [(Text, Text)] -> Assertion +performPruningShouldKeepSomeTx useTxOutAddress = do + withCustomConfigAndDropDB cmdLineArgs (Just $ configPrune useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do startDBSync dbSyncEnv let txOutTableType = txOutTableTypeFromConfig dbSyncEnv b1 <- forgeAndSubmitBlocks interpreter mockServer 80 @@ -164,8 +199,14 @@ pruningShouldKeepSomeTx = do -- prune with rollback pruneAndRollBackOneBlock :: IOManager -> [(Text, Text)] -> Assertion -pruneAndRollBackOneBlock = do - withCustomConfig cmdLineArgs (Just configPruneForceTxIn) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do +pruneAndRollBackOneBlock = performPruneAndRollBackOneBlock False + +pruneAndRollBackOneBlockWithAddress :: IOManager -> [(Text, Text)] -> Assertion +pruneAndRollBackOneBlockWithAddress = performPruneAndRollBackOneBlock True + +performPruneAndRollBackOneBlock :: Bool -> IOManager -> [(Text, Text)] -> Assertion +performPruneAndRollBackOneBlock useTxOutAddress = do + withCustomConfigAndDropDB cmdLineArgs (Just $ configPruneForceTxIn useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do startDBSync dbSyncEnv let txOutTableType = txOutTableTypeFromConfig dbSyncEnv void $ forgeAndSubmitBlocks interpreter mockServer 98 @@ -197,8 +238,14 @@ pruneAndRollBackOneBlock = do -- consume with rollback noPruneAndRollBack :: IOManager -> [(Text, Text)] -> Assertion -noPruneAndRollBack = do - withCustomConfig cmdLineArgs (Just configConsume) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do +noPruneAndRollBack = performNoPruneAndRollBack False + +noPruneAndRollBackWithAddress :: IOManager -> [(Text, Text)] -> Assertion +noPruneAndRollBackWithAddress = performNoPruneAndRollBack True + +performNoPruneAndRollBack :: Bool -> IOManager -> [(Text, Text)] -> Assertion +performNoPruneAndRollBack useTxOutAddress = do + withCustomConfigAndDropDB cmdLineArgs (Just $ configConsume useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do startDBSync dbSyncEnv let txOutTableType = txOutTableTypeFromConfig dbSyncEnv void $ forgeAndSubmitBlocks interpreter mockServer 98 @@ -229,8 +276,14 @@ noPruneAndRollBack = do testLabel = "configPruneAndRollBack" pruneSameBlock :: IOManager -> [(Text, Text)] -> Assertion -pruneSameBlock = - withCustomConfig cmdLineArgs (Just configPruneForceTxIn) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do +pruneSameBlock = performPruneSameBlock False + +pruneSameBlockWithAddress :: IOManager -> [(Text, Text)] -> Assertion +pruneSameBlockWithAddress = performPruneSameBlock True + +performPruneSameBlock :: Bool -> IOManager -> [(Text, Text)] -> Assertion +performPruneSameBlock useTxOutAddress = + withCustomConfigAndDropDB cmdLineArgs (Just $ configPruneForceTxIn useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do startDBSync dbSyncEnv let txOutTableType = txOutTableTypeFromConfig dbSyncEnv void $ forgeAndSubmitBlocks interpreter mockServer 76 @@ -255,8 +308,14 @@ pruneSameBlock = testLabel = "configPruneSameBlock" noPruneSameBlock :: IOManager -> [(Text, Text)] -> Assertion -noPruneSameBlock = - withCustomConfig cmdLineArgs (Just configConsume) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do +noPruneSameBlock = performNoPruneSameBlock False + +noPruneSameBlockWithAddress :: IOManager -> [(Text, Text)] -> Assertion +noPruneSameBlockWithAddress = performNoPruneSameBlock True + +performNoPruneSameBlock :: Bool -> IOManager -> [(Text, Text)] -> Assertion +performNoPruneSameBlock useTxOutAddress = + withCustomConfigAndDropDB cmdLineArgs (Just $ configConsume useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do startDBSync dbSyncEnv let txOutTableType = txOutTableTypeFromConfig dbSyncEnv void $ forgeAndSubmitBlocks interpreter mockServer 96 @@ -278,8 +337,14 @@ noPruneSameBlock = testLabel = "configNoPruneSameBlock" migrateAndPruneRestart :: IOManager -> [(Text, Text)] -> Assertion -migrateAndPruneRestart = do - withCustomConfig cmdLineArgs (Just configConsume) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do +migrateAndPruneRestart = performMigrateAndPruneRestart False + +migrateAndPruneRestartWithAddress :: IOManager -> [(Text, Text)] -> Assertion +migrateAndPruneRestartWithAddress = performMigrateAndPruneRestart True + +performMigrateAndPruneRestart :: Bool -> IOManager -> [(Text, Text)] -> Assertion +performMigrateAndPruneRestart useTxOutAddress = do + withCustomConfigAndDropDB cmdLineArgs (Just $ configConsume useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do startDBSync dbSyncEnv void $ forgeAndSubmitBlocks interpreter mockServer 50 assertBlockNoBackoff dbSyncEnv 50 @@ -297,8 +362,14 @@ migrateAndPruneRestart = do testLabel = "configMigrateAndPruneRestart" pruneRestartMissingFlag :: IOManager -> [(Text, Text)] -> Assertion -pruneRestartMissingFlag = do - withCustomConfig cmdLineArgs (Just configPruneForceTxIn) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do +pruneRestartMissingFlag = performPruneRestartMissingFlag False + +pruneRestartMissingFlagWithAddress :: IOManager -> [(Text, Text)] -> Assertion +pruneRestartMissingFlagWithAddress = performPruneRestartMissingFlag True + +performPruneRestartMissingFlag :: Bool -> IOManager -> [(Text, Text)] -> Assertion +performPruneRestartMissingFlag useTxOutAddress = do + withCustomConfigAndDropDB cmdLineArgs (Just $ configPruneForceTxIn useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do startDBSync dbSyncEnv void $ forgeAndSubmitBlocks interpreter mockServer 50 assertBlockNoBackoff dbSyncEnv 50 @@ -316,8 +387,14 @@ pruneRestartMissingFlag = do testLabel = "configPruneRestartMissingFlag" bootstrapRestartMissingFlag :: IOManager -> [(Text, Text)] -> Assertion -bootstrapRestartMissingFlag = do - withCustomConfig cmdLineArgs (Just configBootstrap) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do +bootstrapRestartMissingFlag = performBootstrapRestartMissingFlag False + +bootstrapRestartMissingFlagWithAddress :: IOManager -> [(Text, Text)] -> Assertion +bootstrapRestartMissingFlagWithAddress = performBootstrapRestartMissingFlag True + +performBootstrapRestartMissingFlag :: Bool -> IOManager -> [(Text, Text)] -> Assertion +performBootstrapRestartMissingFlag useTxOutAddress = do + withCustomConfigAndDropDB cmdLineArgs (Just $ configBootstrap useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do startDBSync dbSyncEnv void $ forgeAndSubmitBlocks interpreter mockServer 50 assertBlockNoBackoff dbSyncEnv 50 diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway.hs index 3832fef3d..8afc4e590 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway.hs @@ -62,6 +62,29 @@ unitTests iom knownMigrations = "set bootstrap flag, restart missing bootstrap flag" $ MigrateConsumedPruneTxOut.bootstrapRestartMissingFlag iom knownMigrations ] + , testGroup + "tx-out with use_address_table config" + [ test "basic prune, with use_address_table config" MigrateConsumedPruneTxOut.basicPruneWithAddress + , test "prune with simple rollback, with use_address_table config" MigrateConsumedPruneTxOut.pruneWithSimpleRollbackWithAddress + , test "prune with full tx rollback, with use_address_table config" MigrateConsumedPruneTxOut.pruneWithFullTxRollbackWithAddress + , test "pruning should keep some tx, with use_address_table config" MigrateConsumedPruneTxOut.pruningShouldKeepSomeTxWithAddress + , test "prune and rollback one block, with use_address_table config" MigrateConsumedPruneTxOut.pruneAndRollBackOneBlockWithAddress + , test "no pruning and rollback, with use_address_table config" MigrateConsumedPruneTxOut.noPruneAndRollBackWithAddress + , test "prune same block, with use_address_table config" MigrateConsumedPruneTxOut.pruneSameBlockWithAddress + , test "no pruning same block, with use_address_table config" MigrateConsumedPruneTxOut.noPruneSameBlockWithAddress + , expectFailSilent + "restart with new consumed set to false, with use_address_table config" + $ MigrateConsumedPruneTxOut.migrateAndPruneRestartWithAddress iom knownMigrations + , expectFailSilent + "set prune flag, restart missing prune flag, with use_address_table config" + $ MigrateConsumedPruneTxOut.pruneRestartMissingFlagWithAddress iom knownMigrations + , expectFailSilent + "set bootstrap flag, restart missing bootstrap flag, with use_address_table config" + $ MigrateConsumedPruneTxOut.bootstrapRestartMissingFlagWithAddress iom knownMigrations + , expectFailSilent + "populate db then reset with use_address_table config config active" + $ MigrateConsumedPruneTxOut.populateDbRestartWithAddressConfig iom knownMigrations + ] ] , testGroup "simple" 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 debf685d1..2d8f723f9 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 @@ -7,19 +7,32 @@ module Test.Cardano.Db.Mock.Unit.Conway.Config.MigrateConsumedPruneTxOut ( basicPrune, + basicPruneWithAddress, pruneWithSimpleRollback, + pruneWithSimpleRollbackWithAddress, pruneWithFullTxRollback, + pruneWithFullTxRollbackWithAddress, pruningShouldKeepSomeTx, + pruningShouldKeepSomeTxWithAddress, pruneAndRollBackOneBlock, + pruneAndRollBackOneBlockWithAddress, noPruneAndRollBack, + noPruneAndRollBackWithAddress, pruneSameBlock, + pruneSameBlockWithAddress, noPruneSameBlock, + noPruneSameBlockWithAddress, migrateAndPruneRestart, + migrateAndPruneRestartWithAddress, pruneRestartMissingFlag, + pruneRestartMissingFlagWithAddress, bootstrapRestartMissingFlag, + bootstrapRestartMissingFlagWithAddress, + populateDbRestartWithAddressConfig, ) where import qualified Cardano.Db as DB +import Cardano.DbSync.Config.Types (ForceTxIn (..), SyncInsertOptions (..), SyncNodeConfig (..), TxOutConfig (..), UseTxOutAddress (..)) import Cardano.Mock.ChainSync.Server (IOManager (), addBlock) import Cardano.Mock.Forging.Interpreter (forgeNext) import qualified Cardano.Mock.Forging.Tx.Conway as Conway @@ -38,8 +51,14 @@ import qualified Prelude -- Tests ----------------------------------------------------------------------------- basicPrune :: IOManager -> [(Text, Text)] -> Assertion -basicPrune = do - withCustomConfig args (Just configPruneForceTxIn) cfgDir testLabel $ \interpreter mockServer dbSync -> do +basicPrune = performBasicPrune False + +basicPruneWithAddress :: IOManager -> [(Text, Text)] -> Assertion +basicPruneWithAddress = performBasicPrune True + +performBasicPrune :: Bool -> IOManager -> [(Text, Text)] -> Assertion +performBasicPrune useTxOutAddress = do + withCustomConfigAndDropDB args (Just $ configPruneForceTxIn useTxOutAddress) cfgDir testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync let txOutTableType = txOutTableTypeFromConfig dbSync @@ -72,8 +91,14 @@ basicPrune = do cfgDir = conwayConfigDir pruneWithSimpleRollback :: IOManager -> [(Text, Text)] -> Assertion -pruneWithSimpleRollback = - withCustomConfig cmdLineArgs (Just configPruneForceTxIn) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do +pruneWithSimpleRollback = performPruneWithSimpleRollback False + +pruneWithSimpleRollbackWithAddress :: IOManager -> [(Text, Text)] -> Assertion +pruneWithSimpleRollbackWithAddress = performPruneWithSimpleRollback True + +performPruneWithSimpleRollback :: Bool -> IOManager -> [(Text, Text)] -> Assertion +performPruneWithSimpleRollback useTxOutAddress = + withCustomConfigAndDropDB cmdLineArgs (Just $ configPruneForceTxIn useTxOutAddress) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do let txOutTableType = txOutTableTypeFromConfig dbSync -- Forge some blocks blk0 <- forgeNext interpreter mockBlock0 @@ -109,8 +134,14 @@ pruneWithSimpleRollback = fullBlockSize b = fromIntegral $ length b + 4 pruneWithFullTxRollback :: IOManager -> [(Text, Text)] -> Assertion -pruneWithFullTxRollback = - withCustomConfig cmdLineArgs (Just configPruneForceTxIn) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do +pruneWithFullTxRollback = performPruneWithFullTxRollback False + +pruneWithFullTxRollbackWithAddress :: IOManager -> [(Text, Text)] -> Assertion +pruneWithFullTxRollbackWithAddress = performPruneWithFullTxRollback True + +performPruneWithFullTxRollback :: Bool -> IOManager -> [(Text, Text)] -> Assertion +performPruneWithFullTxRollback useTxOutAddress = + withCustomConfigAndDropDB cmdLineArgs (Just $ configPruneForceTxIn useTxOutAddress) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync let txOutTableType = txOutTableTypeFromConfig dbSync -- Forge a block @@ -146,9 +177,16 @@ pruneWithFullTxRollback = testLabel = "conwayConfigPruneOnFullRollback" -- The transactions in the last `2 * securityParam` blocks should not be pruned + pruningShouldKeepSomeTx :: IOManager -> [(Text, Text)] -> Assertion -pruningShouldKeepSomeTx = do - withCustomConfig cmdLineArgs (Just configPrune) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do +pruningShouldKeepSomeTx = performPruningShouldKeepSomeTx False + +pruningShouldKeepSomeTxWithAddress :: IOManager -> [(Text, Text)] -> Assertion +pruningShouldKeepSomeTxWithAddress = performPruningShouldKeepSomeTx True + +performPruningShouldKeepSomeTx :: Bool -> IOManager -> [(Text, Text)] -> Assertion +performPruningShouldKeepSomeTx useTxOutAddress = do + withCustomConfigAndDropDB cmdLineArgs (Just $ configPrune useTxOutAddress) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync let txOutTableType = txOutTableTypeFromConfig dbSync -- Forge some blocks @@ -177,8 +215,14 @@ pruningShouldKeepSomeTx = do testLabel = "conwayConfigPruneCorrectAmount" pruneAndRollBackOneBlock :: IOManager -> [(Text, Text)] -> Assertion -pruneAndRollBackOneBlock = - withCustomConfig cmdLineArgs (Just configPruneForceTxIn) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do +pruneAndRollBackOneBlock = performPruneAndRollBackOneBlock False + +pruneAndRollBackOneBlockWithAddress :: IOManager -> [(Text, Text)] -> Assertion +pruneAndRollBackOneBlockWithAddress = performPruneAndRollBackOneBlock True + +performPruneAndRollBackOneBlock :: Bool -> IOManager -> [(Text, Text)] -> Assertion +performPruneAndRollBackOneBlock useTxOutAddress = + withCustomConfigAndDropDB cmdLineArgs (Just $ configPruneForceTxIn useTxOutAddress) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync let txOutTableType = txOutTableTypeFromConfig dbSync @@ -217,8 +261,14 @@ pruneAndRollBackOneBlock = testLabel = "conwayConfigPruneAndRollBack" noPruneAndRollBack :: IOManager -> [(Text, Text)] -> Assertion -noPruneAndRollBack = - withCustomConfig cmdLineArgs (Just configConsume) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do +noPruneAndRollBack = performNoPruneAndRollBack False + +noPruneAndRollBackWithAddress :: IOManager -> [(Text, Text)] -> Assertion +noPruneAndRollBackWithAddress = performNoPruneAndRollBack True + +performNoPruneAndRollBack :: Bool -> IOManager -> [(Text, Text)] -> Assertion +performNoPruneAndRollBack useTxOutAddress = + withCustomConfigAndDropDB cmdLineArgs (Just $ configConsume useTxOutAddress) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync let txOutTableType = txOutTableTypeFromConfig dbSync @@ -257,8 +307,14 @@ noPruneAndRollBack = testLabel = "conwayConfigNoPruneAndRollBack" pruneSameBlock :: IOManager -> [(Text, Text)] -> Assertion -pruneSameBlock = - withCustomConfig cmdLineArgs (Just configPruneForceTxIn) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do +pruneSameBlock = performPruneSameBlock False + +pruneSameBlockWithAddress :: IOManager -> [(Text, Text)] -> Assertion +pruneSameBlockWithAddress = performPruneSameBlock True + +performPruneSameBlock :: Bool -> IOManager -> [(Text, Text)] -> Assertion +performPruneSameBlock useTxOutAddress = + withCustomConfigAndDropDB cmdLineArgs (Just $ configPruneForceTxIn useTxOutAddress) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync let txOutTableType = txOutTableTypeFromConfig dbSync @@ -294,8 +350,14 @@ pruneSameBlock = testLabel = "conwayConfigPruneSameBlock" noPruneSameBlock :: IOManager -> [(Text, Text)] -> Assertion -noPruneSameBlock = - withCustomConfig cmdLineArgs (Just configConsume) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do +noPruneSameBlock = performNoPruneSameBlock False + +noPruneSameBlockWithAddress :: IOManager -> [(Text, Text)] -> Assertion +noPruneSameBlockWithAddress = performNoPruneSameBlock True + +performNoPruneSameBlock :: Bool -> IOManager -> [(Text, Text)] -> Assertion +performNoPruneSameBlock useTxOutAddress = + withCustomConfigAndDropDB cmdLineArgs (Just $ configConsume useTxOutAddress) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync -- Forge some blocks @@ -326,8 +388,14 @@ noPruneSameBlock = testLabel = "conwayConfigNoPruneSameBlock" migrateAndPruneRestart :: IOManager -> [(Text, Text)] -> Assertion -migrateAndPruneRestart = - withCustomConfig cmdLineArgs (Just configConsume) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do +migrateAndPruneRestart = performMigrateAndPruneRestart False + +migrateAndPruneRestartWithAddress :: IOManager -> [(Text, Text)] -> Assertion +migrateAndPruneRestartWithAddress = performMigrateAndPruneRestart True + +performMigrateAndPruneRestart :: Bool -> IOManager -> [(Text, Text)] -> Assertion +performMigrateAndPruneRestart useTxOutAddress = + withCustomConfigAndDropDB cmdLineArgs (Just $ configConsume useTxOutAddress) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync -- Forge some blocks @@ -349,8 +417,14 @@ migrateAndPruneRestart = testLabel = "conwayConfigMigrateAndPruneRestart" pruneRestartMissingFlag :: IOManager -> [(Text, Text)] -> Assertion -pruneRestartMissingFlag = - withCustomConfig cmdLineArgs (Just configPruneForceTxIn) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do +pruneRestartMissingFlag = performPruneRestartMissingFlag False + +pruneRestartMissingFlagWithAddress :: IOManager -> [(Text, Text)] -> Assertion +pruneRestartMissingFlagWithAddress = performPruneRestartMissingFlag True + +performPruneRestartMissingFlag :: Bool -> IOManager -> [(Text, Text)] -> Assertion +performPruneRestartMissingFlag useTxOutAddress = + withCustomConfigAndDropDB cmdLineArgs (Just $ configPruneForceTxIn useTxOutAddress) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync -- Forge some blocks @@ -372,8 +446,14 @@ pruneRestartMissingFlag = testLabel = "conwayConfigPruneRestartMissingFlag" bootstrapRestartMissingFlag :: IOManager -> [(Text, Text)] -> Assertion -bootstrapRestartMissingFlag = - withCustomConfig cmdLineArgs (Just configBootstrap) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do +bootstrapRestartMissingFlag = performBootstrapRestartMissingFlag False + +bootstrapRestartMissingFlagWithAddress :: IOManager -> [(Text, Text)] -> Assertion +bootstrapRestartMissingFlagWithAddress = performBootstrapRestartMissingFlag True + +performBootstrapRestartMissingFlag :: Bool -> IOManager -> [(Text, Text)] -> Assertion +performBootstrapRestartMissingFlag useTxOutAddress = + withCustomConfigAndDropDB cmdLineArgs (Just $ configBootstrap useTxOutAddress) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync -- Forge some blocks @@ -393,3 +473,36 @@ bootstrapRestartMissingFlag = where cmdLineArgs = initCommandLineArgs testLabel = "conwayConfigBootstrapRestartMissingFlag" + +populateDbRestartWithAddressConfig :: IOManager -> [(Text, Text)] -> Assertion +populateDbRestartWithAddressConfig = + withCustomConfigAndDropDB cmdLineArgs (Just $ configConsume False) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + + -- Forge some blocks + void $ forgeAndSubmitBlocks interpreter mockServer 50 + -- Wait for them to sync + assertBlockNoBackoff dbSync 50 + + stopDBSync dbSync + + let newDBSync = + dbSync + { dbSyncConfig = + (dbSyncConfig dbSync) + { dncInsertOptions = + (dncInsertOptions $ dbSyncConfig dbSync) + { sioTxOut = TxOutConsumedPrune (ForceTxIn False) (UseTxOutAddress True) + } + } + } + -- Start without tx-out=prune + newEnv <- replaceConfigFile "test-db-sync-config.json" newDBSync + startDBSync newEnv + -- There is a slight delay before the flag is checked + threadDelay 6_000_000 + -- Expected to fail + checkStillRuns newDBSync + where + cmdLineArgs = initCommandLineArgs + testLabel = "conwayPopulateDbRestartWithAddressConfig" 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 574e033ef..907d18a5f 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs @@ -136,9 +136,10 @@ 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 TxOutCore - consumedNullCount <- queryDBSync syncEnv $ DB.queryTxOutUnspentCount TxOutCore +assertUnspentTx dbSyncEnv = do + let txOutTableType = txOutTableTypeFromConfig dbSyncEnv + unspentTxCount <- queryDBSync dbSyncEnv $ DB.queryTxOutConsumedNullCount txOutTableType + consumedNullCount <- queryDBSync dbSyncEnv $ DB.queryTxOutUnspentCount txOutTableType assertEqual "Unexpected tx unspent count between tx-in & tx-out" unspentTxCount consumedNullCount defaultDelays :: [Int] diff --git a/cardano-db-sync/src/Cardano/DbSync.hs b/cardano-db-sync/src/Cardano/DbSync.hs index 6bfa5b9a9..9df654d4c 100644 --- a/cardano-db-sync/src/Cardano/DbSync.hs +++ b/cardano-db-sync/src/Cardano/DbSync.hs @@ -100,7 +100,7 @@ runDbSync metricsSetters knownMigrations iomgr trce params syncNodeConfigFromFil logInfo trce $ "Running database migrations in mode " <> textShow mode logInfo trce msg when (mode `elem` [Db.Indexes, Db.Full]) $ logWarning trce indexesMsg - Db.runMigrations pgConfig True dbMigrationDir (Just $ Db.LogFileDir "/tmp") mode + Db.runMigrations pgConfig True dbMigrationDir (Just $ Db.LogFileDir "/tmp") mode (txOutConfigToTableType txOutConfig) (ranMigrations, unofficial) <- if enpForceIndexes params then runMigration Db.Full else runMigration Db.Initial unless (null unofficial) $ logWarning trce $ diff --git a/cardano-db-sync/src/Cardano/DbSync/Api.hs b/cardano-db-sync/src/Cardano/DbSync/Api.hs index 66162924c..e31e3d629 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Api.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Api.hs @@ -54,7 +54,6 @@ import Cardano.BM.Trace (Trace, logInfo, logWarning) import qualified Cardano.Chain.Genesis as Byron import Cardano.Crypto.ProtocolMagic (ProtocolMagicId (..)) import qualified Cardano.Db as DB -import qualified Cardano.Db as Multiplex (queryWrongConsumedBy) import Cardano.DbSync.Api.Types import Cardano.DbSync.Cache.Types (CacheCapacity (..), newEmptyCache, useNoCache) import Cardano.DbSync.Config.Cardano @@ -118,7 +117,7 @@ isConsistent env = do getIsConsumedFixed :: SyncEnv -> IO (Maybe Word64) getIsConsumedFixed env = case (DB.pcmPruneTxOut pcm, DB.pcmConsumedTxOut pcm) of - (False, True) -> Just <$> DB.runDbIohkNoLogging backend (Multiplex.queryWrongConsumedBy txOutTableType) + (False, True) -> Just <$> DB.runDbIohkNoLogging backend (DB.queryWrongConsumedBy txOutTableType) _ -> pure Nothing where txOutTableType = getTxOutTableType env diff --git a/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs b/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs index d55bfcaac..55ff83c89 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs @@ -692,10 +692,10 @@ instance ToJSON RemoveJsonbFromSchemaConfig where toJSON = boolToEnableDisable . isRemoveJsonbFromSchemaEnabled instance FromJSON TxOutTableTypeConfig where - parseJSON = Aeson.withText "add_address_table_to_txout" $ \v -> + parseJSON = Aeson.withText "use_address_table" $ \v -> case enableDisableToTxOutTableType v of Just g -> pure (TxOutTableTypeConfig g) - Nothing -> fail $ "unexpected add_address_table_to_txout: " <> show v + Nothing -> fail $ "unexpected use_address_table: " <> show v instance ToJSON TxOutTableTypeConfig where toJSON = addressTypeToEnableDisable . unTxOutTableTypeConfig diff --git a/cardano-db-tool/app/cardano-db-tool.hs b/cardano-db-tool/app/cardano-db-tool.hs index 16e2a9bf3..821d4cdcb 100644 --- a/cardano-db-tool/app/cardano-db-tool.hs +++ b/cardano-db-tool/app/cardano-db-tool.hs @@ -34,10 +34,10 @@ main = do -- ----------------------------------------------------------------------------- data Command - = CmdCreateMigration !MigrationDir + = CmdCreateMigration !MigrationDir !TxOutTableType | CmdReport !Report !TxOutTableType | CmdRollback !SlotNo !TxOutTableType - | CmdRunMigrations !MigrationDir !Bool !Bool !(Maybe LogFileDir) + | CmdRunMigrations !MigrationDir !Bool !Bool !(Maybe LogFileDir) !TxOutTableType | CmdTxOutMigration !TxOutTableType | CmdUtxoSetAtBlock !Word64 !TxOutTableType | CmdPrepareSnapshot !PrepareSnapshotArgs @@ -48,32 +48,32 @@ data Command runCommand :: Command -> IO () runCommand cmd = case cmd of - CmdCreateMigration mdir -> runCreateMigration mdir + CmdCreateMigration mdir txOutAddressType -> runCreateMigration mdir txOutAddressType CmdReport report txOutAddressType -> runReport report txOutAddressType CmdRollback slotNo txOutAddressType -> runRollback slotNo txOutAddressType - CmdRunMigrations mdir forceIndexes mockFix mldir -> do + CmdRunMigrations mdir forceIndexes mockFix mldir txOutTabletype -> do pgConfig <- runOrThrowIODb (readPGPass PGPassDefaultEnv) - unofficial <- snd <$> runMigrations pgConfig False mdir mldir Initial + unofficial <- snd <$> runMigrations pgConfig False mdir mldir Initial txOutTabletype unless (null unofficial) $ putStrLn $ "Unofficial migration scripts found: " ++ show unofficial when forceIndexes $ void $ - runMigrations pgConfig False mdir mldir Indexes + runMigrations pgConfig False mdir mldir Indexes txOutTabletype when mockFix $ void $ - runMigrations pgConfig False mdir mldir Fix + runMigrations pgConfig False mdir mldir Fix txOutTabletype CmdTxOutMigration txOutTableType -> do - runWithConnectionNoLogging PGPassDefaultEnv $ migrateTxOutTests txOutTableType + runWithConnectionNoLogging PGPassDefaultEnv $ migrateTxOutDbTool txOutTableType CmdUtxoSetAtBlock blkid txOutAddressType -> utxoSetAtSlot txOutAddressType blkid CmdPrepareSnapshot pargs -> runPrepareSnapshot pargs CmdValidateDb txOutAddressType -> runDbValidation txOutAddressType CmdValidateAddressBalance params txOutAddressType -> runLedgerValidation params txOutAddressType CmdVersion -> runVersionCommand -runCreateMigration :: MigrationDir -> IO () -runCreateMigration mdir = do - mfp <- createMigration PGPassDefaultEnv mdir +runCreateMigration :: MigrationDir -> TxOutTableType -> IO () +runCreateMigration mdir txOutTableType = do + mfp <- createMigration PGPassDefaultEnv mdir txOutTableType case mfp of Nothing -> putStrLn "No migration needed." Just fp -> putStrLn $ "New migration '" ++ fp ++ "' created." @@ -163,7 +163,7 @@ pCommand = where pCreateMigration :: Parser Command pCreateMigration = - CmdCreateMigration <$> pMigrationDir + CmdCreateMigration <$> pMigrationDir <*> pTxOutTableType pRunMigrations :: Parser Command pRunMigrations = @@ -172,6 +172,7 @@ pCommand = <*> pForceIndexes <*> pMockFix <*> optional pLogFileDir + <*> pTxOutTableType pRollback :: Parser Command pRollback = diff --git a/cardano-db/src/Cardano/Db/Migration.hs b/cardano-db/src/Cardano/Db/Migration.hs index ff2c57842..7e5e01396 100644 --- a/cardano-db/src/Cardano/Db/Migration.hs +++ b/cardano-db/src/Cardano/Db/Migration.hs @@ -29,10 +29,12 @@ import Cardano.Crypto.Hash (Blake2b_256, ByteString, Hash, hashToStringAsHex, ha import Cardano.Db.Migration.Haskell import Cardano.Db.Migration.Version import Cardano.Db.Operations.Query +import Cardano.Db.Operations.Types (TxOutTableType (..)) import Cardano.Db.PGConfig import Cardano.Db.Run import Cardano.Db.Schema.BaseSchema import Cardano.Db.Schema.Core.TxOut (migrateCoreTxOutCardanoDb) +import Cardano.Db.Schema.Variant.TxOut (migrateVariantAddressCardanoDb) import Cardano.Prelude (Typeable, textShow) import Control.Exception (Exception, SomeException, handle) import Control.Monad.Extra @@ -104,8 +106,8 @@ data MigrationToRun = Initial | Full | Fix | Indexes -- | Run the migrations in the provided 'MigrationDir' and write date stamped log file -- to 'LogFileDir'. It returns a list of file names of all non-official schema migration files. -runMigrations :: PGConfig -> Bool -> MigrationDir -> Maybe LogFileDir -> MigrationToRun -> IO (Bool, [FilePath]) -runMigrations pgconfig quiet migrationDir mLogfiledir mToRun = do +runMigrations :: PGConfig -> Bool -> MigrationDir -> Maybe LogFileDir -> MigrationToRun -> TxOutTableType -> IO (Bool, [FilePath]) +runMigrations pgconfig quiet migrationDir mLogfiledir mToRun txOutTableType = do allScripts <- getMigrationScripts migrationDir ranAll <- case (mLogfiledir, allScripts) of (_, []) -> @@ -140,23 +142,22 @@ runMigrations pgconfig quiet migrationDir mLogfiledir mToRun = do filterMigrations :: [(MigrationVersion, FilePath)] -> IO ([(MigrationVersion, FilePath)], Bool) filterMigrations scripts = case mToRun of - Full -> do - mVersion <- runWithConnectionNoLogging (PGPassCached pgconfig) querySchemaVersion - case mVersion of - Just (SchemaVersion _ v _) | v == hardCoded3_0 -> do - pure (filter (not . filterFix) scripts, False) - _ -> pure (scripts, True) - Initial -> do - mVersion <- runWithConnectionNoLogging (PGPassCached pgconfig) querySchemaVersion - case mVersion of - Just (SchemaVersion _ v _) | v == hardCoded3_0 -> do - pure (filter (\m -> not $ filterFix m || filterIndexes m) scripts, False) - _ -> pure (filter (not . filterIndexes) scripts, True) + Full -> pure (filter filterIndexesFull scripts, True) + Initial -> pure (filter filterInitial scripts, True) Fix -> pure (filter filterFix scripts, False) - Indexes -> pure (filter filterIndexes scripts, False) + Indexes -> do + pure (filter filterIndexes scripts, False) filterFix (mv, _) = mvStage mv == 2 && mvVersion mv > hardCoded3_0 - filterIndexes (mv, _) = mvStage mv == 4 + filterIndexesFull (mv, _) = do + case txOutTableType of + TxOutCore -> True + TxOutVariantAddress -> not $ mvStage mv == 4 && mvVersion mv == 1 + filterInitial (mv, _) = mvStage mv < 4 + filterIndexes (mv, _) = do + case txOutTableType of + TxOutCore -> mvStage mv == 4 + TxOutVariantAddress -> mvStage mv == 4 && mvVersion mv > 1 hardCoded3_0 :: Int hardCoded3_0 = 19 @@ -226,8 +227,8 @@ applyMigration (MigrationDir location) quiet pgconfig mLogFilename logHandle (ve -- | Create a database migration (using functionality built into Persistent). If no -- migration is needed return 'Nothing' otherwise return the migration as 'Text'. -createMigration :: PGPassSource -> MigrationDir -> IO (Maybe FilePath) -createMigration source (MigrationDir migdir) = do +createMigration :: PGPassSource -> MigrationDir -> TxOutTableType -> IO (Maybe FilePath) +createMigration source (MigrationDir migdir) txOutTableType = do mt <- runDbNoLogging source create case mt of Nothing -> pure Nothing @@ -239,10 +240,16 @@ createMigration source (MigrationDir migdir) = do create :: ReaderT SqlBackend (NoLoggingT IO) (Maybe (MigrationVersion, Text)) create = do ver <- getSchemaVersion - -- here is the place to combine any "core" schemas to the base schema statementsBase <- getMigration migrateBaseCardanoDb - statementsTxOut <- getMigration migrateCoreTxOutCardanoDb - let statements = statementsBase <> statementsTxOut + -- handle what type of migration to generate + statements <- + case txOutTableType of + TxOutCore -> do + statementsTxOut <- getMigration migrateCoreTxOutCardanoDb + pure $ statementsBase <> statementsTxOut + TxOutVariantAddress -> do + statementsTxOut <- getMigration migrateVariantAddressCardanoDb + pure $ statementsBase <> statementsTxOut if null statements then pure Nothing else do diff --git a/cardano-db/src/Cardano/Db/Operations/Other/ConsumedTxOut.hs b/cardano-db/src/Cardano/Db/Operations/Other/ConsumedTxOut.hs index 6cba99935..d6c77d745 100644 --- a/cardano-db/src/Cardano/Db/Operations/Other/ConsumedTxOut.hs +++ b/cardano-db/src/Cardano/Db/Operations/Other/ConsumedTxOut.hs @@ -23,7 +23,7 @@ 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 (..), MigrationValues (..), PruneConsumeMigration (..), processMigrationValues) -import Cardano.Prelude (textShow) +import Cardano.Prelude (textShow, void) import Control.Exception (throw) import Control.Exception.Lifted (handle, throwIO) import Control.Monad.Extra (unless, when, whenJust) @@ -52,63 +52,68 @@ data ConsumedTriplet = ConsumedTriplet -------------------------------------------------------------------------------------------------- -- Queries -------------------------------------------------------------------------------------------------- - --- | 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 + txOutIds <- getTxOutConsumedAfter txId + mapM_ setNullTxOutConsumedAfter txOutIds let updatedEntries = length txOutIds liftIO $ logInfo trce $ "Set to null " <> textShow updatedEntries <> " tx_out.consumed_by_tx_id" - -updateListTxOutConsumedByTxId :: MonadIO m => [(TxOutIdW, TxId)] -> ReaderT SqlBackend m () -updateListTxOutConsumedByTxId ls = do - mapM_ (uncurry updateTxOutConsumedByTxId) ls + where + -- \| This requires an index at TxOutConsumedByTxId. + getTxOutConsumedAfter :: MonadIO m => TxId -> ReaderT SqlBackend m [TxOutIdW] + getTxOutConsumedAfter 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 => TxOutIdW -> ReaderT SqlBackend m () + setNullTxOutConsumedAfter 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] runExtraMigrations :: (MonadBaseControl IO m, MonadIO m) => Trace IO Text -> TxOutTableType -> Word64 -> PruneConsumeMigration -> ReaderT SqlBackend m () runExtraMigrations trce txOutTableType blockNoDiff pcm = do ems <- queryAllExtraMigrations + isTxOutNull <- queryTxOutIsNull txOutTableType let migrationValues = processMigrationValues ems pcm - -- Make sure the config address_table is there if the migration wasn't previously set in teh db - when (not (isTxOutVariantAddress txOutTableType) && isTxOutAddressPreviouslySet migrationValues) $ throw $ DBExtraMigration "The configuration option 'tx_out.address_table' was previously set and the database updated. Unfortunately reverting this isn't possible." + + -- can only run "use_address_table" on a non populated database + when (isTxOutVariantAddress txOutTableType && not isTxOutNull) $ + throw $ + DBExtraMigration "runExtraMigrations: The use the config 'tx_out.use_address_table' can only be caried out on a non populated database." + -- Make sure the config "use_address_table" is there if the migration wasn't previously set in the past + when (not (isTxOutVariantAddress txOutTableType) && isTxOutAddressPreviouslySet migrationValues) $ + throw $ + DBExtraMigration "runExtraMigrations: The configuration option 'tx_out.use_address_table' was previously set and the database updated. Unfortunately reverting this isn't possible." -- Has the user given txout address config && the migration wasn't previously set when (isTxOutVariantAddress txOutTableType && not (isTxOutAddressPreviouslySet migrationValues)) $ do updateTxOutAndCreateAddress insertExtraMigration TxOutAddressPreviouslySet - -- first check if pruneTxOut flag is missing and it has previously been used when (isPruneTxOutPreviouslySet migrationValues && not (pcmPruneTxOut pcm)) $ throw $ @@ -159,54 +164,70 @@ queryWrongConsumedBy = \case pure $ maybe 0 unValue (listToMaybe res) -------------------------------------------------------------------------------------------------- --- Updates +-- Queries Tests -------------------------------------------------------------------------------------------------- -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) + +-- | 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 - wrapTxOutIds constructor = fmap (map constructor) - - queryConsumedTxOutIds :: - forall a m. - (TxOutFields a, MonadIO m) => - TxId -> - ReaderT SqlBackend m [TxOutIdFor a] - queryConsumedTxOutIds txId' = do + query :: + forall (a :: TxOutTableType) m. + (MonadIO m, TxOutFields a) => + ReaderT SqlBackend m Word64 + query = do res <- select $ do txOut <- from $ table @(TxOutTable a) - where_ (txOut ^. txOutConsumedByTxIdField @a >=. just (val txId')) - pure $ txOut ^. txOutIdField @a - pure $ map unValue res + where_ (not_ $ isNothing $ txOut ^. txOutConsumedByTxIdField @a) + pure countRows + pure $ maybe 0 unValue (listToMaybe 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 +queryTxOutIsNull :: TxOutTableType -> MonadIO m => ReaderT SqlBackend m Bool +queryTxOutIsNull = \case + TxOutCore -> pure False + TxOutVariantAddress -> query @'TxOutVariantAddress 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] + query :: + forall (a :: TxOutTableType) m. + (MonadIO m, TxOutFields a) => + ReaderT SqlBackend m Bool + query = do + res <- select $ do + _ <- from $ table @(TxOutTable a) + limit 1 + pure (val (1 :: Int)) + pure $ null res -migrateTxOutTests :: (MonadIO m, MonadBaseControl IO m) => TxOutTableType -> ReaderT SqlBackend m () -migrateTxOutTests txOutTableType = do - _ <- createConsumedIndexTxOut - migrateNextPageTxOut Nothing txOutTableType 0 +-------------------------------------------------------------------------------------------------- +-- Updates +-------------------------------------------------------------------------------------------------- +updateListTxOutConsumedByTxId :: MonadIO m => [(TxOutIdW, TxId)] -> ReaderT SqlBackend m () +updateListTxOutConsumedByTxId ls = do + mapM_ (uncurry updateTxOutConsumedByTxId) ls + where + 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] migrateTxOut :: ( MonadBaseControl IO m @@ -216,21 +237,34 @@ migrateTxOut :: TxOutTableType -> Maybe MigrationValues -> ReaderT SqlBackend m () -migrateTxOut trce txOutTableType _mMvs = do - liftIO $ logInfo trce "migrateTxOut:" - _ <- createConsumedIndexTxOut +migrateTxOut trce txOutTableType mMvs = do + whenJust mMvs $ \mvs -> do + liftIO $ logInfo trce $ "migrateTxOut: previously set: " <> textShow (not (isTxOutAddressPreviouslySet mvs)) + liftIO $ logInfo trce $ "migrateTxOut: pcmConsumedTxOut: " <> textShow (pcmConsumedTxOut (pruneConsumeMigration mvs)) + when (pcmConsumedTxOut (pruneConsumeMigration mvs) && not (isTxOutAddressPreviouslySet mvs)) $ do + liftIO $ logInfo trce "migrateTxOut: addeding consumed-by-id Index" + void createConsumedIndexTxOut + when (pcmPruneTxOut (pruneConsumeMigration mvs)) $ do + liftIO $ logInfo trce "migrateTxOut: adding prune contraint on tx_out table" + void createPruneConstraintTxOut migrateNextPageTxOut (Just trce) txOutTableType 0 migrateNextPageTxOut :: MonadIO m => Maybe (Trace IO Text) -> TxOutTableType -> Word64 -> ReaderT SqlBackend m () migrateNextPageTxOut mTrce txOutTableType offst = do whenJust mTrce $ \trce -> - liftIO $ logInfo trce $ "Handling input offset " <> textShow offst + liftIO $ logInfo trce $ "migrateNextPageTxOut: Handling input offset " <> textShow offst page <- getInputPage offst pageSize updatePageEntries txOutTableType page when (fromIntegral (length page) == pageSize) $ migrateNextPageTxOut mTrce txOutTableType $! (offst + pageSize) +-- TODO: cmdv put into tools or something +migrateTxOutDbTool :: (MonadIO m, MonadBaseControl IO m) => TxOutTableType -> ReaderT SqlBackend m () +migrateTxOutDbTool txOutTableType = do + _ <- createConsumedIndexTxOut + migrateNextPageTxOut Nothing txOutTableType 0 + -------------------------------------------------------------------------------------------------- -- Delete + Update -------------------------------------------------------------------------------------------------- @@ -247,8 +281,9 @@ deleteAndUpdateConsumedTxOut trce txOutTableType migrationValues blockNoDiff = d 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" + liftIO $ logInfo trce "deleteAndUpdateConsumedTxOut: Now Running extra migration prune tx_out" migrateTxOut trce txOutTableType $ Just migrationValues + insertExtraMigration ConsumeTxOutPreviouslySet Right mTxId -> do migrateNextPage mTxId False 0 where @@ -350,13 +385,13 @@ createConsumedIndexTxOut = do exceptHandler e = liftIO $ throwIO (DBPruneConsumed $ show e) -createConsumedConstraintTxOut :: +createPruneConstraintTxOut :: forall m. ( MonadBaseControl IO m , MonadIO m ) => ReaderT SqlBackend m () -createConsumedConstraintTxOut = do +createPruneConstraintTxOut = do handle exceptHandler $ rawExecute addConstraint [] where addConstraint = @@ -385,9 +420,18 @@ updateTxOutAndCreateAddress :: ) => ReaderT SqlBackend m () updateTxOutAndCreateAddress = do + handle exceptHandler $ rawExecute dropViewsQuery [] handle exceptHandler $ rawExecute alterTxOutQuery [] handle exceptHandler $ rawExecute createAddressTableQuery [] + handle exceptHandler $ rawExecute createIndexPaymentCredQuery [] + handle exceptHandler $ rawExecute createIndexRawQuery [] where + dropViewsQuery = + Text.unlines + [ "DROP VIEW IF EXISTS utxo_byron_view;" + , "DROP VIEW IF EXISTS utxo_view;" + ] + alterTxOutQuery = Text.unlines [ "ALTER TABLE \"tx_out\"" @@ -397,6 +441,7 @@ updateTxOutAndCreateAddress = do , " DROP COLUMN \"payment_cred\"," , " DROP COLUMN \"stake_address_id\"" ] + createAddressTableQuery = Text.unlines [ "CREATE TABLE \"address\" (" @@ -408,6 +453,13 @@ updateTxOutAndCreateAddress = do , " \"stake_address_id\" INT8 NULL" , ")" ] + + createIndexPaymentCredQuery = + "CREATE INDEX IF NOT EXISTS idx_address_payment_cred ON address(payment_cred);" + + createIndexRawQuery = + "CREATE INDEX IF NOT EXISTS idx_address_raw ON address(raw);" + exceptHandler :: SqlError -> ReaderT SqlBackend m a exceptHandler e = liftIO $ throwIO (DBPruneConsumed $ show e) diff --git a/cardano-db/src/Cardano/Db/Operations/Other/MinId.hs b/cardano-db/src/Cardano/Db/Operations/Other/MinId.hs index 3c03942a7..261c47064 100644 --- a/cardano-db/src/Cardano/Db/Operations/Other/MinId.hs +++ b/cardano-db/src/Cardano/Db/Operations/Other/MinId.hs @@ -108,7 +108,6 @@ 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 -> diff --git a/cardano-db/test/Test/IO/Cardano/Db/Migration.hs b/cardano-db/test/Test/IO/Cardano/Db/Migration.hs index 642923c1c..640b68a45 100644 --- a/cardano-db/test/Test/IO/Cardano/Db/Migration.hs +++ b/cardano-db/test/Test/IO/Cardano/Db/Migration.hs @@ -12,6 +12,7 @@ import Cardano.Db ( MigrationValidateError (..), MigrationVersion (..), SchemaVersion (..), + TxOutTableType (..), getMigrationScripts, querySchemaVersion, readPGPassDefault, @@ -131,7 +132,7 @@ migrationTest :: IO () migrationTest = do let schemaDir = MigrationDir "../schema" pgConfig <- runOrThrowIODb readPGPassDefault - _ <- runMigrations pgConfig True schemaDir (Just $ LogFileDir "/tmp") Initial + _ <- runMigrations pgConfig True schemaDir (Just $ LogFileDir "/tmp") Initial TxOutVariantAddress expected <- readSchemaVersion schemaDir actual <- getDbSchemaVersion unless (expected == actual) $ diff --git a/doc/configuration.md b/doc/configuration.md index db3e86f91..be936af4a 100644 --- a/doc/configuration.md +++ b/doc/configuration.md @@ -194,20 +194,29 @@ Disables almost all data except `block` and `tx` tables. * Type: `object` + **Example** + ``` + "tx_out": { + "value": "consumed", + "force_tx_in": false, + "use_address_table": true, + }, + ``` + Tx Out Properties: | Property | Type | Required | | :------------------------------- | :-------- | :------- | | [value](#value) | `string` | Optional | | [force\_tx\_in](#force-tx-in) | `boolean` | Optional | -| [address\_table](#address-table) | `boolean` | Optional | +| [use\_address\_table](#address-table) | `boolean` | Optional | #### Value `tx_out.value` * Type: `string` - + **enum**: the value of this property must be equal to one of the following values: | Value | Explanation | @@ -270,11 +279,14 @@ can be changed. `tx_out.force_tx_in` * Type: `boolean` + +This value defaults to false. + ### Address Table -`tx_out.address_table` +`tx_out.use_address_table` * Type: `boolean` @@ -290,8 +302,14 @@ Key changes in the variant representation: - Replaces `address`, `address_has_script`, and `payment_cred` fields with a single `address_id` field - `addressId` references the new `Address` table +The address table can only be used on an empty database due to the schema restructuring which would cause data loss. + +The following indexes are added to the new `address` table: +1. `idx_address_payment_cred ON address(payment_cred)` +2. `idx_address_raw ON address(raw)` +Then `address.id` having a unique constraint. ## Ledger diff --git a/schema/migration-4-0001-20200702.sql b/schema/migration-4-0001-20200702.sql index 5fe18540a..f10c18c30 100644 --- a/schema/migration-4-0001-20200702.sql +++ b/schema/migration-4-0001-20200702.sql @@ -1,3 +1,10 @@ +-- +-- The following index creations only happen when not using "use_address_table" config in tx-out. +-- This is because the following uses columns that get moved to the `address` table . +-- --- This Index takes a lot of time to be created. -CREATE INDEX IF NOT EXISTS idx_tx_out_address ON tx_out USING hash (address); +CREATE INDEX IF NOT EXISTS idx_tx_out_payment_cred ON tx_out(payment_cred); +CREATE INDEX IF NOT EXISTS idx_tx_out_stake_address_id ON tx_out(stake_address_id) ; + +-- Left here for reference, it's removed to speed up restoring from a snapshot as this index is very slow to create. +-- CREATE INDEX IF NOT EXISTS idx_tx_out_address ON tx_out USING hash (address); diff --git a/schema/migration-4-0002-20200810.sql b/schema/migration-4-0002-20200810.sql index 4805612ca..e14a44bad 100644 --- a/schema/migration-4-0002-20200810.sql +++ b/schema/migration-4-0002-20200810.sql @@ -1,4 +1,3 @@ CREATE INDEX IF NOT EXISTS idx_block_time ON block(time); -CREATE INDEX IF NOT EXISTS idx_tx_out_payment_cred ON tx_out(payment_cred); CREATE INDEX IF NOT EXISTS idx_pool_update_hash_id ON pool_update(hash_id); diff --git a/schema/migration-4-0003-20210116.sql b/schema/migration-4-0003-20210116.sql index 11faa861e..617896a0e 100644 --- a/schema/migration-4-0003-20210116.sql +++ b/schema/migration-4-0003-20210116.sql @@ -34,7 +34,6 @@ CREATE INDEX IF NOT EXISTS idx_reward_addr_id ON reward(addr_id) ; CREATE INDEX IF NOT EXISTS idx_stake_deregistration_addr_id ON stake_deregistration(addr_id) ; CREATE INDEX IF NOT EXISTS idx_stake_registration_addr_id ON stake_registration(addr_id) ; CREATE INDEX IF NOT EXISTS idx_treasury_addr_id ON treasury(addr_id) ; -CREATE INDEX IF NOT EXISTS idx_tx_out_stake_address_id ON tx_out(stake_address_id) ; CREATE INDEX IF NOT EXISTS idx_withdrawal_addr_id ON withdrawal(addr_id) ; CREATE INDEX IF NOT EXISTS idx_ma_tx_out_tx_out_id ON ma_tx_out(tx_out_id) ; CREATE INDEX IF NOT EXISTS idx_pool_update_meta_id ON pool_update(meta_id) ; From a3098e0d95077b81124c3338f76faeadeb6c4ead Mon Sep 17 00:00:00 2001 From: Cmdv Date: Wed, 25 Sep 2024 10:13:05 +0100 Subject: [PATCH 6/6] update docmentation for db-tool for address table schema --- doc/schema-management.md | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/doc/schema-management.md b/doc/schema-management.md index 9c4a911c1..87e99d6fd 100644 --- a/doc/schema-management.md +++ b/doc/schema-management.md @@ -15,13 +15,11 @@ indexes during syncing slows down db-sync and so they are added later. Index creation is idempotent and the `schema_version.stage_tree` field is ignored. These files cannot be modified but they can be extended, in case users want to introduce their own indexes from the begining. -- `stage 4`: introduces all the other indexes. By default these are the indexes -that were created by previous db-sync versions. This stage is executed when -db-sync has reached 30mins before the tip of the chain. It is advised to increase -the `maintenance_work_mem` from Postgres config to 0.5GB - 1GB to speed this -process (default is 64MB). Also use the default (2) or higher -`max_parallel_maintenance_workers`. These files can be modified or extended -by users. +- `stage 4`: introduces all the other indexes. By default these are the indexes that were created by previous db-sync versions. This stage is executed when +db-sync has reached 30mins before the tip of the chain. It is advised to increase the `maintenance_work_mem` from Postgres config to 0.5GB - 1GB to speed this +process (default is 64MB). +Also use the default (2) or higher `max_parallel_maintenance_workers`. These files can be modified or extended +by users. All of the schema migrations in these three stages are written to be idempotent (so that they "know" if they have already been applied). @@ -34,6 +32,11 @@ where the `1` denotes "stage 1" of the SQL migration, the `0000` is the migratio last number is the date. Listing the directory containing the schema and sorting the list will order them in the correct order for applying to the database. +Since the introduction of `use_address_table` [config](https://github.com/IntersectMBO/cardano-db-sync/blob/master/doc/configuration.md#tx-out). The file `migration-4-001-*` when indexing will not be ran when the this configuration is active. + +There is also a flag you can use in cardano-db-tool `--use-tx-out-address` which handles the alternate variation of the schema, one might be using. + + ## Creating a Migration Whenever the Haskell schema definition in `Cardano.Db.Schema` is updated, a schema migration will need to be migrated. @@ -52,6 +55,12 @@ cabal run cardano-db-tool -- create-migration --mdir schema/ ``` This will generate a migration if one is needed. +There is an alternate way to create/run a migration when using the `use_txout_address` configuration as previously mentioned, this uses a different variation of the schema. +To do this, you simply add the flag `--use-tx-out-address` like so: +``` +PGPASSFILE=config/pgpass-mainnet cabal run cardano-db-tool -- create-migration --use-tx-out-address --mdir schema/ +``` + Once this has completed it's good practice to rebuild `cardano-db-sync` due to how it caches schema files when built, this can be done using the following documentation [Build and Install](./installing.md#build-and-install) **Note:** For extra reassurance one can run the test suite to check that the new migration hasn't broken any tests: