Make it clearer that we are confirming the presence of the script wit…

…ness index in the execution units map

Remove mapTxScriptWitnessses
Update substituteExecutionUnits to update proposal and vote script witnesses

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,55 @@ 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
+substituteExecutionUnits
+ exUnitsMap
  txbodycontent@TxBodyContent
  { txIns
  , txWithdrawals
  , txCertificates
  , txMintValue
+ , txVotingProcedures
+ , txProposalProcedures
  } = 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 +1461,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 +1486,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 +1523,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 +1534,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 +1593,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

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
@@ -1654,8 +1672,8 @@ validateTxOuts sbe txOuts = do
  cardanoEraConstraints era $
  sequence_
  [ do
-  positiveOutput era (txOutValueToValue v) txout
-  outputDoesNotExceedMax era (txOutValueToValue v) txout
+ positiveOutput era (txOutValueToValue v) txout
+ outputDoesNotExceedMax era (txOutValueToValue v) txout
  | txout@(TxOut _ v _ _) <- txOuts
  ]
 
@@ -1859,23 +1877,23 @@ fromLedgerTxOuts sbe body scriptdata =
  [fromShelleyTxOut sbe txout | txout <- toList (body ^. L.outputsTxBodyL)]
  ShelleyBasedEraAlonzo ->
  [ fromAlonzoTxOut
-  AlonzoEraOnwardsAlonzo
-  txout
+ AlonzoEraOnwardsAlonzo
+ txout
  | txout <- toList (body ^. L.outputsTxBodyL)
  ]
  ShelleyBasedEraBabbage ->
  [ fromBabbageTxOut
-  BabbageEraOnwardsBabbage
-  txdatums
-  txouts
+ BabbageEraOnwardsBabbage
+ txdatums
+ txouts
  | let txdatums = selectTxDatums scriptdata
  , txouts <- toList (body ^. L.outputsTxBodyL)
  ]
  ShelleyBasedEraConway ->
  [ fromBabbageTxOut
-  BabbageEraOnwardsConway
-  txdatums
-  txouts
+ BabbageEraOnwardsConway
+ txdatums
+ txouts
  | let txdatums = selectTxDatums scriptdata
  , txouts <- toList (body ^. L.outputsTxBodyL)
  ]
@@ -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

cardano-api/src/Cardano/Api.hs

@@ -528,7 +528,6 @@ module Cardano.Api
  , ScriptWitnessIndex (..)
  , renderScriptWitnessIndex
  , collectTxBodyScriptWitnesses
- , mapTxScriptWitnesses
 
  -- ** Languages supported in each era
  , ScriptLanguageInEra (..)