fix resolveScriptHash in shelley whitelist error

Author: Cmdv

cardano-db-sync/src/Cardano/DbSync/Config/Types.hs

@@ -45,6 +45,7 @@ module Cardano.DbSync.Config.Types (
   hasLedger,
   shouldUseLedger,
   isShelleyModeActive,
+  isShelleyWhitelistModeActive,
   isMultiAssetModeActive,
   isMetadataModeActive,
   isPlutusModeActive,
@@ -330,6 +331,10 @@ isShelleyModeActive ShelleyDisable = False
 isShelleyModeActive ShelleyEnable = True
 isShelleyModeActive (ShelleyStakeAddrs _) = True
 
+isShelleyWhitelistModeActive :: ShelleyInsertConfig -> Bool
+isShelleyWhitelistModeActive (ShelleyStakeAddrs _) = True
+isShelleyWhitelistModeActive _other = False
+
 isMultiAssetModeActive :: MultiAssetConfig -> Bool
 isMultiAssetModeActive MultiAssetDisable = False
 isMultiAssetModeActive MultiAssetEnable = True

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

@@ -288,6 +288,7 @@ insertVotingProcedures ::
   (Voter StandardCrypto, [(GovActionId StandardCrypto, VotingProcedure StandardConway)]) ->
   ExceptT SyncNodeError (ReaderT SqlBackend m) ()
 insertVotingProcedures syncEnv txId proposalPs (voter, actions) =
+  -- TODO: cmdv will actions & proposalPs always be the same length?
   mapM_ (insertVotingProcedure syncEnv txId voter) (zip3 [0 ..] actions proposalPs)
 
 insertVotingProcedure ::

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

@@ -62,6 +62,7 @@ data ExtendedTxOut = ExtendedTxOut
   { etoTxHash :: !ByteString
   , etoTxOut :: !DB.TxOut
   }
+  deriving (Show)
 
 data ExtendedTxIn = ExtendedTxIn
   { etiTxIn :: !DB.TxIn
@@ -144,12 +145,15 @@ insertReverseIndex blockId minIds =
 -- This happens the input consumes an output introduced in the same block.
 resolveTxInputs ::
   MonadIO m =>
+  SyncEnv ->
+  -- | Has the output been consumed?
   Bool ->
+  -- | Does the output need a value?
   Bool ->
   [ExtendedTxOut] ->
   Generic.TxIn ->
   ExceptT SyncNodeError (ReaderT SqlBackend m) (Generic.TxIn, DB.TxId, Either Generic.TxIn DB.TxOutId, Maybe DbLovelace)
-resolveTxInputs hasConsumed needsValue groupedOutputs txIn =
+resolveTxInputs _syncEnv hasConsumed needsValue groupedOutputs txIn =
   liftLookupFail ("resolveTxInputs " <> textShow txIn <> " ") $ do
     qres <-
       case (hasConsumed, needsValue) of

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

@@ -20,9 +20,10 @@ module Cardano.DbSync.Era.Universal.Insert.Other (
 where
 
 import qualified Cardano.Db as DB
-import Cardano.DbSync.Api.Types (SyncEnv)
+import Cardano.DbSync.Api.Types (InsertOptions (..), SyncEnv (..), SyncOptions (..))
 import Cardano.DbSync.Cache (insertDatumAndCache, queryDatum, queryMAWithCache, queryOrInsertRewardAccount, queryOrInsertStakeAddress)
 import Cardano.DbSync.Cache.Types (Cache (..), CacheNew (..))
+import Cardano.DbSync.Config.Types (isShelleyWhitelistModeActive)
 import qualified Cardano.DbSync.Era.Shelley.Generic as Generic
 import Cardano.DbSync.Era.Shelley.Query (queryStakeRefPtr)
 import Cardano.DbSync.Era.Universal.Insert.Grouped
@@ -74,11 +75,14 @@ insertRedeemer syncEnv disInOut groupedOutputs txId (rix, redeemer) = do
       (MonadBaseControl IO m, MonadIO m) =>
       ExceptT SyncNodeError (ReaderT SqlBackend m) (Maybe ByteString)
     findScriptHash =
-      case (disInOut, Generic.txRedeemerScriptHash redeemer) of
-        (True, _) -> pure Nothing
-        (_, Nothing) -> pure Nothing
-        (_, Just (Right bs)) -> pure $ Just bs
-        (_, Just (Left txIn)) -> resolveScriptHash groupedOutputs txIn
+      -- If we are in shelley whitelist mode, we don't need to resolve the script hash
+      if isShelleyWhitelistModeActive $ ioShelley $ soptInsertOptions $ envOptions syncEnv
+        then pure Nothing
+        else case (disInOut, Generic.txRedeemerScriptHash redeemer) of
+          (True, _) -> pure Nothing
+          (_, Nothing) -> pure Nothing
+          (_, Just (Right bs)) -> pure $ Just bs
+          (_, Just (Left txIn)) -> resolveScriptHash groupedOutputs txIn
 
 insertRedeemerData ::
   (MonadBaseControl IO m, MonadIO m) =>

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

@@ -86,18 +86,18 @@ insertTx syncEnv isMember blkId epochNo slotNo applyResult blockIndex tx grouped
   (resolvedInputs, fees', deposits) <- case (disInOut, mdeposits, unCoin <$> Generic.txFees tx) of
     (True, _, _) -> pure ([], 0, unCoin <$> mdeposits)
     (_, Just deposits, Just fees) -> do
-      (resolvedInputs, _) <- splitLast <$> mapM (resolveTxInputs hasConsumed False (fst <$> groupedTxOut grouped)) (Generic.txInputs tx)
+      (resolvedInputs, _) <- splitLast <$> mapM (resolveTxInputs syncEnv hasConsumed False (fst <$> groupedTxOut grouped)) (Generic.txInputs tx)
       pure (resolvedInputs, fees, Just (unCoin deposits))
     (_, Nothing, Just fees) -> do
-      (resolvedInputs, amounts) <- splitLast <$> mapM (resolveTxInputs hasConsumed False (fst <$> groupedTxOut grouped)) (Generic.txInputs tx)
+      (resolvedInputs, amounts) <- splitLast <$> mapM (resolveTxInputs syncEnv hasConsumed False (fst <$> groupedTxOut grouped)) (Generic.txInputs tx)
       if any isNothing amounts
         then pure (resolvedInputs, fees, Nothing)
         else
           let !inSum = sum $ map unDbLovelace $ catMaybes amounts
            in pure (resolvedInputs, fees, Just $ fromIntegral (inSum + withdrawalSum) - fromIntegral outSum - fromIntegral fees)
     (_, _, Nothing) -> do
       -- Nothing in fees means a phase 2 failure
-      (resolvedInsFull, amounts) <- splitLast <$> mapM (resolveTxInputs hasConsumed True (fst <$> groupedTxOut grouped)) (Generic.txInputs tx)
+      (resolvedInsFull, amounts) <- splitLast <$> mapM (resolveTxInputs syncEnv hasConsumed True (fst <$> groupedTxOut grouped)) (Generic.txInputs tx)
       let !inSum = sum $ map unDbLovelace $ catMaybes amounts
           !diffSum = if inSum >= outSum then inSum - outSum else 0
           !fees = maybe diffSum (fromIntegral . unCoin) (Generic.txFees tx)

cardano-db/src/Cardano/Db/Schema.hs

@@ -153,6 +153,7 @@ share
     inlineDatumId       DatumId Maybe       noreference
     referenceScriptId   ScriptId Maybe      noreference
     UniqueTxout         txId index          -- The (tx_id, index) pair must be unique.
+    deriving Eq Show
 
   CollateralTxOut
     txId                TxId                noreference     -- This type is the primary key for the 'tx' table.