From cfd2778e1a237f537d84ad35e96936b02d31c315 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Mon, 11 Nov 2024 14:52:16 -0400 Subject: [PATCH 1/4] Propagate IsPlutusLanguage constraint --- cardano-api/internal/Cardano/Api/Script.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Script.hs b/cardano-api/internal/Cardano/Api/Script.hs index dc1d12c9a2..dfe3df1a84 100644 --- a/cardano-api/internal/Cardano/Api/Script.hs +++ b/cardano-api/internal/Cardano/Api/Script.hs @@ -228,7 +228,8 @@ instance HasTypeProxy PlutusScriptV3 where -- data ScriptLanguage lang where SimpleScriptLanguage :: ScriptLanguage SimpleScript' - PlutusScriptLanguage :: PlutusScriptVersion lang -> ScriptLanguage lang + PlutusScriptLanguage + :: IsPlutusScriptLanguage lang => PlutusScriptVersion lang -> ScriptLanguage lang deriving instance (Eq (ScriptLanguage lang)) @@ -285,7 +286,8 @@ instance Bounded AnyScriptLanguage where data AnyPlutusScriptVersion where AnyPlutusScriptVersion - :: PlutusScriptVersion lang + :: IsPlutusScriptLanguage lang + => PlutusScriptVersion lang -> AnyPlutusScriptVersion deriving instance (Show AnyPlutusScriptVersion) @@ -407,7 +409,8 @@ data Script lang where :: !SimpleScript -> Script SimpleScript' PlutusScript - :: !(PlutusScriptVersion lang) + :: IsPlutusScriptLanguage lang + => !(PlutusScriptVersion lang) -> !(PlutusScript lang) -> Script lang @@ -721,7 +724,8 @@ data ScriptWitness witctx era where -> SimpleScriptOrReferenceInput SimpleScript' -> ScriptWitness witctx era PlutusScriptWitness - :: ScriptLanguageInEra lang era + :: IsPlutusScriptLanguage lang + => ScriptLanguageInEra lang era -> PlutusScriptVersion lang -> PlutusScriptOrReferenceInput lang -> ScriptDatum witctx From a374fb6ab68d02a5aefa67cac59689fe227ae538 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Fri, 25 Oct 2024 11:51:52 +0200 Subject: [PATCH 2/4] Refactor `TxMintValue` to better represent minting state --- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 42 +++++++-- cardano-api/internal/Cardano/Api/Fees.hs | 42 +++------ cardano-api/internal/Cardano/Api/Script.hs | 17 ++-- cardano-api/internal/Cardano/Api/Tx/Body.hs | 94 ++++++++++++------- cardano-api/internal/Cardano/Api/Value.hs | 3 +- cardano-api/src/Cardano/Api.hs | 3 + .../Cardano/Api/Transaction/Autobalance.hs | 6 +- 7 files changed, 123 insertions(+), 84 deletions(-) diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 4a1f5caaa1..815f42d9cc 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -662,11 +662,18 @@ genTxMintValue :: CardanoEra era -> Gen (TxMintValue BuildTx era) genTxMintValue = inEonForEra (pure TxMintNone) - $ \supported -> + $ \w -> do + policies <- Gen.list (Range.constant 1 3) genPolicyId + assets <- forM policies $ \policy -> + (,) policy <$> + Gen.list + (Range.constant 1 3) + ((,,) <$> genAssetName + <*> genPositiveQuantity + <*> fmap (fmap pure) genScriptWitnessForMint (maryEraOnwardsToShelleyBasedEra w)) Gen.choice [ pure TxMintNone - -- TODO write a generator for the last parameter of 'TxMintValue' constructor - , TxMintValue supported <$> genValueForMinting <*> return (pure mempty) + , pure $ TxMintValue w (fromList assets) ] genTxBodyContent :: ShelleyBasedEra era -> Gen (TxBodyContent BuildTx era) @@ -1196,13 +1203,13 @@ genScriptWitnessForStake sbe = do SimpleScript simpleScript -> do simpleScriptOrReferenceInput <- Gen.choice [ pure $ SScript simpleScript - , SReferenceScript <$> genTxIn <*> Gen.maybe genScriptHash + , SReferenceScript <$> genTxIn ] pure $ Api.SimpleScriptWitness scriptLangInEra simpleScriptOrReferenceInput PlutusScript plutusScriptVersion' plutusScript -> do plutusScriptOrReferenceInput <- Gen.choice [ pure $ PScript plutusScript - , PReferenceScript <$> genTxIn <*> Gen.maybe genScriptHash + , PReferenceScript <$> genTxIn ] scriptRedeemer <- genHashableScriptData PlutusScriptWitness @@ -1213,6 +1220,27 @@ genScriptWitnessForStake sbe = do scriptRedeemer <$> genExecutionUnits - - +genScriptWitnessForMint :: ShelleyBasedEra era -> Gen (Api.ScriptWitness WitCtxMint era) +genScriptWitnessForMint sbe = do + ScriptInEra scriptLangInEra script' <- genScriptInEra sbe + case script' of + SimpleScript simpleScript -> do + simpleScriptOrReferenceInput <- Gen.choice + [ pure $ SScript simpleScript + , SReferenceScript <$> genTxIn + ] + pure $ Api.SimpleScriptWitness scriptLangInEra simpleScriptOrReferenceInput + PlutusScript plutusScriptVersion' plutusScript -> do + plutusScriptOrReferenceInput <- Gen.choice + [ pure $ PScript plutusScript + , PReferenceScript <$> genTxIn + ] + scriptRedeemer <- genHashableScriptData + PlutusScriptWitness + scriptLangInEra + plutusScriptVersion' + plutusScriptOrReferenceInput + NoScriptDatumForMint + scriptRedeemer + <$> genExecutionUnits diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index f026efde5c..3e44dc189c 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -8,6 +8,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} -- | Fee calculation module Cardano.Api.Fees @@ -1320,10 +1321,8 @@ calculateChangeValue :: ShelleyBasedEra era -> Value -> TxBodyContent build era -> Value calculateChangeValue sbe incoming txbodycontent = let outgoing = calculateCreatedUTOValue sbe txbodycontent - minted = case txMintValue txbodycontent of - TxMintNone -> mempty - TxMintValue _ v _ -> v - in mconcat [incoming, minted, negateValue outgoing] + mintedValue = txMintValueToValue $ txMintValue txbodycontent + in mconcat [incoming, mintedValue, negateValue outgoing] -- | This is used in the balance calculation in the event where -- the user does not supply the UTxO(s) they intend to spend @@ -1593,33 +1592,20 @@ substituteExecutionUnits :: TxMintValue BuildTx era -> Either (TxBodyErrorAutoBalance era) (TxMintValue BuildTx era) mapScriptWitnessesMinting TxMintNone = Right TxMintNone - mapScriptWitnessesMinting - ( TxMintValue - supported - value - (BuildTxWith witnesses) - ) = - -- TxMintValue supported value $ BuildTxWith $ fromList - let mappedScriptWitnesses - :: [(PolicyId, Either (TxBodyErrorAutoBalance era) (ScriptWitness WitCtxMint era))] - mappedScriptWitnesses = - [ (policyid, witness') - | -- The minting policies are indexed in policy id order in the value - let ValueNestedRep bundle = valueToNestedRep value - , (ix, ValueNestedBundle policyid _) <- zip [0 ..] bundle - , witness <- maybeToList (Map.lookup policyid witnesses) - , let witness' = substituteExecUnits (ScriptWitnessIndexMint ix) witness - ] - in do - final <- traverseScriptWitnesses mappedScriptWitnesses - Right . TxMintValue supported value . BuildTxWith $ - fromList final + mapScriptWitnessesMinting txMintValue'@(TxMintValue w _) = do + let mappedScriptWitnesses = + [ (policyId, pure . (assetName',quantity,) <$> substitutedWitness) + | (ix, policyId, assetName', quantity, BuildTxWith witness) <- txMintValueToIndexed txMintValue' + , let substitutedWitness = BuildTxWith <$> substituteExecUnits ix witness + ] + final <- Map.fromListWith (<>) <$> traverseScriptWitnesses mappedScriptWitnesses + pure $ TxMintValue w final traverseScriptWitnesses - :: [(a, Either (TxBodyErrorAutoBalance era) (ScriptWitness ctx era))] - -> Either (TxBodyErrorAutoBalance era) [(a, ScriptWitness ctx era)] + :: [(a, Either (TxBodyErrorAutoBalance era) b)] + -> Either (TxBodyErrorAutoBalance era) [(a, b)] traverseScriptWitnesses = - traverse (\(item, eScriptWitness) -> eScriptWitness >>= (\sWit -> Right (item, sWit))) + traverse (\(item, eRes) -> eRes >>= (\res -> Right (item, res))) calculateMinimumUTxO :: ShelleyBasedEra era diff --git a/cardano-api/internal/Cardano/Api/Script.hs b/cardano-api/internal/Cardano/Api/Script.hs index dfe3df1a84..a1de27f666 100644 --- a/cardano-api/internal/Cardano/Api/Script.hs +++ b/cardano-api/internal/Cardano/Api/Script.hs @@ -54,6 +54,7 @@ module Cardano.Api.Script , WitCtxMint , WitCtxStake , WitCtx (..) + , WitCtxMaybe (..) , ScriptWitness (..) , Witness (..) , KeyWitnessInCtx (..) @@ -165,7 +166,7 @@ import Data.String (IsString) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text -import Data.Type.Equality (TestEquality (..), (:~:) (Refl)) +import Data.Type.Equality (TestEquality (..), type (==), (:~:) (Refl)) import Data.Typeable (Typeable) import Data.Vector (Vector) import GHC.Exts (IsList (..)) @@ -688,20 +689,18 @@ data PlutusScriptOrReferenceInput lang | -- | Needed to construct the redeemer pointer map -- in the case of minting reference scripts where we don't -- have direct access to the script - PReferenceScript - TxIn - (Maybe ScriptHash) + PReferenceScript TxIn deriving (Eq, Show) data SimpleScriptOrReferenceInput lang = SScript SimpleScript - | SReferenceScript TxIn (Maybe ScriptHash) + | SReferenceScript TxIn deriving (Eq, Show) getScriptWitnessReferenceInput :: ScriptWitness witctx era -> Maybe TxIn -getScriptWitnessReferenceInput (SimpleScriptWitness _ (SReferenceScript txIn _)) = +getScriptWitnessReferenceInput (SimpleScriptWitness _ (SReferenceScript txIn)) = Just txIn -getScriptWitnessReferenceInput (PlutusScriptWitness _ _ (PReferenceScript txIn _) _ _ _) = +getScriptWitnessReferenceInput (PlutusScriptWitness _ _ (PReferenceScript txIn) _ _ _) = Just txIn getScriptWitnessReferenceInput (SimpleScriptWitness _ (SScript _)) = Nothing getScriptWitnessReferenceInput (PlutusScriptWitness _ _ (PScript _) _ _ _) = Nothing @@ -804,9 +803,9 @@ scriptWitnessScript (SimpleScriptWitness SimpleScriptInConway (SScript script)) Just $ ScriptInEra SimpleScriptInConway (SimpleScript script) scriptWitnessScript (PlutusScriptWitness langInEra version (PScript script) _ _ _) = Just $ ScriptInEra langInEra (PlutusScript version script) -scriptWitnessScript (SimpleScriptWitness _ (SReferenceScript _ _)) = +scriptWitnessScript (SimpleScriptWitness _ (SReferenceScript _)) = Nothing -scriptWitnessScript (PlutusScriptWitness _ _ (PReferenceScript _ _) _ _ _) = +scriptWitnessScript (PlutusScriptWitness _ _ (PReferenceScript _) _ _ _) = Nothing -- ---------------------------------------------------------------------------- diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs index 4189434b60..1ee6d790dd 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Body.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Body.hs @@ -111,6 +111,8 @@ module Cardano.Api.Tx.Body , TxCertificates (..) , TxUpdateProposal (..) , TxMintValue (..) + , txMintValueToValue + , txMintValueToIndexed , TxVotingProcedures (..) , mkTxVotingProcedures , TxProposalProcedures (..) @@ -1248,16 +1250,46 @@ data TxMintValue build era where TxMintNone :: TxMintValue build era TxMintValue :: MaryEraOnwards era - -> Value - -> BuildTxWith - build - (Map PolicyId (ScriptWitness WitCtxMint era)) + -> Map + PolicyId + [ ( AssetName + , Quantity + , BuildTxWith build (ScriptWitness WitCtxMint era) + ) + ] -> TxMintValue build era deriving instance Eq (TxMintValue build era) deriving instance Show (TxMintValue build era) +-- | Convert 'TxMintValue' to a more handy 'Value'. +txMintValueToValue :: TxMintValue build era -> Value +txMintValueToValue TxMintNone = mempty +txMintValueToValue (TxMintValue _ policiesWithAssets) = + fromList + [ (AssetId policyId' assetName', quantity) + | (policyId', assets) <- toList policiesWithAssets + , (assetName', quantity, _) <- assets + ] + +-- | Index the assets with witnesses in the order of policy ids. +txMintValueToIndexed + :: TxMintValue build era + -> [ ( ScriptWitnessIndex + , PolicyId + , AssetName + , Quantity + , BuildTxWith build (ScriptWitness WitCtxMint era) + ) + ] +txMintValueToIndexed TxMintNone = [] +txMintValueToIndexed (TxMintValue _ policiesWithAssets) = + [ (ScriptWitnessIndexMint ix, policyId', assetName', quantity, witness) + | (ix, (policyId', assets)) <- zip [0 ..] $ toList policiesWithAssets + , (assetName', quantity, witness) <- assets + ] + -- ---------------------------------------------------------------------------- -- Votes within transactions (era-dependent) -- @@ -1555,7 +1587,7 @@ data TxBodyError | TxBodyOutputNegative !Quantity !TxOutInAnyEra | TxBodyOutputOverflow !Quantity !TxOutInAnyEra | TxBodyMetadataError ![(Word64, TxMetadataRangeError)] - | TxBodyMintAdaError + | TxBodyMintAdaError -- TODO remove - case nonexistent | TxBodyInIxOverflow !TxIn | TxBodyMissingProtocolParams | TxBodyProtocolParamsConversionError !ProtocolParametersConversionError @@ -1824,11 +1856,9 @@ validateTxOuts sbe txOuts = do | txout@(TxOut _ v _ _) <- txOuts ] +-- TODO remove validateMintValue :: TxMintValue build era -> Either TxBodyError () -validateMintValue txMintValue = - case txMintValue of - TxMintNone -> return () - TxMintValue _ v _ -> guard (selectLovelace v == 0) ?! TxBodyMintAdaError +validateMintValue _txMintValue = pure () inputIndexDoesNotExceedMax :: [(TxIn, a)] -> Either TxBodyError () inputIndexDoesNotExceedMax txIns = @@ -2285,20 +2315,20 @@ fromLedgerTxMintValue :: ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> TxMintValue ViewTx era -fromLedgerTxMintValue sbe body = - case sbe of - ShelleyBasedEraShelley -> TxMintNone - ShelleyBasedEraAllegra -> TxMintNone - ShelleyBasedEraMary -> toMintValue body MaryEraOnwardsMary - ShelleyBasedEraAlonzo -> toMintValue body MaryEraOnwardsAlonzo - ShelleyBasedEraBabbage -> toMintValue body MaryEraOnwardsBabbage - ShelleyBasedEraConway -> toMintValue body MaryEraOnwardsConway - where - toMintValue txBody maInEra - | L.isZero mint = TxMintNone - | otherwise = TxMintValue maInEra (fromMaryValue mint) ViewTx - where - mint = MaryValue (Ledger.Coin 0) (txBody ^. L.mintTxBodyL) +fromLedgerTxMintValue sbe body = forEraInEon (toCardanoEra sbe) TxMintNone $ \w -> + maryEraOnwardsConstraints w $ do + let mint = MaryValue (Ledger.Coin 0) (body ^. L.mintTxBodyL) + if L.isZero mint + then TxMintNone + else do + let assetMap = toList $ fromMaryValue mint + TxMintValue w $ + Map.fromListWith + (<>) + [ (policyId', [(assetName', quantity, ViewTx)]) + | -- only non-ada can be here + (AssetId policyId' assetName', quantity) <- toList assetMap + ] makeByronTransactionBody :: () @@ -2412,12 +2442,9 @@ convTxUpdateProposal sbe = \case TxUpdateProposal _ p -> bimap TxBodyProtocolParamsConversionError pure $ toLedgerUpdate sbe p convMintValue :: TxMintValue build era -> MultiAsset StandardCrypto -convMintValue txMintValue = - case txMintValue of - TxMintNone -> mempty - TxMintValue _ v _ -> - case toMaryValue v of - MaryValue _ ma -> ma +convMintValue txMintValue = do + let L.MaryValue _coin multiAsset = toMaryValue $ txMintValueToValue txMintValue + multiAsset convExtraKeyWitnesses :: TxExtraKeyWitnesses era -> Set (Shelley.KeyHash Shelley.Witness StandardCrypto) @@ -3328,12 +3355,9 @@ collectTxBodyScriptWitnesses :: TxMintValue BuildTx era -> [(ScriptWitnessIndex, AnyScriptWitness era)] scriptWitnessesMinting TxMintNone = [] - scriptWitnessesMinting (TxMintValue _ value (BuildTxWith witnesses)) = - [ (ScriptWitnessIndexMint ix, AnyScriptWitness witness) - | -- The minting policies are indexed in policy id order in the value - let ValueNestedRep bundle = valueToNestedRep value - , (ix, ValueNestedBundle policyid _) <- zip [0 ..] bundle - , witness <- maybeToList (Map.lookup policyid witnesses) + scriptWitnessesMinting txMintValue' = + [ (ix, AnyScriptWitness witness) + | (ix, _, _, _, BuildTxWith witness) <- txMintValueToIndexed txMintValue' ] scriptWitnessesVoting diff --git a/cardano-api/internal/Cardano/Api/Value.hs b/cardano-api/internal/Cardano/Api/Value.hs index 070b4aba8e..c97133e2bc 100644 --- a/cardano-api/internal/Cardano/Api/Value.hs +++ b/cardano-api/internal/Cardano/Api/Value.hs @@ -328,6 +328,7 @@ calcMinimumDeposit v = -- ---------------------------------------------------------------------------- -- An alternative nested representation -- +-- TODO remove ? - it is now unused -- | An alternative nested representation for 'Value' that groups assets that -- share a 'PolicyId'. @@ -358,7 +359,7 @@ valueToNestedRep v = valueFromNestedRep :: ValueNestedRep -> Value valueFromNestedRep (ValueNestedRep bundles) = - valueFromList + fromList [ (aId, q) | bundle <- bundles , (aId, q) <- case bundle of diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index b98b2eb3eb..17891ba79f 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -368,6 +368,8 @@ module Cardano.Api , TxCertificates (..) , TxUpdateProposal (..) , TxMintValue (..) + , txMintValueToValue + , txMintValueToIndexed , TxVotingProcedures (..) , mkTxVotingProcedures , TxProposalProcedures (..) @@ -535,6 +537,7 @@ module Cardano.Api , WitCtxMint , WitCtxStake , WitCtx (..) + , WitCtxMaybe (..) , ScriptWitness (..) , Witness (..) , KeyWitnessInCtx (..) diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Autobalance.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Autobalance.hs index 207cec7c25..2a3fc42dec 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Autobalance.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Autobalance.hs @@ -83,8 +83,7 @@ prop_make_transaction_body_autobalance_return_correct_fee_for_multi_asset = H.pr let txMint = TxMintValue meo - [(AssetId policyId' "eeee", 1)] - (BuildTxWith [(policyId', plutusWitness)]) + [(policyId', [("eeee", 1, BuildTxWith plutusWitness)])] -- tx body content without an asset in TxOut let content = @@ -167,8 +166,7 @@ prop_make_transaction_body_autobalance_multi_asset_collateral = H.propertyOnce $ let txMint = TxMintValue meo - [(AssetId policyId' "eeee", 1)] - (BuildTxWith [(policyId', plutusWitness)]) + [(policyId', [("eeee", 1, BuildTxWith plutusWitness)])] let content = defaultTxBodyContent sbe From e58eb3f1fbc831f6cca69e41c7c1155f475bca33 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Fri, 8 Nov 2024 18:18:28 +0100 Subject: [PATCH 3/4] Add getScriptWitnessScript, getScriptWitnessReferenceInput, getScriptWitnessReferenceInputOrScript functions --- cardano-api/internal/Cardano/Api/Script.hs | 58 ++++++++----------- cardano-api/internal/Cardano/Api/Tx/Body.hs | 27 +++------ cardano-api/src/Cardano/Api.hs | 5 +- .../Test/Golden/ErrorsSpec.hs | 1 - .../TxBodyMintAdaError.txt | 1 - 5 files changed, 34 insertions(+), 58 deletions(-) delete mode 100644 cardano-api/test/cardano-api-golden/files/golden/errors/Cardano.Api.Tx.Body.TxBodyError/TxBodyMintAdaError.txt diff --git a/cardano-api/internal/Cardano/Api/Script.hs b/cardano-api/internal/Cardano/Api/Script.hs index a1de27f666..bbcba91605 100644 --- a/cardano-api/internal/Cardano/Api/Script.hs +++ b/cardano-api/internal/Cardano/Api/Script.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} @@ -47,22 +48,22 @@ module Cardano.Api.Script -- * Reference scripts , ReferenceScript (..) , refScriptToShelleyScript - , getScriptWitnessReferenceInput -- * Use of a script in an era as a witness , WitCtxTxIn , WitCtxMint , WitCtxStake , WitCtx (..) - , WitCtxMaybe (..) , ScriptWitness (..) + , getScriptWitnessReferenceInput + , getScriptWitnessScript + , getScriptWitnessReferenceInputOrScript , Witness (..) , KeyWitnessInCtx (..) , ScriptWitnessInCtx (..) , IsScriptWitnessInCtx (..) , ScriptDatum (..) , ScriptRedeemer - , scriptWitnessScript -- ** Languages supported in each era , ScriptLanguageInEra (..) @@ -686,10 +687,7 @@ data WitCtx witctx where -- or to mint tokens. This datatype encapsulates this concept. data PlutusScriptOrReferenceInput lang = PScript (PlutusScript lang) - | -- | Needed to construct the redeemer pointer map - -- in the case of minting reference scripts where we don't - -- have direct access to the script - PReferenceScript TxIn + | PReferenceScript TxIn deriving (Eq, Show) data SimpleScriptOrReferenceInput lang @@ -697,14 +695,6 @@ data SimpleScriptOrReferenceInput lang | SReferenceScript TxIn deriving (Eq, Show) -getScriptWitnessReferenceInput :: ScriptWitness witctx era -> Maybe TxIn -getScriptWitnessReferenceInput (SimpleScriptWitness _ (SReferenceScript txIn)) = - Just txIn -getScriptWitnessReferenceInput (PlutusScriptWitness _ _ (PReferenceScript txIn) _ _ _) = - Just txIn -getScriptWitnessReferenceInput (SimpleScriptWitness _ (SScript _)) = Nothing -getScriptWitnessReferenceInput (PlutusScriptWitness _ _ (PScript _) _ _ _) = Nothing - -- | A /use/ of a script within a transaction body to witness that something is -- being used in an authorised manner. That can be -- @@ -785,28 +775,26 @@ deriving instance Eq (ScriptDatum witctx) deriving instance Show (ScriptDatum witctx) --- We cannot always extract a script from a script witness due to reference scripts. +getScriptWitnessReferenceInput :: ScriptWitness witctx era -> Maybe TxIn +getScriptWitnessReferenceInput = either (const Nothing) Just . getScriptWitnessReferenceInputOrScript + +getScriptWitnessScript :: ScriptWitness witctx era -> Maybe (ScriptInEra era) +getScriptWitnessScript = either Just (const Nothing) . getScriptWitnessReferenceInputOrScript + +-- | We cannot always extract a script from a script witness due to reference scripts. -- Reference scripts exist in the UTxO, so without access to the UTxO we cannot -- retrieve the script. -scriptWitnessScript :: ScriptWitness witctx era -> Maybe (ScriptInEra era) -scriptWitnessScript (SimpleScriptWitness SimpleScriptInShelley (SScript script)) = - Just $ ScriptInEra SimpleScriptInShelley (SimpleScript script) -scriptWitnessScript (SimpleScriptWitness SimpleScriptInAllegra (SScript script)) = - Just $ ScriptInEra SimpleScriptInAllegra (SimpleScript script) -scriptWitnessScript (SimpleScriptWitness SimpleScriptInMary (SScript script)) = - Just $ ScriptInEra SimpleScriptInMary (SimpleScript script) -scriptWitnessScript (SimpleScriptWitness SimpleScriptInAlonzo (SScript script)) = - Just $ ScriptInEra SimpleScriptInAlonzo (SimpleScript script) -scriptWitnessScript (SimpleScriptWitness SimpleScriptInBabbage (SScript script)) = - Just $ ScriptInEra SimpleScriptInBabbage (SimpleScript script) -scriptWitnessScript (SimpleScriptWitness SimpleScriptInConway (SScript script)) = - Just $ ScriptInEra SimpleScriptInConway (SimpleScript script) -scriptWitnessScript (PlutusScriptWitness langInEra version (PScript script) _ _ _) = - Just $ ScriptInEra langInEra (PlutusScript version script) -scriptWitnessScript (SimpleScriptWitness _ (SReferenceScript _)) = - Nothing -scriptWitnessScript (PlutusScriptWitness _ _ (PReferenceScript _) _ _ _) = - Nothing +-- So in the cases for script reference, the result contains @Right TxIn@. +getScriptWitnessReferenceInputOrScript :: ScriptWitness witctx era -> Either (ScriptInEra era) TxIn +getScriptWitnessReferenceInputOrScript = \case + SimpleScriptWitness (s :: (ScriptLanguageInEra SimpleScript' era)) (SScript script) -> + Left $ ScriptInEra s (SimpleScript script) + PlutusScriptWitness langInEra version (PScript script) _ _ _ -> + Left $ ScriptInEra langInEra (PlutusScript version script) + SimpleScriptWitness _ (SReferenceScript txIn) -> + Right txIn + PlutusScriptWitness _ _ (PReferenceScript txIn) _ _ _ -> + Right txIn -- ---------------------------------------------------------------------------- -- The kind of witness to use, key (signature) or script diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs index 1ee6d790dd..0332ccf4ee 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Body.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Body.hs @@ -183,7 +183,6 @@ module Cardano.Api.Tx.Body , guardShelleyTxInsOverflow , validateTxOuts , validateMetadata - , validateMintValue , validateTxInsCollateral , validateProtocolParameters ) @@ -1274,6 +1273,7 @@ txMintValueToValue (TxMintValue _ policiesWithAssets) = ] -- | Index the assets with witnesses in the order of policy ids. +-- See section 4.1 of https://github.com/intersectmbo/cardano-ledger/releases/latest/download/alonzo-ledger.pdf txMintValueToIndexed :: TxMintValue build era -> [ ( ScriptWitnessIndex @@ -1587,7 +1587,6 @@ data TxBodyError | TxBodyOutputNegative !Quantity !TxOutInAnyEra | TxBodyOutputOverflow !Quantity !TxOutInAnyEra | TxBodyMetadataError ![(Word64, TxMetadataRangeError)] - | TxBodyMintAdaError -- TODO remove - case nonexistent | TxBodyInIxOverflow !TxIn | TxBodyMissingProtocolParams | TxBodyProtocolParamsConversionError !ProtocolParametersConversionError @@ -1623,8 +1622,6 @@ instance Error TxBodyError where | (k, err) <- errs ] ] - TxBodyMintAdaError -> - "Transaction cannot mint ada, only non-ada assets" TxBodyMissingProtocolParams -> "Transaction uses Plutus scripts but does not provide the protocol " <> "parameters to hash" @@ -1786,13 +1783,11 @@ validateTxBodyContent guardShelleyTxInsOverflow (map fst txIns) validateTxOuts sbe txOuts validateMetadata txMetadata - validateMintValue txMintValue ShelleyBasedEraAlonzo -> do validateTxIns txIns guardShelleyTxInsOverflow (map fst txIns) validateTxOuts sbe txOuts validateMetadata txMetadata - validateMintValue txMintValue validateTxInsCollateral txInsCollateral languages validateProtocolParameters txProtocolParams languages ShelleyBasedEraBabbage -> do @@ -1800,14 +1795,12 @@ validateTxBodyContent guardShelleyTxInsOverflow (map fst txIns) validateTxOuts sbe txOuts validateMetadata txMetadata - validateMintValue txMintValue validateTxInsCollateral txInsCollateral languages validateProtocolParameters txProtocolParams languages ShelleyBasedEraConway -> do validateTxIns txIns validateTxOuts sbe txOuts validateMetadata txMetadata - validateMintValue txMintValue validateTxInsCollateral txInsCollateral languages validateProtocolParameters txProtocolParams languages @@ -1856,10 +1849,6 @@ validateTxOuts sbe txOuts = do | txout@(TxOut _ v _ _) <- txOuts ] --- TODO remove -validateMintValue :: TxMintValue build era -> Either TxBodyError () -validateMintValue _txMintValue = pure () - inputIndexDoesNotExceedMax :: [(TxIn, a)] -> Either TxBodyError () inputIndexDoesNotExceedMax txIns = for_ txIns $ \(txin@(TxIn _ (TxIx txix)), _) -> @@ -2463,7 +2452,7 @@ convScripts -> [Ledger.Script ledgerera] convScripts scriptWitnesses = catMaybes - [ toShelleyScript <$> scriptWitnessScript scriptwitness + [ toShelleyScript <$> getScriptWitnessScript scriptwitness | (_, AnyScriptWitness scriptwitness) <- scriptWitnesses ] @@ -2630,7 +2619,7 @@ makeShelleyTransactionBody scripts_ :: [Ledger.Script StandardShelley] scripts_ = catMaybes - [ toShelleyScript <$> scriptWitnessScript scriptwitness + [ toShelleyScript <$> getScriptWitnessScript scriptwitness | (_, AnyScriptWitness scriptwitness) <- collectTxBodyScriptWitnesses sbe txbodycontent ] @@ -2675,7 +2664,7 @@ makeShelleyTransactionBody scripts_ :: [Ledger.Script StandardAllegra] scripts_ = catMaybes - [ toShelleyScript <$> scriptWitnessScript scriptwitness + [ toShelleyScript <$> getScriptWitnessScript scriptwitness | (_, AnyScriptWitness scriptwitness) <- collectTxBodyScriptWitnesses sbe txbodycontent ] @@ -2724,7 +2713,7 @@ makeShelleyTransactionBody scripts = List.nub $ catMaybes - [ toShelleyScript <$> scriptWitnessScript scriptwitness + [ toShelleyScript <$> getScriptWitnessScript scriptwitness | (_, AnyScriptWitness scriptwitness) <- collectTxBodyScriptWitnesses sbe txbodycontent ] @@ -2789,7 +2778,7 @@ makeShelleyTransactionBody scripts = List.nub $ catMaybes - [ toShelleyScript <$> scriptWitnessScript scriptwitness + [ toShelleyScript <$> getScriptWitnessScript scriptwitness | (_, AnyScriptWitness scriptwitness) <- witnesses ] @@ -2910,7 +2899,7 @@ makeShelleyTransactionBody scripts = List.nub $ catMaybes - [ toShelleyScript <$> scriptWitnessScript scriptwitness + [ toShelleyScript <$> getScriptWitnessScript scriptwitness | (_, AnyScriptWitness scriptwitness) <- witnesses ] @@ -3049,7 +3038,7 @@ makeShelleyTransactionBody scripts :: [Ledger.Script StandardConway] scripts = catMaybes - [ toShelleyScript <$> scriptWitnessScript scriptwitness + [ toShelleyScript <$> getScriptWitnessScript scriptwitness | (_, AnyScriptWitness scriptwitness) <- witnesses ] diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 17891ba79f..aebcbbf6fb 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -537,15 +537,16 @@ module Cardano.Api , WitCtxMint , WitCtxStake , WitCtx (..) - , WitCtxMaybe (..) , ScriptWitness (..) + , getScriptWitnessScript + , getScriptWitnessReferenceInput + , getScriptWitnessReferenceInputOrScript , Witness (..) , KeyWitnessInCtx (..) , ScriptWitnessInCtx (..) , IsScriptWitnessInCtx (..) , ScriptDatum (..) , ScriptRedeemer - , scriptWitnessScript -- ** Inspecting 'ScriptWitness'es , AnyScriptWitness (..) diff --git a/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs b/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs index b86611c8bb..b39ea2151b 100644 --- a/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs +++ b/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs @@ -415,7 +415,6 @@ test_TxBodyError = , ("TxBodyOutputNegative", TxBodyOutputNegative 1 txOutInAnyEra1) , ("TxBodyOutputOverflow", TxBodyOutputOverflow 1 txOutInAnyEra1) , ("TxBodyMetadataError", TxBodyMetadataError [(1, TxMetadataBytesTooLong 2)]) - , ("TxBodyMintAdaError", TxBodyMintAdaError) , ("TxBodyMissingProtocolParams", TxBodyMissingProtocolParams) , ("TxBodyInIxOverflow", TxBodyInIxOverflow txin1) ] diff --git a/cardano-api/test/cardano-api-golden/files/golden/errors/Cardano.Api.Tx.Body.TxBodyError/TxBodyMintAdaError.txt b/cardano-api/test/cardano-api-golden/files/golden/errors/Cardano.Api.Tx.Body.TxBodyError/TxBodyMintAdaError.txt deleted file mode 100644 index d2e5d85c44..0000000000 --- a/cardano-api/test/cardano-api-golden/files/golden/errors/Cardano.Api.Tx.Body.TxBodyError/TxBodyMintAdaError.txt +++ /dev/null @@ -1 +0,0 @@ -Transaction cannot mint ada, only non-ada assets \ No newline at end of file From 0f5187411b69e902f4665927c24a17cba62c1290 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Tue, 19 Nov 2024 23:29:15 +0100 Subject: [PATCH 4/4] Add sbeToSimpleScriptLanguageInEra --- cardano-api/internal/Cardano/Api/Script.hs | 55 +++++++++++---------- cardano-api/internal/Cardano/Api/Tx/Body.hs | 1 - cardano-api/internal/Cardano/Api/Value.hs | 1 - cardano-api/src/Cardano/Api.hs | 1 + 4 files changed, 29 insertions(+), 29 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Script.hs b/cardano-api/internal/Cardano/Api/Script.hs index bbcba91605..ce59e80da5 100644 --- a/cardano-api/internal/Cardano/Api/Script.hs +++ b/cardano-api/internal/Cardano/Api/Script.hs @@ -68,6 +68,7 @@ module Cardano.Api.Script -- ** Languages supported in each era , ScriptLanguageInEra (..) , scriptLanguageSupportedInEra + , sbeToSimpleScriptLanguageInEra , languageOfScriptLanguageInEra , eraOfScriptLanguageInEra @@ -167,7 +168,7 @@ import Data.String (IsString) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text -import Data.Type.Equality (TestEquality (..), type (==), (:~:) (Refl)) +import Data.Type.Equality (TestEquality (..), (:~:) (Refl)) import Data.Typeable (Typeable) import Data.Vector (Vector) import GHC.Exts (IsList (..)) @@ -581,18 +582,8 @@ scriptLanguageSupportedInEra -> Maybe (ScriptLanguageInEra lang era) scriptLanguageSupportedInEra era lang = case (era, lang) of - (ShelleyBasedEraShelley, SimpleScriptLanguage) -> - Just SimpleScriptInShelley - (ShelleyBasedEraAllegra, SimpleScriptLanguage) -> - Just SimpleScriptInAllegra - (ShelleyBasedEraMary, SimpleScriptLanguage) -> - Just SimpleScriptInMary - (ShelleyBasedEraAlonzo, SimpleScriptLanguage) -> - Just SimpleScriptInAlonzo - (ShelleyBasedEraBabbage, SimpleScriptLanguage) -> - Just SimpleScriptInBabbage - (ShelleyBasedEraConway, SimpleScriptLanguage) -> - Just SimpleScriptInConway + (sbe, SimpleScriptLanguage) -> + Just $ sbeToSimpleScriptLanguageInEra sbe (ShelleyBasedEraAlonzo, PlutusScriptLanguage PlutusScriptV1) -> Just PlutusScriptV1InAlonzo (ShelleyBasedEraBabbage, PlutusScriptLanguage PlutusScriptV1) -> @@ -625,23 +616,33 @@ languageOfScriptLanguageInEra langInEra = PlutusScriptV2InConway -> PlutusScriptLanguage PlutusScriptV2 PlutusScriptV3InConway -> PlutusScriptLanguage PlutusScriptV3 +sbeToSimpleScriptLanguageInEra + :: ShelleyBasedEra era + -> ScriptLanguageInEra SimpleScript' era +sbeToSimpleScriptLanguageInEra = \case + ShelleyBasedEraShelley -> SimpleScriptInShelley + ShelleyBasedEraAllegra -> SimpleScriptInAllegra + ShelleyBasedEraMary -> SimpleScriptInMary + ShelleyBasedEraAlonzo -> SimpleScriptInAlonzo + ShelleyBasedEraBabbage -> SimpleScriptInBabbage + ShelleyBasedEraConway -> SimpleScriptInConway + eraOfScriptLanguageInEra :: ScriptLanguageInEra lang era -> ShelleyBasedEra era -eraOfScriptLanguageInEra langInEra = - case langInEra of - SimpleScriptInShelley -> ShelleyBasedEraShelley - SimpleScriptInAllegra -> ShelleyBasedEraAllegra - SimpleScriptInMary -> ShelleyBasedEraMary - SimpleScriptInAlonzo -> ShelleyBasedEraAlonzo - SimpleScriptInBabbage -> ShelleyBasedEraBabbage - SimpleScriptInConway -> ShelleyBasedEraConway - PlutusScriptV1InAlonzo -> ShelleyBasedEraAlonzo - PlutusScriptV1InBabbage -> ShelleyBasedEraBabbage - PlutusScriptV1InConway -> ShelleyBasedEraConway - PlutusScriptV2InBabbage -> ShelleyBasedEraBabbage - PlutusScriptV2InConway -> ShelleyBasedEraConway - PlutusScriptV3InConway -> ShelleyBasedEraConway +eraOfScriptLanguageInEra = \case + SimpleScriptInShelley -> ShelleyBasedEraShelley + SimpleScriptInAllegra -> ShelleyBasedEraAllegra + SimpleScriptInMary -> ShelleyBasedEraMary + SimpleScriptInAlonzo -> ShelleyBasedEraAlonzo + SimpleScriptInBabbage -> ShelleyBasedEraBabbage + SimpleScriptInConway -> ShelleyBasedEraConway + PlutusScriptV1InAlonzo -> ShelleyBasedEraAlonzo + PlutusScriptV1InBabbage -> ShelleyBasedEraBabbage + PlutusScriptV1InConway -> ShelleyBasedEraConway + PlutusScriptV2InBabbage -> ShelleyBasedEraBabbage + PlutusScriptV2InConway -> ShelleyBasedEraConway + PlutusScriptV3InConway -> ShelleyBasedEraConway -- | Given a target era and a script in some language, check if the language is -- supported in that era, and if so return a 'ScriptInEra'. diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs index 0332ccf4ee..38d12be3e6 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Body.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Body.hs @@ -1757,7 +1757,6 @@ validateTxBodyContent , txInsCollateral , txOuts , txProtocolParams - , txMintValue , txMetadata } = let witnesses = collectTxBodyScriptWitnesses sbe txBodContent diff --git a/cardano-api/internal/Cardano/Api/Value.hs b/cardano-api/internal/Cardano/Api/Value.hs index c97133e2bc..9fc9f18607 100644 --- a/cardano-api/internal/Cardano/Api/Value.hs +++ b/cardano-api/internal/Cardano/Api/Value.hs @@ -328,7 +328,6 @@ calcMinimumDeposit v = -- ---------------------------------------------------------------------------- -- An alternative nested representation -- --- TODO remove ? - it is now unused -- | An alternative nested representation for 'Value' that groups assets that -- share a 'PolicyId'. diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index aebcbbf6fb..7438af2ede 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -557,6 +557,7 @@ module Cardano.Api -- ** Languages supported in each era , ScriptLanguageInEra (..) , scriptLanguageSupportedInEra + , sbeToSimpleScriptLanguageInEra , languageOfScriptLanguageInEra , eraOfScriptLanguageInEra