Skip to content

Commit 90f24cb

Browse files
carbolymercarbolymer
committed
Add posibility to provide datums hashes preimage for reference inputs
1 parent ed1b363 commit 90f24cb

7 files changed

Lines changed: 126 additions & 64 deletions

File tree

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1036,7 +1036,7 @@ genValidTxBody sbe =
10361036
-- | Partial! This function will throw an error when the generated transaction is invalid.
10371037
genTxBody :: (HasCallStack, Typeable era) => ShelleyBasedEra era -> Gen (TxBody era)
10381038
genTxBody era = do
1039-
res <- Api.createTransactionBody era <$> genTxBodyContent era
1039+
res <- Api.createTransactionBody era mempty <$> genTxBodyContent era
10401040
case res of
10411041
Left err -> error (docToString (prettyError err))
10421042
Right txBody -> pure txBody

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

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -134,6 +134,7 @@ import Cardano.Api.Internal.ReexposeLedger (StrictMaybe (..), maybeToStrictMaybe
134134
import Cardano.Api.Internal.ReexposeLedger qualified as L
135135
import Cardano.Api.Internal.Tx.Body
136136
import Cardano.Api.Internal.Tx.Sign
137+
import Cardano.Api.Internal.Tx.UTxO (UTxO)
137138

138139
import Cardano.Crypto.Hash qualified as Hash
139140
import Cardano.Ledger.Alonzo.TxBody qualified as L
@@ -162,14 +163,16 @@ newtype UnsignedTxError
162163

163164
makeUnsignedTx
164165
:: Era era
166+
-> UTxO era
167+
-- ^ UTXO for reference inputs
165168
-> TxBodyContent BuildTx era
166169
-> Either TxBodyError (UnsignedTx era)
167-
makeUnsignedTx era bc = obtainCommonConstraints era $ do
170+
makeUnsignedTx era utxo bc = obtainCommonConstraints era $ do
168171
let sbe = convert era
169172
aeon = convert era
170173
TxScriptWitnessRequirements languages scripts datums redeemers <-
171174
shelleyBasedEraConstraints sbe $
172-
collectTxBodyScriptWitnessRequirements (convert era) bc
175+
collectTxBodyScriptWitnessRequirements (convert era) utxo bc
173176

174177
-- cardano-api types
175178
let apiTxOuts = txOuts bc

‎cardano-api/src/Cardano/Api/Internal/Fees.hs‎

Lines changed: 8 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -596,6 +596,7 @@ estimateBalancedTxBody
596596
first TxFeeEstimationxBodyError $ -- TODO: impossible to fail now
597597
createTransactionBody
598598
sbe
599+
mempty
599600
txbodycontent1
600601
{ txFee = TxFeeExplicit sbe maxLovelaceFee
601602
, txOuts =
@@ -638,6 +639,7 @@ estimateBalancedTxBody
638639
first TxFeeEstimationxBodyError $ -- TODO: impossible to fail now
639640
createTransactionBody
640641
sbe
642+
mempty
641643
txbodycontent1
642644
{ txFee = TxFeeExplicit sbe fee
643645
, txReturnCollateral = retColl
@@ -678,7 +680,7 @@ estimateBalancedTxBody
678680
first TxFeeEstimationFinalConstructionError $ -- TODO: impossible to fail now. We need to implement a function
679681
-- that simply creates a transaction body because we have already
680682
-- validated the transaction body earlier within makeTransactionBodyAutoBalance
681-
createTransactionBody sbe finalTxBodyContent
683+
createTransactionBody sbe mempty finalTxBodyContent
682684
return
683685
( BalancedTxBody
684686
finalTxBodyContent
@@ -1365,7 +1367,7 @@ makeTransactionBodyAutoBalance
13651367
-- 3. update tx with fees
13661368
-- 4. balance the transaction and update tx change output
13671369

1368-
txbodyForChange <- first TxBodyError $ createTransactionBody sbe txbodycontent
1370+
txbodyForChange <- first TxBodyError $ createTransactionBody sbe utxo txbodycontent
13691371
let initialChangeTxOutValue =
13701372
evaluateTransactionBalance sbe pp poolids stakeDelegDeposits drepDelegDeposits utxo txbodyForChange
13711373
initialChangeTxOut =
@@ -1387,6 +1389,7 @@ makeTransactionBodyAutoBalance
13871389
first TxBodyError
13881390
$ createTransactionBody
13891391
sbe
1392+
utxo
13901393
$ txbodycontent
13911394
& modTxOuts
13921395
(<> [initialChangeTxOut])
@@ -1425,6 +1428,7 @@ makeTransactionBodyAutoBalance
14251428
first TxBodyError $ -- TODO: impossible to fail now
14261429
createTransactionBody
14271430
sbe
1431+
utxo
14281432
txbodycontent1
14291433
{ txFee = TxFeeExplicit sbe maxLovelaceFee
14301434
, txOuts =
@@ -1472,6 +1476,7 @@ makeTransactionBodyAutoBalance
14721476
first TxBodyError $ -- TODO: impossible to fail now
14731477
createTransactionBody
14741478
sbe
1479+
utxo
14751480
txbodycontent1
14761481
{ txFee = TxFeeExplicit sbe fee
14771482
, txReturnCollateral = retColl
@@ -1504,7 +1509,7 @@ makeTransactionBodyAutoBalance
15041509
first TxBodyError $ -- TODO: impossible to fail now. We need to implement a function
15051510
-- that simply creates a transaction body because we have already
15061511
-- validated the transaction body earlier within makeTransactionBodyAutoBalance
1507-
createTransactionBody sbe finalTxBodyContent
1512+
createTransactionBody sbe utxo finalTxBodyContent
15081513
return
15091514
( BalancedTxBody
15101515
finalTxBodyContent

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

Lines changed: 75 additions & 34 deletions
Original file line numberDiff line numberDiff line change
@@ -432,6 +432,8 @@ import Cardano.Api.Internal.SerialiseJSON
432432
import Cardano.Api.Internal.Tx.BuildTxWith
433433
import Cardano.Api.Internal.Tx.Output
434434
import Cardano.Api.Internal.Tx.Sign
435+
import Cardano.Api.Internal.Tx.UTxO (UTxO)
436+
import Cardano.Api.Internal.Tx.UTxO qualified as UTxO
435437
import Cardano.Api.Internal.TxIn
436438
import Cardano.Api.Internal.TxMetadata
437439
import Cardano.Api.Internal.Utils
@@ -570,16 +572,20 @@ 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+
-> BuildTxWith build (Set HashableScriptData)
582+
-- ^ A set of datums, which hashes are referenced in UTXO of reference inputs. Those datums will be inserted
583+
-- to the datum map available to the scripts.
584+
-> TxInsReference build era
579585

580-
deriving instance Eq (TxInsReference era)
586+
deriving instance Eq (TxInsReference build era)
581587

582-
deriving instance Show (TxInsReference era)
588+
deriving instance Show (TxInsReference build era)
583589

584590
-- ----------------------------------------------------------------------------
585591
-- Transaction fees
@@ -984,7 +990,7 @@ data TxBodyContent build era
984990
= TxBodyContent
985991
{ txIns :: TxIns build era
986992
, txInsCollateral :: TxInsCollateral era
987-
, txInsReference :: TxInsReference era
993+
, txInsReference :: TxInsReference build era
988994
, txOuts :: [TxOut CtxTx era]
989995
, txTotalCollateral :: TxTotalCollateral era
990996
, txReturnCollateral :: TxReturnCollateral CtxTx era
@@ -1075,25 +1081,36 @@ addTxInCollateral
10751081
:: IsAlonzoBasedEra era => TxIn -> TxBodyContent build era -> TxBodyContent build era
10761082
addTxInCollateral txInCollateral = addTxInsCollateral [txInCollateral]
10771083

1078-
setTxInsReference :: TxInsReference era -> TxBodyContent build era -> TxBodyContent build era
1084+
setTxInsReference :: TxInsReference build era -> TxBodyContent build era -> TxBodyContent build era
10791085
setTxInsReference v txBodyContent = txBodyContent{txInsReference = v}
10801086

10811087
modTxInsReference
1082-
:: (TxInsReference era -> TxInsReference era) -> TxBodyContent build era -> TxBodyContent build era
1088+
:: (TxInsReference build era -> TxInsReference build era)
1089+
-> TxBodyContent build era
1090+
-> TxBodyContent build era
10831091
modTxInsReference f txBodyContent = txBodyContent{txInsReference = f (txInsReference txBodyContent)}
10841092

10851093
addTxInsReference
1086-
:: IsBabbageBasedEra era => [TxIn] -> TxBodyContent build era -> TxBodyContent build era
1087-
addTxInsReference txInsReference =
1094+
:: Applicative (BuildTxWith build)
1095+
=> IsBabbageBasedEra era
1096+
=> [TxIn]
1097+
-> Set HashableScriptData
1098+
-> TxBodyContent build era
1099+
-> TxBodyContent build era
1100+
addTxInsReference txInsReference scriptData =
10881101
modTxInsReference
10891102
( \case
1090-
TxInsReferenceNone -> TxInsReference babbageBasedEra txInsReference
1091-
TxInsReference era xs -> TxInsReference era (xs <> txInsReference)
1103+
TxInsReferenceNone -> TxInsReference babbageBasedEra txInsReference (pure scriptData)
1104+
TxInsReference era xs bScriptData' -> TxInsReference era (xs <> txInsReference) ((<> scriptData) <$> bScriptData')
10921105
)
10931106

10941107
addTxInReference
1095-
:: IsBabbageBasedEra era => TxIn -> TxBodyContent build era -> TxBodyContent build era
1096-
addTxInReference txInReference = addTxInsReference [txInReference]
1108+
:: Applicative (BuildTxWith build)
1109+
=> IsBabbageBasedEra era
1110+
=> TxIn
1111+
-> TxBodyContent build era
1112+
-> TxBodyContent build era
1113+
addTxInReference txInReference = addTxInsReference [txInReference] mempty
10971114

10981115
setTxOuts :: [TxOut CtxTx era] -> TxBodyContent build era -> TxBodyContent build era
10991116
setTxOuts v txBodyContent = txBodyContent{txOuts = v}
@@ -1370,9 +1387,11 @@ createTransactionBody
13701387
:: forall era
13711388
. HasCallStack
13721389
=> ShelleyBasedEra era
1390+
-> UTxO era
1391+
-- ^ UTXO for reference inputs
13731392
-> TxBodyContent BuildTx era
13741393
-> Either TxBodyError (TxBody era)
1375-
createTransactionBody sbe bc =
1394+
createTransactionBody sbe utxo bc =
13761395
shelleyBasedEraConstraints sbe $ do
13771396
(sData, mScriptIntegrityHash, scripts) <-
13781397
caseShelleyToMaryOrAlonzoEraOnwards
@@ -1387,7 +1406,7 @@ createTransactionBody sbe bc =
13871406
)
13881407
( \aeon -> do
13891408
TxScriptWitnessRequirements languages scripts dats redeemers <-
1390-
collectTxBodyScriptWitnessRequirements aeon bc
1409+
collectTxBodyScriptWitnessRequirements aeon utxo bc
13911410

13921411
let pparams = txProtocolParams bc
13931412
sData = TxBodyScriptData aeon dats redeemers
@@ -1742,11 +1761,11 @@ fromLedgerTxInsCollateral sbe body =
17421761
sbe
17431762

17441763
fromLedgerTxInsReference
1745-
:: ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> TxInsReference era
1764+
:: ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> TxInsReference ViewTx era
17461765
fromLedgerTxInsReference sbe txBody =
17471766
caseShelleyToAlonzoOrBabbageEraOnwards
17481767
(const TxInsReferenceNone)
1749-
(\w -> TxInsReference w $ map fromShelleyTxIn . toList $ txBody ^. L.referenceInputsTxBodyL)
1768+
(\w -> TxInsReference w (map fromShelleyTxIn . toList $ txBody ^. L.referenceInputsTxBodyL) ViewTx)
17501769
sbe
17511770

17521771
fromLedgerTxTotalCollateral
@@ -2108,11 +2127,11 @@ convPParamsToScriptIntegrityHash
21082127
-> Alonzo.TxDats (ShelleyLedgerEra era)
21092128
-> Set Plutus.Language
21102129
-> StrictMaybe L.ScriptIntegrityHash
2111-
convPParamsToScriptIntegrityHash w txProtocolParams redeemers datums languages =
2130+
convPParamsToScriptIntegrityHash w (BuildTxWith mTxProtocolParams) redeemers datums languages =
21122131
alonzoEraOnwardsConstraints w $
2113-
case txProtocolParams of
2114-
BuildTxWith Nothing -> SNothing
2115-
BuildTxWith (Just (LedgerProtocolParameters pp)) ->
2132+
case mTxProtocolParams of
2133+
Nothing -> SNothing
2134+
Just (LedgerProtocolParameters pp) ->
21162135
Alonzo.hashScriptIntegrity (Set.map (L.getLanguageView pp) languages) redeemers datums
21172136

21182137
convLanguages :: [(ScriptWitnessIndex, AnyScriptWitness era)] -> Set Plutus.Language
@@ -2122,11 +2141,11 @@ convLanguages witnesses =
21222141
| (_, AnyScriptWitness (PlutusScriptWitness _ v _ _ _ _)) <- witnesses
21232142
]
21242143

2125-
convReferenceInputs :: TxInsReference era -> Set Ledger.TxIn
2144+
convReferenceInputs :: TxInsReference build era -> Set Ledger.TxIn
21262145
convReferenceInputs txInsReference =
21272146
case txInsReference of
21282147
TxInsReferenceNone -> mempty
2129-
TxInsReference _ refTxins -> fromList $ map toShelleyTxIn refTxins
2148+
TxInsReference _ refTxins _ -> fromList $ map toShelleyTxIn refTxins
21302149

21312150
-- | Returns an OSet of proposals from 'TxProposalProcedures'.
21322151
convProposalProcedures
@@ -2986,18 +3005,27 @@ collectTxBodyScriptWitnessRequirements
29863005
:: forall era
29873006
. IsShelleyBasedEra era
29883007
=> AlonzoEraOnwards era
3008+
-> UTxO era
3009+
-- ^ UTXO for reference inputs
29893010
-> TxBodyContent BuildTx era
29903011
-> Either
29913012
TxBodyError
29923013
(TxScriptWitnessRequirements (ShelleyLedgerEra era))
29933014
collectTxBodyScriptWitnessRequirements
29943015
aEon
3016+
utxo
29953017
bc@TxBodyContent
2996-
{ txOuts
3018+
{ txInsReference
3019+
, txOuts
29973020
} =
29983021
obtainAlonzoScriptPurposeConstraints aEon $ do
29993022
let sbe = shelleyBasedEra @era
3000-
supplementaldatums = TxScriptWitnessRequirements mempty mempty (getSupplementalDatums aEon txOuts) mempty
3023+
supplementaldatums =
3024+
TxScriptWitnessRequirements
3025+
mempty
3026+
mempty
3027+
(getSupplementalDatums aEon txInsReference utxo txOuts)
3028+
mempty
30013029
txInWits <-
30023030
first TxBodyPlutusScriptDecodeError $
30033031
legacyWitnessToScriptRequirements aEon $
@@ -3053,17 +3081,30 @@ collectTxBodyScriptWitnessRequirements
30533081

30543082
getSupplementalDatums
30553083
:: AlonzoEraOnwards era
3084+
-> TxInsReference BuildTx era
3085+
-- ^ reference inputs
3086+
-> UTxO era
3087+
-- ^ UTxO for reference inputs
30563088
-> [TxOut CtxTx era]
30573089
-> 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
3090+
getSupplementalDatums eon txInsRef utxo txOutsFromTx = alonzoEraOnwardsConstraints eon $ do
3091+
let refTxInsDats =
3092+
[ d
3093+
| TxInsReference _ txIns (BuildTxWith datumSet) <- [txInsRef]
3094+
, let datumMap = fromList $ map (\h -> (hashScriptDataBytes h, h)) $ toList datumSet
3095+
, txIn <- txIns
3096+
, -- resolve only hashes
3097+
TxOut _ _ (TxOutDatumHash _ datumHash) _ <- maybeToList $ UTxO.lookup txIn utxo
3098+
, d <- maybeToList $ Map.lookup datumHash datumMap
30663099
]
3100+
-- use only supplemental datum
3101+
txOutsDats = [d | TxOut _ _ (TxOutSupplementalDatum _ d) _ <- txOutsFromTx]
3102+
L.TxDats $
3103+
fromList $
3104+
[ (L.hashData ledgerData, ledgerData)
3105+
| d <- refTxInsDats <> txOutsDats
3106+
, let ledgerData = toAlonzoData d
3107+
]
30673108

30683109
extractWitnessableTxIns
30693110
:: AlonzoEraOnwards era

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

Lines changed: 25 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -14,30 +14,43 @@
1414
{-# LANGUAGE TypeOperators #-}
1515

1616
module Cardano.Api.Internal.Tx.Output
17-
( -- ** Transaction outputs
18-
CtxTx
17+
( -- * Transaction outputs
18+
TxOut (..)
19+
20+
-- ** Transaction output contexts
21+
, CtxTx
1922
, CtxUTxO
20-
, TxOut (..)
21-
, TxOutValue (..)
22-
, TxOutDatum (TxOutDatumNone, TxOutDatumHash, TxOutSupplementalDatum, TxOutDatumInline)
2323
, toCtxUTxOTxOut
2424
, fromCtxUTxOTxOut
25-
, lovelaceToTxOutValue
26-
, prettyRenderTxOut
27-
, txOutValueToLovelace
28-
, txOutValueToValue
29-
, parseHash
30-
, TxOutInAnyEra (..)
31-
, txOutInAnyEra
25+
26+
-- ** Ledger conversion functions for outputs
3227
, fromShelleyTxOut
3328
, toShelleyTxOut
3429
, toShelleyTxOutAny
3530
, convTxOuts
3631
, fromLedgerTxOuts
3732
, toByronTxOut
33+
-- ** An Output Value
34+
, TxOutValue (..)
35+
, lovelaceToTxOutValue
36+
, txOutValueToLovelace
37+
, txOutValueToValue
38+
39+
-- ** Datum
40+
, TxOutDatum (..)
3841
, binaryDataToScriptData
3942
, scriptDataToInlineDatum
43+
44+
-- ** Existential type over an era
45+
, TxOutInAnyEra (..)
46+
, txOutInAnyEra
47+
48+
-- ** Utilities
4049
, validateTxOuts
50+
, parseHash
51+
, prettyRenderTxOut
52+
53+
-- ** Error types
4154
, TxOutputError (..)
4255
)
4356
where
@@ -960,8 +973,6 @@ deriving instance Eq (TxOutDatum ctx era)
960973

961974
deriving instance Show (TxOutDatum ctx era)
962975

963-
{-# COMPLETE TxOutDatumNone, TxOutDatumHash, TxOutSupplementalDatum, TxOutDatumInline #-}
964-
965976
toAlonzoTxOutDatumHash
966977
:: TxOutDatum ctx era -> StrictMaybe Plutus.DataHash
967978
toAlonzoTxOutDatumHash TxOutDatumNone = SNothing

0 commit comments

Comments
 (0)