From 898790738701797f134843dee8b5ee093a29a3ff Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Fri, 8 Nov 2024 18:18:28 +0100 Subject: [PATCH] Add getScriptWitnessScript, getScriptWitnessReferenceInput, getScriptWitnessReferenceInputOrScript functions --- cardano-api/internal/Cardano/Api/Script.hs | 69 +++++++------------ 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(+), 69 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 da15aab24f..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 (..) @@ -680,27 +681,13 @@ data WitCtx witctx where WitCtxMint :: WitCtx WitCtxMint WitCtxStake :: WitCtx WitCtxStake --- TODO: not needed anymore - remove - --- | A typed version of a 'Maybe'. Allows to store value of type @a@ when @purpose ~ witctx@, otherwise it is empty. -data WitCtxMaybe purpose witctx a where - WitCtxJust :: WitCtx purpose -> a -> WitCtxMaybe purpose purpose a - WitCtxNothing :: (purpose == witctx) ~ False => WitCtxMaybe purpose witctx a - -instance Show a => Show (WitCtxMaybe p w a) where - show (WitCtxJust _ a) = "WitCtxJust " <> show a - show WitCtxNothing = "WitCtxNothing" - -- | Scripts can now exist in the UTxO at a transaction output. We can -- reference these scripts via specification of a reference transaction input -- in order to witness spending inputs, withdrawals, certificates -- 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 @@ -708,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 -- @@ -796,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 19cc093595..18ed8125ae 100644 --- a/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs +++ b/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs @@ -355,7 +355,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