diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 7abe632c9d..894d506195 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -144,7 +144,7 @@ where import Cardano.Api hiding (txIns) import qualified Cardano.Api as Api -import qualified Cardano.Api.Experimental as Exp +import qualified Cardano.Api.Experimental as Exp import Cardano.Api.Byron (KeyWitness (ByronKeyWitness), WitnessNetworkIdOrByronAddress (..)) import qualified Cardano.Api.Byron as Byron @@ -965,11 +965,17 @@ genTxInsCollateral = ] ) -genTxInsReference :: CardanoEra era -> Gen (TxInsReference era) +genTxInsReference + :: Applicative (BuildTxWith build) + => CardanoEra era + -> Gen (TxInsReference build era) genTxInsReference = caseByronToAlonzoOrBabbageEraOnwards (const (pure TxInsReferenceNone)) - (\w -> TxInsReference w <$> Gen.list (Range.linear 0 10) genTxIn) + (\w -> do + txIns <- Gen.list (Range.linear 0 10) genTxIn + pure $ TxInsReference w txIns mempty + ) genTxReturnCollateral :: ShelleyBasedEra era -> Gen (TxReturnCollateral CtxTx era) genTxReturnCollateral era = @@ -1022,7 +1028,7 @@ genWitnessesByron = Gen.list (Range.constant 1 10) genByronKeyWitness -- | This generator validates generated 'TxBodyContent' and backtracks when the generated body -- fails the validation. That also means that it is quite slow. -genValidTxBody :: Typeable era +genValidTxBody :: Typeable era => ShelleyBasedEra era -> Gen (TxBody era, TxBodyContent BuildTx era) -- ^ validated 'TxBody' and 'TxBodyContent' genValidTxBody sbe = @@ -1135,7 +1141,6 @@ genShelleyBootstrapWitness sbe = <*> (fst <$> genValidTxBody sbe) <*> genSigningKey AsByronKey - genShelleyKeyWitness :: () => Typeable era @@ -1385,39 +1390,39 @@ genTreasuryDonation :: ConwayEraOnwards era -> Gen L.Coin genTreasuryDonation _era = Q.arbitrary genWitnessable :: L.AlonzoEraScript era => Gen (Exp.Witnessable Exp.TxInItem era) -genWitnessable = Exp.WitTxIn <$> genTxIn +genWitnessable = Exp.WitTxIn <$> genTxIn genMintWitnessable :: L.AlonzoEraScript era => Gen (Exp.Witnessable Exp.MintItem era) -genMintWitnessable = Exp.WitMint <$> genPolicyId <*> genPolicyAssets +genMintWitnessable = Exp.WitMint <$> genPolicyId <*> genPolicyAssets -genIndexedPlutusScriptWitness - :: L.AlonzoEraScript (ShelleyLedgerEra era) +genIndexedPlutusScriptWitness + :: L.AlonzoEraScript (ShelleyLedgerEra era) => Gen (Exp.IndexedPlutusScriptWitness Exp.TxInItem L.PlutusV3 Exp.SpendingScript (ShelleyLedgerEra era)) genIndexedPlutusScriptWitness = do index <- Gen.word32 $ Range.linear 1 10 witnessable <- genWitnessable - Exp.IndexedPlutusScriptWitness + Exp.IndexedPlutusScriptWitness <$> genWitnessable <*> genPlutusPurpose index witnessable - <*> genPlutusScriptWitness + <*> genPlutusScriptWitness -genPlutusPurpose - :: Word32 - -> Exp.Witnessable thing (ShelleyLedgerEra era) +genPlutusPurpose + :: Word32 + -> Exp.Witnessable thing (ShelleyLedgerEra era) -> Gen (L.PlutusPurpose L.AsIx (ShelleyLedgerEra era)) genPlutusPurpose index wit = return $ Exp.toPlutusScriptPurpose index wit genPlutusScriptWitness :: Gen (Exp.PlutusScriptWitness L.PlutusV3 purpose era) -genPlutusScriptWitness = do +genPlutusScriptWitness = do let l = Exp.toPlutusSLanguage PlutusScriptV3 - Exp.PlutusScriptWitness l . Exp.PReferenceScript + Exp.PlutusScriptWitness l . Exp.PReferenceScript <$> genTxIn <*> genPlutusScriptDatum <*> genHashableScriptData - <*> genExecutionUnits + <*> genExecutionUnits genPlutusScriptDatum :: Gen (Exp.PlutusScriptDatum lang purpose) -genPlutusScriptDatum = return Exp.NoScriptDatum +genPlutusScriptDatum = return Exp.NoScriptDatum -- | This generator does not generate a valid witness - just a random one. genScriptWitnessForStake :: ShelleyBasedEra era -> Gen (Api.ScriptWitness WitCtxStake era) diff --git a/cardano-api/src/Cardano/Api/Internal/Tx/Body.hs b/cardano-api/src/Cardano/Api/Internal/Tx/Body.hs index 49a23e7f99..f524d58c50 100644 --- a/cardano-api/src/Cardano/Api/Internal/Tx/Body.hs +++ b/cardano-api/src/Cardano/Api/Internal/Tx/Body.hs @@ -301,6 +301,8 @@ module Cardano.Api.Internal.Tx.Body -- ** Other transaction body types , TxInsCollateral (..) , TxInsReference (..) + , TxInsReferenceDatums + , getReferenceInputDatumMap , TxReturnCollateral (..) , TxTotalCollateral (..) , TxFee (..) @@ -570,16 +572,31 @@ deriving instance Eq (TxTotalCollateral era) deriving instance Show (TxTotalCollateral era) -data TxInsReference era where - TxInsReferenceNone :: TxInsReference era +data TxInsReference build era where + TxInsReferenceNone :: TxInsReference build era TxInsReference :: BabbageEraOnwards era -> [TxIn] - -> TxInsReference era + -- ^ A list of reference inputs + -> TxInsReferenceDatums build + -- ^ A set of datums, whose hashes are referenced in UTXO of reference inputs. Those datums will be inserted + -- to the datum map available to the scripts. Note that inserting a datum with hash not present in the reference + -- input will result in an error on transaction submission. + -> TxInsReference build era -deriving instance Eq (TxInsReference era) +deriving instance Eq (TxInsReference build era) -deriving instance Show (TxInsReference era) +deriving instance Show (TxInsReference build era) + +-- | The actual datums, referenced by hash in the transaction reference inputs. +type TxInsReferenceDatums build = BuildTxWith build (Set HashableScriptData) + +getReferenceInputDatumMap + :: TxInsReferenceDatums build + -> Map (Hash ScriptData) HashableScriptData +getReferenceInputDatumMap = \case + ViewTx -> mempty + BuildTxWith datumSet -> fromList $ map (\h -> (hashScriptDataBytes h, h)) $ toList datumSet -- ---------------------------------------------------------------------------- -- Transaction fees @@ -984,7 +1001,7 @@ data TxBodyContent build era = TxBodyContent { txIns :: TxIns build era , txInsCollateral :: TxInsCollateral era - , txInsReference :: TxInsReference era + , txInsReference :: TxInsReference build era , txOuts :: [TxOut CtxTx era] , txTotalCollateral :: TxTotalCollateral era , txReturnCollateral :: TxReturnCollateral CtxTx era @@ -1075,25 +1092,36 @@ addTxInCollateral :: IsAlonzoBasedEra era => TxIn -> TxBodyContent build era -> TxBodyContent build era addTxInCollateral txInCollateral = addTxInsCollateral [txInCollateral] -setTxInsReference :: TxInsReference era -> TxBodyContent build era -> TxBodyContent build era +setTxInsReference :: TxInsReference build era -> TxBodyContent build era -> TxBodyContent build era setTxInsReference v txBodyContent = txBodyContent{txInsReference = v} modTxInsReference - :: (TxInsReference era -> TxInsReference era) -> TxBodyContent build era -> TxBodyContent build era + :: (TxInsReference build era -> TxInsReference build era) + -> TxBodyContent build era + -> TxBodyContent build era modTxInsReference f txBodyContent = txBodyContent{txInsReference = f (txInsReference txBodyContent)} addTxInsReference - :: IsBabbageBasedEra era => [TxIn] -> TxBodyContent build era -> TxBodyContent build era -addTxInsReference txInsReference = - modTxInsReference - ( \case - TxInsReferenceNone -> TxInsReference babbageBasedEra txInsReference - TxInsReference era xs -> TxInsReference era (xs <> txInsReference) - ) + :: Applicative (BuildTxWith build) + => IsBabbageBasedEra era + => [TxIn] + -> Set HashableScriptData + -> TxBodyContent build era + -> TxBodyContent build era +addTxInsReference txInsReference scriptData = + modTxInsReference $ + \case + TxInsReferenceNone -> TxInsReference babbageBasedEra txInsReference (pure scriptData) + TxInsReference era xs bScriptData' -> TxInsReference era (xs <> txInsReference) ((<> scriptData) <$> bScriptData') addTxInReference - :: IsBabbageBasedEra era => TxIn -> TxBodyContent build era -> TxBodyContent build era -addTxInReference txInReference = addTxInsReference [txInReference] + :: Applicative (BuildTxWith build) + => IsBabbageBasedEra era + => TxIn + -> Maybe HashableScriptData + -> TxBodyContent build era + -> TxBodyContent build era +addTxInReference txInReference mDatum = addTxInsReference [txInReference] . fromList $ maybeToList mDatum setTxOuts :: [TxOut CtxTx era] -> TxBodyContent build era -> TxBodyContent build era setTxOuts v txBodyContent = txBodyContent{txOuts = v} @@ -1742,11 +1770,11 @@ fromLedgerTxInsCollateral sbe body = sbe fromLedgerTxInsReference - :: ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> TxInsReference era + :: ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> TxInsReference ViewTx era fromLedgerTxInsReference sbe txBody = caseShelleyToAlonzoOrBabbageEraOnwards (const TxInsReferenceNone) - (\w -> TxInsReference w $ map fromShelleyTxIn . toList $ txBody ^. L.referenceInputsTxBodyL) + (\w -> TxInsReference w (map fromShelleyTxIn . toList $ txBody ^. L.referenceInputsTxBodyL) ViewTx) sbe fromLedgerTxTotalCollateral @@ -2108,11 +2136,11 @@ convPParamsToScriptIntegrityHash -> Alonzo.TxDats (ShelleyLedgerEra era) -> Set Plutus.Language -> StrictMaybe L.ScriptIntegrityHash -convPParamsToScriptIntegrityHash w txProtocolParams redeemers datums languages = +convPParamsToScriptIntegrityHash w (BuildTxWith mTxProtocolParams) redeemers datums languages = alonzoEraOnwardsConstraints w $ - case txProtocolParams of - BuildTxWith Nothing -> SNothing - BuildTxWith (Just (LedgerProtocolParameters pp)) -> + case mTxProtocolParams of + Nothing -> SNothing + Just (LedgerProtocolParameters pp) -> Alonzo.hashScriptIntegrity (Set.map (L.getLanguageView pp) languages) redeemers datums convLanguages :: [(ScriptWitnessIndex, AnyScriptWitness era)] -> Set Plutus.Language @@ -2122,11 +2150,11 @@ convLanguages witnesses = | (_, AnyScriptWitness (PlutusScriptWitness _ v _ _ _ _)) <- witnesses ] -convReferenceInputs :: TxInsReference era -> Set Ledger.TxIn +convReferenceInputs :: TxInsReference build era -> Set Ledger.TxIn convReferenceInputs txInsReference = case txInsReference of TxInsReferenceNone -> mempty - TxInsReference _ refTxins -> fromList $ map toShelleyTxIn refTxins + TxInsReference _ refTxins _ -> fromList $ map toShelleyTxIn refTxins -- | Returns an OSet of proposals from 'TxProposalProcedures'. convProposalProcedures @@ -2993,11 +3021,17 @@ collectTxBodyScriptWitnessRequirements collectTxBodyScriptWitnessRequirements aEon bc@TxBodyContent - { txOuts + { txInsReference + , txOuts } = obtainAlonzoScriptPurposeConstraints aEon $ do let sbe = shelleyBasedEra @era - supplementaldatums = TxScriptWitnessRequirements mempty mempty (getSupplementalDatums aEon txOuts) mempty + supplementaldatums = + TxScriptWitnessRequirements + mempty + mempty + (getDatums aEon txInsReference txOuts) + mempty txInWits <- first TxBodyPlutusScriptDecodeError $ legacyWitnessToScriptRequirements aEon $ @@ -3051,19 +3085,32 @@ collectTxBodyScriptWitnessRequirements , txProposalWits ] -getSupplementalDatums +-- | Extract datum: +-- 1. supplemental datums from transaction outputs +-- 2. datums from reference inputs +-- +-- Note that this function does not check whose datum datum hashes are present in the reference inputs. This means +-- if there are redundant datums in 'TxInsReference', a submission of such transaction will fail. +getDatums :: AlonzoEraOnwards era + -> TxInsReference BuildTx era + -- ^ reference inputs -> [TxOut CtxTx era] -> L.TxDats (ShelleyLedgerEra era) -getSupplementalDatums eon [] = alonzoEraOnwardsConstraints eon mempty -getSupplementalDatums eon txouts = - alonzoEraOnwardsConstraints eon $ - L.TxDats $ - fromList - [ (L.hashData ledgerData, ledgerData) - | TxOut _ _ (TxOutSupplementalDatum _ d) _ <- txouts - , let ledgerData = toAlonzoData d +getDatums eon txInsRef txOutsFromTx = alonzoEraOnwardsConstraints eon $ do + let refTxInsDats = + [ d + | TxInsReference _ _ (BuildTxWith datumSet) <- [txInsRef] + , d <- toList datumSet ] + -- use only supplemental datum + txOutsDats = [d | TxOut _ _ (TxOutSupplementalDatum _ d) _ <- txOutsFromTx] + L.TxDats $ + fromList $ + [ (L.hashData ledgerData, ledgerData) + | d <- refTxInsDats <> txOutsDats + , let ledgerData = toAlonzoData d + ] extractWitnessableTxIns :: AlonzoEraOnwards era diff --git a/cardano-api/src/Cardano/Api/Internal/Tx/BuildTxWith.hs b/cardano-api/src/Cardano/Api/Internal/Tx/BuildTxWith.hs index bb46230494..8c0cc42a6d 100644 --- a/cardano-api/src/Cardano/Api/Internal/Tx/BuildTxWith.hs +++ b/cardano-api/src/Cardano/Api/Internal/Tx/BuildTxWith.hs @@ -40,6 +40,13 @@ instance Applicative (BuildTxWith BuildTx) where pure = BuildTxWith (BuildTxWith f) <*> (BuildTxWith a) = BuildTxWith (f a) +instance Semigroup a => Semigroup (BuildTxWith build a) where + ViewTx <> ViewTx = ViewTx + (BuildTxWith a) <> (BuildTxWith b) = BuildTxWith (a <> b) + +instance (Applicative (BuildTxWith build), Monoid a) => Monoid (BuildTxWith build a) where + mempty = pure mempty + buildTxWithToMaybe :: BuildTxWith build a -> Maybe a buildTxWithToMaybe ViewTx = Nothing buildTxWithToMaybe (BuildTxWith a) = Just a diff --git a/cardano-api/src/Cardano/Api/Internal/Tx/Output.hs b/cardano-api/src/Cardano/Api/Internal/Tx/Output.hs index f31e519ff0..4601cc66f2 100644 --- a/cardano-api/src/Cardano/Api/Internal/Tx/Output.hs +++ b/cardano-api/src/Cardano/Api/Internal/Tx/Output.hs @@ -14,30 +14,43 @@ {-# LANGUAGE TypeOperators #-} module Cardano.Api.Internal.Tx.Output - ( -- ** Transaction outputs - CtxTx + ( -- * Transaction outputs + TxOut (..) + + -- ** Transaction output contexts + , CtxTx , CtxUTxO - , TxOut (..) - , TxOutValue (..) - , TxOutDatum (TxOutDatumNone, TxOutDatumHash, TxOutSupplementalDatum, TxOutDatumInline) , toCtxUTxOTxOut , fromCtxUTxOTxOut - , lovelaceToTxOutValue - , prettyRenderTxOut - , txOutValueToLovelace - , txOutValueToValue - , parseHash - , TxOutInAnyEra (..) - , txOutInAnyEra + + -- ** Ledger conversion functions for outputs , fromShelleyTxOut , toShelleyTxOut , toShelleyTxOutAny , convTxOuts , fromLedgerTxOuts , toByronTxOut + -- ** An Output Value + , TxOutValue (..) + , lovelaceToTxOutValue + , txOutValueToLovelace + , txOutValueToValue + + -- ** Datum + , TxOutDatum (..) , binaryDataToScriptData , scriptDataToInlineDatum + + -- ** Existential type over an era + , TxOutInAnyEra (..) + , txOutInAnyEra + + -- ** Utilities , validateTxOuts + , parseHash + , prettyRenderTxOut + + -- ** Error types , TxOutputError (..) ) where @@ -960,8 +973,6 @@ deriving instance Eq (TxOutDatum ctx era) deriving instance Show (TxOutDatum ctx era) -{-# COMPLETE TxOutDatumNone, TxOutDatumHash, TxOutSupplementalDatum, TxOutDatumInline #-} - toAlonzoTxOutDatumHash :: TxOutDatum ctx era -> StrictMaybe Plutus.DataHash toAlonzoTxOutDatumHash TxOutDatumNone = SNothing diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs index b635cb6a4b..88227334a9 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs @@ -61,16 +61,18 @@ prop_created_transaction_with_both_apis_are_the_same = H.propertyOnce $ do let era = Exp.ConwayEra let sbe = Api.convert era - signedTxTraditional <- exampleTransacitonTraditionalWay sbe + signedTxTraditional <- exampleTransactionTraditionalWay sbe signedTxExperimental <- exampleTransactionExperimentalWay era sbe let oldStyleTx :: Api.Tx Api.ConwayEra = ShelleyTx sbe signedTxExperimental oldStyleTx H.=== signedTxTraditional where - exampleTransacitonTraditionalWay - :: H.MonadTest m => Api.ShelleyBasedEra Exp.ConwayEra -> m (Tx Exp.ConwayEra) - exampleTransacitonTraditionalWay sbe = do + exampleTransactionTraditionalWay + :: H.MonadTest m + => Api.ShelleyBasedEra Exp.ConwayEra + -> m (Tx Exp.ConwayEra) + exampleTransactionTraditionalWay sbe = do txBodyContent <- exampleTxBodyContent Api.AsConwayEra sbe signingKey <- exampleSigningKey