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

IntersectMBO · Sep 26, 2023 · 2fa9f38 · 2fa9f38
1 parent f009c92
commit 2fa9f38
Show file tree

Hide file tree

Showing 4 changed files with 47 additions and 37 deletions.
diff --git a/cardano-api/internal/Cardano/Api/Certificate.hs b/cardano-api/internal/Cardano/Api/Certificate.hs
@@ -664,22 +664,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
@@ -954,7 +954,7 @@ makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters
             failures
             exUnitsMap'
 
-    txbodycontent1 <- substituteExecutionUnits sbe exUnitsMap' txbodycontent
+    txbodycontent1 <- substituteExecutionUnits exUnitsMap' txbodycontent
 
     -- Make a txbody that we will use for calculating the fees. For the purpose
     -- of fees we just need to make a txbody of the right size in bytes. We do
@@ -1177,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
@@ -1199,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,
@@ -1211,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
@@ -1276,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/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs
@@ -274,6 +274,7 @@ import qualified Text.Parsec as Parsec
 import           Text.Parsec ((<?>))
 import qualified Text.Parsec.String as Parsec
 
+
 -- | Indicates whether a script is expected to fail or pass validation.
 data ScriptValidity
   = ScriptInvalid -- ^ Script is expected to fail validation.
@@ -3508,6 +3509,7 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraBabbage
     txAuxData :: Maybe (L.TxAuxData StandardBabbage)
     txAuxData = toAuxiliaryData sbe txMetadata txAuxScripts
 
+
 makeShelleyTransactionBody sbe@ShelleyBasedEraConway
                             txbodycontent@TxBodyContent {
                              txIns,
@@ -3609,7 +3611,6 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraConway
     txAuxData = toAuxiliaryData sbe txMetadata txAuxScripts
 
 
-
 -- | A variant of 'toShelleyTxOutAny that is used only internally to this module
 -- that works with a 'TxOut' in any context (including CtxTx) by ignoring
 -- embedded datums (taking only their hash).
@@ -3675,6 +3676,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
@@ -3791,11 +3794,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)]