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

cabal.project

@@ -10,6 +10,13 @@ repository cardano-haskell-packages
     c00aae8461a256275598500ea0e187588c35a5d5d7454fb57eac18d9edb86a56
     d4a35cd3121aa00d18544bb0ac01c3e1691d618f462c46129271bccf39f7e8ee
 
+source-repository-package
+  type: git
+  location: https://github.com/IntersectMBO/cardano-api
+  tag: 99577e1b1853a189a788f56536cf452a604b2022
+  --sha256: sha256-EwbEX25xCScsWIrOwLhJg0yqHbZnLk+OamTg8UpnZxw=
+  subdir: cardano-api
+
 -- See CONTRIBUTING for information about these, including some Nix commands
 -- you need to run if you change them
 index-state:

cardano-cli/cardano-cli.cabal

@@ -214,6 +214,7 @@ library
     cardano-crypto-wrapper ^>=1.5.1,
     cardano-data >=1.1,
     cardano-git-rev ^>=0.2.2,
+    cardano-ledger-api,
     cardano-ping ^>=0.5,
     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 (..)
@@ -42,6 +43,7 @@ data TransactionCmds era
   | TransactionPolicyIdCmd !TransactionPolicyIdCmdArgs
   | TransactionCalculateMinFeeCmd !TransactionCalculateMinFeeCmdArgs
   | TransactionCalculateMinValueCmd !(TransactionCalculateMinValueCmdArgs era)
+  | TransactionCalculatePlutusScriptCostCmd !TransactionCalculatePlutusScriptCostCmdArgs
   | TransactionHashScriptDataCmd !TransactionHashScriptDataCmdArgs
   | TransactionTxIdCmd !TransactionTxIdCmdArgs
 
@@ -238,6 +240,14 @@ data TransactionCalculateMinValueCmdArgs era = TransactionCalculateMinValueCmdAr
   }
   deriving Show
 
+data TransactionCalculatePlutusScriptCostCmdArgs = TransactionCalculatePlutusScriptCostCmdArgs
+  { nodeSocketPath :: !SocketPath
+  , consensusModeParams :: !ConsensusModeParams
+  , networkId :: !NetworkId
+  , txFileIn :: FilePath
+  , outputFile :: !(File () Out)
+  }
+
 newtype TransactionHashScriptDataCmdArgs = TransactionHashScriptDataCmdArgs
   { scriptDataOrFile :: ScriptDataOrFile
   }
@@ -264,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

@@ -1405,7 +1405,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
   :: ShelleyBasedEra era

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" $
@@ -365,6 +369,19 @@ pTransactionCalculateMinReqUTxO era' =
       <$> pProtocolParamsFile
       <*> pTxOutShelleyBased
 
+pTransactionCalculatePlutusScriptCost :: EnvCli -> Parser (TransactionCmds era)
+pTransactionCalculatePlutusScriptCost envCli =
+  fmap TransactionCalculatePlutusScriptCostCmd $
+    TransactionCalculatePlutusScriptCostCmdArgs
+      <$> pSocketPath envCli
+      <*> pConsensusModeParams
+      <*> pNetworkId envCli
+      <*> pTxInputFile
+      <*> 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
@@ -59,8 +63,9 @@ 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 (renderScriptCosts, renderScriptCostsWithScriptHashesMap)
 import           Cardano.CLI.Types.TxFeature
+import           Cardano.Ledger.Api (allInputsTxBodyF, bodyTxL)
 
 import           Control.Monad (forM, unless)
 import           Data.Aeson ((.=))
@@ -97,6 +102,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
@@ -1652,6 +1658,102 @@ runTransactionCalculateMinValueCmd
     let minValue = calculateMinimumUTxO eon out pp
     liftIO . IO.print $ minValue
 
+runTransactionCalculatePlutusScriptCostCmd
+  :: Cmd.TransactionCalculatePlutusScriptCostCmdArgs -> ExceptT TxCmdError IO ()
+runTransactionCalculatePlutusScriptCostCmd
+  Cmd.TransactionCalculatePlutusScriptCostCmdArgs
+    { nodeSocketPath
+    , consensusModeParams
+    , networkId = networkId
+    , txFileIn
+    , outputFile
+    } = do
+    txFileOrPipeIn <- liftIO $ fileOrPipe txFileIn
+    InAnyShelleyBasedEra txEra tx@(ShelleyTx sbe ledgerTx) <-
+      liftIO (readFileTx txFileOrPipeIn) & onLeft (left . TxCmdTextEnvCddlError)
+
+    let localNodeConnInfo =
+          LocalNodeConnectInfo
+            { localConsensusModeParams = consensusModeParams
+            , localNodeNetworkId = networkId
+            , localNodeSocketPath = nodeSocketPath
+            }
+
+        relevantTxIns :: Set TxIn
+        relevantTxIns = Set.map fromShelleyTxIn $ shelleyBasedEraConstraints sbe (ledgerTx ^. bodyTxL . allInputsTxBodyF)
+
+        txBody = getTxBody tx
+
+    (AnyCardanoEra nodeEra, systemStart, eraHistory, txEraUtxo, pparams) <-
+      lift
+        ( executeLocalStateQueryExpr localNodeConnInfo 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
+      txBody
+   where
+    calculatePlutusScriptsCosts
+      :: CardanoEra era
+      -> SystemStart
+      -> EraHistory
+      -> LedgerProtocolParameters era
+      -> UTxO era
+      -> TxBody era
+      -> ExceptT TxCmdError IO ()
+    calculatePlutusScriptsCosts era' systemStart eraHistory pparams txEraUtxo txBody = do
+      scriptHashes <-
+        monoidForEraInEon @AlonzoEraOnwards era' (\aeo -> pure $ collectScriptHashes aeo txBody txEraUtxo)
+          & hoistMaybe (TxCmdAlonzoEraOnwardsRequired era')
+
+      executionUnitPrices <-
+        pure (getExecutionUnitPrices era' pparams) & onNothing (left TxCmdPParamExecutionUnitsNotAvailable)
+
+      scriptExecUnitsMap <-
+        firstExceptT (TxCmdTxExecUnitsErr . AnyTxCmdTxExecUnitsErr) $
+          hoistEither $
+            evaluateTransactionExecutionUnits
+              era'
+              systemStart
+              (toLedgerEpochInfo eraHistory)
+              pparams
+              txEraUtxo
+              txBody
+
+      scriptCostOutput <-
+        firstExceptT TxCmdPlutusScriptCostErr $
+          hoistEither $
+            renderScriptCostsWithScriptHashesMap
+              executionUnitPrices
+              scriptHashes
+              scriptExecUnitsMap
+      liftIO $ LBS.writeFile (unFile outputFile) $ encodePretty scriptCostOutput
+
 runTransactionPolicyIdCmd
   :: ()
   => Cmd.TransactionPolicyIdCmdArgs

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

@@ -92,6 +92,7 @@ data TxCmdError
   | TxCmdPoolMetadataHashError AnchorDataFromCertificateError
   | TxCmdHashCheckError L.Url HashCheckError
   | TxCmdUnregisteredStakeAddress !(Set StakeCredential)
+  | forall era. TxCmdAlonzoEraOnwardsRequired !(CardanoEra era)
 
 renderTxCmdError :: TxCmdError -> Doc ann
 renderTxCmdError = \case
@@ -233,6 +234,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

@@ -14,6 +14,7 @@ module Cardano.CLI.Types.Output
   , ScriptCostOutput (..)
   , createOpCertIntervalInfo
   , renderScriptCosts
+  , renderScriptCostsWithScriptHashesMap
   )
 where
 
@@ -27,7 +28,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)
@@ -363,14 +363,65 @@ renderScriptCosts
   -- ^ Post execution cost calculation mapping of script witness
   -- index to execution units.
   -> Either PlutusScriptCostError [ScriptCostOutput]
-renderScriptCosts (UTxO utxo) eUnitPrices scriptMapping executionCostMapping =
+renderScriptCosts (UTxO utxo) eUnitPrices scriptMapping =
+  renderScriptCostsWithScriptHashesFunc eUnitPrices getHashForScriptWitnessIndex
+ where
+  getHashForScriptWitnessIndex
+    :: ScriptWitnessIndex -> Either PlutusScriptCostError (Maybe ScriptHash)
+  getHashForScriptWitnessIndex sWitInd = case lookup sWitInd scriptMapping of
+    Nothing -> Left (PlutusScriptCostErrPlutusScriptNotFound sWitInd)
+    Just script -> anyScriptWitnessToHash script
+
+  anyScriptWitnessToHash :: AnyScriptWitness era -> Either PlutusScriptCostError (Maybe ScriptHash)
+  anyScriptWitnessToHash = \case
+    AnyScriptWitness SimpleScriptWitness{} -> Right Nothing
+    AnyScriptWitness (PlutusScriptWitness _ pVer (PScript pScript) _ _ _) ->
+      Right $ Just $ hashScript $ PlutusScript pVer pScript
+    AnyScriptWitness (PlutusScriptWitness _ _ (PReferenceScript refTxIn) _ _ _) ->
+      case Map.lookup refTxIn utxo of
+        Nothing -> Left (PlutusScriptCostErrRefInputNotInUTxO refTxIn)
+        Just (TxOut _ _ _ refScript) ->
+          case refScript of
+            ReferenceScriptNone -> Left (PlutusScriptCostErrRefInputNoScript refTxIn)
+            ReferenceScript _ (ScriptInAnyLang _ script) ->
+              Right $ Just $ hashScript 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]
+renderScriptCostsWithScriptHashesMap eUnitPrices scriptMapping = renderScriptCostsWithScriptHashesFunc eUnitPrices scriptMappingFunction
+ where
+  scriptMappingFunction witScriptIdx =
+    maybe
+      (Left $ PlutusScriptCostErrPlutusScriptNotFound witScriptIdx)
+      (Right . Just)
+      (Map.lookup witScriptIdx scriptMapping)
+
+renderScriptCostsWithScriptHashesFunc
+  :: L.Prices
+  -> (ScriptWitnessIndex -> Either PlutusScriptCostError (Maybe 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. Left is an error, Right Nothing
+  -- means that the script is not a Plutus script, so it is not meant
+  -- to be found, Right (Just scriptHash) is the script hash.
+  -> Map ScriptWitnessIndex (Either ScriptExecutionError ([Text], ExecutionUnits))
+  -- ^ Post execution cost calculation mapping of script witness
+  -- index to execution units.
+  -> Either PlutusScriptCostError [ScriptCostOutput]
+renderScriptCostsWithScriptHashesFunc eUnitPrices scriptMapping 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 scriptMapping sWitInd of
+            Right (Just scriptHash) -> do
               case eExecUnits of
                 Right (logs, execUnits) ->
                   case calculateExecutionUnitsLovelace eUnitPrices execUnits of
@@ -381,26 +432,8 @@ 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
+            Right Nothing -> accum
+            Left err -> Left err : accum
       )
       []
       executionCostMapping