Extendend whitelist options

cardano-chain-gen/cardano-chain-gen.cabal

@@ -61,6 +61,7 @@ library
   build-depends:        base                            >= 4.14         && < 5
                       , async
                       , aeson
+                      , base16-bytestring
                       , bytestring
                       , cardano-binary
                       , cardano-crypto-class
@@ -167,6 +168,7 @@ test-suite cardano-chain-gen
                         Test.Cardano.Db.Mock.Unit.Conway.Simple
                         Test.Cardano.Db.Mock.Unit.Conway.Stake
                         Test.Cardano.Db.Mock.Unit.Conway.Tx
+                        Test.Cardano.Db.Mock.Unit.Conway.Whitelist
                         Test.Cardano.Db.Mock.UnifiedApi
                         Test.Cardano.Db.Mock.Validate
 
@@ -200,7 +202,6 @@ test-suite cardano-chain-gen
                       , stm
                       , strict-stm
                       , tasty
-                      , tasty-expected-failure
                       , tasty-quickcheck
                       , text
                       , transformers

cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo/ScriptsExamples.hs

@@ -23,6 +23,7 @@ module Cardano.Mock.Forging.Tx.Alonzo.ScriptsExamples (
   alwaysMintScriptHash,
   alwaysMintScriptAddr,
   alwaysMintScriptStake,
+  alwaysMintScriptHashRandomPolicyVal,
   scriptHash,
   assetNames,
   plutusData2,
@@ -47,6 +48,7 @@ import Codec.Serialise
 import Codec.Serialise.Encoding
 import Data.ByteString.Short
 import Data.Maybe
+import Numeric.Natural (Natural)
 import Ouroboros.Consensus.Cardano.Block (StandardAlonzo)
 import qualified PlutusCore.Data as Plutus
 import qualified PlutusLedgerApi.Test.Examples as Plutus
@@ -103,6 +105,15 @@ alwaysMintScriptStake = ScriptHashObj alwaysMintScriptHash
 mkPlutusScriptEra :: AlonzoEraScript era => PlutusBinary -> AlonzoScript era
 mkPlutusScriptEra sh = PlutusScript $ fromJust $ mkBinaryPlutusScript PlutusV1 sh
 
+alwaysMintScriptHashRandomPolicyVal :: Natural -> ScriptHash StandardCrypto
+alwaysMintScriptHashRandomPolicyVal n = scriptHash @StandardAlonzo $ alwaysMintRandomScript n
+
+alwaysMintRandomScript :: AlonzoEraScript era => Natural -> AlonzoScript era
+alwaysMintRandomScript n = mkPlutusScriptEra $ alwaysMintRandomPlutusBinary n
+
+alwaysMintRandomPlutusBinary :: Natural -> PlutusBinary
+alwaysMintRandomPlutusBinary n = PlutusBinary $ Plutus.alwaysFailingNAryFunction n
+
 scriptHash ::
   forall era.
   ( EraCrypto era ~ StandardCrypto

cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway.hs

@@ -38,6 +38,7 @@ module Cardano.Mock.Forging.Tx.Conway (
   mkNewConstitutionTx,
   mkDummyRegisterTx,
   mkDummyTxBody,
+  mkDummyTxBodyWithFee,
   mkTxDelegCert,
   mkRegTxCert,
   mkUnRegTxCert,
@@ -589,6 +590,21 @@ mkDummyTxBody =
     mempty
     (Withdrawals mempty)
 
+mkDummyTxBodyWithFee ::
+  Coin ->
+  ConwayTxBody StandardConway
+mkDummyTxBodyWithFee coin' =
+  consTxBody
+    mempty
+    mempty
+    mempty
+    mempty
+    SNothing
+    coin'
+    mempty
+    mempty
+    (Withdrawals mempty)
+
 mkFullTx ::
   Int ->
   Integer ->

cardano-chain-gen/src/Cardano/Mock/Query.hs

@@ -11,10 +11,20 @@ module Cardano.Mock.Query (
   queryGovActionCounts,
   queryConstitutionAnchor,
   queryRewardRests,
+  queryMultiAssetMetadataPolicy,
+  queryStakeAddressHashRaw,
+  queryStakeAddressCount,
+  queryCollateralTxOutCount,
+  queryPoolUpdateCount,
+  queryStakeDeRegCount,
+  queryStakeRegCount,
+  countTxOutNonNullStakeAddrIds,
 ) where
 
 import qualified Cardano.Db as Db
-import Cardano.Prelude hiding (from, on)
+import Cardano.Prelude hiding (from, isNothing, on)
+import qualified Data.ByteString.Base16 as Base16
+import Data.ByteString.Short (ShortByteString, toShort)
 import Database.Esqueleto.Experimental
 import Prelude ()
 
@@ -150,3 +160,60 @@ queryRewardRests = do
     pure (reward ^. Db.RewardRestType, reward ^. Db.RewardRestAmount)
 
   pure $ map (bimap unValue (Db.unDbLovelace . unValue)) res
+
+queryMultiAssetMetadataPolicy :: MonadIO io => ReaderT SqlBackend io (Maybe ShortByteString)
+queryMultiAssetMetadataPolicy = do
+  res <- selectOne $ do
+    metadataPolicy <- from $ table @Db.MultiAsset
+    pure $ metadataPolicy ^. Db.MultiAssetPolicy
+  pure $ toShort . Base16.encode . unValue <$> res
+
+queryStakeAddressHashRaw :: MonadIO io => ReaderT SqlBackend io (Maybe ShortByteString)
+queryStakeAddressHashRaw = do
+  res <- selectOne $ do
+    stakeAddress <- from $ table @Db.StakeAddress
+    pure $ stakeAddress ^. Db.StakeAddressHashRaw
+  pure $ toShort . Base16.encode . unValue <$> res
+
+queryStakeAddressCount :: MonadIO io => ReaderT SqlBackend io Word
+queryStakeAddressCount = do
+  res <- selectOne $ do
+    _ <- from (table @Db.StakeAddress)
+    pure countRows
+  pure $ maybe 0 unValue res
+
+queryCollateralTxOutCount :: MonadIO io => ReaderT SqlBackend io Word
+queryCollateralTxOutCount = do
+  res <- selectOne $ do
+    _ <- from (table @Db.CollateralTxOut)
+    pure countRows
+  pure $ maybe 0 unValue res
+
+queryPoolUpdateCount :: MonadIO io => ReaderT SqlBackend io Word
+queryPoolUpdateCount = do
+  res <- selectOne $ do
+    _ <- from (table @Db.PoolUpdate)
+    pure countRows
+  pure $ maybe 0 unValue res
+
+queryStakeDeRegCount :: MonadIO io => ReaderT SqlBackend io Word
+queryStakeDeRegCount = do
+  res <- selectOne $ do
+    _ <- from (table @Db.StakeDeregistration)
+    pure countRows
+  pure $ maybe 0 unValue res
+
+queryStakeRegCount :: MonadIO io => ReaderT SqlBackend io Word
+queryStakeRegCount = do
+  res <- selectOne $ do
+    _ <- from (table @Db.StakeRegistration)
+    pure countRows
+  pure $ maybe 0 unValue res
+
+countTxOutNonNullStakeAddrIds :: (MonadIO m) => SqlPersistT m Word
+countTxOutNonNullStakeAddrIds = do
+  result <- selectOne $ do
+    txOut <- from $ table @Db.TxOut
+    where_ $ not_ (isNothing $ txOut ^. Db.TxOutStakeAddressId)
+    pure countRows
+  pure $ maybe 0 unValue result

cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage.hs

@@ -9,7 +9,6 @@ module Test.Cardano.Db.Mock.Unit.Babbage (
 import Cardano.Mock.ChainSync.Server (IOManager)
 import Data.Text (Text)
 import Test.Tasty (TestTree, testGroup)
-import Test.Tasty.ExpectedFailure (expectFail)
 import Test.Tasty.HUnit (Assertion, testCase)
 
 import qualified Test.Cardano.Db.Mock.Unit.Babbage.CommandLineArg.ConfigFile as ConfigFile
@@ -25,6 +24,7 @@ import qualified Test.Cardano.Db.Mock.Unit.Babbage.Rollback as BabRollback
 import qualified Test.Cardano.Db.Mock.Unit.Babbage.Simple as BabSimple
 import qualified Test.Cardano.Db.Mock.Unit.Babbage.Stake as BabStake
 import qualified Test.Cardano.Db.Mock.Unit.Babbage.Tx as BabTx
+import Test.Cardano.Db.Mock.Validate (expectFailSilent)
 
 unitTests :: IOManager -> [(Text, Text)] -> TestTree
 unitTests iom knownMigrations =
@@ -45,9 +45,9 @@ unitTests iom knownMigrations =
             , test "no pruning and rollback" MigrateConsumedPruneTxOut.noPruneAndRollBack
             , test "prune same block" MigrateConsumedPruneTxOut.pruneSameBlock
             , test "no pruning same block" MigrateConsumedPruneTxOut.noPruneSameBlock
-            , expectFail $ test "restart with new consumed set to false" MigrateConsumedPruneTxOut.migrateAndPruneRestart
-            , expectFail $ test "set prune flag, restart missing prune flag" MigrateConsumedPruneTxOut.pruneRestartMissingFlag
-            , expectFail $ test "set bootstrap flag, restart missing bootstrap flag" MigrateConsumedPruneTxOut.bootstrapRestartMissingFlag
+            , expectFailSilent "restart with new consumed set to false" $ MigrateConsumedPruneTxOut.migrateAndPruneRestart iom knownMigrations
+            , expectFailSilent "set prune flag, restart missing prune flag" $ MigrateConsumedPruneTxOut.pruneRestartMissingFlag iom knownMigrations
+            , expectFailSilent "set bootstrap flag, restart missing bootstrap flag" $ MigrateConsumedPruneTxOut.bootstrapRestartMissingFlag iom knownMigrations
             ]
         ]
     , testGroup
@@ -63,7 +63,7 @@ unitTests iom knownMigrations =
         "Command Line Arguments"
         [ testGroup
             "config"
-            [ expectFail $ test "fails if incorrect config file given" ConfigFile.checkConfigFileArg
+            [ expectFailSilent "fails if incorrect config file given" $ ConfigFile.checkConfigFileArg iom knownMigrations
             ]
         , testGroup
             "disable-epoch"

cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway.hs

@@ -16,8 +16,9 @@ import qualified Test.Cardano.Db.Mock.Unit.Conway.Rollback as Rollback
 import qualified Test.Cardano.Db.Mock.Unit.Conway.Simple as Simple
 import qualified Test.Cardano.Db.Mock.Unit.Conway.Stake as Stake
 import qualified Test.Cardano.Db.Mock.Unit.Conway.Tx as Tx
+import qualified Test.Cardano.Db.Mock.Unit.Conway.Whitelist as Whitelist
+import Test.Cardano.Db.Mock.Validate (expectFailSilent)
 import Test.Tasty (TestTree (), testGroup)
-import Test.Tasty.ExpectedFailure (expectFail)
 import Test.Tasty.HUnit (Assertion (), testCase)
 import Prelude (String ())
 
@@ -34,6 +35,12 @@ unitTests iom knownMigrations =
         , testCase "mismatched conway genesis hash" Config.wrongConwayGenesisHash
         , testCase "default insert config" Config.defaultInsertConfig
         , testCase "insert config" Config.insertConfig
+        , testGroup
+            "invalid whitelist hashes"
+            [ testCase "Fail if Shelley stake address hash is invalid" Config.invalidShelleyStkAddrHash
+            , testCase "Fail if multi-asset policies hash is invalid" Config.invalidMultiAssetPoliciesHash
+            , testCase "Fail if Plutus script hash invalid" Config.invalidPlutusScriptHash
+            ]
         , testGroup
             "tx-out"
             [ test "consumed_by_tx_id column check" MigrateConsumedPruneTxOut.txConsumedColumnCheck
@@ -45,18 +52,9 @@ unitTests iom knownMigrations =
             , test "no pruning and rollback" MigrateConsumedPruneTxOut.noPruneAndRollBack
             , test "prune same block" MigrateConsumedPruneTxOut.pruneSameBlock
             , test "no pruning same block" MigrateConsumedPruneTxOut.noPruneSameBlock
-            , expectFail $
-                test
-                  "restart with new consumed set to false"
-                  MigrateConsumedPruneTxOut.migrateAndPruneRestart
-            , expectFail $
-                test
-                  "set prune flag, restart missing prune flag"
-                  MigrateConsumedPruneTxOut.pruneRestartMissingFlag
-            , expectFail $
-                test
-                  "set bootstrap flag, restart missing bootstrap flag"
-                  MigrateConsumedPruneTxOut.bootstrapRestartMissingFlag
+            , expectFailSilent "restart with new consumed set to false" $ MigrateConsumedPruneTxOut.migrateAndPruneRestart iom knownMigrations
+            , expectFailSilent "set prune flag, restart missing prune flag" $ MigrateConsumedPruneTxOut.pruneRestartMissingFlag iom knownMigrations
+            , expectFailSilent "set bootstrap flag, restart missing bootstrap flag" $ MigrateConsumedPruneTxOut.bootstrapRestartMissingFlag iom knownMigrations
             ]
         ]
     , testGroup
@@ -72,10 +70,7 @@ unitTests iom knownMigrations =
         "Command Line Arguments"
         [ testGroup
             "config"
-            [ expectFail $
-                test
-                  "fails if incorrect config file given"
-                  ConfigFile.checkConfigFileArg
+            [ expectFailSilent "fails if incorrect config file given" $ ConfigFile.checkConfigFileArg iom knownMigrations
             ]
         , testGroup
             "disable-epoch"
@@ -113,7 +108,6 @@ unitTests iom knownMigrations =
         , test "consume utxo same block" Tx.consumeSameBlock
         , test "tx with metadata" Tx.addTxMetadata
         , test "tx with metadata disabled" Tx.addTxMetadataDisabled
-        , test "tx with metadata whitelist" Tx.addTxMetadataWhitelist
         ]
     , testGroup
         "stake addresses"
@@ -175,6 +169,14 @@ unitTests iom knownMigrations =
         , test "swap many multi assets" Plutus.swapMultiAssets
         , test "swap with multi assets disabled" Plutus.swapMultiAssetsDisabled
         ]
+    , testGroup
+        "Whitelist"
+        [ test "add tx with whitelist" Whitelist.addTxMultiAssetsWhitelist
+        , test "tx with metadata whitelist" Whitelist.addTxMetadataWhitelist
+        , test "tx with metadata whitelist multiple" Whitelist.addTxMetadataWhitelistMultiple
+        , test "add simple tx, whitelist tx address" Whitelist.addSimpleTxStakeAddrsWhitelist
+        , test "add full tx, with stake address whitelist" Whitelist.fullTxStakeAddressWhitelist
+        ]
     , testGroup
         "Pools and smash"
         [ test "pool registration" Other.poolReg

cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Config/Parse.hs

@@ -8,22 +8,29 @@ module Test.Cardano.Db.Mock.Unit.Conway.Config.Parse (
   wrongConwayGenesisHash,
   insertConfig,
   defaultInsertConfig,
-) where
+  invalidShelleyStkAddrHash,
+  invalidMultiAssetPoliciesHash,
+  invalidPlutusScriptHash,
+)
+where
 
 import Cardano.DbSync.Config
 import Cardano.DbSync.Config.Types
 import Cardano.DbSync.Error
 import Cardano.Prelude hiding (from, isNothing)
 import qualified Data.Aeson as Aeson
 import Data.Default.Class (Default (..))
+import Data.String (String)
+import Data.Text (pack)
 import Test.Cardano.Db.Mock.Config
 import Test.Tasty.HUnit (Assertion (), assertBool, (@?=))
 import Prelude ()
 
 conwayGenesis :: Assertion
 conwayGenesis =
   mkSyncNodeConfig configDir initCommandLineArgs
-    >>= void . mkConfig configDir mutableDir cmdLineArgs
+    >>= void
+      . mkConfig configDir mutableDir cmdLineArgs
   where
     configDir = "config-conway"
     mutableDir = mkMutableDir "conwayConfigSimple"
@@ -106,3 +113,27 @@ insertConfig = do
   dncInsertOptions cfg @?= expected
   where
     configDir = "config-conway-insert-options"
+
+invalidShelleyStkAddrHash :: Assertion
+invalidShelleyStkAddrHash =
+  let invalidJson = "{ \"enable\": true, \"stake_addresses\": " <> invalidHash <> " }"
+      decodedResult :: Either String ShelleyInsertConfig
+      decodedResult = Aeson.eitherDecodeStrict $ encodeUtf8 $ pack invalidJson
+   in assertBool "Decoding should fail for invalid Shelley stake address hash" (isLeft decodedResult)
+
+invalidMultiAssetPoliciesHash :: Assertion
+invalidMultiAssetPoliciesHash =
+  let invalidJson = "{ \"enable\": true, \"policies\": " <> invalidHash <> " }"
+      decodedResult :: Either String MultiAssetConfig
+      decodedResult = Aeson.eitherDecodeStrict $ encodeUtf8 $ pack invalidJson
+   in assertBool "Decoding should fail for invalid MultiAsset policies hash" (isLeft decodedResult)
+
+invalidPlutusScriptHash :: Assertion
+invalidPlutusScriptHash =
+  let invalidJson = "{ \"enable\": true, \"script_hashes\": " <> invalidHash <> " }"
+      decodedResult :: Either String PlutusConfig
+      decodedResult = Aeson.eitherDecodeStrict $ encodeUtf8 $ pack invalidJson
+   in assertBool "Decoding should fail for invalid Plutus script hash" (isLeft decodedResult)
+
+invalidHash :: String
+invalidHash = "[\"\\xe0758b08dea05dabd1cd3510689ebd9efb6a49316acb30eead750e2e9e\"]"