Replace TxProposalProcedures unsafe constructor with a pattern

cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs

@@ -260,38 +260,38 @@ genSimpleScript =
 -- plutus scripts as well as valid plutus scripts.
 genPlutusScript :: PlutusScriptVersion lang -> Gen (PlutusScript lang)
 genPlutusScript l =
-  case l of 
-    PlutusScriptV1 -> do 
+  case l of
+    PlutusScriptV1 -> do
       PlutusScript _ s <- genPlutusV1Script
       return s
-    PlutusScriptV2 -> do 
+    PlutusScriptV2 -> do
       PlutusScript _ s <- genPlutusV2Script
       return s
-    PlutusScriptV3 -> do 
+    PlutusScriptV3 -> do
       PlutusScript _ s <- genPlutusV3Script
       return s
 
 genValidPlutusScript :: PlutusScriptVersion lang -> Gen (PlutusScript lang)
 genValidPlutusScript l =
-  case l of 
-    PlutusScriptV1 -> do 
+  case l of
+    PlutusScriptV1 -> do
       PlutusScript _ s <- genValidPlutusV1Script
       return s
-    PlutusScriptV2 -> do 
+    PlutusScriptV2 -> do
       PlutusScript _ s <- genValidPlutusV2Script
       return s
-    PlutusScriptV3 -> do 
+    PlutusScriptV3 -> do
       PlutusScript _ s <- genValidPlutusV3Script
       return s
 
 genPlutusV1Script :: Gen (Script PlutusScriptV1)
-genPlutusV1Script = do 
+genPlutusV1Script = do
   v1Script <- Gen.element [v1Loop2024PlutusScriptHexDoubleEncoded,v1Loop2024PlutusScriptHex]
   let v1ScriptBytes = Base16.decodeLenient v1Script
   return . PlutusScript PlutusScriptV1 . PlutusScriptSerialised $ SBS.toShort v1ScriptBytes
 
 genValidPlutusV1Script :: Gen (Script PlutusScriptV1)
-genValidPlutusV1Script = do 
+genValidPlutusV1Script = do
   v1Script <- Gen.element [v1Loop2024PlutusScriptHex]
   let v1ScriptBytes = Base16.decodeLenient v1Script
   return . PlutusScript PlutusScriptV1 . PlutusScriptSerialised $ SBS.toShort v1ScriptBytes
@@ -310,14 +310,14 @@ genValidPlutusV2Script = do
 
 genPlutusV3Script :: Gen (Script PlutusScriptV3)
 genPlutusV3Script = do
-  v3AlwaysSucceedsPlutusScriptHex 
+  v3AlwaysSucceedsPlutusScriptHex
    <- Gen.element [v3AlwaysSucceedsPlutusScriptDoubleEncoded, v3AlwaysSucceedsPlutusScript]
   let v3ScriptBytes = Base16.decodeLenient v3AlwaysSucceedsPlutusScriptHex
   return . PlutusScript PlutusScriptV3 . PlutusScriptSerialised $ SBS.toShort v3ScriptBytes
 
 genValidPlutusV3Script :: Gen (Script PlutusScriptV3)
 genValidPlutusV3Script = do
-  v3AlwaysSucceedsPlutusScriptHex 
+  v3AlwaysSucceedsPlutusScriptHex
    <- Gen.element [v3AlwaysSucceedsPlutusScript]
   let v3ScriptBytes = Base16.decodeLenient v3AlwaysSucceedsPlutusScriptHex
   return . PlutusScript PlutusScriptV3 . PlutusScriptSerialised $ SBS.toShort v3ScriptBytes
@@ -1341,18 +1341,12 @@ genProposals :: Applicative (BuildTxWith build)
              => ConwayEraOnwards era
              -> Gen (TxProposalProcedures build era)
 genProposals w = conwayEraOnwardsConstraints w $ do
-  proposals <- Gen.list (Range.constant 0 10) (genProposal w)
-  proposalsToBeWitnessed <- Gen.subsequence proposals
-  -- We're generating also some extra proposals, purposely not included in the proposals list, which results
-  -- in an invalid state of 'TxProposalProcedures'.
-  -- We're doing it for the complete representation of possible values space of TxProposalProcedures.
-  -- Proposal procedures code in cardano-api should handle such invalid values just fine.
-  extraProposals <- Gen.list (Range.constant 0 10) (genProposal w)
+  proposals <- Gen.list (Range.constant 0 15) (genProposal w)
   let sbe = convert w
-  proposalsWithWitnesses <-
-    forM (extraProposals <> proposalsToBeWitnessed) $ \proposal ->
-      (proposal,) <$> genScriptWitnessForStake sbe
-  pure $ TxProposalProcedures (fromList proposals) (pure $ fromList proposalsWithWitnesses)
+  proposalsWithMaybeWitnesses <-
+    forM proposals $ \proposal ->
+      (proposal,) <$> Gen.maybe (genScriptWitnessForStake sbe)
+  pure $ mkTxProposalProcedures proposalsWithMaybeWitnesses
 
 genProposal :: ConwayEraOnwards era -> Gen (L.ProposalProcedure (ShelleyLedgerEra era))
 genProposal w =

cardano-api/internal/Cardano/Api/Experimental/Tx.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -41,6 +42,7 @@ import           Cardano.Ledger.Hashes
 import qualified Cardano.Ledger.Keys as L
 import qualified Cardano.Ledger.SafeHash as L
 
+import           Data.Maybe
 import qualified Data.Set as Set
 import           GHC.Exts (IsList (..))
 import           GHC.Stack
@@ -153,7 +155,13 @@ eraSpecificLedgerTxBody ConwayEra ledgerbody bc =
    in return $
         ledgerbody
           & L.proposalProceduresTxBodyL
-            .~ convProposalProcedures (maybe TxProposalProceduresNone unFeatured propProcedures)
+            .~ fromMaybe
+              mempty
+              ( propProcedures
+                  >>= \case
+                    Featured _ TxProposalProceduresNone -> Nothing
+                    Featured _ (TxProposalProcedures pp _) -> Just pp
+              )
           & L.votingProceduresTxBodyL
             .~ convVotingProcedures (maybe TxVotingProceduresNone unFeatured voteProcedures)
           & L.treasuryDonationTxBodyL .~ maybe (L.Coin 0) unFeatured treasuryDonation

cardano-api/internal/Cardano/Api/Fees.hs

@@ -250,7 +250,14 @@ estimateBalancedTxBody
         proposalProcedures :: OSet.OSet (L.ProposalProcedure (ShelleyLedgerEra era))
         proposalProcedures =
           maryEraOnwardsConstraints w $
-            maybe mempty (convProposalProcedures . unFeatured) (txProposalProcedures txbodycontent1)
+            maybe mempty (unTxProposalProcedures . unFeatured) (txProposalProcedures txbodycontent1)
+         where
+          unTxProposalProcedures
+            :: TxProposalProcedures BuildTx era
+            -> OSet.OSet (L.ProposalProcedure (ShelleyLedgerEra era))
+          unTxProposalProcedures = \case
+            TxProposalProceduresNone -> OSet.empty
+            TxProposalProcedures ps _ -> ps
 
         totalDeposits :: L.Coin
         totalDeposits =
@@ -673,8 +680,8 @@ evaluateTransactionExecutionUnits
   -> UTxO era
   -> TxBody era
   -> Either
-      (TransactionValidityError era)
-      (Map ScriptWitnessIndex (Either ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)))
+       (TransactionValidityError era)
+       (Map ScriptWitnessIndex (Either ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)))
 evaluateTransactionExecutionUnits era systemstart epochInfo pp utxo txbody =
   case makeSignedTransaction' era [] txbody of
     ShelleyTx sbe tx' -> evaluateTransactionExecutionUnitsShelley sbe systemstart epochInfo pp utxo tx'
@@ -689,8 +696,8 @@ evaluateTransactionExecutionUnitsShelley
   -> UTxO era
   -> L.Tx (ShelleyLedgerEra era)
   -> Either
-      (TransactionValidityError era)
-      (Map ScriptWitnessIndex (Either ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)))
+       (TransactionValidityError era)
+       (Map ScriptWitnessIndex (Either ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)))
 evaluateTransactionExecutionUnitsShelley sbe systemstart epochInfo (LedgerProtocolParameters pp) utxo tx =
   caseShelleyToMaryOrAlonzoEraOnwards
     (const (Right Map.empty))
@@ -707,8 +714,8 @@ evaluateTransactionExecutionUnitsShelley sbe systemstart epochInfo (LedgerProtoc
     :: Alonzo.AlonzoEraScript (ShelleyLedgerEra era)
     => AlonzoEraOnwards era
     -> Map
-        (L.PlutusPurpose L.AsIx (ShelleyLedgerEra era))
-        (Either (L.TransactionScriptFailure (ShelleyLedgerEra era)) (EvalTxExecutionUnitsLog, Alonzo.ExUnits))
+         (L.PlutusPurpose L.AsIx (ShelleyLedgerEra era))
+         (Either (L.TransactionScriptFailure (ShelleyLedgerEra era)) (EvalTxExecutionUnitsLog, Alonzo.ExUnits))
     -> Map ScriptWitnessIndex (Either ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
   fromLedgerScriptExUnitsMap aOnwards exmap =
     fromList
@@ -1502,15 +1509,15 @@ substituteExecutionUnits
       let mappedScriptWitnesses
             :: [ ( Certificate era
                  , Either
-                    (TxBodyErrorAutoBalance era)
-                    ( BuildTxWith
-                        BuildTx
-                        ( Maybe
-                            ( StakeCredential
-                            , Witness WitCtxStake era
-                            )
-                        )
-                    )
+                     (TxBodyErrorAutoBalance era)
+                     ( BuildTxWith
+                         BuildTx
+                         ( Maybe
+                             ( StakeCredential
+                             , Witness WitCtxStake era
+                             )
+                         )
+                     )
                  )
                ]
           mappedScriptWitnesses =
@@ -1523,8 +1530,8 @@ substituteExecutionUnits
     mapScriptWitnessesVotes
       :: Maybe (Featured ConwayEraOnwards era (TxVotingProcedures build era))
       -> Either
-          (TxBodyErrorAutoBalance era)
-          (Maybe (Featured ConwayEraOnwards era (TxVotingProcedures build era)))
+           (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
@@ -1542,13 +1549,14 @@ substituteExecutionUnits
           (Featured era (TxVotingProcedures vProcedures (BuildTxWith $ fromList substitutedExecutionUnits)))
 
     mapScriptWitnessesProposals
-      :: Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era))
+      :: Applicative (BuildTxWith build)
+      => Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era))
       -> Either
-          (TxBodyErrorAutoBalance era)
-          (Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era)))
+           (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 _ (TxProposalProcedures _ ViewTx))) = return Nothing -- TODO why it's not returning the original proposal?
     mapScriptWitnessesProposals (Just (Featured era txpp@(TxProposalProcedures osetProposalProcedures (BuildTxWith _)))) = do
       let eSubstitutedExecutionUnits =
             [ (proposal, updatedWitness)
@@ -1557,13 +1565,19 @@ substituteExecutionUnits
             ]
 
       substitutedExecutionUnits <- traverseScriptWitnesses eSubstitutedExecutionUnits
+      -- join again with osetProposalProcedures, just in case anything was left there
+      let allUpdatedProposals =
+            [ (proposal, mWitness)
+            | proposal <- toList osetProposalProcedures
+            , -- substituteExecUnits has only distinct proposals, so we can safely use lookup to find the first match
+            let mWitness = lookup proposal substitutedExecutionUnits
+            ]
 
-      return $
-        Just
-          ( Featured
-              era
-              (TxProposalProcedures osetProposalProcedures (BuildTxWith $ fromList substitutedExecutionUnits))
-          )
+      pure $
+        Just $
+          Featured era $
+            conwayEraOnwardsConstraints era $
+              mkTxProposalProcedures allUpdatedProposals
 
     mapScriptWitnessesMinting
       :: TxMintValue BuildTx era