Merge pull request #587 from IntersectMBO/jordan/map-voting-and-propo…

…sing-script-witnesses Update substituteExecutionUnits to include proposal and vote script witnesses
IntersectMBO · Jul 19, 2024 · 8421437 · 8421437
2 parents 25b3433 + 99ff62f
commit 8421437
Show file tree

Hide file tree

Showing 3 changed files with 106 additions and 58 deletions.
diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs
@@ -43,7 +43,6 @@ module Cardano.Api.Fees
   , calculateMinimumUTxO
 
     -- * Internal helpers
-  , mapTxScriptWitnesses
   , ResolvablePointers (..)
   )
 where
@@ -52,6 +51,7 @@ import           Cardano.Api.Address
 import           Cardano.Api.Certificate
 import           Cardano.Api.Eon.AlonzoEraOnwards
 import           Cardano.Api.Eon.BabbageEraOnwards
+import           Cardano.Api.Eon.ConwayEraOnwards
 import           Cardano.Api.Eon.MaryEraOnwards
 import           Cardano.Api.Eon.ShelleyBasedEra
 import           Cardano.Api.Eras.Case
@@ -1395,60 +1395,50 @@ maybeDummyTotalCollAndCollReturnOutput sbe TxBodyContent{txInsCollateral, txRetu
         )
 
 substituteExecutionUnits
-  :: Map ScriptWitnessIndex ExecutionUnits
+  :: forall era. Map ScriptWitnessIndex ExecutionUnits
   -> TxBodyContent BuildTx era
   -> Either (TxBodyErrorAutoBalance era) (TxBodyContent BuildTx era)
-substituteExecutionUnits exUnitsMap =
-  mapTxScriptWitnesses f
- where
-  f
-    :: ScriptWitnessIndex
-    -> ScriptWitness witctx era
-    -> Either (TxBodyErrorAutoBalance era) (ScriptWitness witctx era)
-  f _ wit@SimpleScriptWitness{} = Right wit
-  f idx (PlutusScriptWitness langInEra version script datum redeemer _) =
-    case Map.lookup idx exUnitsMap of
-      Nothing ->
-        Left $ TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap idx exUnitsMap
-      Just exunits ->
-        Right $
-          PlutusScriptWitness
-            langInEra
-            version
-            script
-            datum
-            redeemer
-            exunits
-
-mapTxScriptWitnesses
-  :: forall era
-   . ( forall witctx
-        . ScriptWitnessIndex
-       -> ScriptWitness witctx era
-       -> Either (TxBodyErrorAutoBalance era) (ScriptWitness witctx era)
-     )
-  -> TxBodyContent BuildTx era
-  -> Either (TxBodyErrorAutoBalance era) (TxBodyContent BuildTx era)
-mapTxScriptWitnesses
-  f
-  txbodycontent@TxBodyContent
-    { txIns
-    , txWithdrawals
-    , txCertificates
-    , txMintValue
-    } = do
+substituteExecutionUnits
+  exUnitsMap
+  txbodycontent@(TxBodyContent txIns _ _ _ _ _ _ _ _ _ _ _ _ txWithdrawals txCertificates _
+                   txMintValue _ txProposalProcedures txVotingProcedures _ _) = do
+
     mappedTxIns <- mapScriptWitnessesTxIns txIns
     mappedWithdrawals <- mapScriptWitnessesWithdrawals txWithdrawals
     mappedMintedVals <- mapScriptWitnessesMinting txMintValue
     mappedTxCertificates <- mapScriptWitnessesCertificates txCertificates
+    mappedVotes <- mapScriptWitnessesVotes txVotingProcedures
+    mappedProposals <- mapScriptWitnessesProposals txProposalProcedures
 
     Right $
       txbodycontent
         & setTxIns mappedTxIns
         & setTxMintValue mappedMintedVals
         & setTxCertificates mappedTxCertificates
         & setTxWithdrawals mappedWithdrawals
+        & setTxVotingProcedures mappedVotes
+        & setTxProposalProcedures mappedProposals
+
    where
+    substituteExecUnits
+      :: ScriptWitnessIndex
+      -> ScriptWitness witctx era
+      -> Either (TxBodyErrorAutoBalance era) (ScriptWitness witctx era)
+    substituteExecUnits _ wit@SimpleScriptWitness{} = Right wit
+    substituteExecUnits idx (PlutusScriptWitness langInEra version script datum redeemer _) =
+      case Map.lookup idx exUnitsMap of
+        Nothing ->
+          Left $ TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap idx exUnitsMap
+        Just exunits ->
+          Right $
+            PlutusScriptWitness
+              langInEra
+              version
+              script
+              datum
+              redeemer
+              exunits
+
     mapScriptWitnessesTxIns
       :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))]
       -> Either (TxBodyErrorAutoBalance era) [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))]
@@ -1466,7 +1456,7 @@ mapTxScriptWitnesses
                     KeyWitness{} -> Right wit
                     ScriptWitness ctx witness -> ScriptWitness ctx <$> witness'
                      where
-                      witness' = f (ScriptWitnessIndexTxIn ix) witness
+                      witness' = substituteExecUnits (ScriptWitnessIndexTxIn ix) witness
             ]
        in traverse
             ( \(txIn, eWitness) ->
@@ -1491,7 +1481,7 @@ mapTxScriptWitnesses
             [ (addr, withdrawal, BuildTxWith <$> mappedWitness)
             | -- The withdrawals are indexed in the map order by stake credential
             (ix, (addr, withdrawal, BuildTxWith wit)) <- zip [0 ..] (orderStakeAddrs withdrawals)
-            , let mappedWitness = adjustWitness (f (ScriptWitnessIndexWithdrawal ix)) wit
+            , let mappedWitness = adjustWitness (substituteExecUnits (ScriptWitnessIndexWithdrawal ix)) wit
             ]
        in TxWithdrawals supported
             <$> traverse
@@ -1528,7 +1518,7 @@ mapTxScriptWitnesses
               , stakecred <- maybeToList (selectStakeCredentialWitness cert)
               , ScriptWitness ctx witness <-
                   maybeToList (Map.lookup stakecred witnesses)
-              , let witness' = f (ScriptWitnessIndexCertificate ix) witness
+              , let witness' = substituteExecUnits (ScriptWitnessIndexCertificate ix) witness
               ]
          in TxCertificates supported certs . BuildTxWith . Map.fromList
               <$> traverse
@@ -1539,6 +1529,46 @@ mapTxScriptWitnesses
                 )
                 mappedScriptWitnesses
 
+    mapScriptWitnessesVotes
+      :: Maybe (Featured ConwayEraOnwards era (TxVotingProcedures build era))
+      -> Either (TxBodyErrorAutoBalance era) (Maybe (Featured ConwayEraOnwards era (TxVotingProcedures build era)))
+    mapScriptWitnessesVotes Nothing = return Nothing
+    mapScriptWitnessesVotes (Just (Featured _ TxVotingProceduresNone)) = return Nothing
+    mapScriptWitnessesVotes (Just (Featured _ (TxVotingProcedures _ ViewTx))) = return Nothing
+    mapScriptWitnessesVotes (Just (Featured era (TxVotingProcedures vProcedures (BuildTxWith sWitMap)))) = do
+
+      let eSubstitutedExecutionUnits =
+            [ (vote, updatedWitness)
+            | let allVoteMap = L.unVotingProcedures vProcedures
+            , (vote, scriptWitness) <- Map.toList sWitMap
+            , index <- maybeToList $ Map.lookupIndex vote allVoteMap
+            , let updatedWitness = substituteExecUnits (ScriptWitnessIndexVoting $ fromIntegral index) scriptWitness
+            ]
+
+      substitutedExecutionUnits  <- traverseScriptWitnesses eSubstitutedExecutionUnits
+
+      return $ Just (Featured era (TxVotingProcedures vProcedures (BuildTxWith $ Map.fromList substitutedExecutionUnits)))
+
+    mapScriptWitnessesProposals
+      :: Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era))
+      -> Either (TxBodyErrorAutoBalance era) (Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era)))
+    mapScriptWitnessesProposals Nothing = return Nothing
+    mapScriptWitnessesProposals (Just (Featured _ TxProposalProceduresNone)) = return Nothing
+    mapScriptWitnessesProposals (Just (Featured _ (TxProposalProcedures _ ViewTx))) = return Nothing
+    mapScriptWitnessesProposals (Just (Featured era (TxProposalProcedures osetProposalProcedures (BuildTxWith sWitMap)))) = do
+      let eSubstitutedExecutionUnits =
+            [ (proposal, updatedWitness)
+            | let allProposalsList = toList osetProposalProcedures
+            , (proposal, scriptWitness) <- Map.toList sWitMap
+            , index <- maybeToList $ List.elemIndex proposal allProposalsList
+            , let updatedWitness = substituteExecUnits (ScriptWitnessIndexProposing $ fromIntegral index) scriptWitness
+            ]
+
+      substitutedExecutionUnits  <- traverseScriptWitnesses eSubstitutedExecutionUnits
+
+      return $ Just (Featured era (TxProposalProcedures osetProposalProcedures (BuildTxWith $ Map.fromList substitutedExecutionUnits)))
+
+
     mapScriptWitnessesMinting
       :: TxMintValue BuildTx era
       -> Either (TxBodyErrorAutoBalance era) (TxMintValue BuildTx era)
@@ -1558,20 +1588,19 @@ mapTxScriptWitnesses
               let ValueNestedRep bundle = valueToNestedRep value
               , (ix, ValueNestedBundle policyid _) <- zip [0 ..] bundle
               , witness <- maybeToList (Map.lookup policyid witnesses)
-              , let witness' = f (ScriptWitnessIndexMint ix) witness
+              , let witness' = substituteExecUnits (ScriptWitnessIndexMint ix) witness
               ]
          in do
-              final <-
-                traverse
-                  ( \(pid, eScriptWitness) ->
-                      case eScriptWitness of
-                        Left e -> Left e
-                        Right wit -> Right (pid, wit)
-                  )
-                  mappedScriptWitnesses
+              final <- traverseScriptWitnesses mappedScriptWitnesses
               Right . TxMintValue supported value . BuildTxWith $
                 Map.fromList final
 
+traverseScriptWitnesses
+  :: [(a, Either (TxBodyErrorAutoBalance era) (ScriptWitness ctx era))]
+  -> Either (TxBodyErrorAutoBalance era) [(a, ScriptWitness ctx era)]
+traverseScriptWitnesses =
+  traverse (\(item, eScriptWitness) -> eScriptWitness >>= (\sWit -> Right (item, sWit)))
+
 calculateMinimumUTxO
   :: ShelleyBasedEra era
   -> TxOut CtxTx era

diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs
@@ -55,6 +55,8 @@ module Cardano.Api.Tx.Body
   , setTxWithdrawals
   , setTxCertificates
   , setTxUpdateProposal
+  , setTxProposalProcedures
+  , setTxVotingProcedures
   , setTxMintValue
   , setTxScriptValidity
   , setTxCurrentTreasuryValue
@@ -717,7 +719,8 @@ toAlonzoTxOutDatumHashUTxO (TxOutDatumInline{}) = SNothing
 
 toBabbageTxOutDatumUTxO
   :: (L.Era (ShelleyLedgerEra era), Ledger.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto)
-  => TxOutDatum CtxUTxO era -> Plutus.Datum (ShelleyLedgerEra era)
+  => TxOutDatum CtxUTxO era
+  -> Plutus.Datum (ShelleyLedgerEra era)
 toBabbageTxOutDatumUTxO TxOutDatumNone = Plutus.NoDatum
 toBabbageTxOutDatumUTxO (TxOutDatumHash _ (ScriptDataHash dh)) = Plutus.DatumHash dh
 toBabbageTxOutDatumUTxO (TxOutDatumInline _ sd) = scriptDataToInlineDatum sd
@@ -785,7 +788,8 @@ toAlonzoTxOutDatumHash (TxOutDatumInTx' _ (ScriptDataHash dh) _) = SJust dh
 
 toBabbageTxOutDatum
   :: (L.Era (ShelleyLedgerEra era), Ledger.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto)
-  => TxOutDatum ctx era -> Plutus.Datum (ShelleyLedgerEra era)
+  => TxOutDatum ctx era
+  -> Plutus.Datum (ShelleyLedgerEra era)
 toBabbageTxOutDatum TxOutDatumNone = Plutus.NoDatum
 toBabbageTxOutDatum (TxOutDatumHash _ (ScriptDataHash dh)) = Plutus.DatumHash dh
 toBabbageTxOutDatum (TxOutDatumInline _ sd) = scriptDataToInlineDatum sd
@@ -1356,6 +1360,18 @@ setTxWithdrawals v txBodyContent = txBodyContent{txWithdrawals = v}
 setTxCertificates :: TxCertificates build era -> TxBodyContent build era -> TxBodyContent build era
 setTxCertificates v txBodyContent = txBodyContent{txCertificates = v}
 
+setTxProposalProcedures
+  :: Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era))
+  -> TxBodyContent build era
+  -> TxBodyContent build era
+setTxProposalProcedures v txBodyContent = txBodyContent{txProposalProcedures = v}
+
+setTxVotingProcedures
+  :: Maybe (Featured ConwayEraOnwards era (TxVotingProcedures build era))
+  -> TxBodyContent build era
+  -> TxBodyContent build era
+setTxVotingProcedures v txBodyContent = txBodyContent{txVotingProcedures = v}
+
 setTxUpdateProposal :: TxUpdateProposal era -> TxBodyContent build era -> TxBodyContent build era
 setTxUpdateProposal v txBodyContent = txBodyContent{txUpdateProposal = v}
 
@@ -1393,7 +1409,9 @@ getTxId (ShelleyTxBody sbe tx _ _ _ _) =
 getTxIdShelley
   :: Ledger.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto
   => Ledger.EraTxBody (ShelleyLedgerEra era)
-  => ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> TxId
+  => ShelleyBasedEra era
+  -> Ledger.TxBody (ShelleyLedgerEra era)
+  -> TxId
 getTxIdShelley _ tx =
   TxId
     . Crypto.castHash
@@ -2183,7 +2201,9 @@ convTotalCollateral txTotalCollateral =
 convTxOuts
   :: forall ctx era ledgerera
    . ShelleyLedgerEra era ~ ledgerera
-  => ShelleyBasedEra era -> [TxOut ctx era] -> Seq.StrictSeq (Ledger.TxOut ledgerera)
+  => ShelleyBasedEra era
+  -> [TxOut ctx era]
+  -> Seq.StrictSeq (Ledger.TxOut ledgerera)
 convTxOuts sbe txOuts = Seq.fromList $ map (toShelleyTxOutAny sbe) txOuts
 
 convCertificates

diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs
@@ -528,7 +528,6 @@ module Cardano.Api
   , ScriptWitnessIndex (..)
   , renderScriptWitnessIndex
   , collectTxBodyScriptWitnesses
-  , mapTxScriptWitnesses
 
     -- ** Languages supported in each era
   , ScriptLanguageInEra (..)