review changes to whitelists

cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Query.hs

@@ -8,7 +8,6 @@
 module Cardano.DbSync.Era.Shelley.Query (
   queryPoolHashId,
   queryStakeAddress,
-  queryMultipleStakeAddress,
   queryStakeRefPtr,
   resolveInputTxId,
   resolveInputTxOutId,
@@ -30,7 +29,6 @@ import Database.Esqueleto.Experimental (
   Value (..),
   desc,
   from,
-  in_,
   innerJoin,
   just,
   limit,
@@ -39,7 +37,6 @@ import Database.Esqueleto.Experimental (
   select,
   table,
   val,
-  valList,
   where_,
   (:&) ((:&)),
   (==.),
@@ -67,17 +64,6 @@ queryStakeAddress addr = do
     pure (saddr ^. StakeAddressId)
   pure $ maybeToEither (DbLookupMessage $ "StakeAddress " <> renderByteArray addr) unValue (listToMaybe res)
 
-queryMultipleStakeAddress ::
-  MonadIO m =>
-  [ByteString] ->
-  ReaderT SqlBackend m (Either LookupFail [StakeAddressId])
-queryMultipleStakeAddress addrs = do
-  res <- select $ do
-    saddr <- from $ table @StakeAddress
-    where_ (saddr ^. StakeAddressHashRaw `in_` valList addrs)
-    pure (saddr ^. StakeAddressId)
-  pure $ Right $ map unValue res
-
 resolveInputTxId :: MonadIO m => Generic.TxIn -> ReaderT SqlBackend m (Either LookupFail TxId)
 resolveInputTxId = queryTxId . Generic.txInHash
 

cardano-db-sync/src/Cardano/DbSync/Era/Universal/Epoch.hs

@@ -36,7 +36,7 @@ import Cardano.DbSync.Era.Universal.Insert.Other (toDouble)
 import Cardano.DbSync.Error
 import Cardano.DbSync.Ledger.Event
 import Cardano.DbSync.Types
-import Cardano.DbSync.Util (whenStrictJust)
+import Cardano.DbSync.Util (whenFalseEmpty, whenStrictJust)
 import Cardano.DbSync.Util.Constraint (constraintNameEpochStake, constraintNameReward)
 import Cardano.DbSync.Util.Whitelist (shelleyStakeAddrWhitelistCheck)
 import qualified Cardano.Ledger.Address as Ledger
@@ -217,23 +217,21 @@ insertEpochStake syncEnv nw epochNo stakeChunk = do
       (StakeCred, (Shelley.Coin, PoolKeyHash)) ->
       ExceptT SyncNodeError (ReaderT SqlBackend m) (Maybe DB.EpochStake)
     mkStake cache (saddr, (coin, pool)) =
-      -- Check if the stake address is in the shelley whitelist
-      if shelleyStakeAddrWhitelistCheck syncEnv $ Ledger.RewardAccount nw saddr
-        then
-          ( do
-              saId <- lift $ queryOrInsertStakeAddress syncEnv cache CacheNew nw saddr
-              poolId <- lift $ queryPoolKeyOrInsert "insertEpochStake" syncEnv cache CacheNew (isShelleyModeActive $ ioShelley iopts) pool
-              pure $
-                Just $
-                  DB.EpochStake
-                    { DB.epochStakeAddrId = saId
-                    , DB.epochStakePoolId = poolId
-                    , DB.epochStakeAmount = Generic.coinToDbLovelace coin
-                    , DB.epochStakeEpochNo = unEpochNo epochNo -- The epoch where this delegation becomes valid.
-                    }
-          )
-        else pure Nothing
-
+      whenFalseEmpty
+        (shelleyStakeAddrWhitelistCheck syncEnv $ Ledger.RewardAccount nw saddr)
+        Nothing
+        ( do
+            saId <- lift $ queryOrInsertStakeAddress syncEnv cache CacheNew nw saddr
+            poolId <- lift $ queryPoolKeyOrInsert "insertEpochStake" syncEnv cache CacheNew (isShelleyModeActive $ ioShelley iopts) pool
+            pure $
+              Just $
+                DB.EpochStake
+                  { DB.epochStakeAddrId = saId
+                  , DB.epochStakePoolId = poolId
+                  , DB.epochStakeAmount = Generic.coinToDbLovelace coin
+                  , DB.epochStakeEpochNo = unEpochNo epochNo -- The epoch where this delegation becomes valid.
+                  }
+        )
     iopts = getInsertOptions syncEnv
 
 insertRewards ::

cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Other.hs

@@ -14,6 +14,7 @@ module Cardano.DbSync.Era.Universal.Insert.Other (
   insertRedeemerData,
   insertStakeAddressRefIfMissing,
   insertMultiAsset,
+  insertScriptWithWhitelist,
   insertScript,
   insertExtraKeyWitness,
 )
@@ -30,7 +31,7 @@ import Cardano.DbSync.Era.Universal.Insert.Grouped
 import Cardano.DbSync.Era.Util (safeDecodeToJson)
 import Cardano.DbSync.Error
 import Cardano.DbSync.Util
-import Cardano.DbSync.Util.Whitelist (isSimplePlutusScriptHashInWhitelist, shelleyStakeAddrWhitelistCheck)
+import Cardano.DbSync.Util.Whitelist (shelleyStakeAddrWhitelistCheck, isSimplePlutusScriptHashInWhitelist)
 import qualified Cardano.Ledger.Address as Ledger
 import qualified Cardano.Ledger.BaseTypes as Ledger
 import Cardano.Ledger.Coin (Coin (..))
@@ -95,7 +96,7 @@ insertRedeemerData syncEnv txId txd = do
   case mRedeemerDataId of
     Just redeemerDataId -> pure redeemerDataId
     Nothing -> do
-      value <- safeDecodeToJson tracer "insertRedeemerData: Column 'value' in table 'datum' " $ Generic.txDataValue txd
+      value <- safeDecodeToJson syncEnv "insertRedeemerData: Column 'value' in table 'datum' " $ Generic.txDataValue txd
       lift
         . DB.insertRedeemerData
         $ DB.RedeemerData
@@ -120,7 +121,7 @@ insertDatum syncEnv cache txId txd = do
   case mDatumId of
     Just datumId -> pure datumId
     Nothing -> do
-      value <- safeDecodeToJson tracer "insertDatum: Column 'value' in table 'redeemer' " $ Generic.txDataValue txd
+      value <- safeDecodeToJson syncEnv "insertDatum: Column 'value' in table 'redeemer' " $ Generic.txDataValue txd
       lift $
         insertDatumAndCache cache (Generic.txDataHash txd) $
           DB.Datum
@@ -168,10 +169,10 @@ insertStakeAddressRefIfMissing syncEnv cache addr = do
       case sref of
         Ledger.StakeRefBase cred -> do
           -- Check if the stake address is in the shelley whitelist
-          if shelleyStakeAddrWhitelistCheck syncEnv $ Ledger.RewardAccount nw cred
-            then do
-              Just <$> queryOrInsertStakeAddress syncEnv cache DontCacheNew nw cred
-            else pure Nothing
+          whenFalseEmpty
+            (shelleyStakeAddrWhitelistCheck syncEnv $ Ledger.RewardAccount nw cred)
+            Nothing
+            (Just <$> queryOrInsertStakeAddress syncEnv cache DontCacheNew nw cred)
         Ledger.StakeRefPtr ptr -> do
           queryStakeRefPtr ptr
         Ledger.StakeRefNull -> pure Nothing
@@ -204,36 +205,42 @@ insertMultiAsset cache mWhitelist policy aName = do
           , DB.multiAssetFingerprint = DB.unAssetFingerprint (DB.mkAssetFingerprint policyBs assetNameBs)
           }
 
-insertScript ::
+insertScriptWithWhitelist ::
   (MonadBaseControl IO m, MonadIO m) =>
   SyncEnv ->
   DB.TxId ->
   Generic.TxScript ->
   ReaderT SqlBackend m (Maybe DB.ScriptId)
-insertScript syncEnv txId script =
-  if isSimplePlutusScriptHashInWhitelist syncEnv $ Generic.txScriptHash script
-    then do
-      mScriptId <- DB.queryScript $ Generic.txScriptHash script
-      case mScriptId of
-        Just scriptId -> pure $ Just scriptId
-        Nothing -> do
-          json <- scriptConvert script
-          mInScript <-
-            DB.insertScript $
-              DB.Script
-                { DB.scriptTxId = txId
-                , DB.scriptHash = Generic.txScriptHash script
-                , DB.scriptType = Generic.txScriptType script
-                , DB.scriptSerialisedSize = Generic.txScriptPlutusSize script
-                , DB.scriptJson = json
-                , DB.scriptBytes = Generic.txScriptCBOR script
-                }
-          pure $ Just mInScript
+insertScriptWithWhitelist syncEnv txId script = do
+ if isSimplePlutusScriptHashInWhitelist syncEnv $ Generic.txScriptHash script
+    then insertScript syncEnv txId script <&> Just
     else pure Nothing
+
+insertScript ::
+  (MonadBaseControl IO m, MonadIO m) =>
+  SyncEnv ->
+  DB.TxId ->
+  Generic.TxScript ->
+  ReaderT SqlBackend m DB.ScriptId
+insertScript syncEnv txId script = do
+  mScriptId <- DB.queryScript $ Generic.txScriptHash script
+  case mScriptId of
+    Just scriptId -> pure scriptId
+    Nothing -> do
+      json <- scriptConvert script
+      DB.insertScript $
+          DB.Script
+            { DB.scriptTxId = txId
+            , DB.scriptHash = Generic.txScriptHash script
+            , DB.scriptType = Generic.txScriptType script
+            , DB.scriptSerialisedSize = Generic.txScriptPlutusSize script
+            , DB.scriptJson = json
+            , DB.scriptBytes = Generic.txScriptCBOR script
+            }
   where
     scriptConvert :: (MonadIO m) => Generic.TxScript -> m (Maybe Text)
     scriptConvert s =
-      maybe (pure Nothing) (safeDecodeToJson tracer "insertScript: Column 'json' in table 'script' ") (Generic.txScriptJson s)
+      maybe (pure Nothing) (safeDecodeToJson syncEnv "insertScript: Column 'json' in table 'script' ") (Generic.txScriptJson s)
 
 insertExtraKeyWitness ::
   (MonadBaseControl IO m, MonadIO m) =>

cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Tx.hs

@@ -37,7 +37,7 @@ import Cardano.DbSync.Era.Universal.Insert.Other (
   insertRedeemer,
   insertScript,
   insertStakeAddressRefIfMissing,
-  insertWithdrawals,
+  insertWithdrawals, insertScriptWithWhitelist,
  )
 import Cardano.DbSync.Era.Universal.Insert.Pool (IsPoolMember)
 import Cardano.DbSync.Era.Util (liftLookupFail, safeDecodeToJson)
@@ -80,6 +80,7 @@ insertTx syncEnv isMember blkId epochNo slotNo applyResult blockIndex tx grouped
   let !outSum = fromIntegral $ unCoin $ Generic.txOutSum tx
       !withdrawalSum = fromIntegral $ unCoin $ Generic.txWithdrawalSum tx
       hasConsumed = getHasConsumedOrPruneTxOut syncEnv
+
   disInOut <- liftIO $ getDisableInOutState syncEnv
   -- In some txs and with specific configuration we may be able to find necessary data within the tx body.
   -- In these cases we can avoid expensive queries.
@@ -123,8 +124,9 @@ insertTx syncEnv isMember blkId epochNo slotNo applyResult blockIndex tx grouped
 
   if not (Generic.txValidContract tx)
     then do
+
       !txOutsGrouped <- do
-        if plutusMultiAssetWhitelistCheck syncEnv txMints txOuts
+        if isplutusMultiAssetInWhitelist
           then mapMaybeM (insertTxOut syncEnv cache iopts (txId, txHash)) txOuts
           else pure mempty
 
@@ -136,7 +138,7 @@ insertTx syncEnv isMember blkId epochNo slotNo applyResult blockIndex tx grouped
       -- The following operations only happen if the script passes stage 2 validation (or the tx has
       -- no script).
       !txOutsGrouped <- do
-        if plutusMultiAssetWhitelistCheck syncEnv txMints txOuts
+        if isplutusMultiAssetInWhitelist
           then mapMaybeM (insertTxOut syncEnv cache iopts (txId, txHash)) txOuts
           else pure mempty
 
@@ -150,9 +152,9 @@ insertTx syncEnv isMember blkId epochNo slotNo applyResult blockIndex tx grouped
         mapM_ (insertDatum syncEnv cache txId) (Generic.txData tx)
         mapM_ (insertCollateralTxIn tracer txId) (Generic.txCollateralInputs tx)
         mapM_ (insertReferenceTxIn tracer txId) (Generic.txReferenceInputs tx)
-        mapM_ (insertCollateralTxOut syncEnv cache (txId, txHash)) (Generic.txCollateralOutputs tx)
-        mapM_ (lift . insertScript syncEnv txId) $ Generic.txScripts tx
         mapM_ (insertExtraKeyWitness txId) $ Generic.txExtraKeyWitnesses tx
+        mapM_ (lift . insertScriptWithWhitelist syncEnv txId) $ Generic.txScripts tx
+        mapM_ (insertCollateralTxOut syncEnv cache (txId, txHash)) (Generic.txCollateralOutputs tx)
 
       txMetadata <- do
         case ioMetadata iopts of
@@ -187,6 +189,8 @@ insertTx syncEnv isMember blkId epochNo slotNo applyResult blockIndex tx grouped
     cache = envCache syncEnv
     iopts = getInsertOptions syncEnv
     mDeposits = maybeFromStrict $ apDeposits applyResult
+    isplutusMultiAssetInWhitelist = plutusMultiAssetWhitelistCheck syncEnv txMints txOuts
+
 
 --------------------------------------------------------------------------------------
 -- INSERT TXOUT
@@ -210,7 +214,7 @@ insertTxOut syncEnv cache iopts (txId, txHash) (Generic.TxOut index addr value m
     buildExtendedTxOutPart1 = do
       mDatumId <- Generic.whenInlineDatum dt $ insertDatum syncEnv cache txId
       mScriptId <- case mScript of
-        Just script -> lift $ insertScript syncEnv txId script
+        Just script -> lift $ Just <$> insertScript syncEnv txId script
         Nothing -> pure Nothing
       buildExtendedTxOutPart2 mDatumId mScriptId
 
@@ -290,7 +294,7 @@ prepareTxMetadata syncEnv mWhitelist txId mmetadata =
     mkDbTxMetadata (key, md) = do
       let jsonbs = LBS.toStrict $ Aeson.encode (metadataValueToJsonNoSchema md)
           singleKeyCBORMetadata = serialiseTxMetadataToCbor $ Map.singleton key md
-      mjson <- safeDecodeToJson tracer "prepareTxMetadata: Column 'json' in table 'metadata' " jsonbs
+      mjson <- safeDecodeToJson syncEnv "prepareTxMetadata: Column 'json' in table 'metadata' " jsonbs
       pure $
         DB.TxMetadata
           { DB.txMetadataKey = DbWord64 key
@@ -386,7 +390,7 @@ insertCollateralTxOut syncEnv cache (txId, _txHash) txout@(Generic.TxOut index a
     insertColTxOutPart1 = do
       mDatumId <- Generic.whenInlineDatum dt $ insertDatum syncEnv cache txId
       mScriptId <- case mScript of
-        Just script -> lift $ insertScript syncEnv txId script
+        Just script -> lift $ Just <$> insertScript syncEnv txId script
         Nothing -> pure Nothing
       insertColTxOutPart2 mDatumId mScriptId
       pure ()

cardano-db-sync/src/Cardano/DbSync/Util/Whitelist.hs

@@ -26,18 +26,17 @@ plutusMultiAssetWhitelistCheck ::
 plutusMultiAssetWhitelistCheck syncEnv txMints txOuts =
   isPlutusScriptHashesInWhitelist syncEnv txOuts || isMAPoliciesInWhitelist syncEnv txMints txOuts
 
+-- | Check if any script hash or address is in the whitelist
 isPlutusScriptHashesInWhitelist :: SyncEnv -> [Generic.TxOut] -> Bool
 isPlutusScriptHashesInWhitelist syncEnv txOuts = do
-  -- first check the config option
   case ioPlutus iopts of
     PlutusEnable -> True
     PlutusDisable -> False
-    PlutusScripts plutusWhitelist -> plutuswhitelistCheck plutusWhitelist
+    PlutusScripts whitelist ->
+      any (\txOut -> isScriptHashWhitelisted whitelist txOut || isAddressWhitelisted whitelist txOut) txOuts
+
   where
     iopts = soptInsertOptions $ envOptions syncEnv
-    plutuswhitelistCheck :: NonEmpty ShortByteString -> Bool
-    plutuswhitelistCheck whitelist =
-      any (\txOut -> isScriptHashWhitelisted whitelist txOut || isAddressWhitelisted whitelist txOut) txOuts
     -- check if the script hash is in the whitelist
     isScriptHashWhitelisted :: NonEmpty ShortByteString -> Generic.TxOut -> Bool
     isScriptHashWhitelisted whitelist txOut =
@@ -51,7 +50,7 @@ isSimplePlutusScriptHashInWhitelist :: SyncEnv -> ByteString -> Bool
 isSimplePlutusScriptHashInWhitelist syncEnv scriptHash = do
   case ioPlutus iopts of
     PlutusEnable -> True
-    PlutusDisable -> True
+    PlutusDisable -> False
     PlutusScripts plutusWhitelist -> toShort scriptHash `elem` plutusWhitelist
   where
     iopts = soptInsertOptions $ envOptions syncEnv