diff --git a/cabal.project b/cabal.project index 1864d105fa..c84909c853 100644 --- a/cabal.project +++ b/cabal.project @@ -14,7 +14,7 @@ repository cardano-haskell-packages -- you need to run if you change them index-state: , hackage.haskell.org 2024-10-11T15:49:11Z - , cardano-haskell-packages 2024-11-12T08:40:13Z + , cardano-haskell-packages 2024-11-20T20:05:41Z packages: cardano-cli diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index c920646133..296d30527a 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -116,6 +116,8 @@ library Cardano.CLI.EraBased.Run.StakePool Cardano.CLI.EraBased.Run.TextView Cardano.CLI.EraBased.Run.Transaction + Cardano.CLI.EraBased.Script.Mint.Read + Cardano.CLI.EraBased.Script.Mint.Types Cardano.CLI.EraBased.Transaction.HashCheck Cardano.CLI.Helpers Cardano.CLI.IO.Lazy @@ -170,10 +172,12 @@ library Cardano.CLI.Types.Errors.KeyCmdError Cardano.CLI.Types.Errors.NodeCmdError Cardano.CLI.Types.Errors.NodeEraMismatchError + Cardano.CLI.Types.Errors.PlutusScriptDecodeError Cardano.CLI.Types.Errors.ProtocolParamsError Cardano.CLI.Types.Errors.QueryCmdError Cardano.CLI.Types.Errors.QueryCmdLocalStateQueryError Cardano.CLI.Types.Errors.RegistrationError + Cardano.CLI.Types.Errors.ScriptDataError Cardano.CLI.Types.Errors.ScriptDecodeError Cardano.CLI.Types.Errors.StakeAddressCmdError Cardano.CLI.Types.Errors.StakeAddressDelegationError @@ -203,7 +207,7 @@ library binary, bytestring, canonical-json, - cardano-api ^>=10.2, + cardano-api ^>=10.3, cardano-binary, cardano-crypto, cardano-crypto-class ^>=2.1.2, diff --git a/cardano-cli/src/Cardano/CLI/Compatible/Transaction.hs b/cardano-cli/src/Cardano/CLI/Compatible/Transaction.hs index 8c3cc9d2c4..a1ffb8cee0 100644 --- a/cardano-cli/src/Cardano/CLI/Compatible/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/Compatible/Transaction.hs @@ -270,18 +270,18 @@ readUpdateProposalFile :: Featured ShelleyToBabbageEra era (Maybe UpdateProposalFile) -> ExceptT CompatibleTransactionError IO (AnyProtocolUpdate era) readUpdateProposalFile (Featured sToB Nothing) = - return $ NoPParamsUpdate $ shelleyToBabbageEraToShelleyBasedEra sToB + return $ NoPParamsUpdate $ inject sToB readUpdateProposalFile (Featured sToB (Just updateProposalFile)) = do prop <- firstExceptT CompatibleFileError $ readTxUpdateProposal sToB updateProposalFile case prop of - TxUpdateProposalNone -> return $ NoPParamsUpdate $ shelleyToBabbageEraToShelleyBasedEra sToB + TxUpdateProposalNone -> return $ NoPParamsUpdate $ inject sToB TxUpdateProposal _ proposal -> return $ ProtocolUpdate sToB proposal readProposalProcedureFile :: Featured ConwayEraOnwards era [(ProposalFile In, Maybe (ScriptWitnessFiles WitCtxStake))] -> ExceptT CompatibleTransactionError IO (AnyProtocolUpdate era) readProposalProcedureFile (Featured cEraOnwards []) = - let sbe = conwayEraOnwardsToShelleyBasedEra cEraOnwards + let sbe = inject cEraOnwards in return $ NoPParamsUpdate sbe readProposalProcedureFile (Featured cEraOnwards proposals) = do props <- diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Transaction.hs index dd9b2604f1..de11edc37b 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Transaction.hs @@ -25,6 +25,7 @@ import qualified Cardano.Api.Experimental as Exp import Cardano.Api.Ledger (Coin) import Cardano.Api.Shelley +import Cardano.CLI.EraBased.Script.Mint.Types import Cardano.CLI.Types.Common import Cardano.CLI.Types.Governance @@ -61,7 +62,7 @@ data TransactionBuildRawCmdArgs era = TransactionBuildRawCmdArgs , requiredSigners :: ![RequiredSigner] -- ^ Required signers , txouts :: ![TxOutAnyEra] - , mValue :: !(Maybe (Value, [ScriptWitnessFiles WitCtxMint])) + , mValue :: !(Maybe (Value, [CliMintScriptRequirements])) -- ^ Multi-Asset value with script witness , mValidityLowerBound :: !(Maybe SlotNo) -- ^ Transaction validity lower bound @@ -111,7 +112,7 @@ data TransactionBuildCmdArgs era = TransactionBuildCmdArgs -- ^ Normal outputs , changeAddresses :: !TxOutChangeAddress -- ^ A change output - , mValue :: !(Maybe (Value, [ScriptWitnessFiles WitCtxMint])) + , mValue :: !(Maybe (Value, [CliMintScriptRequirements])) -- ^ Multi-Asset value with script witness , mValidityLowerBound :: !(Maybe SlotNo) -- ^ Transaction validity lower bound @@ -157,7 +158,7 @@ data TransactionBuildEstimateCmdArgs era = TransactionBuildEstimateCmdArgs -- ^ Normal outputs , changeAddress :: !TxOutChangeAddress -- ^ A change output - , mValue :: !(Maybe (Value, [ScriptWitnessFiles WitCtxMint])) + , mValue :: !(Maybe (Value, [CliMintScriptRequirements])) -- ^ Multi-Asset value with script witness , mValidityLowerBound :: !(Maybe SlotNo) -- ^ Transaction validity lower bound diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs index 8f5a50be6d..629c70d67b 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs @@ -18,6 +18,7 @@ import qualified Cardano.Api.Network as Consensus import Cardano.Api.Shelley import Cardano.CLI.Environment (EnvCli (..), envCliAnyEon) +import Cardano.CLI.EraBased.Script.Mint.Types import Cardano.CLI.Parser import Cardano.CLI.Read import Cardano.CLI.Types.Common @@ -1006,6 +1007,28 @@ pPollNonce = -------------------------------------------------------------------------------- +pMintScriptFile :: Parser (File ScriptInAnyLang In) +pMintScriptFile = + pScriptFor + "mint-script-file" + (Just "minting-script-file") + "The file containing the script to witness the minting of assets for a particular policy Id." + +pPlutusMintScriptWitnessData + :: ShelleyBasedEra era + -> WitCtx witctx + -> BalanceTxExecUnits + -> Parser (ScriptDataOrFile, ExecutionUnits) +pPlutusMintScriptWitnessData _sbe _witctx autoBalanceExecUnits = + let scriptFlagPrefix = "mint" + in ( (,) + <$> pScriptRedeemerOrFile scriptFlagPrefix + <*> ( case autoBalanceExecUnits of + AutoBalance -> pure (ExecutionUnits 0 0) + ManualBalance -> pExecutionUnits scriptFlagPrefix + ) + ) + pScriptWitnessFiles :: forall witctx era . ShelleyBasedEra era @@ -1516,7 +1539,6 @@ pPlutusStakeReferenceScriptWitnessFilesVotingProposing prefix autoBalanceExecUni AutoBalance -> pure (ExecutionUnits 0 0) ManualBalance -> pExecutionUnits $ prefix ++ "reference-tx-in" ) - <*> pure Nothing pPlutusStakeReferenceScriptWitnessFiles :: String @@ -1533,15 +1555,16 @@ pPlutusStakeReferenceScriptWitnessFiles prefix autoBalanceExecUnits = AutoBalance -> pure (ExecutionUnits 0 0) ManualBalance -> pExecutionUnits $ prefix ++ "reference-tx-in" ) - <*> pure Nothing -pPlutusScriptLanguage :: String -> Parser AnyScriptLanguage +pPlutusScriptLanguage :: String -> Parser AnyPlutusScriptVersion pPlutusScriptLanguage prefix = plutusP prefix PlutusScriptV2 "v2" <|> plutusP prefix PlutusScriptV3 "v3" -plutusP :: String -> PlutusScriptVersion lang -> String -> Parser AnyScriptLanguage +plutusP + :: IsPlutusScriptLanguage lang + => String -> PlutusScriptVersion lang -> String -> Parser AnyPlutusScriptVersion plutusP prefix plutusVersion versionString = Opt.flag' - (AnyScriptLanguage $ PlutusScriptLanguage plutusVersion) + (AnyPlutusScriptVersion plutusVersion) ( Opt.long (prefix <> "plutus-script-" <> versionString) <> Opt.help ("Specify a plutus script " <> versionString <> " reference script.") ) @@ -1922,14 +1945,14 @@ pTxIn sbe balance = -> ScriptWitnessFiles WitCtxTxIn createSimpleReferenceScriptWitnessFiles refTxIn = let simpleLang = AnyScriptLanguage SimpleScriptLanguage - in SimpleReferenceScriptWitnessFiles refTxIn simpleLang Nothing + in SimpleReferenceScriptWitnessFiles refTxIn simpleLang pPlutusReferenceScriptWitness :: ShelleyBasedEra era -> BalanceTxExecUnits -> Parser (ScriptWitnessFiles WitCtxTxIn) pPlutusReferenceScriptWitness sbe' autoBalanceExecUnits = caseShelleyToBabbageOrConwayEraOnwards ( const $ - createPlutusReferenceScriptWitnessFiles + PlutusReferenceScriptWitnessFiles <$> pReferenceTxIn "spending-" "plutus" <*> pPlutusScriptLanguage "spending-" <*> pScriptDatumOrFile "spending-reference-tx-in" WitCtxTxIn @@ -1940,7 +1963,7 @@ pTxIn sbe balance = ) ) ( const $ - createPlutusReferenceScriptWitnessFiles + PlutusReferenceScriptWitnessFiles <$> pReferenceTxIn "spending-" "plutus" <*> pPlutusScriptLanguage "spending-" <*> pScriptDatumOrFileCip69 "spending-reference-tx-in" WitCtxTxIn @@ -1951,16 +1974,6 @@ pTxIn sbe balance = ) ) sbe' - where - createPlutusReferenceScriptWitnessFiles - :: TxIn - -> AnyScriptLanguage - -> ScriptDatumOrFile WitCtxTxIn - -> ScriptRedeemerOrFile - -> ExecutionUnits - -> ScriptWitnessFiles WitCtxTxIn - createPlutusReferenceScriptWitnessFiles refIn sLang sDatum sRedeemer execUnits = - PlutusReferenceScriptWitnessFiles refIn sLang sDatum sRedeemer execUnits Nothing pEmbeddedPlutusScriptWitness :: Parser (ScriptWitnessFiles WitCtxTxIn) pEmbeddedPlutusScriptWitness = @@ -2132,7 +2145,7 @@ pRefScriptFp = pMintMultiAsset :: ShelleyBasedEra era -> BalanceTxExecUnits - -> Parser (Value, [ScriptWitnessFiles WitCtxMint]) + -> Parser (Value, [CliMintScriptRequirements]) pMintMultiAsset sbe balanceExecUnits = (,) <$> Opt.option @@ -2142,49 +2155,35 @@ pMintMultiAsset sbe balanceExecUnits = <> Opt.help helpText ) <*> some - ( pMintingScriptOrReferenceScriptWit balanceExecUnits + ( pMintingScript <|> pSimpleReferenceMintingScriptWitness <|> pPlutusMintReferenceScriptWitnessFiles balanceExecUnits ) where - pMintingScriptOrReferenceScriptWit - :: BalanceTxExecUnits -> Parser (ScriptWitnessFiles WitCtxMint) - pMintingScriptOrReferenceScriptWit bExecUnits = - pScriptWitnessFiles - sbe - WitCtxMint - bExecUnits - "mint" - (Just "minting") - "the minting of assets for a particular policy Id." + pMintingScript :: Parser CliMintScriptRequirements + pMintingScript = + createSimpleOrPlutusScriptFromCliArgs + <$> pMintScriptFile + <*> optional (pPlutusMintScriptWitnessData sbe WitCtxMint balanceExecUnits) - pSimpleReferenceMintingScriptWitness :: Parser (ScriptWitnessFiles WitCtxMint) + pSimpleReferenceMintingScriptWitness :: Parser CliMintScriptRequirements pSimpleReferenceMintingScriptWitness = - createSimpleMintingReferenceScriptWitnessFiles + createSimpleReferenceScriptFromCliArgs <$> pReferenceTxIn "simple-minting-script-" "simple" <*> pPolicyId - where - createSimpleMintingReferenceScriptWitnessFiles - :: TxIn - -> PolicyId - -> ScriptWitnessFiles WitCtxMint - createSimpleMintingReferenceScriptWitnessFiles refTxIn pid = - let simpleLang = AnyScriptLanguage SimpleScriptLanguage - in SimpleReferenceScriptWitnessFiles refTxIn simpleLang (Just pid) pPlutusMintReferenceScriptWitnessFiles - :: BalanceTxExecUnits -> Parser (ScriptWitnessFiles WitCtxMint) + :: BalanceTxExecUnits -> Parser CliMintScriptRequirements pPlutusMintReferenceScriptWitnessFiles autoBalanceExecUnits = - PlutusReferenceScriptWitnessFiles + createPlutusReferenceScriptFromCliArgs <$> pReferenceTxIn "mint-" "plutus" <*> pPlutusScriptLanguage "mint-" - <*> pure NoScriptDatumOrFileForMint <*> pScriptRedeemerOrFile "mint-reference-tx-in" <*> ( case autoBalanceExecUnits of AutoBalance -> pure (ExecutionUnits 0 0) ManualBalance -> pExecutionUnits "mint-reference-tx-in" ) - <*> (Just <$> pPolicyId) + <*> pPolicyId helpText = mconcat diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/Actions.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/Actions.hs index 69efca1e4d..d0c3244542 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/Actions.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/Actions.hs @@ -185,11 +185,11 @@ pUpdateProtocolParametersCmd pUpdateProtocolParametersCmd = caseShelleyToBabbageOrConwayEraOnwards ( \shelleyToBab -> - let sbe = shelleyToBabbageEraToShelleyBasedEra shelleyToBab + let sbe = inject shelleyToBab in subParser "create-protocol-parameters-update" $ Opt.info ( Cmd.GovernanceActionProtocolParametersUpdateCmdArgs - (shelleyToBabbageEraToShelleyBasedEra shelleyToBab) + (inject shelleyToBab) <$> fmap Just (pUpdateProtocolParametersPreConway shelleyToBab) <*> pure Nothing <*> dpGovActionProtocolParametersUpdate sbe @@ -199,11 +199,11 @@ pUpdateProtocolParametersCmd = $ Opt.progDesc "Create a protocol parameters update." ) ( \conwayOnwards -> - let sbe = conwayEraOnwardsToShelleyBasedEra conwayOnwards + let sbe = inject conwayOnwards in subParser "create-protocol-parameters-update" $ Opt.info ( Cmd.GovernanceActionProtocolParametersUpdateCmdArgs - (conwayEraOnwardsToShelleyBasedEra conwayOnwards) + (inject conwayOnwards) Nothing <$> fmap Just (pUpdateProtocolParametersPostConway conwayOnwards) <*> dpGovActionProtocolParametersUpdate sbe diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Query.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Query.hs index 03fd68e489..490e81bd0d 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Query.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Query.hs @@ -678,7 +678,8 @@ pQueryTreasuryValueCmd era envCli = do <*> optional pOutputFile pQueryNoArgCmdArgs - :: () + :: forall era + . () => ConwayEraOnwards era -> EnvCli -> Parser (QueryNoArgCmdArgs era) @@ -687,5 +688,5 @@ pQueryNoArgCmdArgs w envCli = <$> pSocketPath envCli <*> pConsensusModeParams <*> pNetworkId envCli - <*> pTarget (conwayEraOnwardsToShelleyBasedEra w) + <*> pTarget (inject w :: ShelleyBasedEra era) <*> optional pOutputFile diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/StakeAddress.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/StakeAddress.hs index 33722c2f6f..e8f6f1aceb 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/StakeAddress.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/StakeAddress.hs @@ -121,7 +121,7 @@ pStakeAddressDeregistrationCertificateCmd = ( \shelleyToBabbage -> subParser "deregistration-certificate" $ Opt.info - ( StakeAddressDeregistrationCertificateCmd (shelleyToBabbageEraToShelleyBasedEra shelleyToBabbage) + ( StakeAddressDeregistrationCertificateCmd (inject shelleyToBabbage) <$> pStakeIdentifier Nothing <*> pure Nothing <*> pOutputFile @@ -131,7 +131,7 @@ pStakeAddressDeregistrationCertificateCmd = ( \conwayOnwards -> subParser "deregistration-certificate" $ Opt.info - ( StakeAddressDeregistrationCertificateCmd (conwayEraOnwardsToShelleyBasedEra conwayOnwards) + ( StakeAddressDeregistrationCertificateCmd (inject conwayOnwards) <$> pStakeIdentifier Nothing <*> fmap Just pKeyRegistDeposit <*> pOutputFile diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Transaction.hs index 2bdb9375e5..cf07a9f14f 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Transaction.hs @@ -227,7 +227,7 @@ pTransactionBuildEstimateCmd eon' _envCli = do where pCmd :: Exp.Era era -> Parser (TransactionCmds era) pCmd era' = do - let sbe = Exp.eraToSbe era' + let sbe = inject era' fmap TransactionBuildEstimateCmd $ TransactionBuildEstimateCmdArgs era' <$> optional pScriptValidity diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance.hs index c982858983..2b558ec325 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance.hs @@ -65,7 +65,8 @@ runGovernanceCmds = \case runGovernanceVoteCmds cmds runGovernanceMIRCertificatePayStakeAddrs - :: ShelleyToBabbageEra era + :: forall era + . ShelleyToBabbageEra era -> L.MIRPot -> [StakeAddress] -- ^ Stake addresses @@ -92,10 +93,11 @@ runGovernanceMIRCertificatePayStakeAddrs w mirPot sAddrs rwdAmts oFp = do makeMIRCertificate $ MirCertificateRequirements w mirPot $ shelleyToBabbageEraConstraints w mirTarget + sbe :: ShelleyBasedEra era = inject w firstExceptT GovernanceCmdTextEnvWriteError . newExceptT - $ shelleyBasedEraConstraints (shelleyToBabbageEraToShelleyBasedEra w) + $ shelleyBasedEraConstraints sbe $ writeLazyByteStringFile oFp $ textEnvelopeToJSON (Just mirCertDesc) mirCert where @@ -103,7 +105,8 @@ runGovernanceMIRCertificatePayStakeAddrs w mirPot sAddrs rwdAmts oFp = do mirCertDesc = "Move Instantaneous Rewards Certificate" runGovernanceCreateMirCertificateTransferToTreasuryCmd - :: () + :: forall era + . () => ShelleyToBabbageEra era -> Lovelace -> File () Out @@ -112,10 +115,11 @@ runGovernanceCreateMirCertificateTransferToTreasuryCmd w ll oFp = do let mirTarget = L.SendToOppositePotMIR ll let mirCert = makeMIRCertificate $ MirCertificateRequirements w L.ReservesMIR mirTarget + sbe :: ShelleyBasedEra era = inject w firstExceptT GovernanceCmdTextEnvWriteError . newExceptT - $ shelleyBasedEraConstraints (shelleyToBabbageEraToShelleyBasedEra w) + $ shelleyBasedEraConstraints sbe $ writeLazyByteStringFile oFp $ textEnvelopeToJSON (Just mirCertDesc) mirCert where @@ -123,7 +127,8 @@ runGovernanceCreateMirCertificateTransferToTreasuryCmd w ll oFp = do mirCertDesc = "MIR Certificate Send To Treasury" runGovernanceCreateMirCertificateTransferToReservesCmd - :: () + :: forall era + . () => ShelleyToBabbageEra era -> Lovelace -> File () Out @@ -132,10 +137,11 @@ runGovernanceCreateMirCertificateTransferToReservesCmd w ll oFp = do let mirTarget = L.SendToOppositePotMIR ll let mirCert = makeMIRCertificate $ MirCertificateRequirements w L.TreasuryMIR mirTarget + sbe :: ShelleyBasedEra era = inject w firstExceptT GovernanceCmdTextEnvWriteError . newExceptT - $ shelleyBasedEraConstraints (shelleyToBabbageEraToShelleyBasedEra w) + $ shelleyBasedEraConstraints sbe $ writeLazyByteStringFile oFp $ textEnvelopeToJSON (Just mirCertDesc) mirCert where diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Actions.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Actions.hs index 7faa12f9a2..33f1c9e78e 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Actions.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Actions.hs @@ -3,6 +3,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} module Cardano.CLI.EraBased.Run.Governance.Actions @@ -77,7 +78,8 @@ runGovernanceActionViewCmd proposal runGovernanceActionInfoCmd - :: () + :: forall era + . () => GovernanceActionInfoCmdArgs era -> ExceptT GovernanceActionsError IO () runGovernanceActionInfoCmd @@ -103,7 +105,7 @@ runGovernanceActionInfoCmd carryHashChecks checkProposalHash proposalAnchor ProposalCheck - let sbe = conwayEraOnwardsToShelleyBasedEra eon + let sbe :: ShelleyBasedEra era = inject eon govAction = InfoAct proposalProcedure = createProposalProcedure sbe networkId deposit depositStakeCredential govAction proposalAnchor @@ -117,7 +119,8 @@ fetchURLErrorToGovernanceActionError adt = withExceptT (GovernanceActionsProposa -- TODO: Conway era - update with new ledger types from cardano-ledger-conway-1.7.0.0 runGovernanceActionCreateNoConfidenceCmd - :: () + :: forall era + . () => GovernanceActionCreateNoConfidenceCmdArgs era -> ExceptT GovernanceActionsError IO () runGovernanceActionCreateNoConfidenceCmd @@ -144,7 +147,7 @@ runGovernanceActionCreateNoConfidenceCmd carryHashChecks checkProposalHash proposalAnchor ProposalCheck - let sbe = conwayEraOnwardsToShelleyBasedEra eon + let sbe :: ShelleyBasedEra era = inject eon previousGovernanceAction = MotionOfNoConfidence $ L.maybeToStrictMaybe $ @@ -165,7 +168,8 @@ runGovernanceActionCreateNoConfidenceCmd writeFileTextEnvelope outFile (Just "Motion of no confidence proposal") proposalProcedure runGovernanceActionCreateConstitutionCmd - :: () + :: forall era + . () => GovernanceActionCreateConstitutionCmdArgs era -> ExceptT GovernanceActionsError IO () runGovernanceActionCreateConstitutionCmd @@ -210,7 +214,7 @@ runGovernanceActionCreateConstitutionCmd prevGovActId constitutionAnchor (toShelleyScriptHash <$> L.maybeToStrictMaybe constitutionScript) - sbe = conwayEraOnwardsToShelleyBasedEra eon + sbe :: ShelleyBasedEra era = inject eon proposalProcedure = createProposalProcedure sbe networkId deposit depositStakeCredential govAct proposalAnchor carryHashChecks checkConstitutionHash constitutionAnchor ConstitutionCheck @@ -225,7 +229,8 @@ runGovernanceActionCreateConstitutionCmd -- TODO: Conway era - After ledger bump update this function -- with the new ledger types runGovernanceActionUpdateCommitteeCmd - :: () + :: forall era + . () => GovernanceActionUpdateCommitteeCmdArgs era -> ExceptT GovernanceActionsError IO () runGovernanceActionUpdateCommitteeCmd @@ -243,7 +248,7 @@ runGovernanceActionUpdateCommitteeCmd , Cmd.mPrevGovernanceActionId , Cmd.outFile } = do - let sbe = conwayEraOnwardsToShelleyBasedEra eon + let sbe :: ShelleyBasedEra era = inject eon govActIdentifier = L.maybeToStrictMaybe $ shelleyBasedEraConstraints sbe $ @@ -301,7 +306,8 @@ runGovernanceActionUpdateCommitteeCmd proposal runGovernanceActionCreateProtocolParametersUpdateCmd - :: () + :: forall era + . () => Cmd.GovernanceActionProtocolParametersUpdateCmdArgs era -> ExceptT GovernanceActionsError IO () runGovernanceActionCreateProtocolParametersUpdateCmd eraBasedPParams' = do @@ -309,7 +315,7 @@ runGovernanceActionCreateProtocolParametersUpdateCmd eraBasedPParams' = do caseShelleyToBabbageOrConwayEraOnwards ( \sToB -> do let oFp = uppFilePath eraBasedPParams' - anyEra = AnyShelleyBasedEra $ shelleyToBabbageEraToShelleyBasedEra sToB + anyEra = AnyShelleyBasedEra (inject sToB :: ShelleyBasedEra era) UpdateProtocolParametersPreConway _stB expEpoch genesisVerKeys <- hoistMaybe (GovernanceActionsValueUpdateProtocolParametersNotFound anyEra) $ uppPreConway eraBasedPParams' @@ -335,7 +341,7 @@ runGovernanceActionCreateProtocolParametersUpdateCmd eraBasedPParams' = do ) ( \conwayOnwards -> do let oFp = uppFilePath eraBasedPParams' - anyEra = AnyShelleyBasedEra $ conwayEraOnwardsToShelleyBasedEra conwayOnwards + anyEra = AnyShelleyBasedEra (inject conwayOnwards :: ShelleyBasedEra era) UpdateProtocolParametersConwayOnwards _cOnwards @@ -413,7 +419,8 @@ addCostModelsToEraBasedProtocolParametersUpdate ConwayEraBasedProtocolParametersUpdate common (aOn{alCostModels = SJust cmdls}) inB inC runGovernanceActionTreasuryWithdrawalCmd - :: () + :: forall era + . () => GovernanceActionTreasuryWithdrawalCmdArgs era -> ExceptT GovernanceActionsError IO () runGovernanceActionTreasuryWithdrawalCmd @@ -446,7 +453,7 @@ runGovernanceActionTreasuryWithdrawalCmd firstExceptT GovernanceActionsReadStakeCredErrror $ getStakeCredentialFromIdentifier stakeIdentifier pure (networkId, stakeCredential, lovelace) - let sbe = conwayEraOnwardsToShelleyBasedEra eon + let sbe :: ShelleyBasedEra era = inject eon treasuryWithdrawals = TreasuryWithdrawal withdrawals @@ -465,7 +472,8 @@ runGovernanceActionTreasuryWithdrawalCmd writeFileTextEnvelope outFile (Just "Treasury withdrawal proposal") proposal runGovernanceActionHardforkInitCmd - :: () + :: forall era + . () => GovernanceActionHardforkInitCmdArgs era -> ExceptT GovernanceActionsError IO () runGovernanceActionHardforkInitCmd @@ -493,7 +501,7 @@ runGovernanceActionHardforkInitCmd carryHashChecks checkProposalHash proposalAnchor ProposalCheck - let sbe = conwayEraOnwardsToShelleyBasedEra eon + let sbe :: ShelleyBasedEra era = inject eon govActIdentifier = L.maybeToStrictMaybe $ shelleyBasedEraConstraints sbe $ diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/GenesisKeyDelegationCertificate.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/GenesisKeyDelegationCertificate.hs index f8759e4acc..b7c1b702b8 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/GenesisKeyDelegationCertificate.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/GenesisKeyDelegationCertificate.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} module Cardano.CLI.EraBased.Run.Governance.GenesisKeyDelegationCertificate ( runGovernanceGenesisKeyDelegationCertificate @@ -13,7 +15,8 @@ import Cardano.CLI.Types.Errors.GovernanceCmdError import Cardano.CLI.Types.Key runGovernanceGenesisKeyDelegationCertificate - :: ShelleyToBabbageEra era + :: forall era + . ShelleyToBabbageEra era -> VerificationKeyOrHashOrFile GenesisKey -> VerificationKeyOrHashOrFile GenesisDelegateKey -> VerificationKeyOrHashOrFile VrfKey @@ -41,7 +44,7 @@ runGovernanceGenesisKeyDelegationCertificate firstExceptT GovernanceCmdTextEnvWriteError . newExceptT $ writeLazyByteStringFile oFp - $ shelleyBasedEraConstraints (shelleyToBabbageEraToShelleyBasedEra stb) + $ shelleyBasedEraConstraints (inject stb :: ShelleyBasedEra era) $ textEnvelopeToJSON (Just genKeyDelegCertDesc) genKeyDelegCert where genKeyDelegCertDesc :: TextEnvelopeDescr diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Vote.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Vote.hs index b48c073660..4443c46bea 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Vote.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Vote.hs @@ -41,7 +41,8 @@ runGovernanceVoteCmds = \case & firstExceptT CmdGovernanceVoteError runGovernanceVoteCreateCmd - :: () + :: forall era + . () => Cmd.GovernanceVoteCreateCmdArgs era -> ExceptT GovernanceVoteCmdError IO () runGovernanceVoteCreateCmd @@ -54,7 +55,7 @@ runGovernanceVoteCreateCmd , outFile } = do let (govActionTxId, govActionIndex) = governanceAction - sbe = conwayEraOnwardsToShelleyBasedEra eon -- TODO: Conway era - update vote creation related function to take ConwayEraOnwards + sbe :: ShelleyBasedEra era = inject eon -- TODO: Conway era - update vote creation related function to take ConwayEraOnwards mAnchor' = fmap ( \pca@PotentiallyCheckedAnchor{pcaAnchor = (VoteUrl url, voteHash)} -> @@ -92,7 +93,8 @@ runGovernanceVoteCreateCmd writeFileTextEnvelope outFile Nothing votingProcedures runGovernanceVoteViewCmd - :: () + :: forall era + . () => Cmd.GovernanceVoteViewCmdArgs era -> ExceptT GovernanceVoteCmdError IO () runGovernanceVoteViewCmd @@ -102,7 +104,7 @@ runGovernanceVoteViewCmd , voteFile , mOutFile } = do - let sbe = conwayEraOnwardsToShelleyBasedEra eon + let sbe :: ShelleyBasedEra era = inject eon shelleyBasedEraConstraints sbe $ do voteProcedures <- diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs index 877e7ddbdf..93cc93f889 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs @@ -37,16 +37,19 @@ where import Cardano.Api import qualified Cardano.Api.Byron as Byron -import qualified Cardano.Api.Experimental as Exp import qualified Cardano.Api.Ledger as L import qualified Cardano.Api.Network as Consensus import qualified Cardano.Api.Network as Net.Tx import Cardano.Api.Shelley import qualified Cardano.Binary as CBOR +import Cardano.CLI.EraBased.Commands.Transaction + (TransactionCalculateMinFeeCmdArgs (txBodyFile)) import qualified Cardano.CLI.EraBased.Commands.Transaction as Cmd import Cardano.CLI.EraBased.Run.Genesis.Common (readProtocolParameters) import Cardano.CLI.EraBased.Run.Query +import Cardano.CLI.EraBased.Script.Mint.Read +import Cardano.CLI.EraBased.Script.Mint.Types import Cardano.CLI.EraBased.Transaction.HashCheck (checkCertificateHashes, checkProposalHashes, checkVotingProcedureHashes) import Cardano.CLI.Read @@ -74,7 +77,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 @@ -136,7 +139,7 @@ runTransactionBuildCmd , treasuryDonation -- Maybe TxTreasuryDonation , buildOutputOptions } = do - let eon = Exp.eraToSbe currentEra + let eon = inject currentEra era' = toCardanoEra eon -- The user can specify an era prior to the era that the node is currently in. @@ -174,7 +177,9 @@ runTransactionBuildCmd txMetadata <- firstExceptT TxCmdMetadataError . newExceptT $ readTxMetadata eon metadataSchema metadataFiles - valuesWithScriptWits <- readValueScriptWitnesses eon $ fromMaybe mempty mValue + let (mas, sWitFiles) = fromMaybe (mempty, mempty) mValue + usedToGetReferenceInputs <- + (mas,) <$> firstExceptT TxCmdCliScriptWitnessError (mapM (readMintScriptWitness eon) sWitFiles) scripts <- firstExceptT TxCmdScriptFileError $ mapM (readFileScriptInAnyLang . unFile) scriptFiles @@ -252,7 +257,7 @@ runTransactionBuildCmd let allReferenceInputs = getAllReferenceInputs inputsAndMaybeScriptWits - (snd valuesWithScriptWits) + (map mswScriptWitness $ snd usedToGetReferenceInputs) certsAndMaybeScriptWits withdrawalsAndMaybeScriptWits votingProceduresAndMaybeScriptWits @@ -277,6 +282,8 @@ runTransactionBuildCmd & onLeft (left . TxCmdQueryConvenienceError . AcqFailure) & onLeft (left . TxCmdQueryConvenienceError) + valuesWithScriptWits <- + (mas,) <$> firstExceptT TxCmdCliScriptWitnessError (mapM (readMintScriptWitness eon) sWitFiles) let currentTreasuryValueAndDonation = case (treasuryDonation, unFeatured <$> featuredCurrentTreasuryValueM) of (Nothing, _) -> Nothing -- We shouldn't specify the treasury value when no donation is being done @@ -284,7 +291,7 @@ runTransactionBuildCmd (Just td, Just ctv) -> Just (ctv, td) -- We need to construct the txBodycontent outside of runTxBuild - BalancedTxBody txBodyContent unsignedTx@(Exp.UnsignedTx balancedTxBody) _ _ <- + BalancedTxBody txBodyContent balancedTxBody _ _ <- runTxBuild eon nodeSocketPath @@ -329,13 +336,13 @@ runTransactionBuildCmd scriptExecUnitsMap <- firstExceptT (TxCmdTxExecUnitsErr . AnyTxCmdTxExecUnitsErr) $ hoistEither $ - evaluateTransactionExecutionUnitsShelley - eon + evaluateTransactionExecutionUnits + era' systemStart (toLedgerEpochInfo eraHistory) pparams txEraUtxo - (Exp.obtainCommonConstraints currentEra balancedTxBody) + balancedTxBody let mScriptWits = forEraInEon era' [] $ \sbe -> collectTxBodyScriptWitnesses sbe txBodyContent @@ -349,13 +356,13 @@ runTransactionBuildCmd scriptExecUnitsMap liftIO $ LBS.writeFile (unFile fp) $ encodePretty scriptCostOutput OutputTxBodyOnly fpath -> do - let noWitTx = ShelleyTx eon $ Exp.obtainCommonConstraints currentEra $ Exp.signTx currentEra [] [] unsignedTx - lift (writeTxFileTextEnvelopeCddl eon fpath noWitTx) + let noWitTx = makeSignedTransaction [] balancedTxBody + lift (cardanoEraConstraints era' $ writeTxFileTextEnvelopeCddl eon fpath noWitTx) & onLeft (left . TxCmdWriteFileError) runTransactionBuildEstimateCmd - :: () - => Cmd.TransactionBuildEstimateCmdArgs era + :: forall era + . Cmd.TransactionBuildEstimateCmdArgs era -> ExceptT TxCmdError IO () runTransactionBuildEstimateCmd -- TODO change type Cmd.TransactionBuildEstimateCmdArgs @@ -388,8 +395,8 @@ runTransactionBuildEstimateCmd -- TODO change type , currentTreasuryValueAndDonation , txBodyOutFile } = do - let sbe = Exp.eraToSbe currentEra - meo = babbageEraOnwardsToMaryEraOnwards $ Exp.eraToBabbageEraOnwards currentEra + let sbe = inject currentEra + meo = inject @(BabbageEraOnwards era) $ inject currentEra ledgerPParams <- firstExceptT TxCmdProtocolParamsError $ readProtocolParameters sbe protocolParamsFile @@ -407,7 +414,11 @@ runTransactionBuildEstimateCmd -- TODO change type firstExceptT TxCmdMetadataError . newExceptT $ readTxMetadata sbe metadataSchema metadataFiles - valuesWithScriptWits <- readValueScriptWitnesses sbe $ fromMaybe mempty mValue + + let (mas, sWitFiles) = fromMaybe (mempty, mempty) mValue + valuesWithScriptWits <- + (mas,) <$> firstExceptT TxCmdCliScriptWitnessError (mapM (readMintScriptWitness sbe) sWitFiles) + scripts <- firstExceptT TxCmdScriptFileError $ mapM (readFileScriptInAnyLang . unFile) scriptFiles @@ -491,7 +502,7 @@ runTransactionBuildEstimateCmd -- TODO change type collectTxBodyScriptWitnesses sbe txBodyContent ] - BalancedTxBody _ unsignedTx _ _ <- + BalancedTxBody _ balancedTxBody _ _ <- hoistEither $ first TxCmdFeeEstimationError $ estimateBalancedTxBody @@ -509,8 +520,11 @@ runTransactionBuildEstimateCmd -- TODO change type (anyAddressInShelleyBasedEra sbe changeAddr) totalUTxOValue - let noWitTx = ShelleyTx sbe $ Exp.obtainCommonConstraints currentEra $ Exp.signTx currentEra [] [] unsignedTx - lift (writeTxFileTextEnvelopeCddl sbe txBodyOutFile noWitTx) + let noWitTx = makeSignedTransaction [] balancedTxBody + lift + ( cardanoEraConstraints (toCardanoEra meo) $ + writeTxFileTextEnvelopeCddl (inject meo) txBodyOutFile noWitTx + ) & onLeft (left . TxCmdWriteFileError) getPoolDeregistrationInfo @@ -641,7 +655,11 @@ runTransactionBuildRawCmd firstExceptT TxCmdMetadataError . newExceptT $ readTxMetadata eon metadataSchema metadataFiles - valuesWithScriptWits <- readValueScriptWitnesses eon $ fromMaybe mempty mValue + + let (mas, sWitFiles) = fromMaybe (mempty, mempty) mValue + valuesWithScriptWits <- + (mas,) <$> firstExceptT TxCmdCliScriptWitnessError (mapM (readMintScriptWitness eon) sWitFiles) + scripts <- firstExceptT TxCmdScriptFileError $ mapM (readFileScriptInAnyLang . unFile) scriptFiles @@ -745,7 +763,7 @@ runTxBuildRaw -- ^ Tx upper bound -> Lovelace -- ^ Tx fee - -> (Value, [ScriptWitness WitCtxMint era]) + -> (Value, [MintScriptWitnessWithPolicyId era]) -- ^ Multi-Asset value(s) -> [(Certificate era, Maybe (ScriptWitness WitCtxStake era))] -- ^ Certificate with potential script witness @@ -831,7 +849,7 @@ constructTxBodyContent -- ^ Tx lower bound -> TxValidityUpperBound era -- ^ Tx upper bound - -> (Value, [ScriptWitness WitCtxMint era]) + -> (Value, [MintScriptWitnessWithPolicyId era]) -- ^ Multi-Asset value(s) -> [(Certificate era, Maybe (ScriptWitness WitCtxStake era))] -- ^ Certificate with potential script witness @@ -878,7 +896,7 @@ constructTxBodyContent let allReferenceInputs = getAllReferenceInputs inputsAndMaybeScriptWits - (snd valuesWithScriptWits) + (map mswScriptWitness $ snd valuesWithScriptWits) certsAndMaybeScriptWits withdrawals votingProcedures @@ -971,7 +989,7 @@ runTxBuild -- ^ Normal outputs -> TxOutChangeAddress -- ^ A change output - -> (Value, [ScriptWitness WitCtxMint era]) + -> (Value, [MintScriptWitnessWithPolicyId era]) -- ^ Multi-Asset value(s) -> Maybe SlotNo -- ^ Tx lower bound @@ -1025,7 +1043,7 @@ runTxBuild let allReferenceInputs = getAllReferenceInputs inputsAndMaybeScriptWits - (snd valuesWithScriptWits) + (map mswScriptWitness $ snd valuesWithScriptWits) certsAndMaybeScriptWits withdrawals votingProcedures @@ -1230,9 +1248,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 @@ -1376,7 +1394,7 @@ toTxAlonzoDatum supp cliDatum = createTxMintValue :: forall era . ShelleyBasedEra era - -> (Value, [ScriptWitness WitCtxMint era]) + -> (Value, [MintScriptWitnessWithPolicyId era]) -> Either TxCmdError (TxMintValue BuildTx era) createTxMintValue era (val, scriptWitnesses) = if List.null (toList val) && List.null scriptWitnesses @@ -1385,31 +1403,29 @@ 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] + -- The set of policy ids for which we need witnesses: + witnessesNeededSet :: Set PolicyId + witnessesNeededSet = fromList [pid | (pid, _, _) <- policiesWithAssets] let witnessesProvidedMap :: Map PolicyId (ScriptWitness WitCtxMint era) - witnessesProvidedMap = fromList $ gatherMintingWitnesses scriptWitnesses + witnessesProvidedMap = fromList $ [(polid, sWit) | MintScriptWitnessWithPolicyId polid sWit <- scriptWitnesses] witnessesProvidedSet = Map.keysSet witnessesProvidedMap - + policiesWithWitnesses = + Map.fromListWith + (<>) + [ (pid, [(assetName, quantity, BuildTxWith witness)]) + | (pid, assetName, quantity) <- policiesWithAssets + , witness <- maybeToList $ Map.lookup pid witnessesProvidedMap + ] -- Check not too many, nor too few: validateAllWitnessesProvided witnessesNeededSet witnessesProvidedSet validateNoUnnecessaryWitnesses witnessesNeededSet witnessesProvidedSet - return (TxMintValue w val (BuildTxWith witnessesProvidedMap)) + pure $ TxMintValue w policiesWithWitnesses ) era where - gatherMintingWitnesses - :: [ScriptWitness WitCtxMint era] - -> [(PolicyId, ScriptWitness WitCtxMint era)] - gatherMintingWitnesses [] = [] - gatherMintingWitnesses (sWit : rest) = - case scriptWitnessPolicyId sWit of - Nothing -> gatherMintingWitnesses rest - Just pid -> (pid, sWit) : gatherMintingWitnesses rest - validateAllWitnessesProvided witnessesNeeded witnessesProvided | null witnessesMissing = return () | otherwise = Left (TxCmdPolicyIdsMissing witnessesMissing (toList witnessesProvided)) @@ -1422,24 +1438,6 @@ 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 _ mPid)) = - PolicyId <$> mPid -scriptWitnessPolicyId (PlutusScriptWitness _ version (PScript script) _ _ _) = - Just . scriptPolicyId $ PlutusScript version script -scriptWitnessPolicyId (PlutusScriptWitness _ _ (PReferenceScript _ mPid) _ _ _) = - PolicyId <$> mPid - -readValueScriptWitnesses - :: ShelleyBasedEra era - -> (Value, [ScriptWitnessFiles WitCtxMint]) - -> ExceptT TxCmdError IO (Value, [ScriptWitness WitCtxMint era]) -readValueScriptWitnesses era (v, sWitFiles) = do - sWits <- mapM (firstExceptT TxCmdScriptWitnessError . readScriptWitness era) sWitFiles - return (v, sWits) - -- ---------------------------------------------------------------------------- -- Transaction signing -- diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Script/Mint/Read.hs b/cardano-cli/src/Cardano/CLI/EraBased/Script/Mint/Read.hs new file mode 100644 index 0000000000..5b40eb1690 --- /dev/null +++ b/cardano-cli/src/Cardano/CLI/EraBased/Script/Mint/Read.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} + +module Cardano.CLI.EraBased.Script.Mint.Read + ( readMintScriptWitness + ) +where + +import Cardano.Api +import Cardano.Api.Shelley + +import Cardano.CLI.EraBased.Script.Mint.Types +import Cardano.CLI.Read + +readMintScriptWitness + :: MonadIOTransError (FileError CliScriptWitnessError) t m + => ShelleyBasedEra era -> CliMintScriptRequirements -> t m (MintScriptWitnessWithPolicyId era) +readMintScriptWitness sbe (OnDiskSimpleOrPlutusScript simpleOrPlutus) = + case simpleOrPlutus of + OnDiskSimpleScriptCliArgs simpleFp -> do + let sFp = unFile simpleFp + s <- + modifyError (fmap SimpleScriptWitnessDecodeError) $ readFileSimpleScript sFp + case s of + SimpleScript ss -> do + let polId = PolicyId $ hashScript s + return $ + MintScriptWitnessWithPolicyId polId $ + SimpleScriptWitness (sbeToSimpleScriptLangInEra sbe) $ + SScript ss + OnDiskPlutusScriptCliArgs plutusScriptFp redeemerFile execUnits -> do + let sFp = unFile plutusScriptFp + plutusScript <- + modifyError (fmap PlutusScriptWitnessDecodeError) $ + readFilePlutusScript $ + unFile plutusScriptFp + + redeemer <- + modifyError (FileError sFp . PlutusScriptWitnessRedeemerError) $ + readScriptDataOrFile redeemerFile + case plutusScript of + AnyPlutusScript lang script -> do + let pScript = PScript script + polId = PolicyId $ hashScript $ PlutusScript lang script + sLangSupported <- + modifyError (FileError sFp) + $ hoistMaybe + ( PlutusScriptWitnessLanguageNotSupportedInEra + (AnyPlutusScriptVersion lang) + (shelleyBasedEraConstraints sbe $ AnyShelleyBasedEra sbe) + ) + $ scriptLanguageSupportedInEra sbe + $ PlutusScriptLanguage lang + return $ + MintScriptWitnessWithPolicyId polId $ + PlutusScriptWitness + sLangSupported + lang + pScript + NoScriptDatumForMint + redeemer + execUnits +readMintScriptWitness sbe (OnDiskSimpleRefScript (SimpleRefScriptCliArgs refTxIn polId)) = + return $ + MintScriptWitnessWithPolicyId polId $ + SimpleScriptWitness + (sbeToSimpleScriptLangInEra sbe) + (SReferenceScript refTxIn) +readMintScriptWitness + sbe + ( OnDiskPlutusRefScript + (PlutusRefScriptCliArgs refTxIn anyPlutusScriptVersion redeemerFile execUnits polId) + ) = do + case anyPlutusScriptVersion of + AnyPlutusScriptVersion lang -> do + let pScript = PReferenceScript refTxIn + redeemer <- + -- TODO: Implement a new error type to capture this. FileError is not representative of cases + -- where we do not have access to the script. + modifyError (FileError "Reference script filepath not available" . PlutusScriptWitnessRedeemerError) $ + readScriptDataOrFile redeemerFile + sLangSupported <- + -- TODO: Implement a new error type to capture this. FileError is not representative of cases + -- where we do not have access to the script. + modifyError (FileError "Reference script filepath not available") + $ hoistMaybe + ( PlutusScriptWitnessLanguageNotSupportedInEra + (AnyPlutusScriptVersion lang) + (shelleyBasedEraConstraints sbe $ AnyShelleyBasedEra sbe) + ) + $ scriptLanguageSupportedInEra sbe + $ PlutusScriptLanguage lang + return $ + MintScriptWitnessWithPolicyId polId $ + PlutusScriptWitness + sLangSupported + lang + pScript + NoScriptDatumForMint + redeemer + execUnits + +-- TODO: Remove me when exposed from cardano-api +sbeToSimpleScriptLangInEra + :: ShelleyBasedEra era -> ScriptLanguageInEra SimpleScript' era +sbeToSimpleScriptLangInEra ShelleyBasedEraShelley = SimpleScriptInShelley +sbeToSimpleScriptLangInEra ShelleyBasedEraAllegra = SimpleScriptInAllegra +sbeToSimpleScriptLangInEra ShelleyBasedEraMary = SimpleScriptInMary +sbeToSimpleScriptLangInEra ShelleyBasedEraAlonzo = SimpleScriptInAlonzo +sbeToSimpleScriptLangInEra ShelleyBasedEraBabbage = SimpleScriptInBabbage +sbeToSimpleScriptLangInEra ShelleyBasedEraConway = SimpleScriptInConway diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Script/Mint/Types.hs b/cardano-cli/src/Cardano/CLI/EraBased/Script/Mint/Types.hs new file mode 100644 index 0000000000..192e4ed0f3 --- /dev/null +++ b/cardano-cli/src/Cardano/CLI/EraBased/Script/Mint/Types.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} + +module Cardano.CLI.EraBased.Script.Mint.Types + ( CliScriptWitnessError (..) + , CliMintScriptRequirements (..) + , SimpleOrPlutusScriptCliArgs (..) + , createSimpleOrPlutusScriptFromCliArgs + , PlutusRefScriptCliArgs (..) + , createPlutusReferenceScriptFromCliArgs + , SimpleRefScriptCliArgs (..) + , createSimpleReferenceScriptFromCliArgs + , MintScriptWitnessWithPolicyId (..) + ) +where + +import Cardano.Api + +import Cardano.CLI.Types.Common (ScriptDataOrFile) +import Cardano.CLI.Types.Errors.PlutusScriptDecodeError +import Cardano.CLI.Types.Errors.ScriptDataError +import Cardano.CLI.Types.Errors.ScriptDecodeError + +-- We always need the policy id when constructing a transaction that mints. +-- In the case of reference scripts, the user currently must provide the policy id (script hash) +-- in order to correctly construct the transaction. +data MintScriptWitnessWithPolicyId era + = MintScriptWitnessWithPolicyId + { mswPolId :: PolicyId + , mswScriptWitness :: ScriptWitness WitCtxMint era + } + deriving Show + +data CliMintScriptRequirements + = OnDiskSimpleOrPlutusScript SimpleOrPlutusScriptCliArgs + | OnDiskSimpleRefScript SimpleRefScriptCliArgs + | OnDiskPlutusRefScript PlutusRefScriptCliArgs + deriving Show + +data SimpleOrPlutusScriptCliArgs + = OnDiskSimpleScriptCliArgs + (File ScriptInAnyLang In) + | OnDiskPlutusScriptCliArgs + (File ScriptInAnyLang In) + ScriptDataOrFile + ExecutionUnits + deriving Show + +createSimpleOrPlutusScriptFromCliArgs + :: File ScriptInAnyLang In + -> Maybe (ScriptDataOrFile, ExecutionUnits) + -> CliMintScriptRequirements +createSimpleOrPlutusScriptFromCliArgs scriptFp Nothing = + OnDiskSimpleOrPlutusScript $ OnDiskSimpleScriptCliArgs scriptFp +createSimpleOrPlutusScriptFromCliArgs scriptFp (Just (redeemerFile, execUnits)) = + OnDiskSimpleOrPlutusScript $ OnDiskPlutusScriptCliArgs scriptFp redeemerFile execUnits + +data SimpleRefScriptCliArgs + = SimpleRefScriptCliArgs + TxIn + PolicyId + deriving Show + +createSimpleReferenceScriptFromCliArgs + :: TxIn + -> PolicyId + -> CliMintScriptRequirements +createSimpleReferenceScriptFromCliArgs txin polid = + OnDiskSimpleRefScript $ SimpleRefScriptCliArgs txin polid + +data PlutusRefScriptCliArgs + = PlutusRefScriptCliArgs + TxIn + AnyPlutusScriptVersion + ScriptDataOrFile + ExecutionUnits + PolicyId + deriving Show + +createPlutusReferenceScriptFromCliArgs + :: TxIn + -> AnyPlutusScriptVersion + -> ScriptDataOrFile + -> ExecutionUnits + -> PolicyId + -> CliMintScriptRequirements +createPlutusReferenceScriptFromCliArgs txin scriptVersion scriptData execUnits polid = + OnDiskPlutusRefScript $ PlutusRefScriptCliArgs txin scriptVersion scriptData execUnits polid + +data CliScriptWitnessError + = SimpleScriptWitnessDecodeError ScriptDecodeError + | PlutusScriptWitnessDecodeError PlutusScriptDecodeError + | PlutusScriptWitnessLanguageNotSupportedInEra + AnyPlutusScriptVersion + AnyShelleyBasedEra + | PlutusScriptWitnessRedeemerError ScriptDataError + +instance Error CliScriptWitnessError where + prettyError = \case + SimpleScriptWitnessDecodeError err -> prettyError err + PlutusScriptWitnessDecodeError err -> prettyError err + PlutusScriptWitnessLanguageNotSupportedInEra version era -> + "Plutus script version " <> pshow version <> " is not supported in era " <> pshow era + PlutusScriptWitnessRedeemerError err -> renderScriptDataError err diff --git a/cardano-cli/src/Cardano/CLI/Json/Friendly.hs b/cardano-cli/src/Cardano/CLI/Json/Friendly.hs index 8c95c4bf3f..70c48ec3d4 100644 --- a/cardano-cli/src/Cardano/CLI/Json/Friendly.hs +++ b/cardano-cli/src/Cardano/CLI/Json/Friendly.hs @@ -786,10 +786,10 @@ friendlyFee = \case friendlyLovelace :: Lovelace -> Aeson.Value friendlyLovelace value = String $ docToText (pretty value) -friendlyMintValue :: TxMintValue ViewTx era -> Aeson.Value +friendlyMintValue :: forall era. TxMintValue ViewTx era -> Aeson.Value friendlyMintValue = \case TxMintNone -> Null - TxMintValue sbe v _ -> friendlyValue (maryEraOnwardsToShelleyBasedEra sbe) v + txMintValue@(TxMintValue w _) -> friendlyValue @era (inject 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..8d2a65c085 100644 --- a/cardano-cli/src/Cardano/CLI/Read.hs +++ b/cardano-cli/src/Cardano/CLI/Read.hs @@ -6,6 +6,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} module Cardano.CLI.Read ( -- * Metadata @@ -24,6 +25,10 @@ module Cardano.CLI.Read , ScriptDecodeError (..) , deserialiseScriptInAnyLang , readFileScriptInAnyLang + , readFileSimpleScript + , AnyPlutusScript (..) + , PlutusScriptDecodeError (..) + , readFilePlutusScript -- * Script data (datums and redeemers) , ScriptDataError (..) @@ -107,6 +112,8 @@ import Cardano.Api.Shelley as Api import qualified Cardano.Binary as CBOR import Cardano.CLI.Types.Common import Cardano.CLI.Types.Errors.DelegationError +import Cardano.CLI.Types.Errors.PlutusScriptDecodeError +import Cardano.CLI.Types.Errors.ScriptDataError import Cardano.CLI.Types.Errors.ScriptDecodeError import Cardano.CLI.Types.Errors.StakeCredentialError import Cardano.CLI.Types.Governance @@ -348,11 +355,10 @@ readScriptWitness era ( PlutusReferenceScriptWitnessFiles refTxIn - anyScrLang@(AnyScriptLanguage anyScriptLanguage) + (AnyPlutusScriptVersion version) datumOrFile redeemerOrFile execUnits - mPid ) = do caseShelleyToAlonzoOrBabbageEraOnwards ( const $ @@ -361,31 +367,28 @@ readScriptWitness cardanoEraConstraints (toCardanoEra era) (AnyShelleyBasedEra era) ) ( const $ - case scriptLanguageSupportedInEra era anyScriptLanguage of + case scriptLanguageSupportedInEra era $ PlutusScriptLanguage version of Just sLangInEra -> - case languageOfScriptLanguageInEra sLangInEra of - SimpleScriptLanguage -> - -- TODO: We likely need another datatype eg data ReferenceScriptWitness lang - -- in order to make this branch unrepresentable. - error "readScriptWitness: Should not be possible to specify a simple script" - PlutusScriptLanguage version -> do - datum <- - firstExceptT ScriptWitnessErrorScriptData $ - readScriptDatumOrFile datumOrFile - redeemer <- - firstExceptT ScriptWitnessErrorScriptData $ - readScriptRedeemerOrFile redeemerOrFile - return $ - PlutusScriptWitness - sLangInEra - version - (PReferenceScript refTxIn (unPolicyId <$> mPid)) - datum - redeemer - execUnits + do + datum <- + firstExceptT ScriptWitnessErrorScriptData $ + readScriptDatumOrFile datumOrFile + redeemer <- + firstExceptT ScriptWitnessErrorScriptData $ + readScriptRedeemerOrFile redeemerOrFile + return $ + PlutusScriptWitness + sLangInEra + version + (PReferenceScript refTxIn) + datum + redeemer + execUnits Nothing -> left $ - ScriptWitnessErrorScriptLanguageNotSupportedInEra anyScrLang (anyCardanoEra $ toCardanoEra era) + ScriptWitnessErrorScriptLanguageNotSupportedInEra + (AnyScriptLanguage $ PlutusScriptLanguage version) + (anyCardanoEra $ toCardanoEra era) ) era readScriptWitness @@ -393,7 +396,6 @@ readScriptWitness ( SimpleReferenceScriptWitnessFiles refTxIn anyScrLang@(AnyScriptLanguage anyScriptLanguage) - mPid ) = do caseShelleyToAlonzoOrBabbageEraOnwards ( const $ @@ -407,7 +409,7 @@ readScriptWitness case languageOfScriptLanguageInEra sLangInEra of SimpleScriptLanguage -> return . SimpleScriptWitness sLangInEra $ - SReferenceScript refTxIn (unPolicyId <$> mPid) + SReferenceScript refTxIn PlutusScriptLanguage{} -> error "readScriptWitness: Should not be possible to specify a plutus script" Nothing -> @@ -431,30 +433,6 @@ validateScriptSupportedInEra era script@(ScriptInAnyLang lang _) = (anyCardanoEra $ toCardanoEra era) Just script' -> pure script' -data ScriptDataError - = ScriptDataErrorFile (FileError ()) - | ScriptDataErrorJsonParse !FilePath !String - | ScriptDataErrorConversion !FilePath !ScriptDataJsonError - | ScriptDataErrorValidation !FilePath !ScriptDataRangeError - | ScriptDataErrorMetadataDecode !FilePath !CBOR.DecoderError - | ScriptDataErrorJsonBytes !ScriptDataJsonBytesError - deriving Show - -renderScriptDataError :: ScriptDataError -> Doc ann -renderScriptDataError = \case - ScriptDataErrorFile err -> - prettyError err - ScriptDataErrorJsonParse fp jsonErr -> - "Invalid JSON format in file: " <> pshow fp <> "\nJSON parse error: " <> pretty jsonErr - ScriptDataErrorConversion fp sDataJsonErr -> - "Error reading metadata at: " <> pshow fp <> "\n" <> prettyError sDataJsonErr - ScriptDataErrorValidation fp sDataRangeErr -> - "Error validating script data at: " <> pshow fp <> ":\n" <> prettyError sDataRangeErr - ScriptDataErrorMetadataDecode fp decoderErr -> - "Error decoding CBOR metadata at: " <> pshow fp <> " Error: " <> pshow decoderErr - ScriptDataErrorJsonBytes e -> - prettyError e - readScriptDatumOrFile :: ScriptDatumOrFile witctx -> ExceptT ScriptDataError IO (ScriptDatum witctx) @@ -472,8 +450,9 @@ readScriptRedeemerOrFile readScriptRedeemerOrFile = readScriptDataOrFile readScriptDataOrFile - :: ScriptDataOrFile - -> ExceptT ScriptDataError IO HashableScriptData + :: MonadIO m + => ScriptDataOrFile + -> ExceptT ScriptDataError m HashableScriptData readScriptDataOrFile (ScriptDataValue d) = return d readScriptDataOrFile (ScriptDataJsonFile fp) = do sDataBs <- handleIOExceptT (ScriptDataErrorFile . FileIOError fp) $ LBS.readFile fp @@ -565,20 +544,107 @@ deserialiseScriptInAnyLang bs = -- TODO: Think of a way to get type checker to warn when there is a missing -- script version. textEnvTypes :: [FromSomeType HasTextEnvelope ScriptInAnyLang] - textEnvTypes = - [ FromSomeType - (AsScript AsSimpleScript) - (ScriptInAnyLang SimpleScriptLanguage) - , FromSomeType - (AsScript AsPlutusScriptV1) - (ScriptInAnyLang (PlutusScriptLanguage PlutusScriptV1)) - , FromSomeType - (AsScript AsPlutusScriptV2) - (ScriptInAnyLang (PlutusScriptLanguage PlutusScriptV2)) - , FromSomeType - (AsScript AsPlutusScriptV3) - (ScriptInAnyLang (PlutusScriptLanguage PlutusScriptV3)) - ] + textEnvTypes = fromSomeTypeSimpleScript : fromSomeTypePlutusScripts + +fromSomeTypeSimpleScript :: FromSomeType HasTextEnvelope ScriptInAnyLang +fromSomeTypeSimpleScript = + FromSomeType + (AsScript AsSimpleScript) + (ScriptInAnyLang SimpleScriptLanguage) + +fromSomeTypePlutusScripts :: [FromSomeType HasTextEnvelope ScriptInAnyLang] +fromSomeTypePlutusScripts = + let allPlutusVersions :: [AnyPlutusScriptVersion] = [minBound .. maxBound] + in [plutusScriptVersionFromSomeType v | AnyPlutusScriptVersion v <- allPlutusVersions] + where + plutusScriptVersionFromSomeType + :: IsPlutusScriptLanguage lang + => PlutusScriptVersion lang -> FromSomeType HasTextEnvelope ScriptInAnyLang + plutusScriptVersionFromSomeType v = + FromSomeType + (AsScript $ proxyToAsType (Proxy :: Proxy lang)) + (ScriptInAnyLang $ PlutusScriptLanguage v) + +readFileSimpleScript + :: MonadIOTransError (FileError ScriptDecodeError) t m + => FilePath + -> t m (Script SimpleScript') +readFileSimpleScript file = do + scriptBytes <- handleIOExceptionsLiftWith (FileIOError file) . liftIO $ BS.readFile file + modifyError (FileError file) $ + hoistEither $ + deserialiseSimpleScript scriptBytes + +deserialiseSimpleScript + :: BS.ByteString + -> Either ScriptDecodeError (Script SimpleScript') +deserialiseSimpleScript bs = + case deserialiseFromJSON AsTextEnvelope bs of + Left _ -> + -- In addition to the TextEnvelope format, we also try to + -- deserialize the JSON representation of SimpleScripts. + case Aeson.eitherDecodeStrict' bs of + Left err -> Left (ScriptDecodeSimpleScriptError $ JsonDecodeError err) + Right script -> Right $ SimpleScript script + Right te -> + case deserialiseFromTextEnvelopeAnyOf [teType'] te of + Left err -> Left (ScriptDecodeTextEnvelopeError err) + Right script -> Right script + where + teType' :: FromSomeType HasTextEnvelope (Script SimpleScript') + teType' = FromSomeType (AsScript AsSimpleScript) id + +readFilePlutusScript + :: MonadIOTransError (FileError PlutusScriptDecodeError) t m + => FilePath + -> t m AnyPlutusScript +readFilePlutusScript plutusScriptFp = do + bs <- + handleIOExceptionsLiftWith (FileIOError plutusScriptFp) . liftIO $ + BS.readFile plutusScriptFp + modifyError (FileError plutusScriptFp) $ + hoistEither $ + deserialisePlutusScript bs + +deserialisePlutusScript + :: BS.ByteString + -> Either PlutusScriptDecodeError AnyPlutusScript +deserialisePlutusScript bs = do + te <- first PlutusScriptJsonDecodeError $ deserialiseFromJSON AsTextEnvelope bs + case teType te of + TextEnvelopeType s -> case s of + sVer@"PlutusScriptV1" -> deserialiseAnyPlutusScriptVersion sVer PlutusScriptV1 te + sVer@"PlutusScriptV2" -> deserialiseAnyPlutusScriptVersion sVer PlutusScriptV2 te + sVer@"PlutusScriptV3" -> deserialiseAnyPlutusScriptVersion sVer PlutusScriptV3 te + unknownScriptVersion -> + Left . PlutusScriptDecodeErrorUnknownVersion $ Text.pack unknownScriptVersion + where + deserialiseAnyPlutusScriptVersion + :: IsPlutusScriptLanguage lang + => String + -> PlutusScriptVersion lang + -> TextEnvelope + -> Either PlutusScriptDecodeError AnyPlutusScript + deserialiseAnyPlutusScriptVersion v lang tEnv = + if v == show lang + then + first PlutusScriptDecodeTextEnvelopeError $ + deserialiseFromTextEnvelopeAnyOf [teTypes (AnyPlutusScriptVersion lang)] tEnv + else Left $ PlutusScriptDecodeErrorVersionMismatch (Text.pack v) (AnyPlutusScriptVersion lang) + + teTypes :: AnyPlutusScriptVersion -> FromSomeType HasTextEnvelope AnyPlutusScript + teTypes = + \case + AnyPlutusScriptVersion PlutusScriptV1 -> + FromSomeType (AsPlutusScript AsPlutusScriptV1) (AnyPlutusScript PlutusScriptV1) + AnyPlutusScriptVersion PlutusScriptV2 -> + FromSomeType (AsPlutusScript AsPlutusScriptV2) (AnyPlutusScript PlutusScriptV2) + AnyPlutusScriptVersion PlutusScriptV3 -> + FromSomeType (AsPlutusScript AsPlutusScriptV3) (AnyPlutusScript PlutusScriptV3) + +data AnyPlutusScript where + AnyPlutusScript + :: IsPlutusScriptLanguage lang => PlutusScriptVersion lang -> PlutusScript lang -> AnyPlutusScript -- Tx & TxBody @@ -919,7 +985,7 @@ readSingleVote w (voteFp, mScriptWitFiles) = do case mScriptWitFiles of Nothing -> pure $ (,Nothing) <$> votProceds sWitFile -> do - let sbe = conwayEraOnwardsToShelleyBasedEra w + let sbe = inject w runExceptT $ do sWits <- firstExceptT VoteErrorScriptWitness $ @@ -965,7 +1031,7 @@ readProposal w (fp, mScriptWit) = do case mScriptWit of Nothing -> pure $ (,Nothing) <$> prop sWitFile -> do - let sbe = conwayEraOnwardsToShelleyBasedEra w + let sbe = inject w runExceptT $ do sWit <- firstExceptT ProposalErrorScriptWitness $ diff --git a/cardano-cli/src/Cardano/CLI/Types/Common.hs b/cardano-cli/src/Cardano/CLI/Types/Common.hs index c4d65f2498..c88ba44628 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Common.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Common.hs @@ -9,6 +9,7 @@ module Cardano.CLI.Types.Common ( AllOrOnly (..) , AddressKeyType (..) + , AnyPlutusScriptVersion (..) , BalanceTxExecUnits (..) , BlockId (..) , ByronKeyFormat (..) @@ -398,11 +399,19 @@ type ScriptRedeemerOrFile = ScriptDataOrFile -- the script witness data representation. -- -- It is era-independent, but witness context-dependent. --- --- TODO: Potentially update to WitnessFiles so we can get --- rid of Maybe (ScriptWitnessFiles). This will be clearer --- in conveying that we either expect a script witness --- or a key witness is provided at the signing stage. +-- NB: This is in the process of being deprecated because it is difficult +-- to accomodate for changes for specific plutus script purposes. As an +-- example when minting a multi-asset with a plutus script we need the policy +-- id of the said script. This is fine when we have access to the plutus script however +-- in the case of a reference script we demand the user provides the policy id. +-- Enshrining that change in the 'ScriptWitnessFiles' is difficult because only +-- minting scripts require this but not the other kinds of plutus scripts (spending, certifying etc.) +-- Another example is CIP-69 where datums are no longer required for spending scripts. This is +-- further complicated by the fact at the parsing level we make user facing simplifications e.g `--mint-script-file` +-- which says nothing about the script type (simple vs plutus) or script version. +-- As a result need to separate the different script purposes into +-- their own separate data definitions where we can make changes specific to that script purpose +-- more easily without affecting the rest of the api. data ScriptWitnessFiles witctx where SimpleScriptWitnessFile :: ScriptFile @@ -413,21 +422,21 @@ data ScriptWitnessFiles witctx where -> ScriptRedeemerOrFile -> ExecutionUnits -> ScriptWitnessFiles witctx - -- TODO: Need to figure out how to exclude PlutusV1 scripts at the type level + -- NB: This no longer is used for minting scripts + -- Use MintScriptWitnessWithPolicyId instead PlutusReferenceScriptWitnessFiles :: TxIn - -> AnyScriptLanguage + -> AnyPlutusScriptVersion -> ScriptDatumOrFile witctx -> ScriptRedeemerOrFile -> ExecutionUnits - -> Maybe PolicyId -- ^ For minting reference scripts -> ScriptWitnessFiles witctx + -- NB: This no longer is used for minting scripts + -- Use MintScriptWitnessWithPolicyId instead SimpleReferenceScriptWitnessFiles :: TxIn -> AnyScriptLanguage - -> Maybe PolicyId - -- ^ For minting reference scripts -> ScriptWitnessFiles witctx deriving instance Show (ScriptWitnessFiles witctx) diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/PlutusScriptDecodeError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/PlutusScriptDecodeError.hs new file mode 100644 index 0000000000..e00583b194 --- /dev/null +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/PlutusScriptDecodeError.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE LambdaCase #-} + +module Cardano.CLI.Types.Errors.PlutusScriptDecodeError + ( PlutusScriptDecodeError (..) + ) +where + +import Cardano.Api + +import Data.Text (Text) + +data PlutusScriptDecodeError + = PlutusScriptDecodeErrorUnknownVersion !Text + | PlutusScriptJsonDecodeError !JsonDecodeError + | PlutusScriptDecodeTextEnvelopeError !TextEnvelopeError + | PlutusScriptDecodeErrorVersionMismatch + !Text + -- ^ Script version + !AnyPlutusScriptVersion + -- ^ Attempted to decode with version + +instance Error PlutusScriptDecodeError where + prettyError = \case + PlutusScriptDecodeErrorUnknownVersion version -> + "Unknown Plutus script version: " <> pretty version + PlutusScriptJsonDecodeError err -> + prettyError err + PlutusScriptDecodeTextEnvelopeError err -> + prettyError err + PlutusScriptDecodeErrorVersionMismatch version (AnyPlutusScriptVersion v) -> + "Version mismatch in code: script version that was read" + <> pretty version + <> " but tried to decode script version: " + <> pshow v diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/ScriptDataError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/ScriptDataError.hs new file mode 100644 index 0000000000..aa994380c6 --- /dev/null +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/ScriptDataError.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE LambdaCase #-} + +module Cardano.CLI.Types.Errors.ScriptDataError + ( ScriptDataError (..) + , renderScriptDataError + ) +where + +import Cardano.Api + +import qualified Cardano.Binary as CBOR + +data ScriptDataError + = ScriptDataErrorFile (FileError ()) + | ScriptDataErrorJsonParse !FilePath !String + | ScriptDataErrorConversion !FilePath !ScriptDataJsonError + | ScriptDataErrorValidation !FilePath !ScriptDataRangeError + | ScriptDataErrorMetadataDecode !FilePath !CBOR.DecoderError + | ScriptDataErrorJsonBytes !ScriptDataJsonBytesError + deriving Show + +renderScriptDataError :: ScriptDataError -> Doc ann +renderScriptDataError = \case + ScriptDataErrorFile err -> + prettyError err + ScriptDataErrorJsonParse fp jsonErr -> + "Invalid JSON format in file: " <> pshow fp <> "\nJSON parse error: " <> pretty jsonErr + ScriptDataErrorConversion fp sDataJsonErr -> + "Error reading metadata at: " <> pshow fp <> "\n" <> prettyError sDataJsonErr + ScriptDataErrorValidation fp sDataRangeErr -> + "Error validating script data at: " <> pshow fp <> ":\n" <> prettyError sDataRangeErr + ScriptDataErrorMetadataDecode fp decoderErr -> + "Error decoding CBOR metadata at: " <> pshow fp <> " Error: " <> pshow decoderErr + ScriptDataErrorJsonBytes e -> + prettyError e diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/ScriptDecodeError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/ScriptDecodeError.hs index 2b4c37c9c6..7ba879c591 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/ScriptDecodeError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/ScriptDecodeError.hs @@ -7,6 +7,8 @@ where import Cardano.Api +import Data.Text + -- -- Handling decoding the variety of script languages and formats -- @@ -14,6 +16,7 @@ import Cardano.Api data ScriptDecodeError = ScriptDecodeTextEnvelopeError TextEnvelopeError | ScriptDecodeSimpleScriptError JsonDecodeError + | ScriptDecodeUnknownPlutusScriptVersion Text deriving Show instance Error ScriptDecodeError where @@ -22,3 +25,5 @@ instance Error ScriptDecodeError where "Error decoding script: " <> prettyError err ScriptDecodeSimpleScriptError err -> "Syntax error in script: " <> prettyError err + ScriptDecodeUnknownPlutusScriptVersion version -> + "Unknown Plutus script version: " <> pshow version diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs index 19582fba41..4e57677428 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs @@ -19,6 +19,7 @@ import Cardano.Api.Consensus (EraMismatch (..)) import qualified Cardano.Api.Ledger as L import Cardano.Api.Shelley +import Cardano.CLI.EraBased.Script.Mint.Types import Cardano.CLI.Read import Cardano.CLI.Types.Common import Cardano.CLI.Types.Errors.BootstrapWitnessError @@ -50,6 +51,7 @@ data TxCmdError | TxCmdScriptWitnessError ScriptWitnessError | TxCmdProtocolParamsError ProtocolParamsError | TxCmdScriptFileError (FileError ScriptDecodeError) + | TxCmdCliScriptWitnessError !(FileError CliScriptWitnessError) | TxCmdKeyFileError (FileError InputDecodeError) | TxCmdReadTextViewFileError !(FileError TextEnvelopeError) | TxCmdReadWitnessSigningDataError !ReadWitnessSigningDataError @@ -105,6 +107,8 @@ renderTxCmdError = \case prettyError fileErr TxCmdScriptFileError fileErr -> prettyError fileErr + TxCmdCliScriptWitnessError cliScriptWitnessErr -> + prettyError cliScriptWitnessErr TxCmdKeyFileError fileErr -> prettyError fileErr TxCmdReadWitnessSigningDataError witSignDataErr -> 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/flake.lock b/flake.lock index 8a0d9daf9e..fa6ae379a3 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1731401651, - "narHash": "sha256-tXaUck9+0Ob4h6GBlbhYMI4ekW5e8biVJU5jPT/rjus=", + "lastModified": 1732134025, + "narHash": "sha256-BBz3q09+DqDMYnLLgqXYyAxj9amVibxuEevHzgqL6UM=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "82b295d6147a566c28dbcf038c54040f06f7e6b4", + "rev": "d36fcfb3c0f2632bdaf4637c72e91b93f7eada56", "type": "github" }, "original": {