Merge pull request #5127 from IntersectMBO/lehins/plutus-debug-made-pure

lehins · web-flow · commit 4235e1920b52 · 2025-06-17T16:31:44.000-06:00
Pure version of `plutusDebug`
diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md
@@ -2,6 +2,11 @@
 
 ## 1.18.0.0
 
+* Add a timeout argument to `plutusDebug`
+* Add `pdoExUnitsEnforced` to `PlutusDebugOverrides` and add `defaultPlutusDebugOverrides`
+* Add `NFData` instance for `PlutusDebugInfo`
+* Add `DebugTimedOut` constructor to `PlutusDebugInfo`
+* Add `debugPlutusUnbounded`
 * Added `binaryUpgradeTx`, `binaryUpgradeTxBody`, `binaryUpgradeTxWits`, `binaryUpgradeTxAuxData`
 * Remove `upgradeTx` and `TxUpgradeError` from `EraTx`
 * Remove `upgradeTxBody` and `TxBodyUpgradeError` from `EraTxBody`
diff --git a/libs/cardano-ledger-core/app/CLI.hs b/libs/cardano-ledger-core/app/CLI.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE NumericUnderscores #-}
+
 module CLI (
   Opts (..),
   optsParser,
@@ -6,9 +8,11 @@ module CLI (
 import Cardano.Ledger.Binary (mkVersion64)
 import Cardano.Ledger.Plutus.Evaluate
 import Options.Applicative
+import Text.Read (readMaybe)
 
 data Opts = Opts
   { optsScriptWithContext :: !String
+  , optsTimeout :: !Int
   , optsOverrides :: !PlutusDebugOverrides
   }
   deriving (Show)
@@ -19,6 +23,7 @@ overridesParser =
     <$> option
       (Just <$> str)
       ( long "script"
+          <> short 's'
           <> value Nothing
           <> help "Plutus script hex without context"
       )
@@ -32,12 +37,14 @@ overridesParser =
     <*> option
       (Just <$> auto)
       ( long "language"
+          <> short 'l'
           <> value Nothing
           <> help "Plutus language version"
       )
     <*> option
-      (str >>= pure . Just . map read . words)
+      (mapM readMaybe . words <$> str)
       ( long "cost-model-values"
+          <> short 'c'
           <> value Nothing
           <> help ""
       )
@@ -53,10 +60,28 @@ overridesParser =
           <> value Nothing
           <> help ""
       )
+    <*> switch
+      ( long "enforce-execution-units"
+          <> help
+            ( "By default plutus-debug upon a failure will re-evaluate supplied script one more time "
+                <> "without bounding execution in order to report expected execution units. "
+                <> "In case when this unbounded computation is a problem, this flag allows for "
+                <> "disabling this reporting of expected execution units."
+            )
+      )
 
 optsParser :: Parser Opts
 optsParser =
   Opts
-    <$> strArgument
-      (metavar "SCRIPT_WITH_CONTEXT(BASE64)")
+    <$> strArgument (metavar "SCRIPT_WITH_CONTEXT(BASE64)")
+    <*> option
+      auto
+      ( long "timeout"
+          <> short 't'
+          <> value 5_000_000
+          <> help
+            ( "Timeout in number of milliseconds. Default is 5000000 ms (or 5 seconds). "
+                <> "Specifying a negative number will effectively remove the timeout and unbound execution."
+            )
+      )
     <*> overridesParser
diff --git a/libs/cardano-ledger-core/app/PlutusDebug.hs b/libs/cardano-ledger-core/app/PlutusDebug.hs
@@ -20,10 +20,10 @@ main = do
                   <> "and the script itself with the available command line options."
               )
             <> footer
-              ( "EXAMPLE: plutus-debug \"hgmCAVksj...\" --script \"5906ab010...\" "
+              ( "EXAMPLE: plutus-debug \"hgmCAVksj...\" --script \"WQrOAQEAMjI...\" "
                   <> "Note when rewriting the script with the `--script` option "
                   <> "you will have to provide the hex of the Plutus script as seen in "
                   <> "`Test.Cardano.Ledger.Plutus.Examples`."
               )
         )
-  debugPlutus optsScriptWithContext optsOverrides >>= print
+  debugPlutus optsScriptWithContext optsTimeout optsOverrides >>= print
diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Evaluate.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Evaluate.hs
@@ -5,7 +5,6 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE RankNTypes #-}
@@ -18,14 +17,16 @@
 {-# LANGUAGE UndecidableSuperClasses #-}
 
 module Cardano.Ledger.Plutus.Evaluate (
-  PlutusDebugOverrides (..),
   PlutusWithContext (..),
   ScriptFailure (..),
   ScriptResult (..),
   scriptPass,
   scriptFail,
   PlutusDebugInfo (..),
+  PlutusDebugOverrides (..),
+  defaultPlutusDebugOverrides,
   debugPlutus,
+  debugPlutusUnbounded,
   runPlutusScript,
   runPlutusScriptWithLogs,
   evaluatePlutusWithContext,
@@ -66,25 +67,28 @@ import Cardano.Ledger.Plutus.Language (
   withSamePlutusLanguage,
  )
 import Cardano.Ledger.Plutus.TxInfo
-import Control.DeepSeq (NFData (..), force)
-import Control.Exception (evaluate)
-import Control.Monad (join, unless)
+import Codec.Extras.SerialiseViaFlat (DeserialiseFailureInfo (..), DeserialiseFailureReason (..))
+import Control.DeepSeq (NFData (..), deepseq, ($!!))
+import Control.Monad (unless)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Base16 as B16
 import qualified Data.ByteString.Base64 as B64
 import qualified Data.ByteString.Char8 as BSC
 import qualified Data.ByteString.Short as SBS
 import qualified Data.ByteString.UTF8 as BSU
 import Data.Either (fromRight)
+import Data.Functor ((<&>))
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Maybe (fromMaybe)
 import Data.Text (Text, pack)
 import GHC.Generics (Generic)
+import GHC.Stack (HasCallStack)
 import Numeric.Natural (Natural)
 import qualified PlutusLedgerApi.Common as P (
-  EvaluationError (CodecError),
+  EvaluationError (..),
   ExBudget,
+  ScriptDecodeError (..),
   VerboseMode (..),
  )
 import Prettyprinter (Pretty (..))
@@ -231,20 +235,80 @@ data PlutusDebugInfo
       -- be executed within 5 second limit or there is a problem with decoding plutus script
       -- itself.
       (Maybe P.ExBudget)
+  | -- | Script did not terminate within the imposed limit
+    DebugTimedOut
+      -- | Wall clock limit in microseconds that was imposed on the script execution.
+      Int
   deriving (Show)
 
+instance NFData PlutusDebugInfo where
+  rnf = \case
+    DebugBadHex str -> rnf str
+    DebugCannotDecode str -> rnf str
+    DebugSuccess logs exBudget -> logs `deepseq` rnf exBudget
+    DebugFailure logs evalError pwc mExBudget ->
+      let
+        -- TODO: Upstream `NFData` instance for `EvaluationError`
+        seqEvalError = \case
+          P.CekError exc -> deepseq exc
+          P.DeBruijnError err -> deepseq err
+          P.CodecError err -> deepseqCodecError err
+          P.CostModelParameterMismatch -> id
+          P.InvalidReturnValue -> id
+        -- TODO: Upstream `NFData` instance for `CodecError` and `MajorProtocolVersion`
+        deepseqCodecError = \case
+          P.CBORDeserialiseError failureInfo -> deepseqDeserialiseFailureInfo failureInfo
+          P.RemainderError bsl -> deepseq bsl
+          P.LedgerLanguageNotAvailableError pll ipv tpv -> pll `deepseq` ipv `seq` (tpv `seq`)
+          P.PlutusCoreLanguageNotAvailableError pll ipv tpv -> pll `deepseq` ipv `seq` (tpv `seq`)
+        -- TODO: Upstream `NFData` instance for `DeserialiseFailureInfo`
+        deepseqDeserialiseFailureInfo = \case
+          DeserialiseFailureInfo bo reason ->
+            bo `deepseq`
+              ( -- TODO: Upstream `NFData` instance for `DeserialiseFailureReason`
+                case reason of
+                  EndOfInput -> id
+                  ExpectedBytes -> id
+                  OtherReason str -> deepseq str
+              )
+       in
+        logs `deepseq` evalError `seqEvalError` pwc `deepseq` rnf mExBudget
+    DebugTimedOut t -> rnf t
+
+-- | Various overrides that can be supplied to `plutusDebug` and `plutusDebugUnbouded`
 data PlutusDebugOverrides = PlutusDebugOverrides
   { pdoScript :: !(Maybe ByteString)
+  -- ^ Hex encoded version of the script
   , pdoProtocolVersion :: !(Maybe Version)
+  -- ^ Protocol version to be used for decoding and exection
   , pdoLanguage :: !(Maybe Language)
+  -- ^ Plutus ledger language version
   , pdoCostModelValues :: !(Maybe [Int64])
+  -- ^ Cost model to be used for deciding execution units
   , pdoExUnitsMem :: !(Maybe Natural)
+  -- ^ Memory execution units to be used for execution
   , pdoExUnitsSteps :: !(Maybe Natural)
+  -- ^ CPU execution units to be used for execution
+  , pdoExUnitsEnforced :: !Bool
+  -- ^ Setting this flag to True will disable reporting expected execution units upon a failure,
+  -- which would protect against a potentially unbounded script execution.
   }
   deriving (Show)
 
+defaultPlutusDebugOverrides :: PlutusDebugOverrides
+defaultPlutusDebugOverrides =
+  PlutusDebugOverrides
+    { pdoScript = Nothing
+    , pdoProtocolVersion = Nothing
+    , pdoLanguage = Nothing
+    , pdoCostModelValues = Nothing
+    , pdoExUnitsMem = Nothing
+    , pdoExUnitsSteps = Nothing
+    , pdoExUnitsEnforced = False
+    }
+
 -- TODO: Add support for overriding arguments.
-overrideContext :: PlutusWithContext -> PlutusDebugOverrides -> PlutusWithContext
+overrideContext :: HasCallStack => PlutusWithContext -> PlutusDebugOverrides -> PlutusWithContext
 overrideContext PlutusWithContext {..} PlutusDebugOverrides {..} =
   -- NOTE: due to GADTs, we can't do a record update here and need to
   -- copy all the fields. Otherwise GHC will greet us with
@@ -254,6 +318,7 @@ overrideContext PlutusWithContext {..} PlutusDebugOverrides {..} =
     , pwcScript = overrideScript
     , pwcExUnits = overrideExUnits
     , pwcCostModel = overrideCostModel
+    , pwcScriptHash = overrideSriptHash
     , ..
     }
   where
@@ -266,38 +331,52 @@ overrideContext PlutusWithContext {..} PlutusDebugOverrides {..} =
         mkCostModel
           (fromMaybe (getCostModelLanguage pwcCostModel) pdoLanguage)
           (fromMaybe (getCostModelParams pwcCostModel) pdoCostModelValues)
-    overrideScript =
+    (overrideSriptHash, overrideScript) =
       case pdoScript of
-        Nothing -> pwcScript
-        Just script ->
-          either error (Left . Plutus . PlutusBinary . SBS.toShort) . B16.decode $ BSC.filter (/= '\n') script
+        Nothing -> (pwcScriptHash, pwcScript)
+        Just hexScript ->
+          case Plutus . PlutusBinary . SBS.toShort <$> B16.decode (BSC.filter (/= '\n') hexScript) of
+            Left err -> error $ "Failed hex decoding of the custom script: " <> err
+            Right script -> (hashPlutusScript script, Left script)
+
+-- | Execute a hex encoded script with the context that was produced within the ledger predicate
+-- failure. Using `PlutusDebugOverrides` it is possible to override any part of the execution.
+debugPlutus :: HasCallStack => String -> Int -> PlutusDebugOverrides -> IO PlutusDebugInfo
+debugPlutus scriptsWithContext limit opts =
+  timeout limit (pure $!! debugPlutusUnbounded scriptsWithContext opts)
+    <&> \case
+      Nothing -> DebugTimedOut limit
+      Just res -> res
 
-debugPlutus :: String -> PlutusDebugOverrides -> IO PlutusDebugInfo
-debugPlutus scriptsWithContext opts =
+-- | This is just like `debugPlutus`, except it is pure and if a supplied script contains an
+-- infinite loop or a very expensive computation, it might not terminate within a reasonable
+-- timeframe.
+debugPlutusUnbounded :: HasCallStack => String -> PlutusDebugOverrides -> PlutusDebugInfo
+debugPlutusUnbounded scriptsWithContext opts =
   case B64.decode (BSU.fromString scriptsWithContext) of
-    Left e -> pure $ DebugBadHex (show e)
+    Left e -> DebugBadHex e
     Right bs ->
       case Plain.decodeFull' bs of
-        Left e -> pure $ DebugCannotDecode $ show e
+        Left e -> DebugCannotDecode $ show e
         Right pwcOriginal ->
           let pwc = overrideContext pwcOriginal opts
               cm = getEvaluationContext $ pwcCostModel pwc
               eu = transExUnits $ pwcExUnits pwc
-              onDecoderError err = pure $ DebugFailure [] err pwc Nothing
+              onDecoderError err = DebugFailure [] err pwc Nothing
            in withRunnablePlutusWithContext pwc onDecoderError $ \plutusRunnable args ->
-                let toDebugInfo = \case
-                      (logs, Left err@(P.CodecError {})) -> pure $ DebugFailure logs err pwc Nothing
-                      (logs, Left err) -> do
-                        mExpectedExUnits <-
-                          timeout 5_000_000 $ do
-                            let res =
-                                  evaluatePlutusRunnableBudget (pwcProtocolVersion pwc) P.Verbose cm plutusRunnable args
-                            case snd res of
-                              Left {} -> pure Nothing
-                              Right exUnits -> Just <$> evaluate (force exUnits)
-                        pure $ DebugFailure logs err pwc (join mExpectedExUnits)
-                      (logs, Right ex) -> pure $ DebugSuccess logs ex
-                 in toDebugInfo $
+                let toDebugInfo logs = \case
+                      Left err@(P.CodecError {}) -> DebugFailure logs err pwc Nothing
+                      Left err | pdoExUnitsEnforced opts -> DebugFailure logs err pwc Nothing
+                      Left err ->
+                        let res =
+                              evaluatePlutusRunnableBudget (pwcProtocolVersion pwc) P.Verbose cm plutusRunnable args
+                            mExpectedExUnits =
+                              case snd res of
+                                Left {} -> Nothing
+                                Right exUnits -> Just exUnits
+                         in DebugFailure logs err pwc mExpectedExUnits
+                      Right ex -> DebugSuccess logs ex
+                 in uncurry toDebugInfo $
                       evaluatePlutusRunnable (pwcProtocolVersion pwc) P.Verbose cm eu plutusRunnable args
 
 runPlutusScript :: PlutusWithContext -> ScriptResult

Original file line number	Diff line number	Diff line change
`@@ -20,10 +20,10 @@ main = do`
`20`	`20`	`<> "and the script itself with the available command line options."`
`21`	`21`	`)`
`22`	`22`	`<> footer`
`23`		`- ( "EXAMPLE: plutus-debug \"hgmCAVksj...\" --script \"5906ab010...\" "`
	`23`	`+ ( "EXAMPLE: plutus-debug \"hgmCAVksj...\" --script \"WQrOAQEAMjI...\" "`
`24`	`24`	<> "Note when rewriting the script with the `--script` option "
`25`	`25`	`<> "you will have to provide the hex of the Plutus script as seen in "`
`26`	`26`	<> "`Test.Cardano.Ledger.Plutus.Examples`."
`27`	`27`	`)`
`28`	`28`	`)`
`29`		`- debugPlutus optsScriptWithContext optsOverrides >>= print`
	`29`	`+ debugPlutus optsScriptWithContext optsTimeout optsOverrides >>= print`