Extendend whitelist options

Author: Cmdv

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
@@ -166,6 +167,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
 

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

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

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

@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Cardano.Mock.Query (
@@ -11,11 +12,24 @@ module Cardano.Mock.Query (
   queryGovActionCounts,
   queryConstitutionAnchor,
   queryRewardRests,
+  queryCollateralTxOutCount,
+  queryMultiAssetMetadataPolicy,
+  queryPoolUpdateCount,
+  queryStakeAddressCount,
+  queryStakeAddressHashRaw,
+  queryStakeDeRegCount,
+  queryStakeRegCount,
   queryTreasuryDonations,
+  countTxOutNonNullStakeAddrIds,
 ) where
 
+import Cardano.Db (TxOutTableType (..))
 import qualified Cardano.Db as Db
-import Cardano.Prelude hiding (from, on)
+import qualified Cardano.Db.Schema.Core.TxOut as C
+import qualified Cardano.Db.Schema.Variant.TxOut as V
+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 ()
 
@@ -162,3 +176,81 @@ queryTreasuryDonations = do
 
   let total = join (unValue <$> res)
   pure $ maybe 0 Db.unDbLovelace total
+
+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 =>
+  TxOutTableType ->
+  ReaderT SqlBackend m Word
+countTxOutNonNullStakeAddrIds txOutTableType = do
+  case txOutTableType of
+    TxOutCore -> queryCore
+    TxOutVariantAddress -> queryVariant
+  where
+    queryCore ::
+      MonadIO m =>
+      ReaderT SqlBackend m Word
+    queryCore = do
+      result <- selectOne $ do
+        txOut <- from $ table @C.TxOut
+        where_ $ not_ (isNothing $ txOut ^. C.TxOutStakeAddressId)
+        pure countRows
+      pure $ maybe 0 unValue result
+
+    queryVariant ::
+      MonadIO m =>
+      ReaderT SqlBackend m Word
+    queryVariant = do
+      result <- selectOne $ do
+        txOut <- from $ table @V.Address
+        where_ $ not_ (isNothing $ txOut ^. V.AddressStakeAddressId)
+        pure countRows
+      pure $ maybe 0 unValue result

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

@@ -35,6 +35,12 @@ module Test.Cardano.Db.Mock.Config (
   configMetadataEnable,
   configMetadataDisable,
   configMetadataKeys,
+  configMultipleMetadataKeys,
+  configMulitiAssetPoliciesKeys,
+  configShelleyStakeAddrKeys,
+  configMultipleShelleyStakeAddrKeys,
+
+  -- * Make Functions
   mkFingerPrint,
   mkMutableDir,
   mkDBSyncEnv,
@@ -90,6 +96,7 @@ import Control.Monad.Extra (eitherM)
 import Control.Monad.Logger (NoLoggingT, runNoLoggingT)
 import Control.Monad.Trans.Except.Extra (runExceptT)
 import Control.Tracer (nullTracer)
+import Data.ByteString.Short (ShortByteString)
 import Data.Text (Text)
 import Database.Persist.Postgresql (createPostgresqlPool)
 import Database.Persist.Sql (SqlBackend)
@@ -354,6 +361,22 @@ configMetadataKeys :: SyncNodeConfig -> SyncNodeConfig
 configMetadataKeys cfg = do
   cfg {dncInsertOptions = (dncInsertOptions cfg) {sioMetadata = MetadataKeys $ 1 :| []}}
 
+configMultipleMetadataKeys :: SyncNodeConfig -> SyncNodeConfig
+configMultipleMetadataKeys cfg = do
+  cfg {dncInsertOptions = (dncInsertOptions cfg) {sioMetadata = MetadataKeys $ 1 :| [6]}}
+
+configMulitiAssetPoliciesKeys :: ShortByteString -> SyncNodeConfig -> SyncNodeConfig
+configMulitiAssetPoliciesKeys maPolicyShortBs cfg = do
+  cfg {dncInsertOptions = (dncInsertOptions cfg) {sioMultiAsset = MultiAssetPolicies $ maPolicyShortBs :| []}}
+
+configShelleyStakeAddrKeys :: ShortByteString -> SyncNodeConfig -> SyncNodeConfig
+configShelleyStakeAddrKeys shelleyStakeAddrShortBs cfg = do
+  cfg {dncInsertOptions = (dncInsertOptions cfg) {sioShelley = ShelleyStakeAddrs $ shelleyStakeAddrShortBs :| []}}
+
+configMultipleShelleyStakeAddrKeys :: NonEmpty ShortByteString -> SyncNodeConfig -> SyncNodeConfig
+configMultipleShelleyStakeAddrKeys shelleyStakeAddrShortBs cfg = do
+  cfg {dncInsertOptions = (dncInsertOptions cfg) {sioShelley = ShelleyStakeAddrs shelleyStakeAddrShortBs}}
+
 initCommandLineArgs :: CommandLineArgs
 initCommandLineArgs =
   CommandLineArgs

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

@@ -16,6 +16,7 @@ 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.HUnit (Assertion (), testCase)
@@ -42,6 +43,12 @@ unitTests iom knownMigrations =
                 "remove jsonb from schema and add back"
                 Config.configJsonbInSchemaShouldRemoveThenAdd
             ]
+        , 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 "basic prune" MigrateConsumedPruneTxOut.basicPrune
@@ -135,7 +142,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"
@@ -197,6 +203,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"
@@ -109,3 +116,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\"]"

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

@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications #-}
 
 #if __GLASGOW_HASKELL__ >= 908

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

@@ -416,7 +416,7 @@ registerStakeCreds = do
 
 registerStakeCredsNoShelley :: IOManager -> [(Text, Text)] -> Assertion
 registerStakeCredsNoShelley = do
-  withCustomConfig args (Just configShelleyDisable) cfgDir testLabel $ \interpreter mockServer dbSync -> do
+  withCustomConfigAndDropDB args (Just configShelleyDisable) cfgDir testLabel $ \interpreter mockServer dbSync -> do
     startDBSync dbSync
 
     -- These should not be saved when shelley is disabled

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

@@ -13,7 +13,6 @@ module Test.Cardano.Db.Mock.Unit.Conway.Tx (
   consumeSameBlock,
   addTxMetadata,
   addTxMetadataDisabled,
-  addTxMetadataWhitelist,
 ) where
 
 import Cardano.Ledger.Shelley.TxAuxData (Metadatum (..))
@@ -143,30 +142,6 @@ addTxMetadata = do
     testLabel = "conwayConfigMetadataEnabled"
     cfgDir = conwayConfigDir
 
-addTxMetadataWhitelist :: IOManager -> [(Text, Text)] -> Assertion
-addTxMetadataWhitelist = do
-  withCustomConfigAndDropDB args (Just configMetadataKeys) cfgDir testLabel $ \interpreter mockServer dbSync -> do
-    startDBSync dbSync
-
-    -- Add blocks with transactions
-    void $ do
-      UnifiedApi.withConwayFindLeaderAndSubmitTx interpreter mockServer $ \_ ->
-        let txBody = Conway.mkDummyTxBody
-            auxData = Map.fromList [(1, I 1), (2, I 2)]
-         in Right (Conway.mkAuxDataTx True txBody auxData)
-
-    -- Wait for it to sync
-    assertBlockNoBackoff dbSync 1
-    -- Should have tx metadata
-    assertEqBackoff dbSync queryTxMetadataCount 1 [] "Expected tx metadata"
-  where
-    args =
-      initCommandLineArgs
-        { claFullMode = False
-        }
-    testLabel = "conwayConfigMetadataKeep"
-    cfgDir = conwayConfigDir
-
 addTxMetadataDisabled :: IOManager -> [(Text, Text)] -> Assertion
 addTxMetadataDisabled = do
   withCustomConfigAndDropDB args (Just configMetadataDisable) cfgDir testLabel $