diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs index a84a573e6a..7f2a8ccb1c 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -2159,7 +2160,7 @@ pMintMultiAsset sbe balanceExecUnits = "the minting of assets for a particular policy Id." pSimpleReferenceMintingScriptWitness :: Parser (ScriptWitnessFiles WitCtxMint) - pSimpleReferenceMintingScriptWitness = + pSimpleReferenceMintingScriptWitness = do createSimpleMintingReferenceScriptWitnessFiles <$> pReferenceTxIn "simple-minting-script-" "simple" <*> pPolicyId @@ -2825,7 +2826,7 @@ pMaxTransactionSize = pairIntegralReader :: (Typeable a, Integral a, Bits a) => ReadM (a, a) pairIntegralReader = readerFromParsecParser pairIntegralParsecParser -pairIntegralParsecParser :: (Typeable a, Integral a, Bits a) => Parsec.Parser (a, a) +pairIntegralParsecParser :: forall a. (Typeable a, Integral a, Bits a) => Parsec.Parser (a, a) pairIntegralParsecParser = do Parsec.spaces -- Skip initial spaces void $ Parsec.char '(' diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs index c59ace374a..40ad4aaf42 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,36 @@ 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 = + fromList + [ (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 +1386,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) -> diff --git a/cardano-cli/test/cardano-cli-golden/files/golden/mary/transaction-view.out b/cardano-cli/test/cardano-cli-golden/files/golden/mary/transaction-view.out index 49c118c5a2..2e881720eb 100644 --- a/cardano-cli/test/cardano-cli-golden/files/golden/mary/transaction-view.out +++ b/cardano-cli/test/cardano-cli-golden/files/golden/mary/transaction-view.out @@ -8,13 +8,9 @@ inputs: metadata: null mint: policy a06ee5ffdd7f9b5bd992eb9543f44418323f81229526b77b0e4be067: - asset 736b79 (sky): 142 - asset cafe: 132 asset dead: 136 policy d441227553a0f1a965fee7d60a0f724b368dd1bddbc208730fccebcf: - asset 736e6f77 (snow): 138 asset f00d: 134 - default asset: 130 outputs: - address: addr_test1qrefnr4k09pvge6dq83v6s67ruter8sftmky8qrmkqqsxy7q5psgn8tgqmupq4r79jmxlyk4eqt6z6hj5g8jd8393msqaw47f4 address era: Shelley