Implement experimental estimateBalancedTxBody

cardano-api/cardano-api.cabal

@@ -225,7 +225,9 @@ library
     Cardano.Api.Experimental.Plutus.Internal.ScriptWitness
     Cardano.Api.Experimental.Plutus.Internal.Shim.LegacyScripts
     Cardano.Api.Experimental.Tx.Internal.AnyWitness
+    Cardano.Api.Experimental.Tx.Internal.Body
     Cardano.Api.Experimental.Tx.Internal.Certificate
+    Cardano.Api.Experimental.Tx.Internal.Fee
     Cardano.Api.Experimental.Tx.Internal.TxScriptWitnessRequirements
     Cardano.Api.Genesis.Internal
     Cardano.Api.Genesis.Internal.Parameters

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

@@ -125,6 +125,12 @@ module Test.Gen.Cardano.Api.Typed
   , genLedgerValueForTxOut
   , genLedgerMultiAssetValue
   , genWitnesses
+  , genScriptWitnessedTxIn
+  , genScriptWitnessedTxMintValue
+  , genScriptWitnessedTxCertificates
+  , genScriptWitnessedTxProposals
+  , genScriptWitnessedTxWithdrawals
+  , genScriptWitnesssedTxVotingProcedures
   , genWitnessNetworkIdOrByronAddress
   , genRational
   , genGovernancePoll
@@ -742,6 +748,17 @@ genTxWithdrawals =
           ]
     )
 
+genScriptWitnessedTxWithdrawals :: Exp.Era era -> Gen (TxWithdrawals BuildTx era)
+genScriptWitnessedTxWithdrawals era = do
+  num <- Gen.integral (Range.constant 0 3)
+  sAddrs <- Gen.list (Range.singleton num) genStakeAddress
+  coins <- Gen.list (Range.singleton num) genPositiveLovelace
+  sWits <-
+    Gen.list (Range.singleton num) $
+      ScriptWitness ScriptWitnessForStakeAddr <$> genApiPlutusScriptWitness WitCtxStake era
+  let withdrawals = zipWith3 (\addr c wit -> (addr, c, BuildTxWith wit)) sAddrs coins sWits
+  return $ TxWithdrawals (convert era) withdrawals
+
 genTxCertificates :: Typeable era => CardanoEra era -> Gen (TxCertificates BuildTx era)
 genTxCertificates =
   inEonForEra
@@ -755,6 +772,20 @@ genTxCertificates =
           ]
     )
 
+genScriptWitnessedTxCertificates :: Typeable era => Exp.Era era -> Gen (TxCertificates BuildTx era)
+genScriptWitnessedTxCertificates era = do
+  let w = convert era
+  num <- Gen.integral (Range.linear 0 3)
+  certs <- Gen.list (Range.singleton num) $ genCertificate w
+  plutusScriptWits <- Gen.list (Range.singleton num) $ genApiPlutusScriptWitness WitCtxStake era
+  let certsAndWits =
+        zipWith
+          (\c p -> (c, Just p))
+          certs
+          plutusScriptWits
+
+  pure $ mkTxCertificates (convert era) certsAndWits
+
 genCertificate :: forall era. Typeable era => ShelleyBasedEra era -> Gen (Certificate era)
 genCertificate sbe =
   Gen.choice $
@@ -1388,6 +1419,17 @@ genProposals w = conwayEraOnwardsConstraints w $ do
       (proposal,) <$> Gen.maybe (genScriptWitnessForStake sbe)
   pure $ mkTxProposalProcedures proposalsWithMaybeWitnesses
 
+genScriptWitnessedTxProposals
+  :: Exp.Era era
+  -> Gen (TxProposalProcedures BuildTx era)
+genScriptWitnessedTxProposals era = do
+  let w = convert era
+  num <- Gen.integral (Range.linear 0 3)
+  proposals <- Gen.list (Range.singleton num) (genProposal w)
+  sWits <- Gen.list (Range.singleton num) $ genApiPlutusScriptWitness WitCtxStake era
+  let proposalsWithMaybeWitnesses = zipWith (\p wit -> (p, Just wit)) proposals sWits
+  pure $ Exp.obtainCommonConstraints era $ mkTxProposalProcedures proposalsWithMaybeWitnesses
+
 genProposal :: ConwayEraOnwards era -> Gen (L.ProposalProcedure (ShelleyLedgerEra era))
 genProposal w =
   conwayEraOnwardsTestConstraints w Q.arbitrary
@@ -1405,6 +1447,18 @@ genVotingProcedures w = conwayEraOnwardsConstraints w $ do
     <$> Q.arbitrary
     <*> pure (pure votersWithWitnesses)
 
+genScriptWitnesssedTxVotingProcedures
+  :: Exp.Era era
+  -> Gen (Api.TxVotingProcedures BuildTx era)
+genScriptWitnesssedTxVotingProcedures era = do
+  num <- Gen.integral (Range.linear 0 3)
+  voters <- Gen.list (Range.singleton num) Q.arbitrary
+  plutusScriptWits <- Gen.list (Range.singleton num) $ genApiPlutusScriptWitness WitCtxStake era
+  let votersWithWitnesses = fromList $ zip voters plutusScriptWits
+  Api.TxVotingProcedures
+    <$> Exp.obtainCommonConstraints era Q.arbitrary
+    <*> pure (pure votersWithWitnesses)
+
 genCurrentTreasuryValue :: ConwayEraOnwards era -> Gen L.Coin
 genCurrentTreasuryValue _era = Q.arbitrary
 
@@ -1447,8 +1501,38 @@ genPlutusScriptWitness = do
 genPlutusScriptDatum :: Gen (Exp.PlutusScriptDatum lang purpose)
 genPlutusScriptDatum = return Exp.NoScriptDatum
 
+genScriptWitnessedTxIn
+  :: Exp.Era era -> Gen [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))]
+genScriptWitnessedTxIn era = do
+  num <- Gen.integral (Range.linear 0 3)
+  sWits <-
+    map (ScriptWitness ScriptWitnessForSpending)
+      <$> Gen.list (Range.singleton num) (genApiPlutusScriptWitness WitCtxTxIn era)
+  txIns <- Gen.list (Range.singleton num) genTxIn
+  pure $ zip txIns (BuildTxWith <$> sWits)
+
+genScriptWitnessedTxMintValue
+  :: Exp.Era era -> Gen (TxMintValue BuildTx era)
+genScriptWitnessedTxMintValue era = do
+  let w = convert era
+  num <- Gen.integral (Range.linear 0 3)
+  sWits <-
+    Gen.list (Range.singleton num) (genApiPlutusScriptWitness WitCtxMint era)
+
+  policies <- Gen.list (Range.singleton num) genPolicyId
+  mintValues <- Gen.list (Range.singleton num) genPolicyAssets
+  let assets =
+        [ (p, mintValue, BuildTxWith s)
+        | p <- policies
+        , s <- sWits
+        , mintValue <- mintValues
+        ]
+
+  pure $ mkTxMintValue w assets
+
 -- | This generator does not generate a valid witness - just a random one.
-genScriptWitnessForStake :: ShelleyBasedEra era -> Gen (Api.ScriptWitness WitCtxStake era)
+genScriptWitnessForStake
+  :: ShelleyBasedEra era -> Gen (Api.ScriptWitness WitCtxStake era)
 genScriptWitnessForStake sbe = do
   ScriptInEra scriptLangInEra script' <- genScriptInEra sbe
   case script' of
@@ -1474,6 +1558,50 @@ genScriptWitnessForStake sbe = do
         scriptRedeemer
         <$> genExecutionUnits
 
+genAnyPlutusScriptVersion :: Gen AnyPlutusScriptVersion
+genAnyPlutusScriptVersion = do
+  Gen.element [minBound .. maxBound]
+
+plutusScriptLangaugeInEra
+  :: Exp.Era era -> PlutusScriptVersion lang -> ScriptLanguageInEra lang era
+plutusScriptLangaugeInEra Exp.ConwayEra l =
+  case l of
+    PlutusScriptV1 -> PlutusScriptV1InConway
+    PlutusScriptV2 -> PlutusScriptV2InConway
+    PlutusScriptV3 -> PlutusScriptV3InConway
+
+genApiPlutusScriptWitness
+  :: WitCtx witctx -> Exp.Era era -> Gen (Api.ScriptWitness witctx era)
+genApiPlutusScriptWitness witCtx era = do
+  dat <- case witCtx of
+    WitCtxTxIn -> do
+      datum <- Gen.maybe genHashableScriptData
+
+      Gen.element [ScriptDatumForTxIn datum, InlineScriptDatum]
+    WitCtxMint -> do
+      pure NoScriptDatumForMint
+    WitCtxStake -> do
+      pure NoScriptDatumForStake
+
+  AnyPlutusScriptVersion lang <- genAnyPlutusScriptVersion
+  PlutusScript plutusScriptVersion' plutusScript <-
+    PlutusScript lang <$> genValidPlutusScript lang
+
+  plutusScriptOrReferenceInput <-
+    Gen.choice
+      [ pure $ PScript plutusScript
+      , PReferenceScript <$> genTxIn
+      ]
+
+  scriptRedeemer <- genHashableScriptData
+  PlutusScriptWitness
+    (plutusScriptLangaugeInEra era lang)
+    plutusScriptVersion'
+    plutusScriptOrReferenceInput
+    dat
+    scriptRedeemer
+    <$> genExecutionUnits
+
 genScriptWitnessForMint :: ShelleyBasedEra era -> Gen (Api.ScriptWitness WitCtxMint era)
 genScriptWitnessForMint sbe = do
   ScriptInEra scriptLangInEra script' <- genScriptInEra sbe

cardano-api/src/Cardano/Api/Era/Internal/Eon/ConwayEraOnwards.hs

@@ -22,6 +22,7 @@ where
 import Cardano.Api.Consensus.Internal.Mode
 import Cardano.Api.Era.Internal.Core
 import Cardano.Api.Era.Internal.Eon.AllegraEraOnwards (AllegraEraOnwards (..))
+import Cardano.Api.Era.Internal.Eon.AlonzoEraOnwards
 import Cardano.Api.Era.Internal.Eon.BabbageEraOnwards
 import Cardano.Api.Era.Internal.Eon.Convert
 import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra
@@ -83,6 +84,9 @@ instance Convert ConwayEraOnwards AllegraEraOnwards where
   convert = \case
     ConwayEraOnwardsConway -> AllegraEraOnwardsConway
 
+instance Convert ConwayEraOnwards AlonzoEraOnwards where
+  convert ConwayEraOnwardsConway = AlonzoEraOnwardsConway
+
 instance Convert ConwayEraOnwards BabbageEraOnwards where
   convert = \case
     ConwayEraOnwardsConway -> BabbageEraOnwardsConway

cardano-api/src/Cardano/Api/Experimental.hs

@@ -26,6 +26,9 @@ module Cardano.Api.Experimental
   , convertToOldApiCertificate
   , mkTxCertificates
 
+    -- ** Transaction fee related
+  , estimateBalancedTxBody
+
     -- ** Era-related
   , BabbageEra
   , ConwayEra
@@ -75,4 +78,5 @@ import Cardano.Api.Experimental.Plutus.Internal.Shim.LegacyScripts
 import Cardano.Api.Experimental.Simple.Script
 import Cardano.Api.Experimental.Tx
 import Cardano.Api.Experimental.Tx.Internal.Certificate
+import Cardano.Api.Experimental.Tx.Internal.Fee
 import Cardano.Api.Tx.Internal.Fee (evaluateTransactionExecutionUnitsShelley)

cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Script.hs

@@ -36,10 +36,12 @@ data PlutusScriptInEra (lang :: L.Language) era where
 
 deriving instance Show (PlutusScriptInEra lang era)
 
+deriving instance Eq (PlutusScriptInEra lang era)
+
 -- | You can provide the plutus script directly in the transaction
 -- or a reference input that points to the script in the UTxO.
 -- Using a reference script saves space in your transaction.
 data PlutusScriptOrReferenceInput lang era
   = PScript (PlutusScriptInEra lang era)
   | PReferenceScript TxIn
-  deriving Show
+  deriving (Show, Eq)

cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/ScriptWitness.hs

@@ -60,8 +60,8 @@ type ScriptRedeemer = HashableScriptData
 data PlutusScriptWitness (lang :: L.Language) (purpose :: PlutusScriptPurpose) era where
   PlutusScriptWitness
     :: L.SLanguage lang
-    -> (PlutusScriptOrReferenceInput lang era)
-    -> (PlutusScriptDatum lang purpose)
+    -> PlutusScriptOrReferenceInput lang era
+    -> PlutusScriptDatum lang purpose
     -> ScriptRedeemer
     -> ExecutionUnits
     -> PlutusScriptWitness lang purpose era

cardano-api/src/Cardano/Api/Experimental/Simple/Script.hs

@@ -18,7 +18,9 @@ data SimpleScript era where
 
 deriving instance Show (SimpleScript era)
 
+deriving instance Eq (SimpleScript era)
+
 data SimpleScriptOrReferenceInput era
   = SScript (SimpleScript era)
   | SReferenceScript TxIn
-  deriving Show
+  deriving (Show, Eq)

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

@@ -136,6 +136,7 @@ module Cardano.Api.Experimental.Tx
   , TxScriptWitnessRequirements (..)
 
     -- ** Collecting plutus script witness related transaction requirements.
+  , extractAllIndexedPlutusScriptWitnesses
   , getTxScriptWitnessesRequirements
   , obtainMonoidConstraint
 
@@ -151,6 +152,7 @@ import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra
 import Cardano.Api.Era.Internal.Feature
 import Cardano.Api.Experimental.Era
 import Cardano.Api.Experimental.Tx.Internal.AnyWitness
+import Cardano.Api.Experimental.Tx.Internal.Body
 import Cardano.Api.Experimental.Tx.Internal.TxScriptWitnessRequirements
 import Cardano.Api.HasTypeProxy (HasTypeProxy (..), Proxy, asType)
 import Cardano.Api.Ledger.Internal.Reexport (StrictMaybe (..), maybeToStrictMaybe)

cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Body.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Cardano.Api.Experimental.Tx.Internal.Body
+  ( extractAllIndexedPlutusScriptWitnesses
+  )
+where
+
+import Cardano.Api.Era
+import Cardano.Api.Experimental.Era
+import Cardano.Api.Experimental.Plutus
+import Cardano.Api.Plutus.Internal.Script
+import Cardano.Api.Tx.Internal.Body
+
+import Cardano.Binary qualified as CBOR
+
+extractAllIndexedPlutusScriptWitnesses
+  :: forall era
+   . Era era
+  -> TxBodyContent BuildTx era
+  -> Either
+       CBOR.DecoderError
+       [AnyIndexedPlutusScriptWitness (LedgerEra era)]
+extractAllIndexedPlutusScriptWitnesses era b = obtainCommonConstraints era $ do
+  let sbe = convert era
+      aeon = convert era
+      legacyTxInWits = extractWitnessableTxIns aeon $ txIns b
+      legacyCertWits = extractWitnessableCertificates aeon $ txCertificates b
+      legacyMintWits = extractWitnessableMints aeon $ txMintValue b
+      proposalWits
+        :: [(Witnessable ProposalItem (ShelleyLedgerEra era), BuildTxWith BuildTx (Witness WitCtxStake era))] =
+          caseShelleyToBabbageOrConwayEraOnwards
+            (const [])
+            (`extractWitnessableProposals` txProposalProcedures b)
+            sbe
+      legacyWithdrawalWits = extractWitnessableWithdrawals aeon $ txWithdrawals b
+      legacyVoteWits
+        :: [(Witnessable VoterItem (ShelleyLedgerEra era), BuildTxWith BuildTx (Witness WitCtxStake era))] =
+          caseShelleyToBabbageOrConwayEraOnwards
+            (const [])
+            (`extractWitnessableVotes` txVotingProcedures b)
+            sbe
+
+  txInWits <- legacyWitnessConversion aeon legacyTxInWits
+  let indexedScriptTxInWits = alonzoEraOnwardsConstraints aeon $ createIndexedPlutusScriptWitnesses txInWits
+
+  certWits <- legacyWitnessConversion aeon legacyCertWits
+  let indexedCertScriptWits = alonzoEraOnwardsConstraints aeon $ createIndexedPlutusScriptWitnesses certWits
+
+  mintWits <- legacyWitnessConversion aeon legacyMintWits
+  let indexedMintScriptWits = alonzoEraOnwardsConstraints aeon $ createIndexedPlutusScriptWitnesses mintWits
+
+  withdrawalWits <- legacyWitnessConversion aeon legacyWithdrawalWits
+  let indexedWithdrawalScriptWits = alonzoEraOnwardsConstraints aeon $ createIndexedPlutusScriptWitnesses withdrawalWits
+
+  proposalScriptWits <- legacyWitnessConversion aeon proposalWits
+  let indexedProposalScriptWits = alonzoEraOnwardsConstraints aeon $ createIndexedPlutusScriptWitnesses proposalScriptWits
+
+  voteWits <- legacyWitnessConversion aeon legacyVoteWits
+  let indexedVoteScriptWits = alonzoEraOnwardsConstraints aeon $ createIndexedPlutusScriptWitnesses voteWits
+  return $
+    mconcat
+      [ indexedScriptTxInWits
+      , indexedMintScriptWits
+      , indexedCertScriptWits
+      , indexedWithdrawalScriptWits
+      , indexedProposalScriptWits
+      , indexedVoteScriptWits
+      ]