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

cardano-cli/cardano-cli.cabal

@@ -214,6 +214,9 @@ library
     cardano-crypto-wrapper ^>=1.5.1,
     cardano-data >=1.1,
     cardano-git-rev ^>=0.2.2,
+    cardano-ledger-api,
+    cardano-ledger-alonzo,
+    cardano-ledger-core,
     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,16 @@ data TransactionCalculateMinValueCmdArgs era = TransactionCalculateMinValueCmdAr
   }
   deriving Show
 
+data TransactionCalculatePlutusScriptCostCmdArgs = TransactionCalculatePlutusScriptCostCmdArgs
+  { nodeSocketPath :: !SocketPath
+  , consensusModeParams :: !ConsensusModeParams
+  , networkId :: !NetworkId
+  , txFileIn :: FilePath
+  , outputFile :: !(File () Out)
+  }
+
+-- deriving Show
+
 newtype TransactionHashScriptDataCmdArgs = TransactionHashScriptDataCmdArgs
   { scriptDataOrFile :: ScriptDataOrFile
   }
@@ -264,5 +276,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/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,11 @@ 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, renderScriptCostsWithScriptHashes)
 import           Cardano.CLI.Types.TxFeature
+import qualified Cardano.Ledger.Alonzo.UTxO as Alonzo
+import           Cardano.Ledger.Api (allInputsTxBodyF, bodyTxL)
+import qualified Cardano.Ledger.UTxO as L
 
 import           Control.Monad (forM, unless)
 import           Data.Aeson ((.=))
@@ -97,6 +104,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 +1660,158 @@ 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) <-
+      lift
+        ( executeLocalStateQueryExpr localNodeConnInfo Consensus.VolatileTip $ do
+            eCurrentEra <- queryCurrentEra
+            eSystemStart <- querySystemStart
+            eEraHistory <- queryEraHistory
+            eeUtxo <- queryUtxo txEra (QueryUTxOByTxIn relevantTxIns)
+            return $ do
+              currentEra <- first QceUnsupportedNtcVersion eCurrentEra
+              systemStart <- first QceUnsupportedNtcVersion eSystemStart
+              eraHistory <- first QceUnsupportedNtcVersion eEraHistory
+              utxo <- first QueryEraMismatch =<< first QceUnsupportedNtcVersion eeUtxo
+              return (currentEra, systemStart, eraHistory, utxo)
+        )
+        & onLeft (left . TxCmdQueryConvenienceError . AcqFailure)
+        & onLeft (left . TxCmdQueryConvenienceError)
+
+    Refl <-
+      testEquality nodeEra (convert txEra)
+        & hoistMaybe
+          ( TxCmdTxSubmitErrorEraMismatch $
+              EraMismatch{ledgerEraName = docToText $ pretty nodeEra, otherEraName = docToText $ pretty txEra}
+          )
+
+    pparams <- getProtocolParams sbe localNodeConnInfo
+
+    carryTransactionCalculatePlutusScriptCostCmd
+      (convert txEra)
+      systemStart
+      eraHistory
+      pparams
+      txEraUtxo
+      txBody
+   where
+    getProtocolParams
+      :: ShelleyBasedEra era -> LocalNodeConnectInfo -> ExceptT TxCmdError IO (LedgerProtocolParameters era)
+    getProtocolParams sbe localNodeConnInfo = do
+      let qInMode = QueryInEra $ QueryInShelleyBasedEra sbe Api.QueryProtocolParameters
+      pp <-
+        executeQueryAnyMode localNodeConnInfo qInMode
+          & modifyError TxCmdQueryConvenienceError
+      return $ LedgerProtocolParameters pp
+
+    carryTransactionCalculatePlutusScriptCostCmd
+      :: CardanoEra era
+      -> SystemStart
+      -> EraHistory
+      -> LedgerProtocolParameters era
+      -> UTxO era
+      -> TxBody era
+      -> ExceptT TxCmdError IO ()
+    carryTransactionCalculatePlutusScriptCostCmd 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 $
+            renderScriptCostsWithScriptHashes
+              executionUnitPrices
+              scriptHashes
+              scriptExecUnitsMap
+      liftIO $ LBS.writeFile (unFile outputFile) $ encodePretty scriptCostOutput
+     where
+      collectScriptHashes
+        :: AlonzoEraOnwards era
+        -> TxBody era
+        -> UTxO era
+        -> Map
+            ScriptWitnessIndex
+            ScriptHash
+      collectScriptHashes aeo tb utxo =
+        alonzoEraOnwardsConstraints aeo $
+          let ShelleyTx _ ledgerTx' = makeSignedTransaction [] tb
+              ledgerUTxO = toLedgerUTxO (convert aeo) utxo
+           in getPurpouses aeo $ L.getScriptsNeeded ledgerUTxO (ledgerTx' ^. L.bodyTxL)
+       where
+        getPurpouses
+          :: L.EraCrypto (ShelleyLedgerEra era)
+            ~ L.StandardCrypto
+          => AlonzoEraOnwards era
+          -> Alonzo.AlonzoScriptsNeeded (ShelleyLedgerEra era)
+          -> Map ScriptWitnessIndex Api.ScriptHash
+        getPurpouses aeo' (Alonzo.AlonzoScriptsNeeded purpouses) =
+          alonzoEraOnwardsConstraints aeo $
+            Map.fromList $
+              map (bimap (purpouseToScriptWitnessIndex aeo') fromShelleyScriptHash) purpouses
+
+        purpouseToScriptWitnessIndex
+          :: AlonzoEraOnwards era -> L.PlutusPurpose L.AsIxItem (ShelleyLedgerEra era) -> ScriptWitnessIndex
+        purpouseToScriptWitnessIndex AlonzoEraOnwardsAlonzo purpose =
+          case purpose of
+            L.AlonzoSpending (L.AsIxItem ix _) -> ScriptWitnessIndexTxIn ix
+            L.AlonzoMinting (L.AsIxItem ix _) -> ScriptWitnessIndexMint ix
+            L.AlonzoCertifying (L.AsIxItem ix _) -> ScriptWitnessIndexCertificate ix
+            L.AlonzoRewarding (L.AsIxItem ix _) -> ScriptWitnessIndexWithdrawal ix
+        purpouseToScriptWitnessIndex AlonzoEraOnwardsBabbage purpose =
+          case purpose of
+            L.AlonzoSpending (L.AsIxItem ix _) -> ScriptWitnessIndexTxIn ix
+            L.AlonzoMinting (L.AsIxItem ix _) -> ScriptWitnessIndexMint ix
+            L.AlonzoCertifying (L.AsIxItem ix _) -> ScriptWitnessIndexCertificate ix
+            L.AlonzoRewarding (L.AsIxItem ix _) -> ScriptWitnessIndexWithdrawal ix
+        purpouseToScriptWitnessIndex AlonzoEraOnwardsConway purpose =
+          case purpose of
+            L.ConwaySpending (L.AsIxItem ix _) -> ScriptWitnessIndexTxIn ix
+            L.ConwayMinting (L.AsIxItem ix _) -> ScriptWitnessIndexMint ix
+            L.ConwayCertifying (L.AsIxItem ix _) -> ScriptWitnessIndexCertificate ix
+            L.ConwayRewarding (L.AsIxItem ix _) -> ScriptWitnessIndexWithdrawal ix
+            L.ConwayVoting (L.AsIxItem ix _) -> ScriptWitnessIndexVoting ix
+            L.ConwayProposing (L.AsIxItem ix _) -> ScriptWitnessIndexVoting ix
+
 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
+  , renderScriptCostsWithScriptHashes
   )
 where
 
@@ -404,3 +405,34 @@ renderScriptCosts (UTxO utxo) eUnitPrices scriptMapping executionCostMapping =
       )
       []
       executionCostMapping
+
+renderScriptCostsWithScriptHashes
+  :: 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]
+renderScriptCostsWithScriptHashes eUnitPrices scriptMapping executionCostMapping =
+  sequenceA $
+    Map.foldlWithKey
+      ( \accum sWitInd eExecUnits -> do
+          case Map.lookup sWitInd scriptMapping of
+            Just scriptHash -> do
+              case eExecUnits of
+                Right (logs, execUnits) ->
+                  case calculateExecutionUnitsLovelace eUnitPrices execUnits of
+                    Just llCost ->
+                      Right (ScriptCostOutput scriptHash execUnits llCost)
+                        : accum
+                    Nothing ->
+                      Left (PlutusScriptCostErrRationalExceedsBound logs eUnitPrices execUnits)
+                        : accum
+                Left err -> Left (PlutusScriptCostErrExecError sWitInd (Just scriptHash) err) : accum
+            Nothing -> Left (PlutusScriptCostErrPlutusScriptNotFound sWitInd) : accum
+      )
+      []
+      executionCostMapping