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 7089c4d50..03b16d31a 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs @@ -268,7 +268,7 @@ mkSyncNodeParams staticDir mutableDir CommandLineArgs {..} = do , enpHasShelley = True , enpHasMultiAssets = claHasMultiAssets , enpHasMetadata = claHasMetadata - , enpKeepMetadataNames = [] + , enpWhitelistMetadataNames = [] , enpHasPlutusExtra = True , enpHasGov = True , enpHasOffChainPoolData = True diff --git a/cardano-db-sync/app/cardano-db-sync.hs b/cardano-db-sync/app/cardano-db-sync.hs index 7c9780c7f..c0f827b4b 100644 --- a/cardano-db-sync/app/cardano-db-sync.hs +++ b/cardano-db-sync/app/cardano-db-sync.hs @@ -90,7 +90,7 @@ pRunDbSyncNode = do <*> pHasShelley <*> pHasMultiAssets <*> pHasMetadata - <*> pKeepTxMetadata + <*> pWhiteListTxMetadata <*> pHasPlutusExtra <*> pHasGov <*> pHasOffChainPoolData @@ -232,20 +232,20 @@ pSlotNo = <> Opt.metavar "WORD" ) -pKeepTxMetadata :: Parser [Word64] -pKeepTxMetadata = +pWhiteListTxMetadata :: Parser [Word64] +pWhiteListTxMetadata = Opt.option (parseCommaSeparated <$> Opt.str) - ( Opt.long "keep-tx-metadata" + ( Opt.long "whitelist-tx-metadata" <> Opt.value [] <> Opt.help "Insert a specific set of tx metadata, based on the tx metadata key names" ) - where - parseCommaSeparated :: String -> [Word64] - parseCommaSeparated str = - case traverse readMaybe (splitOn "," str) of - Just values -> values - Nothing -> error "Failed to parse comma-separated values" + +parseCommaSeparated :: String -> [Word64] +parseCommaSeparated str = + case traverse readMaybe (splitOn "," str) of + Just values -> values + Nothing -> error "Failed to parse comma-separated values" pHasInOut :: Parser Bool pHasInOut = diff --git a/cardano-db-sync/src/Cardano/DbSync.hs b/cardano-db-sync/src/Cardano/DbSync.hs index a31cc80d5..f3dfb7dc1 100644 --- a/cardano-db-sync/src/Cardano/DbSync.hs +++ b/cardano-db-sync/src/Cardano/DbSync.hs @@ -35,7 +35,10 @@ import Cardano.DbSync.Config.Types ( ConfigFile (..), GenesisFile (..), LedgerStateDir (..), + MetadataConfig (..), + MultiAssetConfig (..), NetworkName (..), + PlutusConfig (..), SocketPath (..), SyncCommand (..), SyncNodeConfig (..), @@ -55,7 +58,6 @@ import Cardano.Prelude hiding (Nat, (%)) import Cardano.Slotting.Slot (EpochNo (..)) import Control.Concurrent.Async import Control.Monad.Extra (whenJust) -import qualified Data.Strict.Maybe as Strict import qualified Data.Text as Text import Data.Version (showVersion) import Database.Persist.Postgresql (ConnectionString, withPostgresqlConn) @@ -232,11 +234,6 @@ extractSyncOptions snp aop = , snapshotEveryLagging = enpSnEveryLagging snp } where - maybeKeepMNames = - if null (enpKeepMetadataNames snp) - then Strict.Nothing - else Strict.Just (enpKeepMetadataNames snp) - iopts | enpOnlyGov snp = onlyGovInsertOptions useLedger | enpOnlyUTxO snp = onlyUTxOInsertOptions @@ -248,10 +245,9 @@ extractSyncOptions snp aop = , ioUseLedger = useLedger , ioShelley = enpHasShelley snp , ioRewards = True - , ioMultiAssets = enpHasMultiAssets snp - , ioMetadata = enpHasMetadata snp - , ioKeepMetadataNames = maybeKeepMNames - , ioPlutusExtra = enpHasPlutusExtra snp + , ioMultiAssets = MultiAssetDisable + , ioMetadata = MetadataDisable + , ioPlutusExtra = PlutusDisable , ioOffChainPoolData = enpHasOffChainPoolData snp , ioGov = enpHasGov snp } diff --git a/cardano-db-sync/src/Cardano/DbSync/Api.hs b/cardano-db-sync/src/Cardano/DbSync/Api.hs index 50648cd09..4a0c5696a 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Api.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Api.hs @@ -206,10 +206,9 @@ fullInsertOptions useLedger = , ioUseLedger = useLedger , ioShelley = True , ioRewards = True - , ioMultiAssets = True - , ioMetadata = True - , ioKeepMetadataNames = Strict.Nothing - , ioPlutusExtra = True + , ioMultiAssets = MultiAssetEnable + , ioMetadata = MetadataEnable + , ioPlutusExtra = PlutusEnable , ioOffChainPoolData = True , ioGov = True } @@ -221,10 +220,9 @@ onlyUTxOInsertOptions = , ioUseLedger = False , ioShelley = False , ioRewards = False - , ioMultiAssets = True - , ioMetadata = False - , ioKeepMetadataNames = Strict.Nothing - , ioPlutusExtra = False + , ioMultiAssets = MultiAssetEnable + , ioMetadata = MetadataDisable + , ioPlutusExtra = PlutusDisable , ioOffChainPoolData = False , ioGov = False } @@ -239,10 +237,9 @@ disableAllInsertOptions useLedger = , ioUseLedger = useLedger , ioShelley = False , ioRewards = False - , ioMultiAssets = False - , ioMetadata = False - , ioKeepMetadataNames = Strict.Nothing - , ioPlutusExtra = False + , ioMultiAssets = MultiAssetEnable + , ioMetadata = MetadataDisable + , ioPlutusExtra = PlutusDisable , ioOffChainPoolData = False , ioGov = False } diff --git a/cardano-db-sync/src/Cardano/DbSync/Api/Ledger.hs b/cardano-db-sync/src/Cardano/DbSync/Api/Ledger.hs index 396663e71..e7aae8627 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Api/Ledger.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Api/Ledger.hs @@ -142,7 +142,8 @@ storePage :: ExceptT SyncNodeError (ReaderT SqlBackend m) () storePage syncEnv cache percQuantum (n, ls) = do when (n `mod` 10 == 0) $ liftIO $ logInfo trce $ "Bootstrap in progress " <> prc <> "%" - txOuts <- mapM (prepareTxOut syncEnv cache) ls + txOuts <- do + mapM (prepareTxOut syncEnv cache) ls txOutIds <- lift . DB.insertManyTxOutPlex True False $ etoTxOut . fst <$> txOuts let maTxOuts = concatMap mkmaTxOuts $ zip txOutIds (snd <$> txOuts) void . lift $ DB.insertManyMaTxOut maTxOuts @@ -167,7 +168,7 @@ prepareTxOut syncEnv txCache (TxIn txHash (TxIx index), txOut) = do let txHashByteString = Generic.safeHashToByteString $ unTxId txHash let genTxOut = fromTxOut index txOut txId <- queryTxIdWithCache txCache txHashByteString - Insert.prepareTxOut trce cache iopts (txId, txHashByteString) genTxOut + Insert.prepareTxOut trce iopts cache (txId, txHashByteString) genTxOut where trce = getTrace syncEnv cache = envCache syncEnv diff --git a/cardano-db-sync/src/Cardano/DbSync/Api/Types.hs b/cardano-db-sync/src/Cardano/DbSync/Api/Types.hs index 87ff8a101..b5ec9a2e7 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Api/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Api/Types.hs @@ -15,7 +15,7 @@ module Cardano.DbSync.Api.Types ( import qualified Cardano.Db as DB import Cardano.DbSync.Cache.Types (Cache) -import Cardano.DbSync.Config.Types (SyncNodeConfig) +import Cardano.DbSync.Config.Types (MetadataConfig, MultiAssetConfig, PlutusConfig, SyncNodeConfig) import Cardano.DbSync.Ledger.Types (HasLedgerEnv) import Cardano.DbSync.LocalStateQuery (NoLedgerEnv) import Cardano.DbSync.Types ( @@ -24,7 +24,7 @@ import Cardano.DbSync.Types ( OffChainVoteResult, OffChainVoteWorkQueue, ) -import Cardano.Prelude (Bool, Eq, IO, Show, Word64) +import Cardano.Prelude (Bool (..), Eq, IO, Show, Word64) import Cardano.Slotting.Slot (EpochNo (..)) import Control.Concurrent.Class.MonadSTM.Strict ( StrictTVar, @@ -78,10 +78,9 @@ data InsertOptions = InsertOptions , ioUseLedger :: !Bool , ioShelley :: !Bool , ioRewards :: !Bool - , ioMultiAssets :: !Bool - , ioMetadata :: !Bool - , ioKeepMetadataNames :: Strict.Maybe [Word64] - , ioPlutusExtra :: !Bool + , ioMultiAssets :: !MultiAssetConfig + , ioMetadata :: !MetadataConfig + , ioPlutusExtra :: !PlutusConfig , ioOffChainPoolData :: !Bool , ioGov :: !Bool } diff --git a/cardano-db-sync/src/Cardano/DbSync/Config.hs b/cardano-db-sync/src/Cardano/DbSync/Config.hs index 4628dc313..4b2704530 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Config.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Config.hs @@ -20,17 +20,23 @@ module Cardano.DbSync.Config ( readCardanoGenesisConfig, readSyncNodeConfig, configureLogging, + plutusMultiAssetWhitelistCheck, ) where import qualified Cardano.BM.Configuration.Model as Logging import qualified Cardano.BM.Setup as Logging import Cardano.BM.Trace (Trace) import qualified Cardano.BM.Trace as Logging +import Cardano.DbSync.Api.Types (InsertOptions (..), SyncEnv, SyncOptions (..), envOptions) import Cardano.DbSync.Config.Cardano import Cardano.DbSync.Config.Node (NodeConfig (..), parseNodeConfig, parseSyncPreConfig, readByteStringFromFile) import Cardano.DbSync.Config.Shelley import Cardano.DbSync.Config.Types +import qualified Cardano.DbSync.Era.Shelley.Generic as Generic +import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Mary.Value (PolicyID (..)) import Cardano.Prelude +import Data.Map (keys) import System.FilePath (takeDirectory, ()) configureLogging :: SyncNodeConfig -> Text -> IO (Trace IO Text) @@ -88,3 +94,50 @@ coalesceConfig pcfg ncfg adjustGenesisPath = do mkAdjustPath :: SyncPreConfig -> (FilePath -> FilePath) mkAdjustPath cfg fp = takeDirectory (pcNodeConfigFilePath cfg) fp + +-- check both whitelist but also checking plutus Maybes first +plutusMultiAssetWhitelistCheck :: SyncEnv -> [Generic.TxOut] -> Bool +plutusMultiAssetWhitelistCheck syncEnv txOuts = + plutusWhitelistCheck syncEnv txOuts || multiAssetWhitelistCheck syncEnv txOuts + +plutusWhitelistCheck :: SyncEnv -> [Generic.TxOut] -> Bool +plutusWhitelistCheck syncEnv txOuts = do + -- first check the config option + case ioPlutusExtra iopts of + PlutusEnable -> True + PlutusDisable -> True + PlutusWhitelistScripts plutusWhitelist -> plutuswhitelistCheck plutusWhitelist + where + iopts = soptInsertOptions $ envOptions syncEnv + plutuswhitelistCheck :: NonEmpty ByteString -> Bool + plutuswhitelistCheck whitelist = + any (\txOut -> isScriptHashWhitelisted whitelist txOut || isAddressWhitelisted whitelist txOut) txOuts + -- check if the script hash is in the whitelist + isScriptHashWhitelisted :: NonEmpty ByteString -> Generic.TxOut -> Bool + isScriptHashWhitelisted whitelist txOut = + maybe False ((`elem` whitelist) . Generic.txScriptHash) (Generic.txOutScript txOut) + -- check if the address is in the whitelist + isAddressWhitelisted :: NonEmpty ByteString -> Generic.TxOut -> Bool + isAddressWhitelisted whitelist txOut = + maybe False (`elem` whitelist) (Generic.maybePaymentCred $ Generic.txOutAddress txOut) + +multiAssetWhitelistCheck :: SyncEnv -> [Generic.TxOut] -> Bool +multiAssetWhitelistCheck syncEnv txOuts = do + let iopts = soptInsertOptions $ envOptions syncEnv + case ioMultiAssets iopts of + MultiAssetEnable -> True + MultiAssetDisable -> True + MultiAssetWhitelistPolicies multiAssetWhitelist -> + or multiAssetwhitelistCheck + where + -- txOutMaValue is a Map and we want to check if any of the keys match our whitelist + multiAssetwhitelistCheck :: [Bool] + multiAssetwhitelistCheck = + ( \txout -> + any (checkMAValueMap multiAssetWhitelist) (keys $ Generic.txOutMaValue txout) + ) + <$> txOuts + + checkMAValueMap :: NonEmpty ByteString -> PolicyID StandardCrypto -> Bool + checkMAValueMap maWhitelist policyId = + Generic.unScriptHash (policyID policyId) `elem` maWhitelist diff --git a/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs b/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs index 63c578986..707bd5e2b 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -18,11 +19,17 @@ module Cardano.DbSync.Config.Types ( GenesisHashConway (..), SyncNodeConfig (..), SyncPreConfig (..), + MetadataConfig (..), + MultiAssetConfig (..), + PlutusConfig (..), LedgerStateDir (..), LogFileDir (..), NetworkName (..), NodeConfigFile (..), SocketPath (..), + isMetadataEnableOrWhiteList, + isMultiAssetEnableOrWhitelist, + isPlutusEnableOrWhitelist, adjustGenesisFilePath, adjustNodeConfigFilePath, pcNodeConfigFilePath, @@ -72,7 +79,7 @@ data SyncNodeParams = SyncNodeParams , enpHasShelley :: !Bool , enpHasMultiAssets :: !Bool , enpHasMetadata :: !Bool - , enpKeepMetadataNames :: ![Word64] + , enpWhitelistMetadataNames :: ![Word64] , enpHasPlutusExtra :: !Bool , enpHasGov :: !Bool , enpHasOffChainPoolData :: !Bool @@ -131,6 +138,42 @@ data SyncPreConfig = SyncPreConfig , pcPrometheusPort :: !Int } +data MetadataConfig + = MetadataEnable + | MetadataDisable + | MetadataWhitelistKeys (NonEmpty ByteString) + deriving (Eq, Show) + +isMetadataEnableOrWhiteList :: MetadataConfig -> Bool +isMetadataEnableOrWhiteList = \case + MetadataEnable -> True + MetadataDisable -> False + MetadataWhitelistKeys _ -> True + +data MultiAssetConfig + = MultiAssetEnable + | MultiAssetDisable + | MultiAssetWhitelistPolicies (NonEmpty ByteString) + deriving (Eq, Show) + +isMultiAssetEnableOrWhitelist :: MultiAssetConfig -> Bool +isMultiAssetEnableOrWhitelist = \case + MultiAssetEnable -> True + MultiAssetDisable -> False + MultiAssetWhitelistPolicies _ -> True + +data PlutusConfig + = PlutusEnable + | PlutusDisable + | PlutusWhitelistScripts (NonEmpty ByteString) + deriving (Eq, Show) + +isPlutusEnableOrWhitelist :: PlutusConfig -> Bool +isPlutusEnableOrWhitelist = \case + PlutusEnable -> True + PlutusDisable -> False + PlutusWhitelistScripts _ -> True + newtype GenesisFile = GenesisFile { unGenesisFile :: FilePath } diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Block.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Block.hs index e74620297..28c0a69ed 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Block.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Block.hs @@ -25,6 +25,7 @@ module Cardano.DbSync.Era.Shelley.Generic.Block ( import qualified Cardano.Crypto.Hash as Crypto import qualified Cardano.Crypto.KES.Class as KES +import Cardano.DbSync.Config.Types (PlutusConfig) import Cardano.DbSync.Era.Shelley.Generic.Tx import Cardano.DbSync.Types import Cardano.DbSync.Util.Bech32 (serialiseVerKeyVrfToBech32) @@ -120,7 +121,7 @@ fromMaryBlock blk = , blkTxs = map fromMaryTx (getTxs blk) } -fromAlonzoBlock :: Bool -> Maybe Prices -> ShelleyBlock TPraosStandard StandardAlonzo -> Block +fromAlonzoBlock :: PlutusConfig -> Maybe Prices -> ShelleyBlock TPraosStandard StandardAlonzo -> Block fromAlonzoBlock iope mprices blk = Block { blkEra = Alonzo @@ -137,7 +138,7 @@ fromAlonzoBlock iope mprices blk = , blkTxs = map (fromAlonzoTx iope mprices) (getTxs blk) } -fromBabbageBlock :: Bool -> Maybe Prices -> ShelleyBlock PraosStandard StandardBabbage -> Block +fromBabbageBlock :: PlutusConfig -> Maybe Prices -> ShelleyBlock PraosStandard StandardBabbage -> Block fromBabbageBlock iope mprices blk = Block { blkEra = Babbage @@ -154,7 +155,7 @@ fromBabbageBlock iope mprices blk = , blkTxs = map (fromBabbageTx iope mprices) (getTxs blk) } -fromConwayBlock :: Bool -> Maybe Prices -> ShelleyBlock PraosStandard StandardConway -> Block +fromConwayBlock :: PlutusConfig -> Maybe Prices -> ShelleyBlock PraosStandard StandardConway -> Block fromConwayBlock iope mprices blk = Block { blkEra = Conway diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Alonzo.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Alonzo.hs index be17923c0..d5cece36f 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Alonzo.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Alonzo.hs @@ -26,6 +26,7 @@ module Cardano.DbSync.Era.Shelley.Generic.Tx.Alonzo ( import qualified Cardano.Crypto.Hash as Crypto import Cardano.Db (ScriptType (..)) +import Cardano.DbSync.Config.Types (PlutusConfig, isPlutusEnableOrWhitelist) import Cardano.DbSync.Era.Shelley.Generic.Metadata import Cardano.DbSync.Era.Shelley.Generic.Script (fromTimelock) import Cardano.DbSync.Era.Shelley.Generic.ScriptData (ScriptData (..)) @@ -65,7 +66,7 @@ import qualified Data.Set as Set import Lens.Micro import Ouroboros.Consensus.Cardano.Block (EraCrypto, StandardAlonzo, StandardCrypto) -fromAlonzoTx :: Bool -> Maybe Alonzo.Prices -> (Word64, Core.Tx StandardAlonzo) -> Tx +fromAlonzoTx :: PlutusConfig -> Maybe Alonzo.Prices -> (Word64, Core.Tx StandardAlonzo) -> Tx fromAlonzoTx ioExtraPlutus mprices (blkIndex, tx) = Tx { txHash = txHashId tx @@ -176,13 +177,13 @@ resolveRedeemers :: , Core.EraTx era , Alonzo.MaryEraTxBody era ) => - Bool -> + PlutusConfig -> Maybe Alonzo.Prices -> Core.Tx era -> (TxCert era -> Cert) -> (RedeemerMaps, [(Word64, TxRedeemer)]) resolveRedeemers ioExtraPlutus mprices tx toCert = - if not ioExtraPlutus + if not $ isPlutusEnableOrWhitelist ioExtraPlutus then (initRedeemersMaps, []) else mkRdmrAndUpdateRec (initRedeemersMaps, []) $ diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Babbage.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Babbage.hs index 03115436e..e9588814b 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Babbage.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Babbage.hs @@ -13,6 +13,7 @@ module Cardano.DbSync.Era.Shelley.Generic.Tx.Babbage ( fromTxOut, ) where +import Cardano.DbSync.Config.Types (PlutusConfig) import Cardano.DbSync.Era.Shelley.Generic.Metadata import Cardano.DbSync.Era.Shelley.Generic.Tx.Allegra (getInterval) import Cardano.DbSync.Era.Shelley.Generic.Tx.Alonzo @@ -34,7 +35,7 @@ import qualified Data.Map.Strict as Map import Lens.Micro import Ouroboros.Consensus.Shelley.Eras (StandardBabbage, StandardCrypto) -fromBabbageTx :: Bool -> Maybe Alonzo.Prices -> (Word64, Core.Tx StandardBabbage) -> Tx +fromBabbageTx :: PlutusConfig -> Maybe Alonzo.Prices -> (Word64, Core.Tx StandardBabbage) -> Tx fromBabbageTx ioExtraPlutus mprices (blkIndex, tx) = Tx { txHash = txHashId tx diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Conway.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Conway.hs index c45525b7f..3e6701a70 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Conway.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Conway.hs @@ -8,6 +8,7 @@ module Cardano.DbSync.Era.Shelley.Generic.Tx.Conway ( fromConwayTx, ) where +import Cardano.DbSync.Config.Types (PlutusConfig) import Cardano.DbSync.Era.Shelley.Generic.Metadata import Cardano.DbSync.Era.Shelley.Generic.Tx.Allegra (getInterval) import Cardano.DbSync.Era.Shelley.Generic.Tx.Alonzo @@ -26,7 +27,7 @@ import qualified Data.Map.Strict as Map import Lens.Micro import Ouroboros.Consensus.Cardano.Block (StandardConway) -fromConwayTx :: Bool -> Maybe Alonzo.Prices -> (Word64, Core.Tx StandardConway) -> Tx +fromConwayTx :: PlutusConfig -> Maybe Alonzo.Prices -> (Word64, Core.Tx StandardConway) -> Tx fromConwayTx ioExtraPlutus mprices (blkIndex, tx) = Tx { txHash = txHashId tx diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs index 01e99c265..d213a50ba 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs @@ -43,6 +43,8 @@ import Cardano.DbSync.Cache ( import Cardano.DbSync.Cache.Epoch (writeEpochBlockDiffToCache) import Cardano.DbSync.Cache.Types (Cache (..), CacheNew (..), EpochBlockDiff (..)) +import Cardano.DbSync.Config (plutusMultiAssetWhitelistCheck) +import Cardano.DbSync.Config.Types (MetadataConfig (..), MultiAssetConfig (..), PlutusConfig (..), isMetadataEnableOrWhiteList, isPlutusEnableOrWhitelist) import qualified Cardano.DbSync.Era.Shelley.Generic as Generic import Cardano.DbSync.Era.Shelley.Generic.Metadata ( TxMetadataValue (..), @@ -88,7 +90,7 @@ import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Either.Extra (eitherToMaybe) import Data.Group (invert) import qualified Data.Map.Strict as Map -import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Database.Persist.Sql (SqlBackend) import Lens.Micro @@ -320,7 +322,11 @@ insertTx syncEnv isMember blkId epochNo slotNo applyResult blockIndex tx grouped if not (Generic.txValidContract tx) then do - !txOutsGrouped <- mapM (prepareTxOut tracer cache iopts (txId, txHash)) (Generic.txOutputs tx) + !txOutsGrouped <- do + let txOuts = Generic.txOutputs tx + if plutusMultiAssetWhitelistCheck syncEnv txOuts + then mapM (prepareTxOut tracer iopts cache (txId, txHash)) txOuts + else pure mempty let !txIns = map (prepareTxIn txId Map.empty) resolvedInputs -- There is a custom semigroup instance for BlockGroupedData which uses addition for the values `fees` and `outSum`. @@ -329,15 +335,20 @@ insertTx syncEnv isMember blkId epochNo slotNo applyResult blockIndex tx grouped else do -- The following operations only happen if the script passes stage 2 validation (or the tx has -- no script). - !txOutsGrouped <- mapM (prepareTxOut tracer cache iopts (txId, txHash)) (Generic.txOutputs tx) + !txOutsGrouped <- do + let txOuts = Generic.txOutputs tx + -- we do a plutus whitelist check + if plutusMultiAssetWhitelistCheck syncEnv txOuts + then mapM (prepareTxOut tracer iopts cache (txId, txHash)) txOuts + else pure mempty !redeemers <- Map.fromList <$> whenFalseMempty - (ioPlutusExtra iopts) + (isPlutusEnableOrWhitelist $ ioPlutusExtra iopts) (mapM (insertRedeemer tracer disInOut (fst <$> groupedTxOut grouped) txId) (Generic.txRedeemer tx)) - when (ioPlutusExtra iopts) $ do + when (isPlutusEnableOrWhitelist $ ioPlutusExtra iopts) $ do mapM_ (insertDatum tracer cache txId) (Generic.txData tx) mapM_ (insertCollateralTxIn tracer txId) (Generic.txCollateralInputs tx) @@ -347,11 +358,11 @@ insertTx syncEnv isMember blkId epochNo slotNo applyResult blockIndex tx grouped mapM_ (insertCollateralTxOut tracer cache iopts (txId, txHash)) (Generic.txCollateralOutputs tx) txMetadata <- - whenFalseMempty (ioMetadata iopts) $ + whenFalseMempty (isMetadataEnableOrWhiteList $ ioMetadata iopts) $ prepareTxMetadata tracer - txId iopts + txId (Generic.txMetadata tx) mapM_ (insertCertificate syncEnv isMember blkId txId epochNo slotNo redeemers) @@ -364,15 +375,16 @@ insertTx syncEnv isMember blkId epochNo slotNo applyResult blockIndex tx grouped Generic.txParamProposal tx maTxMint <- - whenFalseMempty (ioMetadata iopts) $ - prepareMaTxMint tracer cache txId $ - Generic.txMint tx + case ioMetadata iopts of + MetadataDisable -> pure mempty + MetadataEnable -> prepareMaTxMint tracer cache Nothing txId $ Generic.txMint tx + MetadataWhitelistKeys whitelist -> prepareMaTxMint tracer cache (Just whitelist) txId $ Generic.txMint tx - when (ioPlutusExtra iopts) $ + when (isPlutusEnableOrWhitelist $ ioPlutusExtra iopts) $ mapM_ (lift . insertScript tracer txId) $ Generic.txScripts tx - when (ioPlutusExtra iopts) $ + when (isPlutusEnableOrWhitelist $ ioPlutusExtra iopts) $ mapM_ (insertExtraKeyWitness tracer txId) $ Generic.txExtraKeyWitnesses tx @@ -390,38 +402,53 @@ insertTx syncEnv isMember blkId epochNo slotNo applyResult blockIndex tx grouped prepareTxOut :: (MonadBaseControl IO m, MonadIO m) => Trace IO Text -> - Cache -> InsertOptions -> + Cache -> (DB.TxId, ByteString) -> Generic.TxOut -> ExceptT SyncNodeError (ReaderT SqlBackend m) (ExtendedTxOut, [MissingMaTxOut]) -prepareTxOut tracer cache iopts (txId, txHash) (Generic.TxOut index addr value maMap mScript dt) = do - mSaId <- lift $ insertStakeAddressRefIfMissing tracer cache addr - mDatumId <- - whenFalseEmpty (ioPlutusExtra iopts) Nothing $ - Generic.whenInlineDatum dt $ - insertDatum tracer cache txId - mScriptId <- - 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 - !maTxOuts <- whenFalseMempty (ioMultiAssets iopts) $ prepareMaTxOuts tracer cache maMap - pure (eutxo, maTxOuts) +prepareTxOut tracer iopts cache (txId, txHash) (Generic.TxOut index addr value maMap mScript dt) = do + case ioPlutusExtra iopts of + -- can skip to part2 as mDatumId & mScriptId aren't needed + PlutusDisable -> buildExtendedTxOutPart2 Nothing Nothing + -- we've already done the plutus whitelist check in prepareTxOut + _ -> buildExtendedTxOutPart1 where + buildExtendedTxOutPart1 :: + (MonadBaseControl IO m, MonadIO m) => + ExceptT SyncNodeError (ReaderT SqlBackend m) (ExtendedTxOut, [MissingMaTxOut]) + buildExtendedTxOutPart1 = do + mDatumId <- Generic.whenInlineDatum dt $ insertDatum tracer cache txId + mScriptId <- whenMaybe mScript $ lift . insertScript tracer txId + buildExtendedTxOutPart2 mDatumId mScriptId + + buildExtendedTxOutPart2 :: + (MonadBaseControl IO m, MonadIO m) => + Maybe DB.DatumId -> + Maybe DB.ScriptId -> + ExceptT SyncNodeError (ReaderT SqlBackend m) (ExtendedTxOut, [MissingMaTxOut]) + buildExtendedTxOutPart2 mDatumId mScriptId = do + mSaId <- lift $ insertStakeAddressRefIfMissing tracer cache addr + 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 + case ioMultiAssets iopts of + MultiAssetDisable -> pure (eutxo, mempty) + _ -> do + !maTxOuts <- prepareMaTxOuts tracer cache Nothing maMap + pure (eutxo, maTxOuts) + hasScript :: Bool hasScript = maybe False Generic.hasCredScript (Generic.getPaymentCred addr) @@ -433,36 +460,52 @@ insertCollateralTxOut :: (DB.TxId, ByteString) -> Generic.TxOut -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertCollateralTxOut tracer cache iopts (txId, _txHash) (Generic.TxOut index addr value maMap mScript dt) = do - mSaId <- lift $ insertStakeAddressRefIfMissing tracer cache addr - mDatumId <- - whenFalseEmpty (ioPlutusExtra iopts) Nothing $ - Generic.whenInlineDatum dt $ - insertDatum tracer cache txId - mScriptId <- - whenFalseEmpty (ioPlutusExtra iopts) Nothing $ - whenMaybe mScript $ - lift . insertScript tracer txId - _ <- - lift - . DB.insertCollateralTxOut - $ DB.CollateralTxOut - { DB.collateralTxOutTxId = txId - , DB.collateralTxOutIndex = index - , DB.collateralTxOutAddress = Generic.renderAddress addr - , DB.collateralTxOutAddressHasScript = hasScript - , DB.collateralTxOutPaymentCred = Generic.maybePaymentCred addr - , DB.collateralTxOutStakeAddressId = mSaId - , DB.collateralTxOutValue = Generic.coinToDbLovelace value - , DB.collateralTxOutDataHash = Generic.dataHashToBytes <$> Generic.getTxOutDatumHash dt - , DB.collateralTxOutMultiAssetsDescr = textShow maMap - , DB.collateralTxOutInlineDatumId = mDatumId - , DB.collateralTxOutReferenceScriptId = mScriptId - } - pure () +insertCollateralTxOut tracer cache inOpts (txId, _txHash) (Generic.TxOut index addr value maMap mScript dt) = do + case ioPlutusExtra inOpts of + PlutusDisable -> do + _ <- insertColTxOutPart2 Nothing Nothing + pure () + PlutusEnable -> insertColTxOutPart1 + -- if we have a whitelist we need to check both txOutAddress OR txOutScript are in the whitelist + PlutusWhitelistScripts whitelist -> + case (mScript, Generic.maybePaymentCred addr) of + (Just script, _) -> + if Generic.txScriptHash script `elem` whitelist + then insertColTxOutPart1 + else void $ insertColTxOutPart2 Nothing Nothing + (_, Just address) -> + if address `elem` whitelist + then insertColTxOutPart1 + else void $ insertColTxOutPart2 Nothing Nothing + (Nothing, Nothing) -> void $ insertColTxOutPart2 Nothing Nothing where - -- TODO: Is there any reason to add new tables for collateral multi-assets/multi-asset-outputs + insertColTxOutPart1 = do + mDatumId <- Generic.whenInlineDatum dt $ insertDatum tracer cache txId + mScriptId <- whenMaybe mScript $ lift . insertScript tracer txId + insertColTxOutPart2 mDatumId mScriptId + pure () + + insertColTxOutPart2 mDatumId mScriptId = do + mSaId <- lift $ insertStakeAddressRefIfMissing tracer cache addr + _ <- + lift + . DB.insertCollateralTxOut + $ DB.CollateralTxOut + { DB.collateralTxOutTxId = txId + , DB.collateralTxOutIndex = index + , DB.collateralTxOutAddress = Generic.renderAddress addr + , DB.collateralTxOutAddressHasScript = hasScript + , DB.collateralTxOutPaymentCred = Generic.maybePaymentCred addr + , DB.collateralTxOutStakeAddressId = mSaId + , DB.collateralTxOutValue = Generic.coinToDbLovelace value + , DB.collateralTxOutDataHash = Generic.dataHashToBytes <$> Generic.getTxOutDatumHash dt + , DB.collateralTxOutMultiAssetsDescr = textShow maMap + , DB.collateralTxOutInlineDatumId = mDatumId + , DB.collateralTxOutReferenceScriptId = mScriptId + } + pure () + -- TODO: Is there any reason to add new tables for collateral multi-assets/multi-asset-outputs hasScript :: Bool hasScript = maybe False Generic.hasCredScript (Generic.getPaymentCred addr) @@ -1214,11 +1257,11 @@ insertRedeemerData tracer txId txd = do prepareTxMetadata :: (MonadBaseControl IO m, MonadIO m) => Trace IO Text -> - DB.TxId -> InsertOptions -> + DB.TxId -> Maybe (Map Word64 TxMetadataValue) -> ExceptT SyncNodeError (ReaderT SqlBackend m) [DB.TxMetadata] -prepareTxMetadata tracer txId inOpts mmetadata = do +prepareTxMetadata tracer inOpts txId mmetadata = do case mmetadata of Nothing -> pure [] Just metadata -> mapMaybeM prepare $ Map.toList metadata @@ -1228,14 +1271,14 @@ prepareTxMetadata tracer txId inOpts mmetadata = do (Word64, TxMetadataValue) -> ExceptT SyncNodeError (ReaderT SqlBackend m) (Maybe DB.TxMetadata) prepare (key, md) = do - case ioKeepMetadataNames inOpts of - Strict.Just metadataNames -> do - let isMatchingKey = key `elem` metadataNames - if isMatchingKey + case ioMetadata inOpts of + MetadataDisable -> mkDbTxMetadata (key, md) + MetadataEnable -> pure Nothing + MetadataWhitelistKeys whitelist -> do + -- only keep the metadata in the whitelist + if encodeUtf8 (Text.pack $ show key) `elem` whitelist then mkDbTxMetadata (key, md) else pure Nothing - -- if we have TxMetadata and keepMetadataNames is Nothing then we want to keep all metadata - Strict.Nothing -> mkDbTxMetadata (key, md) mkDbTxMetadata :: (MonadBaseControl IO m, MonadIO m) => @@ -1337,10 +1380,11 @@ prepareMaTxMint :: (MonadBaseControl IO m, MonadIO m) => Trace IO Text -> Cache -> + Maybe (NonEmpty ByteString) -> DB.TxId -> MultiAsset StandardCrypto -> ExceptT SyncNodeError (ReaderT SqlBackend m) [DB.MaTxMint] -prepareMaTxMint _tracer cache txId (MultiAsset mintMap) = +prepareMaTxMint _tracer cache mWhitelist txId (MultiAsset mintMap) = concatMapM (lift . prepareOuter) $ Map.toList mintMap where prepareOuter :: @@ -1348,29 +1392,33 @@ prepareMaTxMint _tracer cache txId (MultiAsset mintMap) = (PolicyID StandardCrypto, Map AssetName Integer) -> ReaderT SqlBackend m [DB.MaTxMint] prepareOuter (policy, aMap) = - mapM (prepareInner policy) $ Map.toList aMap + mapMaybeM (prepareInner policy) $ Map.toList aMap prepareInner :: (MonadBaseControl IO m, MonadIO m) => PolicyID StandardCrypto -> (AssetName, Integer) -> - ReaderT SqlBackend m DB.MaTxMint + ReaderT SqlBackend m (Maybe DB.MaTxMint) prepareInner policy (aname, amount) = do - maId <- insertMultiAsset cache policy aname - pure $ - DB.MaTxMint - { DB.maTxMintIdent = maId - , DB.maTxMintQuantity = DB.integerToDbInt65 amount - , DB.maTxMintTxId = txId - } + mMaId <- insertMultiAsset cache mWhitelist policy aname + pure $ case mMaId of + Just maId -> + Just $ + DB.MaTxMint + { DB.maTxMintIdent = maId + , DB.maTxMintQuantity = DB.integerToDbInt65 amount + , DB.maTxMintTxId = txId + } + Nothing -> Nothing prepareMaTxOuts :: (MonadBaseControl IO m, MonadIO m) => Trace IO Text -> Cache -> + Maybe (NonEmpty ByteString) -> Map (PolicyID StandardCrypto) (Map AssetName Integer) -> ExceptT SyncNodeError (ReaderT SqlBackend m) [MissingMaTxOut] -prepareMaTxOuts _tracer cache maMap = +prepareMaTxOuts _tracer cache mWhitelist maMap = concatMapM (lift . prepareOuter) $ Map.toList maMap where prepareOuter :: @@ -1378,32 +1426,45 @@ prepareMaTxOuts _tracer cache maMap = (PolicyID StandardCrypto, Map AssetName Integer) -> ReaderT SqlBackend m [MissingMaTxOut] prepareOuter (policy, aMap) = - mapM (prepareInner policy) $ Map.toList aMap + mapMaybeM (prepareInner policy) $ Map.toList aMap prepareInner :: (MonadBaseControl IO m, MonadIO m) => PolicyID StandardCrypto -> (AssetName, Integer) -> - ReaderT SqlBackend m MissingMaTxOut + ReaderT SqlBackend m (Maybe MissingMaTxOut) prepareInner policy (aname, amount) = do - maId <- insertMultiAsset cache policy aname - pure $ - MissingMaTxOut - { mmtoIdent = maId - , mmtoQuantity = DbWord64 (fromIntegral amount) - } + mMaId <- insertMultiAsset cache mWhitelist policy aname + pure $ case mMaId of + Just maId -> + Just $ + MissingMaTxOut + { mmtoIdent = maId + , mmtoQuantity = DbWord64 (fromIntegral amount) + } + Nothing -> Nothing insertMultiAsset :: (MonadBaseControl IO m, MonadIO m) => Cache -> + Maybe (NonEmpty ByteString) -> PolicyID StandardCrypto -> AssetName -> - ReaderT SqlBackend m DB.MultiAssetId -insertMultiAsset cache policy aName = do + ReaderT SqlBackend m (Maybe DB.MultiAssetId) +insertMultiAsset cache mWhitelist policy aName = do mId <- queryMAWithCache cache policy aName case mId of - Right maId -> pure maId + Right maId -> pure $ Just maId Left (policyBs, assetNameBs) -> + case mWhitelist of + -- we want to check the whitelist at the begining + Just whitelist -> + if policyBs `elem` whitelist + then Just <$> insertAssettIntoDB policyBs assetNameBs + else pure Nothing + Nothing -> Just <$> insertAssettIntoDB policyBs assetNameBs + where + insertAssettIntoDB policyBs assetNameBs = DB.insertMultiAssetUnchecked $ DB.MultiAsset { DB.multiAssetPolicy = policyBs diff --git a/doc/configuration.md b/doc/configuration.md index 4bd187f53..9e767c02d 100644 --- a/doc/configuration.md +++ b/doc/configuration.md @@ -155,7 +155,7 @@ Some field are left empty when using this flag, like Until the ledger state migration happens any restart requires reusing the `--bootstrap-tx-out` flag. After it's completed the flag can be omitted on restarts. -### --keep-tx-metadata +### --whitelist-tx-metadata -It keeps only metadata with the specified keys. -You can pass multiple values to the flag eg: `--keep-tx-metadata 1,2,3` make sure you are using commas between each key. +To help improved database insert thoughput, user can chose to filter specific tx metadata they would like to keep and insert, ignore everything else. +You can pass multiple values to the flag eg: `--whitelist-tx-metadata 1,2,3` make sure you are using commas between each key.