Skip to content

Commit a795554

Browse files
Jimbo4350Jimbo4350
authored
Merge pull request #887 from IntersectMBO/jordan/implement-experimental-estimateBalancedTxBody
Implement experimental `estimateBalancedTxBody`
2 parents b2e7e53 + 079de21 commit a795554

13 files changed

Lines changed: 530 additions & 26 deletions

File tree

‎cardano-api/cardano-api.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -225,7 +225,9 @@ library
225225
Cardano.Api.Experimental.Plutus.Internal.ScriptWitness
226226
Cardano.Api.Experimental.Plutus.Internal.Shim.LegacyScripts
227227
Cardano.Api.Experimental.Tx.Internal.AnyWitness
228+
Cardano.Api.Experimental.Tx.Internal.Body
228229
Cardano.Api.Experimental.Tx.Internal.Certificate
230+
Cardano.Api.Experimental.Tx.Internal.Fee
229231
Cardano.Api.Experimental.Tx.Internal.TxScriptWitnessRequirements
230232
Cardano.Api.Genesis.Internal
231233
Cardano.Api.Genesis.Internal.Parameters

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

Lines changed: 129 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -125,6 +125,12 @@ module Test.Gen.Cardano.Api.Typed
125125
, genLedgerValueForTxOut
126126
, genLedgerMultiAssetValue
127127
, genWitnesses
128+
, genScriptWitnessedTxIn
129+
, genScriptWitnessedTxMintValue
130+
, genScriptWitnessedTxCertificates
131+
, genScriptWitnessedTxProposals
132+
, genScriptWitnessedTxWithdrawals
133+
, genScriptWitnesssedTxVotingProcedures
128134
, genWitnessNetworkIdOrByronAddress
129135
, genRational
130136
, genGovernancePoll
@@ -742,6 +748,17 @@ genTxWithdrawals =
742748
]
743749
)
744750

751+
genScriptWitnessedTxWithdrawals :: Exp.Era era -> Gen (TxWithdrawals BuildTx era)
752+
genScriptWitnessedTxWithdrawals era = do
753+
num <- Gen.integral (Range.constant 0 3)
754+
sAddrs <- Gen.list (Range.singleton num) genStakeAddress
755+
coins <- Gen.list (Range.singleton num) genPositiveLovelace
756+
sWits <-
757+
Gen.list (Range.singleton num) $
758+
ScriptWitness ScriptWitnessForStakeAddr <$> genApiPlutusScriptWitness WitCtxStake era
759+
let withdrawals = zipWith3 (\addr c wit -> (addr, c, BuildTxWith wit)) sAddrs coins sWits
760+
return $ TxWithdrawals (convert era) withdrawals
761+
745762
genTxCertificates :: Typeable era => CardanoEra era -> Gen (TxCertificates BuildTx era)
746763
genTxCertificates =
747764
inEonForEra
@@ -755,6 +772,20 @@ genTxCertificates =
755772
]
756773
)
757774

775+
genScriptWitnessedTxCertificates :: Typeable era => Exp.Era era -> Gen (TxCertificates BuildTx era)
776+
genScriptWitnessedTxCertificates era = do
777+
let w = convert era
778+
num <- Gen.integral (Range.linear 0 3)
779+
certs <- Gen.list (Range.singleton num) $ genCertificate w
780+
plutusScriptWits <- Gen.list (Range.singleton num) $ genApiPlutusScriptWitness WitCtxStake era
781+
let certsAndWits =
782+
zipWith
783+
(\c p -> (c, Just p))
784+
certs
785+
plutusScriptWits
786+
787+
pure $ mkTxCertificates (convert era) certsAndWits
788+
758789
genCertificate :: forall era. Typeable era => ShelleyBasedEra era -> Gen (Certificate era)
759790
genCertificate sbe =
760791
Gen.choice $
@@ -1388,6 +1419,17 @@ genProposals w = conwayEraOnwardsConstraints w $ do
13881419
(proposal,) <$> Gen.maybe (genScriptWitnessForStake sbe)
13891420
pure $ mkTxProposalProcedures proposalsWithMaybeWitnesses
13901421

1422+
genScriptWitnessedTxProposals
1423+
:: Exp.Era era
1424+
-> Gen (TxProposalProcedures BuildTx era)
1425+
genScriptWitnessedTxProposals era = do
1426+
let w = convert era
1427+
num <- Gen.integral (Range.linear 0 3)
1428+
proposals <- Gen.list (Range.singleton num) (genProposal w)
1429+
sWits <- Gen.list (Range.singleton num) $ genApiPlutusScriptWitness WitCtxStake era
1430+
let proposalsWithMaybeWitnesses = zipWith (\p wit -> (p, Just wit)) proposals sWits
1431+
pure $ Exp.obtainCommonConstraints era $ mkTxProposalProcedures proposalsWithMaybeWitnesses
1432+
13911433
genProposal :: ConwayEraOnwards era -> Gen (L.ProposalProcedure (ShelleyLedgerEra era))
13921434
genProposal w =
13931435
conwayEraOnwardsTestConstraints w Q.arbitrary
@@ -1405,6 +1447,18 @@ genVotingProcedures w = conwayEraOnwardsConstraints w $ do
14051447
<$> Q.arbitrary
14061448
<*> pure (pure votersWithWitnesses)
14071449

1450+
genScriptWitnesssedTxVotingProcedures
1451+
:: Exp.Era era
1452+
-> Gen (Api.TxVotingProcedures BuildTx era)
1453+
genScriptWitnesssedTxVotingProcedures era = do
1454+
num <- Gen.integral (Range.linear 0 3)
1455+
voters <- Gen.list (Range.singleton num) Q.arbitrary
1456+
plutusScriptWits <- Gen.list (Range.singleton num) $ genApiPlutusScriptWitness WitCtxStake era
1457+
let votersWithWitnesses = fromList $ zip voters plutusScriptWits
1458+
Api.TxVotingProcedures
1459+
<$> Exp.obtainCommonConstraints era Q.arbitrary
1460+
<*> pure (pure votersWithWitnesses)
1461+
14081462
genCurrentTreasuryValue :: ConwayEraOnwards era -> Gen L.Coin
14091463
genCurrentTreasuryValue _era = Q.arbitrary
14101464

@@ -1447,8 +1501,38 @@ genPlutusScriptWitness = do
14471501
genPlutusScriptDatum :: Gen (Exp.PlutusScriptDatum lang purpose)
14481502
genPlutusScriptDatum = return Exp.NoScriptDatum
14491503

1504+
genScriptWitnessedTxIn
1505+
:: Exp.Era era -> Gen [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))]
1506+
genScriptWitnessedTxIn era = do
1507+
num <- Gen.integral (Range.linear 0 3)
1508+
sWits <-
1509+
map (ScriptWitness ScriptWitnessForSpending)
1510+
<$> Gen.list (Range.singleton num) (genApiPlutusScriptWitness WitCtxTxIn era)
1511+
txIns <- Gen.list (Range.singleton num) genTxIn
1512+
pure $ zip txIns (BuildTxWith <$> sWits)
1513+
1514+
genScriptWitnessedTxMintValue
1515+
:: Exp.Era era -> Gen (TxMintValue BuildTx era)
1516+
genScriptWitnessedTxMintValue era = do
1517+
let w = convert era
1518+
num <- Gen.integral (Range.linear 0 3)
1519+
sWits <-
1520+
Gen.list (Range.singleton num) (genApiPlutusScriptWitness WitCtxMint era)
1521+
1522+
policies <- Gen.list (Range.singleton num) genPolicyId
1523+
mintValues <- Gen.list (Range.singleton num) genPolicyAssets
1524+
let assets =
1525+
[ (p, mintValue, BuildTxWith s)
1526+
| p <- policies
1527+
, s <- sWits
1528+
, mintValue <- mintValues
1529+
]
1530+
1531+
pure $ mkTxMintValue w assets
1532+
14501533
-- | This generator does not generate a valid witness - just a random one.
1451-
genScriptWitnessForStake :: ShelleyBasedEra era -> Gen (Api.ScriptWitness WitCtxStake era)
1534+
genScriptWitnessForStake
1535+
:: ShelleyBasedEra era -> Gen (Api.ScriptWitness WitCtxStake era)
14521536
genScriptWitnessForStake sbe = do
14531537
ScriptInEra scriptLangInEra script' <- genScriptInEra sbe
14541538
case script' of
@@ -1474,6 +1558,50 @@ genScriptWitnessForStake sbe = do
14741558
scriptRedeemer
14751559
<$> genExecutionUnits
14761560

1561+
genAnyPlutusScriptVersion :: Gen AnyPlutusScriptVersion
1562+
genAnyPlutusScriptVersion = do
1563+
Gen.element [minBound .. maxBound]
1564+
1565+
plutusScriptLangaugeInEra
1566+
:: Exp.Era era -> PlutusScriptVersion lang -> ScriptLanguageInEra lang era
1567+
plutusScriptLangaugeInEra Exp.ConwayEra l =
1568+
case l of
1569+
PlutusScriptV1 -> PlutusScriptV1InConway
1570+
PlutusScriptV2 -> PlutusScriptV2InConway
1571+
PlutusScriptV3 -> PlutusScriptV3InConway
1572+
1573+
genApiPlutusScriptWitness
1574+
:: WitCtx witctx -> Exp.Era era -> Gen (Api.ScriptWitness witctx era)
1575+
genApiPlutusScriptWitness witCtx era = do
1576+
dat <- case witCtx of
1577+
WitCtxTxIn -> do
1578+
datum <- Gen.maybe genHashableScriptData
1579+
1580+
Gen.element [ScriptDatumForTxIn datum, InlineScriptDatum]
1581+
WitCtxMint -> do
1582+
pure NoScriptDatumForMint
1583+
WitCtxStake -> do
1584+
pure NoScriptDatumForStake
1585+
1586+
AnyPlutusScriptVersion lang <- genAnyPlutusScriptVersion
1587+
PlutusScript plutusScriptVersion' plutusScript <-
1588+
PlutusScript lang <$> genValidPlutusScript lang
1589+
1590+
plutusScriptOrReferenceInput <-
1591+
Gen.choice
1592+
[ pure $ PScript plutusScript
1593+
, PReferenceScript <$> genTxIn
1594+
]
1595+
1596+
scriptRedeemer <- genHashableScriptData
1597+
PlutusScriptWitness
1598+
(plutusScriptLangaugeInEra era lang)
1599+
plutusScriptVersion'
1600+
plutusScriptOrReferenceInput
1601+
dat
1602+
scriptRedeemer
1603+
<$> genExecutionUnits
1604+
14771605
genScriptWitnessForMint :: ShelleyBasedEra era -> Gen (Api.ScriptWitness WitCtxMint era)
14781606
genScriptWitnessForMint sbe = do
14791607
ScriptInEra scriptLangInEra script' <- genScriptInEra sbe

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

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -22,6 +22,7 @@ where
2222
import Cardano.Api.Consensus.Internal.Mode
2323
import Cardano.Api.Era.Internal.Core
2424
import Cardano.Api.Era.Internal.Eon.AllegraEraOnwards (AllegraEraOnwards (..))
25+
import Cardano.Api.Era.Internal.Eon.AlonzoEraOnwards
2526
import Cardano.Api.Era.Internal.Eon.BabbageEraOnwards
2627
import Cardano.Api.Era.Internal.Eon.Convert
2728
import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra
@@ -83,6 +84,9 @@ instance Convert ConwayEraOnwards AllegraEraOnwards where
8384
convert = \case
8485
ConwayEraOnwardsConway -> AllegraEraOnwardsConway
8586

87+
instance Convert ConwayEraOnwards AlonzoEraOnwards where
88+
convert ConwayEraOnwardsConway = AlonzoEraOnwardsConway
89+
8690
instance Convert ConwayEraOnwards BabbageEraOnwards where
8791
convert = \case
8892
ConwayEraOnwardsConway -> BabbageEraOnwardsConway

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

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,9 @@ module Cardano.Api.Experimental
2626
, convertToOldApiCertificate
2727
, mkTxCertificates
2828

29+
-- ** Transaction fee related
30+
, estimateBalancedTxBody
31+
2932
-- ** Era-related
3033
, BabbageEra
3134
, ConwayEra
@@ -75,4 +78,5 @@ import Cardano.Api.Experimental.Plutus.Internal.Shim.LegacyScripts
7578
import Cardano.Api.Experimental.Simple.Script
7679
import Cardano.Api.Experimental.Tx
7780
import Cardano.Api.Experimental.Tx.Internal.Certificate
81+
import Cardano.Api.Experimental.Tx.Internal.Fee
7882
import Cardano.Api.Tx.Internal.Fee (evaluateTransactionExecutionUnitsShelley)

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

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -36,10 +36,12 @@ data PlutusScriptInEra (lang :: L.Language) era where
3636

3737
deriving instance Show (PlutusScriptInEra lang era)
3838

39+
deriving instance Eq (PlutusScriptInEra lang era)
40+
3941
-- | You can provide the plutus script directly in the transaction
4042
-- or a reference input that points to the script in the UTxO.
4143
-- Using a reference script saves space in your transaction.
4244
data PlutusScriptOrReferenceInput lang era
4345
= PScript (PlutusScriptInEra lang era)
4446
| PReferenceScript TxIn
45-
deriving Show
47+
deriving (Show, Eq)

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -60,8 +60,8 @@ type ScriptRedeemer = HashableScriptData
6060
data PlutusScriptWitness (lang :: L.Language) (purpose :: PlutusScriptPurpose) era where
6161
PlutusScriptWitness
6262
:: L.SLanguage lang
63-
-> (PlutusScriptOrReferenceInput lang era)
64-
-> (PlutusScriptDatum lang purpose)
63+
-> PlutusScriptOrReferenceInput lang era
64+
-> PlutusScriptDatum lang purpose
6565
-> ScriptRedeemer
6666
-> ExecutionUnits
6767
-> PlutusScriptWitness lang purpose era

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

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -18,7 +18,9 @@ data SimpleScript era where
1818

1919
deriving instance Show (SimpleScript era)
2020

21+
deriving instance Eq (SimpleScript era)
22+
2123
data SimpleScriptOrReferenceInput era
2224
= SScript (SimpleScript era)
2325
| SReferenceScript TxIn
24-
deriving Show
26+
deriving (Show, Eq)

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -136,6 +136,7 @@ module Cardano.Api.Experimental.Tx
136136
, TxScriptWitnessRequirements (..)
137137

138138
-- ** Collecting plutus script witness related transaction requirements.
139+
, extractAllIndexedPlutusScriptWitnesses
139140
, getTxScriptWitnessesRequirements
140141
, obtainMonoidConstraint
141142

@@ -151,6 +152,7 @@ import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra
151152
import Cardano.Api.Era.Internal.Feature
152153
import Cardano.Api.Experimental.Era
153154
import Cardano.Api.Experimental.Tx.Internal.AnyWitness
155+
import Cardano.Api.Experimental.Tx.Internal.Body
154156
import Cardano.Api.Experimental.Tx.Internal.TxScriptWitnessRequirements
155157
import Cardano.Api.HasTypeProxy (HasTypeProxy (..), Proxy, asType)
156158
import Cardano.Api.Ledger.Internal.Reexport (StrictMaybe (..), maybeToStrictMaybe)

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

Lines changed: 70 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,70 @@
1+
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE GADTs #-}
3+
{-# LANGUAGE ScopedTypeVariables #-}
4+
5+
module Cardano.Api.Experimental.Tx.Internal.Body
6+
( extractAllIndexedPlutusScriptWitnesses
7+
)
8+
where
9+
10+
import Cardano.Api.Era
11+
import Cardano.Api.Experimental.Era
12+
import Cardano.Api.Experimental.Plutus
13+
import Cardano.Api.Plutus.Internal.Script
14+
import Cardano.Api.Tx.Internal.Body
15+
16+
import Cardano.Binary qualified as CBOR
17+
18+
extractAllIndexedPlutusScriptWitnesses
19+
:: forall era
20+
. Era era
21+
-> TxBodyContent BuildTx era
22+
-> Either
23+
CBOR.DecoderError
24+
[AnyIndexedPlutusScriptWitness (LedgerEra era)]
25+
extractAllIndexedPlutusScriptWitnesses era b = obtainCommonConstraints era $ do
26+
let sbe = convert era
27+
aeon = convert era
28+
legacyTxInWits = extractWitnessableTxIns aeon $ txIns b
29+
legacyCertWits = extractWitnessableCertificates aeon $ txCertificates b
30+
legacyMintWits = extractWitnessableMints aeon $ txMintValue b
31+
proposalWits
32+
:: [(Witnessable ProposalItem (ShelleyLedgerEra era), BuildTxWith BuildTx (Witness WitCtxStake era))] =
33+
caseShelleyToBabbageOrConwayEraOnwards
34+
(const [])
35+
(`extractWitnessableProposals` txProposalProcedures b)
36+
sbe
37+
legacyWithdrawalWits = extractWitnessableWithdrawals aeon $ txWithdrawals b
38+
legacyVoteWits
39+
:: [(Witnessable VoterItem (ShelleyLedgerEra era), BuildTxWith BuildTx (Witness WitCtxStake era))] =
40+
caseShelleyToBabbageOrConwayEraOnwards
41+
(const [])
42+
(`extractWitnessableVotes` txVotingProcedures b)
43+
sbe
44+
45+
txInWits <- legacyWitnessConversion aeon legacyTxInWits
46+
let indexedScriptTxInWits = alonzoEraOnwardsConstraints aeon $ createIndexedPlutusScriptWitnesses txInWits
47+
48+
certWits <- legacyWitnessConversion aeon legacyCertWits
49+
let indexedCertScriptWits = alonzoEraOnwardsConstraints aeon $ createIndexedPlutusScriptWitnesses certWits
50+
51+
mintWits <- legacyWitnessConversion aeon legacyMintWits
52+
let indexedMintScriptWits = alonzoEraOnwardsConstraints aeon $ createIndexedPlutusScriptWitnesses mintWits
53+
54+
withdrawalWits <- legacyWitnessConversion aeon legacyWithdrawalWits
55+
let indexedWithdrawalScriptWits = alonzoEraOnwardsConstraints aeon $ createIndexedPlutusScriptWitnesses withdrawalWits
56+
57+
proposalScriptWits <- legacyWitnessConversion aeon proposalWits
58+
let indexedProposalScriptWits = alonzoEraOnwardsConstraints aeon $ createIndexedPlutusScriptWitnesses proposalScriptWits
59+
60+
voteWits <- legacyWitnessConversion aeon legacyVoteWits
61+
let indexedVoteScriptWits = alonzoEraOnwardsConstraints aeon $ createIndexedPlutusScriptWitnesses voteWits
62+
return $
63+
mconcat
64+
[ indexedScriptTxInWits
65+
, indexedMintScriptWits
66+
, indexedCertScriptWits
67+
, indexedWithdrawalScriptWits
68+
, indexedProposalScriptWits
69+
, indexedVoteScriptWits
70+
]

0 commit comments

Comments
 (0)