refine the whitelist logic

IntersectMBO · Feb 9, 2024 · 85527d3 · 85527d3
1 parent 602414f
commit 85527d3
Show file tree

Hide file tree

Showing 2 changed files with 70 additions and 42 deletions.
diff --git a/cardano-db-sync/src/Cardano/DbSync/Config.hs b/cardano-db-sync/src/Cardano/DbSync/Config.hs
@@ -20,7 +20,7 @@ module Cardano.DbSync.Config (
   readCardanoGenesisConfig,
   readSyncNodeConfig,
   configureLogging,
-  plutusWhitelistCheckTxOut,
+  plutusMultiAssetWhitelistCheck,
 ) where
 
 import qualified Cardano.BM.Configuration.Model as Logging
@@ -33,7 +33,10 @@ import Cardano.DbSync.Config.Node (NodeConfig (..), parseNodeConfig, parseSyncPr
 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)
@@ -92,27 +95,60 @@ coalesceConfig pcfg ncfg adjustGenesisPath = do
 mkAdjustPath :: SyncPreConfig -> (FilePath -> FilePath)
 mkAdjustPath cfg fp = takeDirectory (pcNodeConfigFilePath cfg) </> fp
 
--- do a whitelist check against a list of TxOut and if one matches we keep them all
-plutusWhitelistCheckTxOut :: SyncEnv -> [Generic.TxOut] -> Bool
-plutusWhitelistCheckTxOut syncEnv txOuts = do
-  let iopts = soptInsertOptions $ envOptions syncEnv
+-- check both whitelist but also checking plutus Maybes first
+-- TODO: cmdv: unsure if this is correct because if plutusMaybeCheck fails then no multiasset whitelist is not checked
+plutusMultiAssetWhitelistCheck :: SyncEnv -> [Generic.TxOut] -> Bool
+plutusMultiAssetWhitelistCheck syncEnv txOuts =
+  plutusMaybeCheck txOuts && (plutusWhitelistCheck syncEnv txOuts || multiAssetWhitelistCheck syncEnv txOuts)
+
+plutusMaybeCheck :: [Generic.TxOut] -> Bool
+plutusMaybeCheck =
+  any (\txOut -> isJust (Generic.txOutScript txOut) || isJust (Generic.maybePaymentCred $ Generic.txOutAddress txOut))
+
+plutusWhitelistCheck :: SyncEnv -> [Generic.TxOut] -> Bool
+plutusWhitelistCheck syncEnv txOuts = do
+  -- first check the config option
   case ioPlutusExtra iopts of
     PlutusEnable -> True
     PlutusDisable -> False
-    PlutusWhitelistScripts whitelist -> do
-      -- we map over our txOuts and check if txOutAddress OR txOutScript are in the whitelist
-      let whitelistCheck =
-            ( \txOut ->
-                case (Generic.txOutScript txOut, Generic.maybePaymentCred $ Generic.txOutAddress txOut) of
-                  (Just script, _) ->
-                    if Generic.txScriptHash script `elem` whitelist
-                      then Just txOut
-                      else Nothing
-                  (_, Just address) ->
-                    if address `elem` whitelist
-                      then Just txOut
-                      else Nothing
-                  (Nothing, Nothing) -> Nothing
-            )
-              <$> txOuts
-      any isJust whitelistCheck
+    PlutusWhitelistScripts plutusWhitelist -> plutuswhitelistCheck plutusWhitelist
+  where
+    iopts = soptInsertOptions $ envOptions syncEnv
+    plutuswhitelistCheck whitelist = do
+      any
+        ( isJust
+            . ( \txOut -> do
+                  case (Generic.txOutScript txOut, Generic.maybePaymentCred $ Generic.txOutAddress txOut) of
+                    (Just script, _) ->
+                      if Generic.txScriptHash script `elem` whitelist
+                        then Just txOut
+                        else Nothing
+                    (_, Just address) ->
+                      if address `elem` whitelist
+                        then Just txOut
+                        else Nothing
+                    (Nothing, Nothing) -> Nothing
+              )
+        )
+        txOuts
+
+multiAssetWhitelistCheck :: SyncEnv -> [Generic.TxOut] -> Bool
+multiAssetWhitelistCheck syncEnv txOuts = do
+  let iopts = soptInsertOptions $ envOptions syncEnv
+  case ioMultiAssets iopts of
+    MultiAssetEnable -> True
+    MultiAssetDisable -> False
+    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/Era/Shelley/Insert.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs
@@ -43,7 +43,7 @@ import Cardano.DbSync.Cache (
 import Cardano.DbSync.Cache.Epoch (writeEpochBlockDiffToCache)
 import Cardano.DbSync.Cache.Types (Cache (..), CacheNew (..), EpochBlockDiff (..))
 
-import Cardano.DbSync.Config (plutusWhitelistCheckTxOut)
+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 (
@@ -324,8 +324,7 @@ insertTx syncEnv isMember blkId epochNo slotNo applyResult blockIndex tx grouped
     then do
       !txOutsGrouped <- do
         let txOuts = Generic.txOutputs tx
-        -- we do a plutus whitelist check
-        if plutusWhitelistCheckTxOut syncEnv txOuts
+        if plutusMultiAssetWhitelistCheck syncEnv txOuts
           then mapM (prepareTxOut tracer iopts cache (txId, txHash)) txOuts
           else pure mempty
 
@@ -339,7 +338,7 @@ insertTx syncEnv isMember blkId epochNo slotNo applyResult blockIndex tx grouped
       !txOutsGrouped <- do
         let txOuts = Generic.txOutputs tx
         -- we do a plutus whitelist check
-        if plutusWhitelistCheckTxOut syncEnv txOuts
+        if plutusMultiAssetWhitelistCheck syncEnv txOuts
           then mapM (prepareTxOut tracer iopts cache (txId, txHash)) txOuts
           else pure mempty
 
@@ -380,7 +379,7 @@ insertTx syncEnv isMember blkId epochNo slotNo applyResult blockIndex tx grouped
           MetadataDisable -> pure mempty
           MetadataEnable -> prepareMaTxMint tracer cache Nothing txId $ Generic.txMint tx
           MetadataWhitelistKeys whitelist -> prepareMaTxMint tracer cache (Just whitelist) txId $ Generic.txMint tx
-      -- TODO: cmdv do whitelist check here maybe?
+
       when (isPlutusEnableOrWhitelist $ ioPlutusExtra iopts) $
         mapM_ (lift . insertScript tracer txId) $
           Generic.txScripts tx
@@ -408,7 +407,7 @@ prepareTxOut ::
   (DB.TxId, ByteString) ->
   Generic.TxOut ->
   ExceptT SyncNodeError (ReaderT SqlBackend m) (ExtendedTxOut, [MissingMaTxOut])
-prepareTxOut tracer iopts cache (txId, txHash) (Generic.TxOut index addr addrRaw value maMap mScript dt) = do
+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
@@ -419,8 +418,8 @@ prepareTxOut tracer iopts cache (txId, txHash) (Generic.TxOut index addr addrRaw
       (MonadBaseControl IO m, MonadIO m) =>
       ExceptT SyncNodeError (ReaderT SqlBackend m) (ExtendedTxOut, [MissingMaTxOut])
     buildExtendedTxOutPart1 = do
-      mDatumId <- whenFalseEmpty (ioPlutusExtra iopts) Nothing $ Generic.whenInlineDatum dt $ insertDatum tracer cache txId
-      mScriptId <-  whenFalseEmpty (ioPlutusExtra iopts) Nothing $ whenMaybe mScript $ lift . insertScript tracer txId
+      mDatumId <- Generic.whenInlineDatum dt $ insertDatum tracer cache txId
+      mScriptId <- whenMaybe mScript $ lift . insertScript tracer txId
       buildExtendedTxOutPart2 mDatumId mScriptId
 
     buildExtendedTxOutPart2 ::
@@ -435,7 +434,6 @@ prepareTxOut tracer iopts cache (txId, txHash) (Generic.TxOut index addr addrRaw
               { DB.txOutTxId = txId
               , DB.txOutIndex = index
               , DB.txOutAddress = Generic.renderAddress addr
-              , DB.txOutAddressRaw = addrRaw
               , DB.txOutAddressHasScript = hasScript
               , DB.txOutPaymentCred = Generic.maybePaymentCred addr
               , DB.txOutStakeAddressId = mSaId
@@ -447,14 +445,9 @@ prepareTxOut tracer iopts cache (txId, txHash) (Generic.TxOut index addr addrRaw
       let !eutxo = ExtendedTxOut txHash txOut
       case ioMultiAssets iopts of
         MultiAssetDisable -> pure (eutxo, mempty)
-        -- prepareMaTxOuts with NO multi asset whitelist check
-        MultiAssetEnable -> do
+        _ -> do
           !maTxOuts <- prepareMaTxOuts tracer cache Nothing maMap
           pure (eutxo, maTxOuts)
-        -- prepareMaTxOuts with a multiasset whitelist check
-        MultiAssetWhitelistPolicies whitelist -> do
-          !maTxOuts <- prepareMaTxOuts tracer cache (Just whitelist) maMap
-          pure (eutxo, maTxOuts)
 
     hasScript :: Bool
     hasScript = maybe False Generic.hasCredScript (Generic.getPaymentCred addr)
@@ -467,7 +460,7 @@ insertCollateralTxOut ::
   (DB.TxId, ByteString) ->
   Generic.TxOut ->
   ExceptT SyncNodeError (ReaderT SqlBackend m) ()
-insertCollateralTxOut tracer cache inOpts (txId, _txHash) (Generic.TxOut index addr addrRaw value maMap mScript dt) = do
+insertCollateralTxOut tracer cache inOpts (txId, _txHash) (Generic.TxOut index addr value maMap mScript dt) = do
   case ioPlutusExtra inOpts of
     PlutusDisable -> do
       _ <- insertColTxOutPart2 Nothing Nothing
@@ -487,8 +480,8 @@ insertCollateralTxOut tracer cache inOpts (txId, _txHash) (Generic.TxOut index a
         (Nothing, Nothing) -> void $ insertColTxOutPart2 Nothing Nothing
   where
     insertColTxOutPart1 = do
-      mDatumId <- whenFalseEmpty (isPlutusEnableOrWhitelist iopts) Nothing $ Generic.whenInlineDatum dt $ insertDatum tracer cache txId
-      mScriptId <- whenFalseEmpty (isPlutusEnableOrWhitelist iopts) Nothing $ whenMaybe mScript $ lift . insertScript tracer txId
+      mDatumId <- Generic.whenInlineDatum dt $ insertDatum tracer cache txId
+      mScriptId <- whenMaybe mScript $ lift . insertScript tracer txId
       insertColTxOutPart2 mDatumId mScriptId
       pure ()
 
@@ -501,7 +494,6 @@ insertCollateralTxOut tracer cache inOpts (txId, _txHash) (Generic.TxOut index a
             { DB.collateralTxOutTxId = txId
             , DB.collateralTxOutIndex = index
             , DB.collateralTxOutAddress = Generic.renderAddress addr
-            , DB.collateralTxOutAddressRaw = addrRaw
             , DB.collateralTxOutAddressHasScript = hasScript
             , DB.collateralTxOutPaymentCred = Generic.maybePaymentCred addr
             , DB.collateralTxOutStakeAddressId = mSaId
@@ -1465,8 +1457,8 @@ insertMultiAsset cache mWhitelist policy aName = do
     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