Skip to content

Commit e997263

Browse files
carbolymercarbolymer
committed
Add posibility to provide actual datums for hashes in reference inputs
1 parent 509a9c3 commit e997263

File tree

4 files changed

+119
-58
lines changed

4 files changed

+119
-58
lines changed

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

+23-18
Original file line numberDiff line numberDiff line change
@@ -144,7 +144,7 @@ where
144144

145145
import Cardano.Api hiding (txIns)
146146
import qualified Cardano.Api as Api
147-
import qualified Cardano.Api.Experimental as Exp
147+
import qualified Cardano.Api.Experimental as Exp
148148
import Cardano.Api.Byron (KeyWitness (ByronKeyWitness),
149149
WitnessNetworkIdOrByronAddress (..))
150150
import qualified Cardano.Api.Byron as Byron
@@ -965,11 +965,17 @@ genTxInsCollateral =
965965
]
966966
)
967967

968-
genTxInsReference :: CardanoEra era -> Gen (TxInsReference era)
968+
genTxInsReference
969+
:: Applicative (BuildTxWith build)
970+
=> CardanoEra era
971+
-> Gen (TxInsReference build era)
969972
genTxInsReference =
970973
caseByronToAlonzoOrBabbageEraOnwards
971974
(const (pure TxInsReferenceNone))
972-
(\w -> TxInsReference w <$> Gen.list (Range.linear 0 10) genTxIn)
975+
(\w -> do
976+
txIns <- Gen.list (Range.linear 0 10) genTxIn
977+
pure $ TxInsReference w txIns mempty
978+
)
973979

974980
genTxReturnCollateral :: ShelleyBasedEra era -> Gen (TxReturnCollateral CtxTx era)
975981
genTxReturnCollateral era =
@@ -1022,7 +1028,7 @@ genWitnessesByron = Gen.list (Range.constant 1 10) genByronKeyWitness
10221028

10231029
-- | This generator validates generated 'TxBodyContent' and backtracks when the generated body
10241030
-- fails the validation. That also means that it is quite slow.
1025-
genValidTxBody :: Typeable era
1031+
genValidTxBody :: Typeable era
10261032
=> ShelleyBasedEra era
10271033
-> Gen (TxBody era, TxBodyContent BuildTx era) -- ^ validated 'TxBody' and 'TxBodyContent'
10281034
genValidTxBody sbe =
@@ -1135,7 +1141,6 @@ genShelleyBootstrapWitness sbe =
11351141
<*> (fst <$> genValidTxBody sbe)
11361142
<*> genSigningKey AsByronKey
11371143

1138-
11391144
genShelleyKeyWitness
11401145
:: ()
11411146
=> Typeable era
@@ -1385,39 +1390,39 @@ genTreasuryDonation :: ConwayEraOnwards era -> Gen L.Coin
13851390
genTreasuryDonation _era = Q.arbitrary
13861391

13871392
genWitnessable :: L.AlonzoEraScript era => Gen (Exp.Witnessable Exp.TxInItem era)
1388-
genWitnessable = Exp.WitTxIn <$> genTxIn
1393+
genWitnessable = Exp.WitTxIn <$> genTxIn
13891394

13901395
genMintWitnessable :: L.AlonzoEraScript era => Gen (Exp.Witnessable Exp.MintItem era)
1391-
genMintWitnessable = Exp.WitMint <$> genPolicyId <*> genPolicyAssets
1396+
genMintWitnessable = Exp.WitMint <$> genPolicyId <*> genPolicyAssets
13921397

1393-
genIndexedPlutusScriptWitness
1394-
:: L.AlonzoEraScript (ShelleyLedgerEra era)
1398+
genIndexedPlutusScriptWitness
1399+
:: L.AlonzoEraScript (ShelleyLedgerEra era)
13951400
=> Gen (Exp.IndexedPlutusScriptWitness Exp.TxInItem L.PlutusV3 Exp.SpendingScript (ShelleyLedgerEra era))
13961401
genIndexedPlutusScriptWitness = do
13971402
index <- Gen.word32 $ Range.linear 1 10
13981403
witnessable <- genWitnessable
1399-
Exp.IndexedPlutusScriptWitness
1404+
Exp.IndexedPlutusScriptWitness
14001405
<$> genWitnessable
14011406
<*> genPlutusPurpose index witnessable
1402-
<*> genPlutusScriptWitness
1407+
<*> genPlutusScriptWitness
14031408

1404-
genPlutusPurpose
1405-
:: Word32
1406-
-> Exp.Witnessable thing (ShelleyLedgerEra era)
1409+
genPlutusPurpose
1410+
:: Word32
1411+
-> Exp.Witnessable thing (ShelleyLedgerEra era)
14071412
-> Gen (L.PlutusPurpose L.AsIx (ShelleyLedgerEra era))
14081413
genPlutusPurpose index wit = return $ Exp.toPlutusScriptPurpose index wit
14091414

14101415
genPlutusScriptWitness :: Gen (Exp.PlutusScriptWitness L.PlutusV3 purpose era)
1411-
genPlutusScriptWitness = do
1416+
genPlutusScriptWitness = do
14121417
let l = Exp.toPlutusSLanguage PlutusScriptV3
1413-
Exp.PlutusScriptWitness l . Exp.PReferenceScript
1418+
Exp.PlutusScriptWitness l . Exp.PReferenceScript
14141419
<$> genTxIn
14151420
<*> genPlutusScriptDatum
14161421
<*> genHashableScriptData
1417-
<*> genExecutionUnits
1422+
<*> genExecutionUnits
14181423

14191424
genPlutusScriptDatum :: Gen (Exp.PlutusScriptDatum lang purpose)
1420-
genPlutusScriptDatum = return Exp.NoScriptDatum
1425+
genPlutusScriptDatum = return Exp.NoScriptDatum
14211426

14221427
-- | This generator does not generate a valid witness - just a random one.
14231428
genScriptWitnessForStake :: ShelleyBasedEra era -> Gen (Api.ScriptWitness WitCtxStake era)

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

+83-36
Original file line numberDiff line numberDiff line change
@@ -301,6 +301,8 @@ module Cardano.Api.Internal.Tx.Body
301301
-- ** Other transaction body types
302302
, TxInsCollateral (..)
303303
, TxInsReference (..)
304+
, TxInsReferenceDatums
305+
, getReferenceInputDatumMap
304306
, TxReturnCollateral (..)
305307
, TxTotalCollateral (..)
306308
, TxFee (..)
@@ -570,16 +572,31 @@ deriving instance Eq (TxTotalCollateral era)
570572

571573
deriving instance Show (TxTotalCollateral era)
572574

573-
data TxInsReference era where
574-
TxInsReferenceNone :: TxInsReference era
575+
data TxInsReference build era where
576+
TxInsReferenceNone :: TxInsReference build era
575577
TxInsReference
576578
:: BabbageEraOnwards era
577579
-> [TxIn]
578-
-> TxInsReference era
580+
-- ^ A list of reference inputs
581+
-> TxInsReferenceDatums build
582+
-- ^ A set of datums, whose hashes are referenced in UTXO of reference inputs. Those datums will be inserted
583+
-- to the datum map available to the scripts. Note that inserting a datum with hash not present in the reference
584+
-- input will result in an error on transaction submission.
585+
-> TxInsReference build era
579586

580-
deriving instance Eq (TxInsReference era)
587+
deriving instance Eq (TxInsReference build era)
581588

582-
deriving instance Show (TxInsReference era)
589+
deriving instance Show (TxInsReference build era)
590+
591+
-- | The actual datums, referenced by hash in the transaction reference inputs.
592+
type TxInsReferenceDatums build = BuildTxWith build (Set HashableScriptData)
593+
594+
getReferenceInputDatumMap
595+
:: TxInsReferenceDatums build
596+
-> Map (Hash ScriptData) HashableScriptData
597+
getReferenceInputDatumMap = \case
598+
ViewTx -> mempty
599+
BuildTxWith datumSet -> fromList $ map (\h -> (hashScriptDataBytes h, h)) $ toList datumSet
583600

584601
-- ----------------------------------------------------------------------------
585602
-- Transaction fees
@@ -984,7 +1001,7 @@ data TxBodyContent build era
9841001
= TxBodyContent
9851002
{ txIns :: TxIns build era
9861003
, txInsCollateral :: TxInsCollateral era
987-
, txInsReference :: TxInsReference era
1004+
, txInsReference :: TxInsReference build era
9881005
, txOuts :: [TxOut CtxTx era]
9891006
, txTotalCollateral :: TxTotalCollateral era
9901007
, txReturnCollateral :: TxReturnCollateral CtxTx era
@@ -1075,25 +1092,36 @@ addTxInCollateral
10751092
:: IsAlonzoBasedEra era => TxIn -> TxBodyContent build era -> TxBodyContent build era
10761093
addTxInCollateral txInCollateral = addTxInsCollateral [txInCollateral]
10771094

1078-
setTxInsReference :: TxInsReference era -> TxBodyContent build era -> TxBodyContent build era
1095+
setTxInsReference :: TxInsReference build era -> TxBodyContent build era -> TxBodyContent build era
10791096
setTxInsReference v txBodyContent = txBodyContent{txInsReference = v}
10801097

10811098
modTxInsReference
1082-
:: (TxInsReference era -> TxInsReference era) -> TxBodyContent build era -> TxBodyContent build era
1099+
:: (TxInsReference build era -> TxInsReference build era)
1100+
-> TxBodyContent build era
1101+
-> TxBodyContent build era
10831102
modTxInsReference f txBodyContent = txBodyContent{txInsReference = f (txInsReference txBodyContent)}
10841103

10851104
addTxInsReference
1086-
:: IsBabbageBasedEra era => [TxIn] -> TxBodyContent build era -> TxBodyContent build era
1087-
addTxInsReference txInsReference =
1088-
modTxInsReference
1089-
( \case
1090-
TxInsReferenceNone -> TxInsReference babbageBasedEra txInsReference
1091-
TxInsReference era xs -> TxInsReference era (xs <> txInsReference)
1092-
)
1105+
:: Applicative (BuildTxWith build)
1106+
=> IsBabbageBasedEra era
1107+
=> [TxIn]
1108+
-> Set HashableScriptData
1109+
-> TxBodyContent build era
1110+
-> TxBodyContent build era
1111+
addTxInsReference txInsReference scriptData =
1112+
modTxInsReference $
1113+
\case
1114+
TxInsReferenceNone -> TxInsReference babbageBasedEra txInsReference (pure scriptData)
1115+
TxInsReference era xs bScriptData' -> TxInsReference era (xs <> txInsReference) ((<> scriptData) <$> bScriptData')
10931116

10941117
addTxInReference
1095-
:: IsBabbageBasedEra era => TxIn -> TxBodyContent build era -> TxBodyContent build era
1096-
addTxInReference txInReference = addTxInsReference [txInReference]
1118+
:: Applicative (BuildTxWith build)
1119+
=> IsBabbageBasedEra era
1120+
=> TxIn
1121+
-> Maybe HashableScriptData
1122+
-> TxBodyContent build era
1123+
-> TxBodyContent build era
1124+
addTxInReference txInReference mDatum = addTxInsReference [txInReference] . fromList $ maybeToList mDatum
10971125

10981126
setTxOuts :: [TxOut CtxTx era] -> TxBodyContent build era -> TxBodyContent build era
10991127
setTxOuts v txBodyContent = txBodyContent{txOuts = v}
@@ -1742,11 +1770,11 @@ fromLedgerTxInsCollateral sbe body =
17421770
sbe
17431771

17441772
fromLedgerTxInsReference
1745-
:: ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> TxInsReference era
1773+
:: ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> TxInsReference ViewTx era
17461774
fromLedgerTxInsReference sbe txBody =
17471775
caseShelleyToAlonzoOrBabbageEraOnwards
17481776
(const TxInsReferenceNone)
1749-
(\w -> TxInsReference w $ map fromShelleyTxIn . toList $ txBody ^. L.referenceInputsTxBodyL)
1777+
(\w -> TxInsReference w (map fromShelleyTxIn . toList $ txBody ^. L.referenceInputsTxBodyL) ViewTx)
17501778
sbe
17511779

17521780
fromLedgerTxTotalCollateral
@@ -2108,11 +2136,11 @@ convPParamsToScriptIntegrityHash
21082136
-> Alonzo.TxDats (ShelleyLedgerEra era)
21092137
-> Set Plutus.Language
21102138
-> StrictMaybe L.ScriptIntegrityHash
2111-
convPParamsToScriptIntegrityHash w txProtocolParams redeemers datums languages =
2139+
convPParamsToScriptIntegrityHash w (BuildTxWith mTxProtocolParams) redeemers datums languages =
21122140
alonzoEraOnwardsConstraints w $
2113-
case txProtocolParams of
2114-
BuildTxWith Nothing -> SNothing
2115-
BuildTxWith (Just (LedgerProtocolParameters pp)) ->
2141+
case mTxProtocolParams of
2142+
Nothing -> SNothing
2143+
Just (LedgerProtocolParameters pp) ->
21162144
Alonzo.hashScriptIntegrity (Set.map (L.getLanguageView pp) languages) redeemers datums
21172145

21182146
convLanguages :: [(ScriptWitnessIndex, AnyScriptWitness era)] -> Set Plutus.Language
@@ -2122,11 +2150,11 @@ convLanguages witnesses =
21222150
| (_, AnyScriptWitness (PlutusScriptWitness _ v _ _ _ _)) <- witnesses
21232151
]
21242152

2125-
convReferenceInputs :: TxInsReference era -> Set Ledger.TxIn
2153+
convReferenceInputs :: TxInsReference build era -> Set Ledger.TxIn
21262154
convReferenceInputs txInsReference =
21272155
case txInsReference of
21282156
TxInsReferenceNone -> mempty
2129-
TxInsReference _ refTxins -> fromList $ map toShelleyTxIn refTxins
2157+
TxInsReference _ refTxins _ -> fromList $ map toShelleyTxIn refTxins
21302158

21312159
-- | Returns an OSet of proposals from 'TxProposalProcedures'.
21322160
convProposalProcedures
@@ -2993,11 +3021,17 @@ collectTxBodyScriptWitnessRequirements
29933021
collectTxBodyScriptWitnessRequirements
29943022
aEon
29953023
bc@TxBodyContent
2996-
{ txOuts
3024+
{ txInsReference
3025+
, txOuts
29973026
} =
29983027
obtainAlonzoScriptPurposeConstraints aEon $ do
29993028
let sbe = shelleyBasedEra @era
3000-
supplementaldatums = TxScriptWitnessRequirements mempty mempty (getSupplementalDatums aEon txOuts) mempty
3029+
supplementaldatums =
3030+
TxScriptWitnessRequirements
3031+
mempty
3032+
mempty
3033+
(getDatums aEon txInsReference txOuts)
3034+
mempty
30013035
txInWits <-
30023036
first TxBodyPlutusScriptDecodeError $
30033037
legacyWitnessToScriptRequirements aEon $
@@ -3051,19 +3085,32 @@ collectTxBodyScriptWitnessRequirements
30513085
, txProposalWits
30523086
]
30533087

3054-
getSupplementalDatums
3088+
-- | Extract datum:
3089+
-- 1. supplemental datums from transaction outputs
3090+
-- 2. datums from reference inputs
3091+
--
3092+
-- Note that this function does not check whose datum datum hashes are present in the reference inputs. This means
3093+
-- if there are redundant datums in 'TxInsReference', a submission of such transaction will fail.
3094+
getDatums
30553095
:: AlonzoEraOnwards era
3096+
-> TxInsReference BuildTx era
3097+
-- ^ reference inputs
30563098
-> [TxOut CtxTx era]
30573099
-> L.TxDats (ShelleyLedgerEra era)
3058-
getSupplementalDatums eon [] = alonzoEraOnwardsConstraints eon mempty
3059-
getSupplementalDatums eon txouts =
3060-
alonzoEraOnwardsConstraints eon $
3061-
L.TxDats $
3062-
fromList
3063-
[ (L.hashData ledgerData, ledgerData)
3064-
| TxOut _ _ (TxOutSupplementalDatum _ d) _ <- txouts
3065-
, let ledgerData = toAlonzoData d
3100+
getDatums eon txInsRef txOutsFromTx = alonzoEraOnwardsConstraints eon $ do
3101+
let refTxInsDats =
3102+
[ d
3103+
| TxInsReference _ _ (BuildTxWith datumSet) <- [txInsRef]
3104+
, d <- toList datumSet
30663105
]
3106+
-- use only supplemental datum
3107+
txOutsDats = [d | TxOut _ _ (TxOutSupplementalDatum _ d) _ <- txOutsFromTx]
3108+
L.TxDats $
3109+
fromList $
3110+
[ (L.hashData ledgerData, ledgerData)
3111+
| d <- refTxInsDats <> txOutsDats
3112+
, let ledgerData = toAlonzoData d
3113+
]
30673114

30683115
extractWitnessableTxIns
30693116
:: AlonzoEraOnwards era

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

+7
Original file line numberDiff line numberDiff line change
@@ -40,6 +40,13 @@ instance Applicative (BuildTxWith BuildTx) where
4040
pure = BuildTxWith
4141
(BuildTxWith f) <*> (BuildTxWith a) = BuildTxWith (f a)
4242

43+
instance Semigroup a => Semigroup (BuildTxWith build a) where
44+
ViewTx <> ViewTx = ViewTx
45+
(BuildTxWith a) <> (BuildTxWith b) = BuildTxWith (a <> b)
46+
47+
instance (Applicative (BuildTxWith build), Monoid a) => Monoid (BuildTxWith build a) where
48+
mempty = pure mempty
49+
4350
buildTxWithToMaybe :: BuildTxWith build a -> Maybe a
4451
buildTxWithToMaybe ViewTx = Nothing
4552
buildTxWithToMaybe (BuildTxWith a) = Just a

‎cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs

+6-4
Original file line numberDiff line numberDiff line change
@@ -61,16 +61,18 @@ prop_created_transaction_with_both_apis_are_the_same = H.propertyOnce $ do
6161
let era = Exp.ConwayEra
6262
let sbe = Api.convert era
6363

64-
signedTxTraditional <- exampleTransacitonTraditionalWay sbe
64+
signedTxTraditional <- exampleTransactionTraditionalWay sbe
6565
signedTxExperimental <- exampleTransactionExperimentalWay era sbe
6666

6767
let oldStyleTx :: Api.Tx Api.ConwayEra = ShelleyTx sbe signedTxExperimental
6868

6969
oldStyleTx H.=== signedTxTraditional
7070
where
71-
exampleTransacitonTraditionalWay
72-
:: H.MonadTest m => Api.ShelleyBasedEra Exp.ConwayEra -> m (Tx Exp.ConwayEra)
73-
exampleTransacitonTraditionalWay sbe = do
71+
exampleTransactionTraditionalWay
72+
:: H.MonadTest m
73+
=> Api.ShelleyBasedEra Exp.ConwayEra
74+
-> m (Tx Exp.ConwayEra)
75+
exampleTransactionTraditionalWay sbe = do
7476
txBodyContent <- exampleTxBodyContent Api.AsConwayEra sbe
7577
signingKey <- exampleSigningKey
7678

0 commit comments

Comments
 (0)