From c46167982011723fda676272735b2c66c574b550 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Thu, 31 Oct 2024 14:12:12 +0100 Subject: [PATCH 1/3] Remove unneeded ScriptHash in PReferenceScript/SReferenceScript --- .../Cardano/CLI/EraBased/Run/Transaction.hs | 60 +++++++++++-------- cardano-cli/src/Cardano/CLI/Json/Friendly.hs | 3 +- cardano-cli/src/Cardano/CLI/Read.hs | 28 +++++---- cardano-cli/src/Cardano/CLI/Types/Output.hs | 2 +- 4 files changed, 53 insertions(+), 40 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs index c59ace374a..97e0a677eb 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs @@ -56,6 +56,7 @@ import Cardano.CLI.Types.TxFeature import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as Consensus import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Client as Net.Tx +import Control.Applicative import Control.Monad (forM) import Data.Aeson ((.=)) import qualified Data.Aeson as Aeson @@ -71,7 +72,7 @@ import Data.Function ((&)) import qualified Data.List as List import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes, fromMaybe, mapMaybe) +import Data.Maybe (catMaybes, fromMaybe, mapMaybe, maybeToList) import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Text as Text @@ -204,7 +205,7 @@ runTransactionBuildCmd let allReferenceInputs = getAllReferenceInputs inputsAndMaybeScriptWits - (snd valuesWithScriptWits) + (snd <$> snd valuesWithScriptWits) certsAndMaybeScriptWits withdrawalsAndMaybeScriptWits votingProceduresAndMaybeScriptWits @@ -697,7 +698,7 @@ runTxBuildRaw -- ^ Tx upper bound -> Lovelace -- ^ Tx fee - -> (Value, [ScriptWitness WitCtxMint era]) + -> (Value, [(Maybe PolicyId, ScriptWitness WitCtxMint era)]) -- ^ Multi-Asset value(s) -> [(Certificate era, Maybe (ScriptWitness WitCtxStake era))] -- ^ Certificate with potential script witness @@ -783,7 +784,7 @@ constructTxBodyContent -- ^ Tx lower bound -> TxValidityUpperBound era -- ^ Tx upper bound - -> (Value, [ScriptWitness WitCtxMint era]) + -> (Value, [(Maybe PolicyId, ScriptWitness WitCtxMint era)]) -- ^ Multi-Asset value(s) -> [(Certificate era, Maybe (ScriptWitness WitCtxStake era))] -- ^ Certificate with potential script witness @@ -830,7 +831,7 @@ constructTxBodyContent let allReferenceInputs = getAllReferenceInputs inputsAndMaybeScriptWits - (snd valuesWithScriptWits) + (snd <$> snd valuesWithScriptWits) certsAndMaybeScriptWits withdrawals votingProcedures @@ -923,7 +924,7 @@ runTxBuild -- ^ Normal outputs -> TxOutChangeAddress -- ^ A change output - -> (Value, [ScriptWitness WitCtxMint era]) + -> (Value, [(Maybe PolicyId, ScriptWitness WitCtxMint era)]) -- ^ Multi-Asset value(s) -> Maybe SlotNo -- ^ Tx lower bound @@ -977,7 +978,7 @@ runTxBuild let allReferenceInputs = getAllReferenceInputs inputsAndMaybeScriptWits - (snd valuesWithScriptWits) + (snd <$> snd valuesWithScriptWits) certsAndMaybeScriptWits withdrawals votingProcedures @@ -1182,9 +1183,9 @@ getAllReferenceInputs :: ScriptWitness witctx era -> Maybe TxIn getReferenceInput sWit = case sWit of - PlutusScriptWitness _ _ (PReferenceScript refIn _) _ _ _ -> Just refIn + PlutusScriptWitness _ _ (PReferenceScript refIn) _ _ _ -> Just refIn PlutusScriptWitness _ _ PScript{} _ _ _ -> Nothing - SimpleScriptWitness _ (SReferenceScript refIn _) -> Just refIn + SimpleScriptWitness _ (SReferenceScript refIn) -> Just refIn SimpleScriptWitness _ SScript{} -> Nothing toAddressInAnyEra @@ -1328,7 +1329,7 @@ toTxAlonzoDatum supp cliDatum = createTxMintValue :: forall era . ShelleyBasedEra era - -> (Value, [ScriptWitness WitCtxMint era]) + -> (Value, [(Maybe PolicyId, ScriptWitness WitCtxMint era)]) -> Either TxCmdError (TxMintValue BuildTx era) createTxMintValue era (val, scriptWitnesses) = if List.null (toList val) && List.null scriptWitnesses @@ -1337,28 +1338,37 @@ createTxMintValue era (val, scriptWitnesses) = caseShelleyToAllegraOrMaryEraOnwards (const (txFeatureMismatchPure (toCardanoEra era) TxFeatureMintValue)) ( \w -> do - -- The set of policy ids for which we need witnesses: - let witnessesNeededSet :: Set PolicyId - witnessesNeededSet = - fromList [pid | (AssetId pid _, _) <- toList val] + let policiesWithAssets :: [(PolicyId, AssetName, Quantity)] + policiesWithAssets = [(pid, assetName, quantity) | (AssetId pid assetName, quantity) <- toList val] - let witnessesProvidedMap :: Map PolicyId (ScriptWitness WitCtxMint era) + -- The set of policy ids for which we need witnesses: + witnessesNeededSet :: Set PolicyId + witnessesNeededSet = fromList [pid | (pid, _, _) <- policiesWithAssets] + + witnessesProvidedMap :: Map PolicyId (ScriptWitness WitCtxMint era) witnessesProvidedMap = fromList $ gatherMintingWitnesses scriptWitnesses witnessesProvidedSet = Map.keysSet witnessesProvidedMap - -- Check not too many, nor too few: + policiesWithWitnesses = + Map.fromListWith + (<>) + [ (pid, [(assetName, quantity, BuildTxWith witness)]) + | (pid, assetName, quantity) <- policiesWithAssets + , witness <- maybeToList $ Map.lookup pid witnessesProvidedMap + ] + validateAllWitnessesProvided witnessesNeededSet witnessesProvidedSet validateNoUnnecessaryWitnesses witnessesNeededSet witnessesProvidedSet - return (TxMintValue w val (BuildTxWith witnessesProvidedMap)) + pure $ TxMintValue w policiesWithWitnesses ) era where gatherMintingWitnesses - :: [ScriptWitness WitCtxMint era] + :: [(Maybe PolicyId, ScriptWitness WitCtxMint era)] -> [(PolicyId, ScriptWitness WitCtxMint era)] gatherMintingWitnesses [] = [] - gatherMintingWitnesses (sWit : rest) = - case scriptWitnessPolicyId sWit of + gatherMintingWitnesses ((mPid, sWit) : rest) = + case scriptWitnessPolicyId sWit <|> mPid of Nothing -> gatherMintingWitnesses rest Just pid -> (pid, sWit) : gatherMintingWitnesses rest @@ -1377,17 +1387,17 @@ createTxMintValue era (val, scriptWitnesses) = scriptWitnessPolicyId :: ScriptWitness witctx era -> Maybe PolicyId scriptWitnessPolicyId (SimpleScriptWitness _ (SScript script)) = Just . scriptPolicyId $ SimpleScript script -scriptWitnessPolicyId (SimpleScriptWitness _ (SReferenceScript _ mPid)) = - PolicyId <$> mPid +scriptWitnessPolicyId (SimpleScriptWitness _ (SReferenceScript _)) = + Nothing scriptWitnessPolicyId (PlutusScriptWitness _ version (PScript script) _ _ _) = Just . scriptPolicyId $ PlutusScript version script -scriptWitnessPolicyId (PlutusScriptWitness _ _ (PReferenceScript _ mPid) _ _ _) = - PolicyId <$> mPid +scriptWitnessPolicyId (PlutusScriptWitness _ _ (PReferenceScript _) _ _ _) = + Nothing readValueScriptWitnesses :: ShelleyBasedEra era -> (Value, [ScriptWitnessFiles WitCtxMint]) - -> ExceptT TxCmdError IO (Value, [ScriptWitness WitCtxMint era]) + -> ExceptT TxCmdError IO (Value, [(Maybe PolicyId, ScriptWitness WitCtxMint era)]) readValueScriptWitnesses era (v, sWitFiles) = do sWits <- mapM (firstExceptT TxCmdScriptWitnessError . readScriptWitness era) sWitFiles return (v, sWits) diff --git a/cardano-cli/src/Cardano/CLI/Json/Friendly.hs b/cardano-cli/src/Cardano/CLI/Json/Friendly.hs index 8549ae2a25..45b9c156bb 100644 --- a/cardano-cli/src/Cardano/CLI/Json/Friendly.hs +++ b/cardano-cli/src/Cardano/CLI/Json/Friendly.hs @@ -804,7 +804,8 @@ friendlyLovelace value = String $ docToText (pretty value) friendlyMintValue :: TxMintValue ViewTx era -> Aeson.Value friendlyMintValue = \case TxMintNone -> Null - TxMintValue sbe v _ -> friendlyValue (maryEraOnwardsToShelleyBasedEra sbe) v + txMintValue@(TxMintValue w _) -> + friendlyValue (maryEraOnwardsToShelleyBasedEra w) (txMintValueToValue txMintValue) friendlyTxOutValue :: TxOutValue era -> Aeson.Value friendlyTxOutValue = \case diff --git a/cardano-cli/src/Cardano/CLI/Read.hs b/cardano-cli/src/Cardano/CLI/Read.hs index 204e9672bc..bcf487cc0b 100644 --- a/cardano-cli/src/Cardano/CLI/Read.hs +++ b/cardano-cli/src/Cardano/CLI/Read.hs @@ -272,7 +272,7 @@ readScriptWitnessFiles readScriptWitnessFiles era = mapM readSwitFile where readSwitFile (tIn, Just switFile) = do - sWit <- readScriptWitness era switFile + sWit <- snd <$> readScriptWitness era switFile return (tIn, Just sWit) readSwitFile (tIn, Nothing) = return (tIn, Nothing) @@ -283,14 +283,14 @@ readScriptWitnessFilesTuple readScriptWitnessFilesTuple era = mapM readSwitFile where readSwitFile (tIn, b, Just switFile) = do - sWit <- readScriptWitness era switFile + sWit <- snd <$> readScriptWitness era switFile return (tIn, b, Just sWit) readSwitFile (tIn, b, Nothing) = return (tIn, b, Nothing) readScriptWitness :: ShelleyBasedEra era -> ScriptWitnessFiles witctx - -> ExceptT ScriptWitnessError IO (ScriptWitness witctx era) + -> ExceptT ScriptWitnessError IO (Maybe PolicyId, ScriptWitness witctx era) readScriptWitness era (SimpleScriptWitnessFile (File scriptFile)) = do script@(ScriptInAnyLang lang _) <- firstExceptT ScriptWitnessErrorFile $ @@ -298,7 +298,7 @@ readScriptWitness era (SimpleScriptWitnessFile (File scriptFile)) = do ScriptInEra langInEra script' <- validateScriptSupportedInEra era script case script' of SimpleScript sscript -> - return . SimpleScriptWitness langInEra $ SScript sscript + return . (Nothing,) . SimpleScriptWitness langInEra $ SScript sscript -- If the supplied cli flags were for a simple script (i.e. the user did -- not supply the datum, redeemer or ex units), but the script file turns -- out to be a valid plutus script, then we must fail. @@ -327,7 +327,7 @@ readScriptWitness redeemer <- firstExceptT ScriptWitnessErrorScriptData $ readScriptRedeemerOrFile redeemerOrFile - return $ + pure . (Nothing,) $ PlutusScriptWitness langInEra version @@ -375,11 +375,11 @@ readScriptWitness redeemer <- firstExceptT ScriptWitnessErrorScriptData $ readScriptRedeemerOrFile redeemerOrFile - return $ + return . (mPid,) $ PlutusScriptWitness sLangInEra version - (PReferenceScript refTxIn (unPolicyId <$> mPid)) + (PReferenceScript refTxIn) datum redeemer execUnits @@ -406,8 +406,8 @@ readScriptWitness Just sLangInEra -> case languageOfScriptLanguageInEra sLangInEra of SimpleScriptLanguage -> - return . SimpleScriptWitness sLangInEra $ - SReferenceScript refTxIn (unPolicyId <$> mPid) + return . (mPid,) . SimpleScriptWitness sLangInEra $ + SReferenceScript refTxIn PlutusScriptLanguage{} -> error "readScriptWitness: Should not be possible to specify a plutus script" Nothing -> @@ -922,8 +922,9 @@ readSingleVote w (voteFp, mScriptWitFiles) = do let sbe = conwayEraOnwardsToShelleyBasedEra w runExceptT $ do sWits <- - firstExceptT VoteErrorScriptWitness $ - mapM (readScriptWitness sbe) sWitFile + fmap (fmap snd) $ + firstExceptT VoteErrorScriptWitness $ + mapM (readScriptWitness sbe) sWitFile hoistEither $ (,sWits) <$> votProceds data ConstitutionError @@ -968,8 +969,9 @@ readProposal w (fp, mScriptWit) = do let sbe = conwayEraOnwardsToShelleyBasedEra w runExceptT $ do sWit <- - firstExceptT ProposalErrorScriptWitness $ - mapM (readScriptWitness sbe) sWitFile + fmap (fmap snd) $ + firstExceptT ProposalErrorScriptWitness $ + mapM (readScriptWitness sbe) sWitFile hoistEither $ (,sWit) <$> prop constitutionHashSourceToHash diff --git a/cardano-cli/src/Cardano/CLI/Types/Output.hs b/cardano-cli/src/Cardano/CLI/Types/Output.hs index 1e9c5d1240..4f47c4ad95 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Output.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Output.hs @@ -383,7 +383,7 @@ renderScriptCosts (UTxO utxo) eUnitPrices scriptMapping executionCostMapping = Left err -> Left (PlutusScriptCostErrExecError sWitInd (Just scriptHash) err) : accum -- TODO: Create a new sum type to encapsulate the fact that we can also -- have a txin and render the txin in the case of reference scripts. - Just (AnyScriptWitness (PlutusScriptWitness _ _ (PReferenceScript refTxIn _) _ _ _)) -> + Just (AnyScriptWitness (PlutusScriptWitness _ _ (PReferenceScript refTxIn) _ _ _)) -> case Map.lookup refTxIn utxo of Nothing -> Left (PlutusScriptCostErrRefInputNotInUTxO refTxIn) : accum Just (TxOut _ _ _ refScript) -> From 1450d804a83c1f90c132ed0bbb83fd928f989b0c Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Wed, 6 Nov 2024 21:52:59 +0100 Subject: [PATCH 2/3] more wip --- .../Cardano/CLI/EraBased/Options/Common.hs | 12 +- .../Cardano/CLI/EraBased/Run/Transaction.hs | 104 +++++++++++------- cardano-cli/src/Cardano/CLI/Read.hs | 31 +++--- cardano-cli/src/Cardano/CLI/Types/Common.hs | 28 ++++- 4 files changed, 112 insertions(+), 63 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs index a84a573e6a..7b6c91d946 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs @@ -1516,7 +1516,7 @@ pPlutusStakeReferenceScriptWitnessFilesVotingProposing prefix autoBalanceExecUni AutoBalance -> pure (ExecutionUnits 0 0) ManualBalance -> pExecutionUnits $ prefix ++ "reference-tx-in" ) - <*> pure Nothing + <*> pure NoPolicyIdSource pPlutusStakeReferenceScriptWitnessFiles :: String @@ -1533,7 +1533,7 @@ pPlutusStakeReferenceScriptWitnessFiles prefix autoBalanceExecUnits = AutoBalance -> pure (ExecutionUnits 0 0) ManualBalance -> pExecutionUnits $ prefix ++ "reference-tx-in" ) - <*> pure Nothing + <*> pure NoPolicyIdSource pPlutusScriptLanguage :: String -> Parser AnyScriptLanguage pPlutusScriptLanguage prefix = plutusP prefix PlutusScriptV2 "v2" <|> plutusP prefix PlutusScriptV3 "v3" @@ -1922,7 +1922,7 @@ pTxIn sbe balance = -> ScriptWitnessFiles WitCtxTxIn createSimpleReferenceScriptWitnessFiles refTxIn = let simpleLang = AnyScriptLanguage SimpleScriptLanguage - in SimpleReferenceScriptWitnessFiles refTxIn simpleLang Nothing + in SimpleReferenceScriptWitnessFiles refTxIn simpleLang NoPolicyIdSource pPlutusReferenceScriptWitness :: ShelleyBasedEra era -> BalanceTxExecUnits -> Parser (ScriptWitnessFiles WitCtxTxIn) @@ -1960,7 +1960,7 @@ pTxIn sbe balance = -> ExecutionUnits -> ScriptWitnessFiles WitCtxTxIn createPlutusReferenceScriptWitnessFiles refIn sLang sDatum sRedeemer execUnits = - PlutusReferenceScriptWitnessFiles refIn sLang sDatum sRedeemer execUnits Nothing + PlutusReferenceScriptWitnessFiles refIn sLang sDatum sRedeemer execUnits NoPolicyIdSource pEmbeddedPlutusScriptWitness :: Parser (ScriptWitnessFiles WitCtxTxIn) pEmbeddedPlutusScriptWitness = @@ -2170,7 +2170,7 @@ pMintMultiAsset sbe balanceExecUnits = -> ScriptWitnessFiles WitCtxMint createSimpleMintingReferenceScriptWitnessFiles refTxIn pid = let simpleLang = AnyScriptLanguage SimpleScriptLanguage - in SimpleReferenceScriptWitnessFiles refTxIn simpleLang (Just pid) + in SimpleReferenceScriptWitnessFiles refTxIn simpleLang (ConcretePolicyId pid) pPlutusMintReferenceScriptWitnessFiles :: BalanceTxExecUnits -> Parser (ScriptWitnessFiles WitCtxMint) @@ -2184,7 +2184,7 @@ pMintMultiAsset sbe balanceExecUnits = AutoBalance -> pure (ExecutionUnits 0 0) ManualBalance -> pExecutionUnits "mint-reference-tx-in" ) - <*> (Just <$> pPolicyId) + <*> (ConcretePolicyId <$> pPolicyId) helpText = mconcat diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs index 97e0a677eb..701ed56d40 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs @@ -3,6 +3,7 @@ {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} @@ -73,6 +74,7 @@ import qualified Data.List as List import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromMaybe, mapMaybe, maybeToList) +import Data.Proxy import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Text as Text @@ -169,7 +171,7 @@ runTransactionBuildCmd txMetadata <- firstExceptT TxCmdMetadataError . newExceptT $ readTxMetadata eon metadataSchema metadataFiles - valuesWithScriptWits <- readValueScriptWitnesses eon $ fromMaybe mempty mValue + valuesWithScriptWits <- readMintScriptWitnesses eon (const undefined) $ fromMaybe mempty mValue scripts <- firstExceptT TxCmdScriptFileError $ mapM (readFileScriptInAnyLang . unFile) scriptFiles @@ -205,7 +207,7 @@ runTransactionBuildCmd let allReferenceInputs = getAllReferenceInputs inputsAndMaybeScriptWits - (snd <$> snd valuesWithScriptWits) + (snd valuesWithScriptWits) certsAndMaybeScriptWits withdrawalsAndMaybeScriptWits votingProceduresAndMaybeScriptWits @@ -360,7 +362,7 @@ runTransactionBuildEstimateCmd -- TODO change type firstExceptT TxCmdMetadataError . newExceptT $ readTxMetadata sbe metadataSchema metadataFiles - valuesWithScriptWits <- readValueScriptWitnesses sbe $ fromMaybe mempty mValue + valuesWithScriptWits <- readMintScriptWitnesses sbe (const undefined) $ fromMaybe mempty mValue scripts <- firstExceptT TxCmdScriptFileError $ mapM (readFileScriptInAnyLang . unFile) scriptFiles @@ -594,7 +596,7 @@ runTransactionBuildRawCmd firstExceptT TxCmdMetadataError . newExceptT $ readTxMetadata eon metadataSchema metadataFiles - valuesWithScriptWits <- readValueScriptWitnesses eon $ fromMaybe mempty mValue + valuesWithScriptWits <- readMintScriptWitnesses eon (const undefined) $ fromMaybe mempty mValue scripts <- firstExceptT TxCmdScriptFileError $ mapM (readFileScriptInAnyLang . unFile) scriptFiles @@ -698,7 +700,7 @@ runTxBuildRaw -- ^ Tx upper bound -> Lovelace -- ^ Tx fee - -> (Value, [(Maybe PolicyId, ScriptWitness WitCtxMint era)]) + -> (Value, [UpdatedReferenceScriptWitness era]) -- ^ Multi-Asset value(s) -> [(Certificate era, Maybe (ScriptWitness WitCtxStake era))] -- ^ Certificate with potential script witness @@ -784,7 +786,7 @@ constructTxBodyContent -- ^ Tx lower bound -> TxValidityUpperBound era -- ^ Tx upper bound - -> (Value, [(Maybe PolicyId, ScriptWitness WitCtxMint era)]) + -> (Value, [UpdatedReferenceScriptWitness era]) -- ^ Multi-Asset value(s) -> [(Certificate era, Maybe (ScriptWitness WitCtxStake era))] -- ^ Certificate with potential script witness @@ -831,7 +833,7 @@ constructTxBodyContent let allReferenceInputs = getAllReferenceInputs inputsAndMaybeScriptWits - (snd <$> snd valuesWithScriptWits) + (snd valuesWithScriptWits) certsAndMaybeScriptWits withdrawals votingProcedures @@ -924,7 +926,7 @@ runTxBuild -- ^ Normal outputs -> TxOutChangeAddress -- ^ A change output - -> (Value, [(Maybe PolicyId, ScriptWitness WitCtxMint era)]) + -> (Value, [UpdatedReferenceScriptWitness era]) -- ^ Multi-Asset value(s) -> Maybe SlotNo -- ^ Tx lower bound @@ -978,7 +980,7 @@ runTxBuild let allReferenceInputs = getAllReferenceInputs inputsAndMaybeScriptWits - (snd <$> snd valuesWithScriptWits) + (snd valuesWithScriptWits) certsAndMaybeScriptWits withdrawals votingProcedures @@ -1145,7 +1147,7 @@ validateTxInsReference sbe allRefIns = do getAllReferenceInputs :: [(TxIn, Maybe (ScriptWitness WitCtxTxIn era))] - -> [ScriptWitness WitCtxMint era] + -> [UpdatedReferenceScriptWitness era] -> [(Certificate era, Maybe (ScriptWitness WitCtxStake era))] -> [(StakeAddress, Lovelace, Maybe (ScriptWitness WitCtxStake era))] -> [(VotingProcedures era, Maybe (ScriptWitness WitCtxStake era))] @@ -1162,7 +1164,7 @@ getAllReferenceInputs propProceduresAnMaybeScriptWits readOnlyRefIns = do let txinsWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- txins] - mintingRefInputs = map getReferenceInput mintWitnesses + mintingRefInputs = [getReferenceInput sWit | UpdatedReferenceScriptWitness _ sWit <- mintWitnesses] certsWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- certFiles] withdrawalsWitByRefInputs = [getReferenceInput sWit | (_, _, Just sWit) <- withdrawals] votesWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- votingProceduresAndMaybeScriptWits] @@ -1329,7 +1331,7 @@ toTxAlonzoDatum supp cliDatum = createTxMintValue :: forall era . ShelleyBasedEra era - -> (Value, [(Maybe PolicyId, ScriptWitness WitCtxMint era)]) + -> (Value, [UpdatedReferenceScriptWitness era]) -> Either TxCmdError (TxMintValue BuildTx era) createTxMintValue era (val, scriptWitnesses) = if List.null (toList val) && List.null scriptWitnesses @@ -1346,7 +1348,9 @@ createTxMintValue era (val, scriptWitnesses) = witnessesNeededSet = fromList [pid | (pid, _, _) <- policiesWithAssets] witnessesProvidedMap :: Map PolicyId (ScriptWitness WitCtxMint era) - witnessesProvidedMap = fromList $ gatherMintingWitnesses scriptWitnesses + witnessesProvidedMap = + fromList + [(policyId', sWit) | UpdatedReferenceScriptWitness (Just policyId') sWit <- scriptWitnesses] witnessesProvidedSet = Map.keysSet witnessesProvidedMap policiesWithWitnesses = @@ -1363,15 +1367,6 @@ createTxMintValue era (val, scriptWitnesses) = ) era where - gatherMintingWitnesses - :: [(Maybe PolicyId, ScriptWitness WitCtxMint era)] - -> [(PolicyId, ScriptWitness WitCtxMint era)] - gatherMintingWitnesses [] = [] - gatherMintingWitnesses ((mPid, sWit) : rest) = - case scriptWitnessPolicyId sWit <|> mPid of - Nothing -> gatherMintingWitnesses rest - Just pid -> (pid, sWit) : gatherMintingWitnesses rest - validateAllWitnessesProvided witnessesNeeded witnessesProvided | null witnessesMissing = return () | otherwise = Left (TxCmdPolicyIdsMissing witnessesMissing (toList witnessesProvided)) @@ -1384,23 +1379,56 @@ createTxMintValue era (val, scriptWitnesses) = where witnessesExtra = Set.elems (witnessesProvided Set.\\ witnessesNeeded) -scriptWitnessPolicyId :: ScriptWitness witctx era -> Maybe PolicyId -scriptWitnessPolicyId (SimpleScriptWitness _ (SScript script)) = - Just . scriptPolicyId $ SimpleScript script -scriptWitnessPolicyId (SimpleScriptWitness _ (SReferenceScript _)) = - Nothing -scriptWitnessPolicyId (PlutusScriptWitness _ version (PScript script) _ _ _) = - Just . scriptPolicyId $ PlutusScript version script -scriptWitnessPolicyId (PlutusScriptWitness _ _ (PReferenceScript _) _ _ _) = - Nothing - -readValueScriptWitnesses +-- TOOD remove + +readMintScriptWitnesses :: ShelleyBasedEra era - -> (Value, [ScriptWitnessFiles WitCtxMint]) - -> ExceptT TxCmdError IO (Value, [(Maybe PolicyId, ScriptWitness WitCtxMint era)]) -readValueScriptWitnesses era (v, sWitFiles) = do - sWits <- mapM (firstExceptT TxCmdScriptWitnessError . readScriptWitness era) sWitFiles - return (v, sWits) + -> ( TxIn + -> ExceptT + QueryConvenienceError + IO + (Maybe (TxOut CtxUTxO era)) + ) + -> (a, [ScriptWitnessFiles WitCtxMint]) + -> ExceptT + TxCmdError + IO + (a, [UpdatedReferenceScriptWitness era]) +readMintScriptWitnesses era getUtxo (v, sWitFiles) = + fmap (v,) . forM sWitFiles $ \witFile -> do + wit <- firstExceptT TxCmdScriptWitnessError $ readScriptWitness era witFile + let mFilePid = getScriptWitnessPolicyId wit + mPid <- getPolicyIdFromWitnessOrCliArg witFile + pure $ UpdatedReferenceScriptWitness (mPid <|> mFilePid) wit + where + -- get policy id from the script + getScriptWitnessPolicyId :: ScriptWitness WitCtxMint era -> Maybe PolicyId + getScriptWitnessPolicyId = \case + SimpleScriptWitness _ (SScript script) -> Just . scriptPolicyId $ SimpleScript script + SimpleScriptWitness _ (SReferenceScript _) -> Nothing + PlutusScriptWitness _ version (PScript script) _ _ _ -> Just . scriptPolicyId $ PlutusScript version script + PlutusScriptWitness _ _ (PReferenceScript _) _ _ _ -> Nothing + + -- get policy id using TxIn reference, getting script from UTXO, or using the provided one on the CLI + getPolicyIdFromWitnessOrCliArg + :: ScriptWitnessFiles WitCtxMint -> ExceptT TxCmdError IO (Maybe PolicyId) + getPolicyIdFromWitnessOrCliArg = \case + SimpleScriptWitnessFile{} -> pure Nothing + PlutusScriptWitnessFiles{} -> pure Nothing + PlutusReferenceScriptWitnessFiles _ _ _ _ _ (ConcretePolicyId pid) -> pure $ Just pid + PlutusReferenceScriptWitnessFiles txIn _ _ _ _ QueryUtxoPolicyId -> getPolicyIdFromTxOut txIn + SimpleReferenceScriptWitnessFiles _ _ (ConcretePolicyId pid) -> pure $ Just pid + SimpleReferenceScriptWitnessFiles txIn _ QueryUtxoPolicyId -> getPolicyIdFromTxOut txIn + + -- get policy id from the UTXO + getPolicyIdFromTxOut :: TxIn -> ExceptT TxCmdError IO (Maybe PolicyId) + getPolicyIdFromTxOut txIn = do + txout <- firstExceptT TxCmdQueryConvenienceError $ getUtxo txIn + pure $ + txout >>= \(TxOut _ _ _ refScript) -> + case refScript of + ReferenceScriptNone -> Nothing + ReferenceScript _ (ScriptInAnyLang _ script) -> Just $ scriptPolicyId script -- ---------------------------------------------------------------------------- -- Transaction signing diff --git a/cardano-cli/src/Cardano/CLI/Read.hs b/cardano-cli/src/Cardano/CLI/Read.hs index bcf487cc0b..b9911aca46 100644 --- a/cardano-cli/src/Cardano/CLI/Read.hs +++ b/cardano-cli/src/Cardano/CLI/Read.hs @@ -272,7 +272,7 @@ readScriptWitnessFiles readScriptWitnessFiles era = mapM readSwitFile where readSwitFile (tIn, Just switFile) = do - sWit <- snd <$> readScriptWitness era switFile + sWit <- readScriptWitness era switFile return (tIn, Just sWit) readSwitFile (tIn, Nothing) = return (tIn, Nothing) @@ -283,14 +283,17 @@ readScriptWitnessFilesTuple readScriptWitnessFilesTuple era = mapM readSwitFile where readSwitFile (tIn, b, Just switFile) = do - sWit <- snd <$> readScriptWitness era switFile + sWit <- readScriptWitness era switFile return (tIn, b, Just sWit) readSwitFile (tIn, b, Nothing) = return (tIn, b, Nothing) readScriptWitness :: ShelleyBasedEra era -> ScriptWitnessFiles witctx - -> ExceptT ScriptWitnessError IO (Maybe PolicyId, ScriptWitness witctx era) + -> ExceptT + ScriptWitnessError + IO + (ScriptWitness witctx era) readScriptWitness era (SimpleScriptWitnessFile (File scriptFile)) = do script@(ScriptInAnyLang lang _) <- firstExceptT ScriptWitnessErrorFile $ @@ -298,7 +301,7 @@ readScriptWitness era (SimpleScriptWitnessFile (File scriptFile)) = do ScriptInEra langInEra script' <- validateScriptSupportedInEra era script case script' of SimpleScript sscript -> - return . (Nothing,) . SimpleScriptWitness langInEra $ SScript sscript + return . SimpleScriptWitness langInEra $ SScript sscript -- If the supplied cli flags were for a simple script (i.e. the user did -- not supply the datum, redeemer or ex units), but the script file turns -- out to be a valid plutus script, then we must fail. @@ -327,7 +330,7 @@ readScriptWitness redeemer <- firstExceptT ScriptWitnessErrorScriptData $ readScriptRedeemerOrFile redeemerOrFile - pure . (Nothing,) $ + pure $ PlutusScriptWitness langInEra version @@ -352,7 +355,7 @@ readScriptWitness datumOrFile redeemerOrFile execUnits - mPid + _ ) = do caseShelleyToAlonzoOrBabbageEraOnwards ( const $ @@ -375,7 +378,7 @@ readScriptWitness redeemer <- firstExceptT ScriptWitnessErrorScriptData $ readScriptRedeemerOrFile redeemerOrFile - return . (mPid,) $ + return $ PlutusScriptWitness sLangInEra version @@ -393,7 +396,7 @@ readScriptWitness ( SimpleReferenceScriptWitnessFiles refTxIn anyScrLang@(AnyScriptLanguage anyScriptLanguage) - mPid + _pid ) = do caseShelleyToAlonzoOrBabbageEraOnwards ( const $ @@ -406,7 +409,7 @@ readScriptWitness Just sLangInEra -> case languageOfScriptLanguageInEra sLangInEra of SimpleScriptLanguage -> - return . (mPid,) . SimpleScriptWitness sLangInEra $ + return . SimpleScriptWitness sLangInEra $ SReferenceScript refTxIn PlutusScriptLanguage{} -> error "readScriptWitness: Should not be possible to specify a plutus script" @@ -922,9 +925,8 @@ readSingleVote w (voteFp, mScriptWitFiles) = do let sbe = conwayEraOnwardsToShelleyBasedEra w runExceptT $ do sWits <- - fmap (fmap snd) $ - firstExceptT VoteErrorScriptWitness $ - mapM (readScriptWitness sbe) sWitFile + firstExceptT VoteErrorScriptWitness $ + mapM (readScriptWitness sbe) sWitFile hoistEither $ (,sWits) <$> votProceds data ConstitutionError @@ -969,9 +971,8 @@ readProposal w (fp, mScriptWit) = do let sbe = conwayEraOnwardsToShelleyBasedEra w runExceptT $ do sWit <- - fmap (fmap snd) $ - firstExceptT ProposalErrorScriptWitness $ - mapM (readScriptWitness sbe) sWitFile + firstExceptT ProposalErrorScriptWitness $ + mapM (readScriptWitness sbe) sWitFile hoistEither $ (,sWit) <$> prop constitutionHashSourceToHash diff --git a/cardano-cli/src/Cardano/CLI/Types/Common.hs b/cardano-cli/src/Cardano/CLI/Types/Common.hs index c765ac64a7..2450b1943d 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Common.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Common.hs @@ -2,8 +2,10 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} module Cardano.CLI.Types.Common ( AllOrOnly (..) @@ -58,6 +60,8 @@ module Cardano.CLI.Types.Common , ScriptFile , ScriptRedeemerOrFile , ScriptWitnessFiles (..) + , MintingPolicyIdSource (..) + , UpdatedReferenceScriptWitness (..) , SigningKeyFile , SlotsTillKesKeyExpiry (..) , SomeKeyFile (..) @@ -101,8 +105,11 @@ import qualified Data.Aeson as Aeson import Data.String (IsString) import Data.Text (Text) import qualified Data.Text as Text +import Data.Type.Equality (type (==)) import Data.Word (Word64) +data IsOnlineCommand = OnlineCommand | OfflineCommand + -- | Determines the direction in which the MIR certificate will transfer ADA. data TransferDirection = TransferToReserves @@ -417,18 +424,31 @@ data ScriptWitnessFiles witctx where -> ScriptDatumOrFile witctx -> ScriptRedeemerOrFile -> ExecutionUnits - -> Maybe PolicyId - -- ^ For minting reference scripts + -> MintingPolicyIdSource witctx -> ScriptWitnessFiles witctx SimpleReferenceScriptWitnessFiles :: TxIn -> AnyScriptLanguage - -> Maybe PolicyId - -- ^ For minting reference scripts + -> MintingPolicyIdSource witctx -> ScriptWitnessFiles witctx deriving instance Show (ScriptWitnessFiles witctx) +data MintingPolicyIdSource witctx where + -- | A concrete policy Id + ConcretePolicyId :: PolicyId -> MintingPolicyIdSource WitCtxMint + -- | Query policy Id from the UTxO set, only for an online command + QueryUtxoPolicyId :: MintingPolicyIdSource WitCtxMint + -- | No policy Id is provided for nonminting contexts + NoPolicyIdSource :: (witctx == WitCtxMint) ~ False => MintingPolicyIdSource witctx + +deriving instance Show (MintingPolicyIdSource witctx) + +data UpdatedReferenceScriptWitness era + = UpdatedReferenceScriptWitness + (Maybe PolicyId) -- todo refine type, remove Maybe + (ScriptWitness WitCtxMint era) + data ScriptDatumOrFile witctx where ScriptDatumOrFileForTxIn :: Maybe ScriptDataOrFile -- CIP-0069 - Spending datums optional in Conway era onwards From fd4a37a6cc1c975831ddcbbe8dc412ae513d522b Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Fri, 8 Nov 2024 18:28:45 +0100 Subject: [PATCH 3/3] more work more progress --- .../Cardano/CLI/EraBased/Run/Transaction.hs | 37 +++++++------------ cardano-cli/src/Cardano/CLI/Types/Common.hs | 12 ++++-- 2 files changed, 22 insertions(+), 27 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs index 701ed56d40..b56bcbe7be 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs @@ -700,7 +700,7 @@ runTxBuildRaw -- ^ Tx upper bound -> Lovelace -- ^ Tx fee - -> (Value, [UpdatedReferenceScriptWitness era]) + -> (Value, [MintingScriptWitness era]) -- ^ Multi-Asset value(s) -> [(Certificate era, Maybe (ScriptWitness WitCtxStake era))] -- ^ Certificate with potential script witness @@ -786,7 +786,7 @@ constructTxBodyContent -- ^ Tx lower bound -> TxValidityUpperBound era -- ^ Tx upper bound - -> (Value, [UpdatedReferenceScriptWitness era]) + -> (Value, [MintingScriptWitness era]) -- ^ Multi-Asset value(s) -> [(Certificate era, Maybe (ScriptWitness WitCtxStake era))] -- ^ Certificate with potential script witness @@ -926,7 +926,7 @@ runTxBuild -- ^ Normal outputs -> TxOutChangeAddress -- ^ A change output - -> (Value, [UpdatedReferenceScriptWitness era]) + -> (Value, [MintingScriptWitness era]) -- ^ Multi-Asset value(s) -> Maybe SlotNo -- ^ Tx lower bound @@ -1147,7 +1147,7 @@ validateTxInsReference sbe allRefIns = do getAllReferenceInputs :: [(TxIn, Maybe (ScriptWitness WitCtxTxIn era))] - -> [UpdatedReferenceScriptWitness era] + -> [MintingScriptWitness era] -> [(Certificate era, Maybe (ScriptWitness WitCtxStake era))] -> [(StakeAddress, Lovelace, Maybe (ScriptWitness WitCtxStake era))] -> [(VotingProcedures era, Maybe (ScriptWitness WitCtxStake era))] @@ -1164,7 +1164,7 @@ getAllReferenceInputs propProceduresAnMaybeScriptWits readOnlyRefIns = do let txinsWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- txins] - mintingRefInputs = [getReferenceInput sWit | UpdatedReferenceScriptWitness _ sWit <- mintWitnesses] + mintingRefInputs = [getReferenceInput sWit | MintingScriptWitness _ sWit <- mintWitnesses] certsWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- certFiles] withdrawalsWitByRefInputs = [getReferenceInput sWit | (_, _, Just sWit) <- withdrawals] votesWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- votingProceduresAndMaybeScriptWits] @@ -1331,7 +1331,7 @@ toTxAlonzoDatum supp cliDatum = createTxMintValue :: forall era . ShelleyBasedEra era - -> (Value, [UpdatedReferenceScriptWitness era]) + -> (Value, [MintingScriptWitness era]) -> Either TxCmdError (TxMintValue BuildTx era) createTxMintValue era (val, scriptWitnesses) = if List.null (toList val) && List.null scriptWitnesses @@ -1350,7 +1350,7 @@ createTxMintValue era (val, scriptWitnesses) = witnessesProvidedMap :: Map PolicyId (ScriptWitness WitCtxMint era) witnessesProvidedMap = fromList - [(policyId', sWit) | UpdatedReferenceScriptWitness (Just policyId') sWit <- scriptWitnesses] + [(policyId', sWit) | MintingScriptWitness (Just policyId') sWit <- scriptWitnesses] witnessesProvidedSet = Map.keysSet witnessesProvidedMap policiesWithWitnesses = @@ -1379,8 +1379,6 @@ createTxMintValue era (val, scriptWitnesses) = where witnessesExtra = Set.elems (witnessesProvided Set.\\ witnessesNeeded) --- TOOD remove - readMintScriptWitnesses :: ShelleyBasedEra era -> ( TxIn @@ -1393,26 +1391,19 @@ readMintScriptWitnesses -> ExceptT TxCmdError IO - (a, [UpdatedReferenceScriptWitness era]) + (a, [MintingScriptWitness era]) readMintScriptWitnesses era getUtxo (v, sWitFiles) = fmap (v,) . forM sWitFiles $ \witFile -> do wit <- firstExceptT TxCmdScriptWitnessError $ readScriptWitness era witFile - let mFilePid = getScriptWitnessPolicyId wit - mPid <- getPolicyIdFromWitnessOrCliArg witFile - pure $ UpdatedReferenceScriptWitness (mPid <|> mFilePid) wit + mPid <- case getScriptWitnessReferenceInputOrScript wit of + Left (ScriptInEra _ script) -> pure . Just $ scriptPolicyId script + Right _ -> getPolicyIdFromScriptReferenceOrCliArg witFile + pure $ MintingScriptWitness mPid wit where - -- get policy id from the script - getScriptWitnessPolicyId :: ScriptWitness WitCtxMint era -> Maybe PolicyId - getScriptWitnessPolicyId = \case - SimpleScriptWitness _ (SScript script) -> Just . scriptPolicyId $ SimpleScript script - SimpleScriptWitness _ (SReferenceScript _) -> Nothing - PlutusScriptWitness _ version (PScript script) _ _ _ -> Just . scriptPolicyId $ PlutusScript version script - PlutusScriptWitness _ _ (PReferenceScript _) _ _ _ -> Nothing - -- get policy id using TxIn reference, getting script from UTXO, or using the provided one on the CLI - getPolicyIdFromWitnessOrCliArg + getPolicyIdFromScriptReferenceOrCliArg :: ScriptWitnessFiles WitCtxMint -> ExceptT TxCmdError IO (Maybe PolicyId) - getPolicyIdFromWitnessOrCliArg = \case + getPolicyIdFromScriptReferenceOrCliArg = \case SimpleScriptWitnessFile{} -> pure Nothing PlutusScriptWitnessFiles{} -> pure Nothing PlutusReferenceScriptWitnessFiles _ _ _ _ _ (ConcretePolicyId pid) -> pure $ Just pid diff --git a/cardano-cli/src/Cardano/CLI/Types/Common.hs b/cardano-cli/src/Cardano/CLI/Types/Common.hs index 2450b1943d..89b639743e 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Common.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Common.hs @@ -61,7 +61,7 @@ module Cardano.CLI.Types.Common , ScriptRedeemerOrFile , ScriptWitnessFiles (..) , MintingPolicyIdSource (..) - , UpdatedReferenceScriptWitness (..) + , MintingScriptWitness (..) , SigningKeyFile , SlotsTillKesKeyExpiry (..) , SomeKeyFile (..) @@ -99,7 +99,10 @@ where import Cardano.Api hiding (Script) import qualified Cardano.Api.Ledger as L +import Cardano.Api.Shelley (PlutusScriptOrReferenceInput (..), + SimpleScriptOrReferenceInput (..)) +import Control.Applicative import Data.Aeson (FromJSON (..), ToJSON (..), object, pairs, (.=)) import qualified Data.Aeson as Aeson import Data.String (IsString) @@ -444,9 +447,10 @@ data MintingPolicyIdSource witctx where deriving instance Show (MintingPolicyIdSource witctx) -data UpdatedReferenceScriptWitness era - = UpdatedReferenceScriptWitness - (Maybe PolicyId) -- todo refine type, remove Maybe +-- | A minting script witness with PolicyId if it is available, or was provided +data MintingScriptWitness era + = MintingScriptWitness + (Maybe PolicyId) -- TODO can this type be refined to avoid maybe? I think so, minting witness without policy id does not make sense (ScriptWitness WitCtxMint era) data ScriptDatumOrFile witctx where