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.