Add command to calculate plutus script costs from an already constructed transaction

cardano-cli/cardano-cli.cabal

@@ -226,6 +226,7 @@ library
     cardano-crypto-wrapper ^>=1.5.1,
     cardano-data >=1.1,
     cardano-git-rev ^>=0.2.2,
+    cardano-ledger-api,
     cardano-ping ^>=0.7,
     cardano-prelude,
     cardano-slotting ^>=0.2.0.0,

cardano-cli/src/Cardano/CLI/EraBased/Commands/Transaction.hs

@@ -14,6 +14,7 @@ module Cardano.CLI.EraBased.Commands.Transaction
   , TransactionPolicyIdCmdArgs (..)
   , TransactionCalculateMinFeeCmdArgs (..)
   , TransactionCalculateMinValueCmdArgs (..)
+  , TransactionCalculatePlutusScriptCostCmdArgs (..)
   , TransactionHashScriptDataCmdArgs (..)
   , TransactionTxIdCmdArgs (..)
   , TransactionViewCmdArgs (..)
@@ -48,6 +49,7 @@ data TransactionCmds era
   | TransactionPolicyIdCmd !TransactionPolicyIdCmdArgs
   | TransactionCalculateMinFeeCmd !TransactionCalculateMinFeeCmdArgs
   | TransactionCalculateMinValueCmd !(TransactionCalculateMinValueCmdArgs era)
+  | TransactionCalculatePlutusScriptCostCmd !TransactionCalculatePlutusScriptCostCmdArgs
   | TransactionHashScriptDataCmd !TransactionHashScriptDataCmdArgs
   | TransactionTxIdCmd !TransactionTxIdCmdArgs
 
@@ -240,6 +242,12 @@ data TransactionCalculateMinValueCmdArgs era = TransactionCalculateMinValueCmdAr
   }
   deriving Show
 
+data TransactionCalculatePlutusScriptCostCmdArgs = TransactionCalculatePlutusScriptCostCmdArgs
+  { nodeConnInfo :: !LocalNodeConnectInfo
+  , txFileIn :: FilePath
+  , outputFile :: !(Maybe (File () Out))
+  }
+
 newtype TransactionHashScriptDataCmdArgs = TransactionHashScriptDataCmdArgs
   { scriptDataOrFile :: ScriptDataOrFile
   }
@@ -266,5 +274,6 @@ renderTransactionCmds = \case
   TransactionPolicyIdCmd{} -> "transaction policyid"
   TransactionCalculateMinFeeCmd{} -> "transaction calculate-min-fee"
   TransactionCalculateMinValueCmd{} -> "transaction calculate-min-value"
+  TransactionCalculatePlutusScriptCostCmd{} -> "transaction calculate-plutus-script-cost"
   TransactionHashScriptDataCmd{} -> "transaction hash-script-data"
   TransactionTxIdCmd{} -> "transaction txid"

cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs

@@ -1439,7 +1439,9 @@ pTxBuildOutputOptions =
     OutputScriptCostOnly . File
       <$> parseFilePath
         "calculate-plutus-script-cost"
-        "Where to write the script cost information."
+        ( "Where to write the script cost information. (Deprecated: this flag is deprecated and will be "
+            <> "removed in a future version. Please, use calculate-plutus-script-cost command instead.)"
+        )
 
 pCertificateFile
   :: BalanceTxExecUnits

cardano-cli/src/Cardano/CLI/EraBased/Options/Transaction.hs

@@ -92,6 +92,10 @@ pTransactionCmds era' envCli =
         subParser "calculate-min-required-utxo" $
           Opt.info (pTransactionCalculateMinReqUTxO era') $
             Opt.progDesc "Calculate the minimum required UTxO for a transaction output."
+    , Just $
+        subParser "calculate-plutus-script-cost" $
+          Opt.info (pTransactionCalculatePlutusScriptCost envCli) $
+            Opt.progDesc "Calculate the costs of the Plutus scripts of a given transaction."
     , Just $ pCalculateMinRequiredUtxoBackwardCompatible era'
     , Just $
         subParser "hash-script-data" $
@@ -369,6 +373,21 @@ pTransactionCalculateMinReqUTxO era' =
       <$> pProtocolParamsFile
       <*> pTxOutShelleyBased
 
+pTransactionCalculatePlutusScriptCost :: EnvCli -> Parser (TransactionCmds era)
+pTransactionCalculatePlutusScriptCost envCli =
+  fmap TransactionCalculatePlutusScriptCostCmd $
+    TransactionCalculatePlutusScriptCostCmdArgs
+      <$> ( LocalNodeConnectInfo
+              <$> pConsensusModeParams
+              <*> pNetworkId envCli
+              <*> pSocketPath envCli
+          )
+      <*> pTxInputFile
+      <*> optional pOutputFile
+ where
+  pTxInputFile :: Parser FilePath
+  pTxInputFile = parseFilePath "tx-file" "Filepath of the transaction whose Plutus scripts to calculate the cost."
+
 pTxHashScriptData :: Parser (TransactionCmds era)
 pTxHashScriptData =
   fmap TransactionHashScriptDataCmd $

cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE EmptyCase #-}
@@ -36,7 +38,9 @@ module Cardano.CLI.EraBased.Run.Transaction
 where
 
 import           Cardano.Api
+import qualified Cardano.Api as Api
 import qualified Cardano.Api.Byron as Byron
+import           Cardano.Api.Consensus (EraMismatch (..))
 import qualified Cardano.Api.Ledger as L
 import qualified Cardano.Api.Network as Consensus
 import qualified Cardano.Api.Network as Net.Tx
@@ -67,8 +71,10 @@ import           Cardano.CLI.Types.Errors.BootstrapWitnessError
 import           Cardano.CLI.Types.Errors.NodeEraMismatchError
 import           Cardano.CLI.Types.Errors.TxCmdError
 import           Cardano.CLI.Types.Errors.TxValidationError
-import           Cardano.CLI.Types.Output (renderScriptCosts)
+import           Cardano.CLI.Types.Output (renderScriptCostsWithScriptHashesMap)
 import           Cardano.CLI.Types.TxFeature
+import           Cardano.Ledger.Api (allInputsTxBodyF, bodyTxL)
+import           Cardano.Prelude (putLByteString)
 
 import           Control.Monad (forM, unless)
 import           Data.Aeson ((.=))
@@ -105,6 +111,7 @@ runTransactionCmds = \case
   Cmd.TransactionSubmitCmd args -> runTransactionSubmitCmd args
   Cmd.TransactionCalculateMinFeeCmd args -> runTransactionCalculateMinFeeCmd args
   Cmd.TransactionCalculateMinValueCmd args -> runTransactionCalculateMinValueCmd args
+  Cmd.TransactionCalculatePlutusScriptCostCmd args -> runTransactionCalculatePlutusScriptCostCmd args
   Cmd.TransactionHashScriptDataCmd args -> runTransactionHashScriptDataCmd args
   Cmd.TransactionTxIdCmd args -> runTransactionTxIdCmd args
   Cmd.TransactionPolicyIdCmd args -> runTransactionPolicyIdCmd args
@@ -328,6 +335,14 @@ runTransactionBuildCmd
     -- the script cost vs having to build the tx body each time
     case buildOutputOptions of
       OutputScriptCostOnly fp -> do
+        -- Warn that the parameter is deprecated to stderr
+        liftIO $
+          IO.hPutStrLn
+            IO.stderr
+            ( "Warning: The `--calculate-plutus-script-cost` parameter is deprecated and will be "
+                <> "removed in a future version. Please use the `calculate-script-cost` command instead."
+            )
+
         let BuildTxWith mTxProtocolParams = txProtocolParams txBodyContent
 
         pparams <- pure mTxProtocolParams & onNothing (left TxCmdProtocolParametersNotPresentInTxBody)
@@ -349,15 +364,18 @@ runTransactionBuildCmd
                 txEraUtxo
                 balancedTxBody
 
-        let mScriptWits = forEraInEon era' [] $ \sbe -> collectTxBodyScriptWitnesses sbe txBodyContent
+        scriptHashes <-
+          monoidForEraInEon @AlonzoEraOnwards
+            era'
+            (\aeo -> pure $ collectPlutusScriptHashes aeo (makeSignedTransaction [] balancedTxBody) txEraUtxo)
+            & hoistMaybe (TxCmdAlonzoEraOnwardsRequired era')
 
         scriptCostOutput <-
           firstExceptT TxCmdPlutusScriptCostErr $
             hoistEither $
-              renderScriptCosts
-                txEraUtxo
+              renderScriptCostsWithScriptHashesMap
                 executionUnitPrices
-                mScriptWits
+                scriptHashes
                 scriptExecUnitsMap
         liftIO $ LBS.writeFile (unFile fp) $ encodePretty scriptCostOutput
       OutputTxBodyOnly fpath -> do
@@ -1621,6 +1639,98 @@ runTransactionCalculateMinValueCmd
     let minValue = calculateMinimumUTxO eon out pp
     liftIO . IO.print $ minValue
 
+runTransactionCalculatePlutusScriptCostCmd
+  :: Cmd.TransactionCalculatePlutusScriptCostCmdArgs -> ExceptT TxCmdError IO ()
+runTransactionCalculatePlutusScriptCostCmd
+  Cmd.TransactionCalculatePlutusScriptCostCmdArgs
+    { nodeConnInfo
+    , txFileIn
+    , outputFile
+    } = do
+    txFileOrPipeIn <- liftIO $ fileOrPipe txFileIn
+    InAnyShelleyBasedEra txEra tx@(ShelleyTx sbe ledgerTx) <-
+      liftIO (readFileTx txFileOrPipeIn) & onLeft (left . TxCmdTextEnvCddlError)
+
+    let relevantTxIns :: Set TxIn
+        relevantTxIns = Set.map fromShelleyTxIn $ shelleyBasedEraConstraints sbe (ledgerTx ^. bodyTxL . allInputsTxBodyF)
+
+    (AnyCardanoEra nodeEra, systemStart, eraHistory, txEraUtxo, pparams) <-
+      lift
+        ( executeLocalStateQueryExpr nodeConnInfo Consensus.VolatileTip $ do
+            eCurrentEra <- queryCurrentEra
+            eSystemStart <- querySystemStart
+            eEraHistory <- queryEraHistory
+            eeUtxo <- queryUtxo txEra (QueryUTxOByTxIn relevantTxIns)
+            ePp <- queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe Api.QueryProtocolParameters
+            return $ do
+              currentEra <- first QceUnsupportedNtcVersion eCurrentEra
+              systemStart <- first QceUnsupportedNtcVersion eSystemStart
+              eraHistory <- first QceUnsupportedNtcVersion eEraHistory
+              utxo <- first QueryEraMismatch =<< first QceUnsupportedNtcVersion eeUtxo
+              pp <- first QueryEraMismatch =<< first QceUnsupportedNtcVersion ePp
+              return (currentEra, systemStart, eraHistory, utxo, LedgerProtocolParameters pp)
+        )
+        & onLeft (left . TxCmdQueryConvenienceError . AcqFailure)
+        & onLeft (left . TxCmdQueryConvenienceError)
+
+    Refl <-
+      testEquality nodeEra (convert txEra)
+        & hoistMaybe
+          ( TxCmdTxSubmitErrorEraMismatch $
+              EraMismatch{ledgerEraName = docToText $ pretty nodeEra, otherEraName = docToText $ pretty txEra}
+          )
+
+    calculatePlutusScriptsCosts
+      (convert txEra)
+      systemStart
+      eraHistory
+      pparams
+      txEraUtxo
+      tx
+   where
+    calculatePlutusScriptsCosts
+      :: CardanoEra era
+      -> SystemStart
+      -> EraHistory
+      -> LedgerProtocolParameters era
+      -> UTxO era
+      -> Tx era
+      -> ExceptT TxCmdError IO ()
+    calculatePlutusScriptsCosts era' systemStart eraHistory pparams txEraUtxo tx = do
+      scriptHashes <-
+        monoidForEraInEon @AlonzoEraOnwards
+          era'
+          (\aeo -> pure $ collectPlutusScriptHashes aeo tx txEraUtxo)
+          & hoistMaybe (TxCmdAlonzoEraOnwardsRequired era')
+
+      executionUnitPrices <-
+        pure (getExecutionUnitPrices era' pparams) & onNothing (left TxCmdPParamExecutionUnitsNotAvailable)
+
+      scriptExecUnitsMap <-
+        firstExceptT (TxCmdTxExecUnitsErr . AnyTxCmdTxExecUnitsErr) $
+          hoistEither $
+            evaluateTransactionExecutionUnits
+              era'
+              systemStart
+              (toLedgerEpochInfo eraHistory)
+              pparams
+              txEraUtxo
+              (getTxBody tx)
+
+      scriptCostOutput <-
+        firstExceptT TxCmdPlutusScriptCostErr $
+          hoistEither $
+            renderScriptCostsWithScriptHashesMap
+              executionUnitPrices
+              scriptHashes
+              scriptExecUnitsMap
+      liftIO
+        $ ( case outputFile of
+              Just file -> LBS.writeFile (unFile file)
+              Nothing -> putLByteString
+          )
+        $ encodePretty scriptCostOutput
+
 runTransactionPolicyIdCmd
   :: ()
   => Cmd.TransactionPolicyIdCmdArgs

cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs

@@ -93,6 +93,7 @@ data TxCmdError
   | TxCmdPoolMetadataHashError AnchorDataFromCertificateError
   | TxCmdHashCheckError L.Url HashCheckError
   | TxCmdUnregisteredStakeAddress !(Set StakeCredential)
+  | forall era. TxCmdAlonzoEraOnwardsRequired !(CardanoEra era)
 
 renderTxCmdError :: TxCmdError -> Doc ann
 renderTxCmdError = \case
@@ -234,6 +235,10 @@ renderTxCmdError = \case
     "Hash of the file is not valid. Url:" <+> pretty (L.urlToText url) <+> prettyException e
   TxCmdUnregisteredStakeAddress credentials ->
     "Stake credential specified in the proposal is not registered on-chain:" <+> pshow credentials
+  TxCmdAlonzoEraOnwardsRequired era ->
+    "This command is only available in the Alonzo era and onwards, since earlier eras do not support scripting. Era requested ("
+      <> pretty era
+      <> ") is not supported."
 
 prettyPolicyIdList :: [PolicyId] -> Doc ann
 prettyPolicyIdList =

cardano-cli/src/Cardano/CLI/Types/Output.hs

@@ -13,7 +13,7 @@ module Cardano.CLI.Types.Output
   , QueryTipLocalStateOutput (..)
   , ScriptCostOutput (..)
   , createOpCertIntervalInfo
-  , renderScriptCosts
+  , renderScriptCostsWithScriptHashesMap
   )
 where
 
@@ -27,7 +27,6 @@ import           Prelude
 
 import           Data.Aeson
 import qualified Data.Aeson.Key as Aeson
-import qualified Data.List as List
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Text (Text)
@@ -352,25 +351,22 @@ instance Error PlutusScriptCostError where
     PlutusScriptCostErrRefInputNotInUTxO txin ->
       "Reference input was not found in utxo: " <> pretty (renderTxIn txin)
 
-renderScriptCosts
-  :: UTxO era
-  -> L.Prices
-  -> [(ScriptWitnessIndex, AnyScriptWitness era)]
-  -- ^ Initial mapping of script witness index to actual script.
+renderScriptCostsWithScriptHashesMap
+  :: L.Prices
+  -> Map ScriptWitnessIndex ScriptHash
+  -- ^ Initial mapping of script witness index to script hash.
   -- We need this in order to know which script corresponds to the
   -- calculated execution units.
   -> Map ScriptWitnessIndex (Either ScriptExecutionError ([Text], ExecutionUnits))
   -- ^ Post execution cost calculation mapping of script witness
   -- index to execution units.
   -> Either PlutusScriptCostError [ScriptCostOutput]
-renderScriptCosts (UTxO utxo) eUnitPrices scriptMapping executionCostMapping =
+renderScriptCostsWithScriptHashesMap eUnitPrices scriptMap executionCostMapping =
   sequenceA $
     Map.foldlWithKey
       ( \accum sWitInd eExecUnits -> do
-          case List.lookup sWitInd scriptMapping of
-            Just (AnyScriptWitness SimpleScriptWitness{}) -> accum
-            Just (AnyScriptWitness (PlutusScriptWitness _ pVer (PScript pScript) _ _ _)) -> do
-              let scriptHash = hashScript $ PlutusScript pVer pScript
+          case Map.lookup sWitInd scriptMap of
+            Just scriptHash -> do
               case eExecUnits of
                 Right (logs, execUnits) ->
                   case calculateExecutionUnitsLovelace eUnitPrices execUnits of
@@ -381,25 +377,6 @@ renderScriptCosts (UTxO utxo) eUnitPrices scriptMapping executionCostMapping =
                       Left (PlutusScriptCostErrRationalExceedsBound logs eUnitPrices execUnits)
                         : accum
                 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) _ _ _)) ->
-              case Map.lookup refTxIn utxo of
-                Nothing -> Left (PlutusScriptCostErrRefInputNotInUTxO refTxIn) : accum
-                Just (TxOut _ _ _ refScript) ->
-                  case refScript of
-                    ReferenceScriptNone -> Left (PlutusScriptCostErrRefInputNoScript refTxIn) : accum
-                    ReferenceScript _ (ScriptInAnyLang _ script) ->
-                      case eExecUnits of
-                        Right (logs, execUnits) ->
-                          case calculateExecutionUnitsLovelace eUnitPrices execUnits of
-                            Just llCost ->
-                              Right (ScriptCostOutput (hashScript script) execUnits llCost)
-                                : accum
-                            Nothing ->
-                              Left (PlutusScriptCostErrRationalExceedsBound logs eUnitPrices execUnits)
-                                : accum
-                        Left err -> Left (PlutusScriptCostErrExecError sWitInd Nothing err) : accum
             Nothing -> Left (PlutusScriptCostErrPlutusScriptNotFound sWitInd) : accum
       )
       []