IntersectMBO/cardano-cli#299 Fix 'MissingRedeemers' error

IntersectMBO · Sep 25, 2023 · 89324bd · 89324bd
1 parent 14d8475
commit 89324bd
Show file tree

Hide file tree

Showing 6 changed files with 61 additions and 40 deletions.
diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal
@@ -179,6 +179,7 @@ library internal
                       , plutus-ledger-api:{plutus-ledger-api, plutus-ledger-api-testlib} ^>= 1.9
                       , prettyprinter
                       , prettyprinter-configurable ^>= 1.9
+                      , pretty-simple
                       , random
                       , scientific
                       , serialise

diff --git a/cardano-api/internal/Cardano/Api/Certificate.hs b/cardano-api/internal/Cardano/Api/Certificate.hs
@@ -662,22 +662,32 @@ makeStakeAddressAndDRepDelegationCertificate w cred delegatee deposit =
 --
 
 selectStakeCredential
-  :: ShelleyBasedEra era -> Certificate era -> Maybe StakeCredential
-selectStakeCredential sbe cert =
-  case cert of
-    ShelleyRelatedCertificate _ (Ledger.ShelleyTxCertDelegCert (Ledger.ShelleyDelegCert stakecred _))
-      -> Just $ shelleyBasedEraConstraints sbe $ fromShelleyStakeCredential stakecred
-    ShelleyRelatedCertificate _ (Ledger.ShelleyTxCertPool (Ledger.RegPool poolParams))
-      -> let poolCred = Ledger.KeyHashObj $ Ledger.ppId poolParams
-         in Just $ shelleyBasedEraConstraints sbe $ fromShelleyStakeCredential $ Ledger.coerceKeyRole poolCred
-
-    ConwayCertificate _ (Ledger.ConwayTxCertDeleg (Ledger.ConwayRegCert stakeCred _))
-      -> Just $ shelleyBasedEraConstraints sbe $ fromShelleyStakeCredential stakeCred
-    ConwayCertificate _ (Ledger.ConwayTxCertPool (Ledger.RegPool poolParams))
-      -> let poolCred = Ledger.KeyHashObj $ Ledger.ppId poolParams
-         in Just $ shelleyBasedEraConstraints sbe $ fromShelleyStakeCredential $ Ledger.coerceKeyRole poolCred
-
-    _                                                 -> Nothing
+  :: Certificate era -> Maybe StakeCredential
+selectStakeCredential = fmap fromShelleyStakeCredential . \case
+  ShelleyRelatedCertificate stbEra shelleyCert -> shelleyToBabbageEraConstraints stbEra $
+    case shelleyCert of
+      Ledger.RegTxCert sCred           -> Just sCred
+      Ledger.UnRegTxCert sCred         -> Just sCred
+      Ledger.DelegStakeTxCert sCred _  -> Just sCred
+      Ledger.RegPoolTxCert poolParams  ->
+        Just . Ledger.coerceKeyRole . Ledger.KeyHashObj $ Ledger.ppId poolParams
+      Ledger.RetirePoolTxCert poolId _ ->
+        Just . Ledger.coerceKeyRole $ Ledger.KeyHashObj poolId
+      _                                -> Nothing
+
+  ConwayCertificate cEra conwayCert -> conwayEraOnwardsConstraints cEra $
+    case conwayCert of
+      Ledger.RegPoolTxCert poolParams        ->
+        Just . Ledger.coerceKeyRole . Ledger.KeyHashObj $ Ledger.ppId poolParams
+      Ledger.RetirePoolTxCert kh _           ->
+        Just . Ledger.coerceKeyRole $ Ledger.KeyHashObj kh
+      Ledger.RegTxCert sCred                 -> Just sCred
+      Ledger.UnRegTxCert sCred               -> Just sCred
+      Ledger.RegDepositTxCert sCred _        -> Just sCred
+      Ledger.UnRegDepositTxCert sCred _      -> Just sCred
+      Ledger.DelegTxCert sCred _             -> Just sCred
+      Ledger.RegDepositDelegTxCert sCred _ _ -> Just sCred
+      _                                      -> Nothing
 
 filterUnRegCreds
   :: ShelleyBasedEra era -> Certificate era -> Maybe StakeCredential

diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs
@@ -91,6 +91,9 @@ import qualified Data.Text as Text
 import           Lens.Micro ((^.))
 import           Prettyprinter
 import           Prettyprinter.Render.String
+import Debug.Trace
+import Text.Pretty.Simple (pShow)
+import qualified Data.Text.Lazy as T
 
 {- HLINT ignore "Redundant return" -}
 --- ----------------------------------------------------------------------------
@@ -949,7 +952,7 @@ makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters
             failures
             exUnitsMap'
 
-    txbodycontent1 <- substituteExecutionUnits sbe exUnitsMap' txbodycontent
+    txbodycontent1 <- substituteExecutionUnits exUnitsMap' txbodycontent
 
     explicitTxFees <- first (const TxBodyErrorByronEraNotSupported) $
                         txFeesExplicitInEra era'
@@ -1045,7 +1048,7 @@ makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters
                           -- that simply creates a transaction body because we have already
                           -- validated the transaction body earlier within makeTransactionBodyAutoBalance
         createAndValidateTransactionBody finalTxBodyContent
-    return (BalancedTxBody finalTxBodyContent txbody3 (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) fee)
+    trace ">>>> F1048" $ trace (T.unpack $ pShow txbody3) $ return (BalancedTxBody finalTxBodyContent txbody3 (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) fee)
  where
    -- Essentially we check for the existence of collateral inputs. If they exist we
    -- create a fictitious collateral return output. Why? Because we need to put dummy values
@@ -1174,12 +1177,11 @@ makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters
                    (txOutInAnyEra txout)
                    minUTxO
 
-substituteExecutionUnits :: ShelleyBasedEra era
-                         -> Map ScriptWitnessIndex ExecutionUnits
+substituteExecutionUnits :: Map ScriptWitnessIndex ExecutionUnits
                          -> TxBodyContent BuildTx era
                          -> Either TxBodyErrorAutoBalance (TxBodyContent BuildTx era)
-substituteExecutionUnits sbe exUnitsMap =
-    mapTxScriptWitnesses f sbe
+substituteExecutionUnits exUnitsMap =
+    mapTxScriptWitnesses f
   where
     f :: ScriptWitnessIndex
       -> ScriptWitness witctx era
@@ -1196,10 +1198,9 @@ mapTxScriptWitnesses
       (forall witctx. ScriptWitnessIndex
                    -> ScriptWitness witctx era
                    -> Either TxBodyErrorAutoBalance (ScriptWitness witctx era))
-  -> ShelleyBasedEra era
   -> TxBodyContent BuildTx era
   -> Either TxBodyErrorAutoBalance (TxBodyContent BuildTx era)
-mapTxScriptWitnesses f sbe txbodycontent@TxBodyContent {
+mapTxScriptWitnesses f txbodycontent@TxBodyContent {
                          txIns,
                          txWithdrawals,
                          txCertificates,
@@ -1208,7 +1209,7 @@ mapTxScriptWitnesses f sbe txbodycontent@TxBodyContent {
     mappedTxIns <- mapScriptWitnessesTxIns txIns
     mappedWithdrawals <- mapScriptWitnessesWithdrawals txWithdrawals
     mappedMintedVals <- mapScriptWitnessesMinting txMintValue
-    mappedTxCertificates <- mapScriptWitnessesCertificates sbe txCertificates
+    mappedTxCertificates <- mapScriptWitnessesCertificates txCertificates
 
     Right $ txbodycontent
       & setTxIns mappedTxIns
@@ -1273,19 +1274,18 @@ mapTxScriptWitnesses f sbe txbodycontent@TxBodyContent {
         adjustWitness g (ScriptWitness ctx witness') = ScriptWitness ctx <$> g witness'
 
     mapScriptWitnessesCertificates
-      :: ShelleyBasedEra era
-      -> TxCertificates BuildTx era
+      :: TxCertificates BuildTx era
       -> Either TxBodyErrorAutoBalance (TxCertificates BuildTx era)
-    mapScriptWitnessesCertificates _ TxCertificatesNone = Right TxCertificatesNone
-    mapScriptWitnessesCertificates sbe' (TxCertificates supported certs
+    mapScriptWitnessesCertificates TxCertificatesNone = Right TxCertificatesNone
+    mapScriptWitnessesCertificates (TxCertificates supported certs
                                                    (BuildTxWith witnesses)) =
       let mappedScriptWitnesses
            :: [(StakeCredential, Either TxBodyErrorAutoBalance (Witness WitCtxStake era))]
           mappedScriptWitnesses =
               [ (stakecred, ScriptWitness ctx <$> witness')
                 -- The certs are indexed in list order
               | (ix, cert) <- zip [0..] certs
-              , stakecred  <- maybeToList (selectStakeCredential sbe' cert)
+              , stakecred  <- maybeToList (selectStakeCredential cert)
               , ScriptWitness ctx witness
                            <- maybeToList (Map.lookup stakecred witnesses)
               , let witness' = f (ScriptWitnessIndexCertificate ix) witness

diff --git a/cardano-api/internal/Cardano/Api/ReexposeLedger.hs b/cardano-api/internal/Cardano/Api/ReexposeLedger.hs
@@ -27,6 +27,7 @@ module Cardano.Api.ReexposeLedger
   , pattern ResignCommitteeColdTxCert
   , pattern RegTxCert
   , pattern UnRegTxCert
+  , pattern DelegStakeTxCert
   , pattern RegDepositDelegTxCert
   , pattern RegDRepTxCert
 
@@ -91,11 +92,11 @@ module Cardano.Api.ReexposeLedger
 import           Cardano.Crypto.Hash.Class (hashFromBytes, hashToBytes)
 import           Cardano.Ledger.Alonzo.Core (CoinPerWord (..))
 import           Cardano.Ledger.Alonzo.Scripts (Prices (..))
-import           Cardano.Ledger.Api.Tx.Cert (pattern AuthCommitteeHotKeyTxCert, pattern DelegTxCert,
-                   pattern RegDRepTxCert, pattern RegDepositDelegTxCert, pattern RegDepositTxCert,
-                   pattern RegPoolTxCert, pattern RegTxCert, pattern ResignCommitteeColdTxCert,
-                   pattern RetirePoolTxCert, pattern UnRegDRepTxCert, pattern UnRegDepositTxCert,
-                   pattern UnRegTxCert)
+import           Cardano.Ledger.Api.Tx.Cert (pattern AuthCommitteeHotKeyTxCert,
+                   pattern DelegStakeTxCert, pattern DelegTxCert, pattern RegDRepTxCert,
+                   pattern RegDepositDelegTxCert, pattern RegDepositTxCert, pattern RegPoolTxCert,
+                   pattern RegTxCert, pattern ResignCommitteeColdTxCert, pattern RetirePoolTxCert,
+                   pattern UnRegDRepTxCert, pattern UnRegDepositTxCert, pattern UnRegTxCert)
 import           Cardano.Ledger.Babbage.Core (CoinPerByte (..))
 import           Cardano.Ledger.BaseTypes (DnsName, Network (..), StrictMaybe (..), Url,
                    boundRational, dnsToText, maybeToStrictMaybe, portToWord16, strictMaybeToMaybe,

diff --git a/cardano-api/internal/Cardano/Api/Tx.hs b/cardano-api/internal/Cardano/Api/Tx.hs
@@ -90,6 +90,8 @@ import           Data.Type.Equality (TestEquality (..), (:~:) (Refl))
 import qualified Data.Vector as Vector
 import           Lens.Micro
 
+import           Debug.Trace
+
 -- ----------------------------------------------------------------------------
 -- Signed transactions
 --
@@ -662,7 +664,7 @@ makeShelleyBasedBootstrapWitness :: forall era.
 makeShelleyBasedBootstrapWitness sbe nwOrAddr txbody (ByronSigningKey sk) =
     ShelleyBootstrapWitness sbe $
       -- Byron era witnesses were weird. This reveals all that weirdness.
-      Shelley.BootstrapWitness {
+      trace "API 665" $ traceShowId $ Shelley.BootstrapWitness {
         Shelley.bwKey        = vk,
         Shelley.bwSig        = signature,
         Shelley.bwChainCode  = chainCode,

diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs
@@ -271,6 +271,7 @@ import qualified Data.Set as Set
 import           Data.String
 import           Data.Text (Text)
 import qualified Data.Text as Text
+import qualified Data.Text.Lazy as T
 import           Data.Type.Equality (TestEquality (..), (:~:) (Refl))
 import           Data.Word (Word16, Word32, Word64)
 import           GHC.Generics
@@ -279,6 +280,9 @@ import           Lens.Micro.Extras (view)
 import qualified Text.Parsec as Parsec
 import           Text.Parsec ((<?>))
 import qualified Text.Parsec.String as Parsec
+import           Text.Pretty.Simple (pShow)
+
+import           Debug.Trace
 
 -- | Indicates whether a script is expected to fail or pass validation.
 data ScriptValidity
@@ -3880,7 +3884,7 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraBabbage
         txScriptValidity
   where
     witnesses :: [(ScriptWitnessIndex, AnyScriptWitness BabbageEra)]
-    witnesses = collectTxBodyScriptWitnesses sbe txbodycontent
+    witnesses = collectTxBodyScriptWitnesses sbe $ trace ">>>> TXB 3886" $ traceWith (T.unpack . pShow) txbodycontent
 
     scripts :: [Ledger.Script StandardBabbage]
     scripts = List.nub $ catMaybes
@@ -3908,7 +3912,7 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraBabbage
 
     redeemers :: Alonzo.Redeemers StandardBabbage
     redeemers =
-      Alonzo.Redeemers $
+      trace "WITT" $ traceWith (T.unpack . pShow ) $ Alonzo.Redeemers $
         Map.fromList
           [ (toAlonzoRdmrPtr idx, (toAlonzoData d, toAlonzoExUnits e))
           | (idx, AnyScriptWitness
@@ -3930,6 +3934,7 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraBabbage
     txAuxData :: Maybe (L.TxAuxData StandardBabbage)
     txAuxData = toAuxiliaryData sbe txMetadata txAuxScripts
 
+
 makeShelleyTransactionBody sbe@ShelleyBasedEraConway
                             txbodycontent@TxBodyContent {
                              txIns,
@@ -4030,6 +4035,7 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraConway
     txAuxData :: Maybe (L.TxAuxData StandardConway)
     txAuxData = toAuxiliaryData sbe txMetadata txAuxScripts
 
+traceWith f a = trace (f a) a
 
 
 -- | A variant of 'toShelleyTxOutAny that is used only internally to this module
@@ -4097,6 +4103,8 @@ toBabbageTxOutDatum' (TxOutDatumInline _ sd) = scriptDataToInlineDatum sd
 data AnyScriptWitness era where
      AnyScriptWitness :: ScriptWitness witctx era -> AnyScriptWitness era
 
+deriving instance Show (AnyScriptWitness era)
+
 -- | Identify the location of a 'ScriptWitness' within the context of a
 -- 'TxBody'. These are indexes of the objects within the transaction that
 -- need or can use script witnesses: inputs, minted assets, withdrawals and
@@ -4213,11 +4221,10 @@ collectTxBodyScriptWitnesses sbe TxBodyContent {
           -- The certs are indexed in list order
         | (ix, cert) <- zip [0..] certs
         , ScriptWitness _ witness <- maybeToList $ do
-                                       stakecred <- shelleyBasedEraConstraints sbe $ selectStakeCredential sbe cert
+                                       stakecred <- shelleyBasedEraConstraints sbe $ selectStakeCredential cert
                                        Map.lookup stakecred witnesses
         ]
 
-
     scriptWitnessesMinting
       :: TxMintValue BuildTx era
       -> [(ScriptWitnessIndex, AnyScriptWitness era)]