Merge pull request #4776 from IntersectMBO/ldan/plutus-debug-cli

Create CLI for `plutus-debug`

hie.yaml

@@ -231,6 +231,9 @@ cradle:
     - path: "libs/cardano-ledger-core/app/PlutusDebug.hs"
       component: "cardano-ledger-core:exe:plutus-debug"
 
+    - path: "libs/cardano-ledger-core/app/CLI.hs"
+      component: "cardano-ledger-core:exe:plutus-debug"
+
     - path: "libs/cardano-ledger-core/test"
       component: "cardano-ledger-core:test:tests"
 

libs/cardano-ledger-core/CHANGELOG.md

@@ -2,6 +2,9 @@
 
 ## 1.16.0.0
 
+* Add `PlutusDebugOverrides` argument to `debugPlutus`
+* Add `PlutusDebugOverrides` data type
+* Add `Read` instance for `Language`
 * Add `toVRFVerKeyHash` and `fromVRFVerKeyHash`
 * Change lens type of `hkdNOptL`, `ppNOptL`, and `ppuNOptL` to `Word16`
 * Add `epochFromSlot`

libs/cardano-ledger-core/app/CLI.hs

@@ -0,0 +1,62 @@
+module CLI (
+  Opts (..),
+  optsParser,
+) where
+
+import Cardano.Ledger.Binary (mkVersion64)
+import Cardano.Ledger.Plutus.Evaluate
+import Options.Applicative
+
+data Opts = Opts
+  { optsScriptWithContext :: !String
+  , optsOverrides :: !PlutusDebugOverrides
+  }
+  deriving (Show)
+
+overridesParser :: Parser PlutusDebugOverrides
+overridesParser =
+  PlutusDebugOverrides
+    <$> option
+      (Just <$> str)
+      ( long "script"
+          <> value Nothing
+          <> help "Plutus script hex without context"
+      )
+    <*> option
+      (mkVersion64 <$> auto)
+      ( long "protocol-version"
+          <> short 'v'
+          <> value Nothing
+          <> help "Major protocol version"
+      )
+    <*> option
+      (Just <$> auto)
+      ( long "language"
+          <> value Nothing
+          <> help "Plutus language version"
+      )
+    <*> option
+      (str >>= pure . Just . map read . words)
+      ( long "cost-model-values"
+          <> value Nothing
+          <> help ""
+      )
+    <*> option
+      (Just <$> auto)
+      ( long "execution-units-memory"
+          <> value Nothing
+          <> help ""
+      )
+    <*> option
+      (Just <$> auto)
+      ( long "execution-units-steps"
+          <> value Nothing
+          <> help ""
+      )
+
+optsParser :: Parser Opts
+optsParser =
+  Opts
+    <$> strArgument
+      (metavar "SCRIPT_WITH_CONTEXT(BASE64)")
+    <*> overridesParser

libs/cardano-ledger-core/app/PlutusDebug.hs

@@ -1,11 +1,31 @@
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Main where
 
+import CLI
 import Cardano.Ledger.Crypto (StandardCrypto)
-import Cardano.Ledger.Plutus.Evaluate (debugPlutus)
-import Control.Monad ((<=<))
-import System.Environment (getArgs)
+import Cardano.Ledger.Plutus.Evaluate
+import Options.Applicative
 
 main :: IO ()
-main = mapM_ (print <=< debugPlutus @StandardCrypto) =<< getArgs
+main = do
+  Opts {..} <-
+    execParser $
+      info
+        (optsParser <* abortOption (ShowHelpText Nothing) (long "help"))
+        ( header "plutus-debug - A Plutus script debugger"
+            <> progDesc
+              ( "The purpose of this tool is to troubleshoot failing Plutus scripts. "
+                  <> "When you encounter a `PlutusFailure`, you can pass the `Base64-encoded script bytes` "
+                  <> "to `plutus-debug` for debugging purposes and override the context of the failed script "
+                  <> "and the script itself with the available command line options."
+              )
+            <> footer
+              ( "EXAMPLE: plutus-debug \"hgmCAVksj...\" --script \"5906ab010...\" "
+                  <> "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 @StandardCrypto optsScriptWithContext optsOverrides >>= print

libs/cardano-ledger-core/cardano-ledger-core.cabal

@@ -219,6 +219,9 @@ library testlib
 executable plutus-debug
   main-is: PlutusDebug.hs
   hs-source-dirs: app
+  other-modules:
+    CLI
+
   default-language: Haskell2010
   ghc-options:
     -Wall
@@ -234,7 +237,9 @@ executable plutus-debug
 
   build-depends:
     base >=4.14 && <5,
+    cardano-ledger-binary,
     cardano-ledger-core,
+    optparse-applicative,
 
 test-suite tests
   type: exitcode-stdio-1.0

libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Evaluate.hs

@@ -18,6 +18,7 @@
 {-# LANGUAGE UndecidableSuperClasses #-}
 
 module Cardano.Ledger.Plutus.Evaluate (
+  PlutusDebugOverrides (..),
   PlutusWithContext (..),
   ScriptFailure (..),
   ScriptResult (..),
@@ -48,11 +49,16 @@ import Cardano.Ledger.Plutus.CostModels (
   CostModel,
   decodeCostModel,
   encodeCostModel,
+  getCostModelLanguage,
+  getCostModelParams,
   getEvaluationContext,
+  mkCostModel,
  )
-import Cardano.Ledger.Plutus.ExUnits (ExUnits)
+import Cardano.Ledger.Plutus.ExUnits (ExUnits (..))
 import Cardano.Ledger.Plutus.Language (
+  Language,
   Plutus (..),
+  PlutusBinary (..),
   PlutusLanguage (..),
   PlutusRunnable (..),
   decodeWithPlutus,
@@ -65,13 +71,24 @@ import Cardano.Ledger.Plutus.TxInfo
 import Control.DeepSeq (NFData (..), force)
 import Control.Exception (evaluate)
 import Control.Monad (join, 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.Int (Int64)
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Maybe (fromMaybe)
 import Data.Text (Text, pack)
 import GHC.Generics (Generic)
-import PlutusLedgerApi.Common as P (EvaluationError (CodecError), ExBudget, VerboseMode (..))
+import Numeric.Natural (Natural)
+import qualified PlutusLedgerApi.Common as P (
+  EvaluationError (CodecError),
+  ExBudget,
+  VerboseMode (..),
+ )
 import Prettyprinter (Pretty (..))
 import System.Timeout (timeout)
 
@@ -80,7 +97,7 @@ data PlutusWithContext c where
   PlutusWithContext ::
     PlutusLanguage l =>
     { pwcProtocolVersion :: !Version
-    -- ^ Mayjor protocol version that is necessary for [de]serialization
+    -- ^ Major protocol version that is necessary for [de]serialization
     , pwcScript :: !(Either (Plutus l) (PlutusRunnable l))
     -- ^ Actual plutus script that will be evaluated. Script is allowed to be in two forms:
     -- serialized and deserialized. This is necesary for implementing the opptimization
@@ -218,16 +235,56 @@ data PlutusDebugInfo c
       (Maybe P.ExBudget)
   deriving (Show)
 
-debugPlutus :: Crypto c => String -> IO (PlutusDebugInfo c)
-debugPlutus db =
-  case B64.decode (BSU.fromString db) of
+data PlutusDebugOverrides = PlutusDebugOverrides
+  { pdoScript :: !(Maybe ByteString)
+  , pdoProtocolVersion :: !(Maybe Version)
+  , pdoLanguage :: !(Maybe Language)
+  , pdoCostModelValues :: !(Maybe [Int64])
+  , pdoExUnitsMem :: !(Maybe Natural)
+  , pdoExUnitsSteps :: !(Maybe Natural)
+  }
+  deriving (Show)
+
+-- TODO: Add support for overriding arguments.
+overrideContext :: PlutusWithContext c -> PlutusDebugOverrides -> PlutusWithContext c
+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
+  -- `Record update for insufficiently polymorphic field...` error
+  PlutusWithContext
+    { pwcProtocolVersion = fromMaybe pwcProtocolVersion pdoProtocolVersion
+    , pwcScript = overrideScript
+    , pwcExUnits = overrideExUnits
+    , pwcCostModel = overrideCostModel
+    , ..
+    }
+  where
+    overrideExUnits =
+      ExUnits
+        (fromMaybe (exUnitsMem pwcExUnits) pdoExUnitsMem)
+        (fromMaybe (exUnitsSteps pwcExUnits) pdoExUnitsSteps)
+    overrideCostModel =
+      fromRight pwcCostModel $
+        mkCostModel
+          (fromMaybe (getCostModelLanguage pwcCostModel) pdoLanguage)
+          (fromMaybe (getCostModelParams pwcCostModel) pdoCostModelValues)
+    overrideScript =
+      case pdoScript of
+        Nothing -> pwcScript
+        Just script ->
+          either error (Left . Plutus . PlutusBinary . SBS.toShort) . B16.decode $ BSC.filter (/= '\n') script
+
+debugPlutus :: Crypto c => String -> PlutusDebugOverrides -> IO (PlutusDebugInfo c)
+debugPlutus scriptsWithContext opts =
+  case B64.decode (BSU.fromString scriptsWithContext) of
     Left e -> pure $ DebugBadHex (show e)
     Right bs ->
       case Plain.decodeFull' bs of
         Left e -> pure $ DebugCannotDecode $ show e
-        Right pwc@(PlutusWithContext {..}) ->
-          let cm = getEvaluationContext pwcCostModel
-              eu = transExUnits pwcExUnits
+        Right pwcOriginal ->
+          let pwc = overrideContext pwcOriginal opts
+              cm = getEvaluationContext $ pwcCostModel pwc
+              eu = transExUnits $ pwcExUnits pwc
               onDecoderError err = pure $ DebugFailure [] err pwc Nothing
            in withRunnablePlutusWithContext pwc onDecoderError $ \plutusRunnable args ->
                 let toDebugInfo = \case
@@ -236,14 +293,14 @@ debugPlutus db =
                         mExpectedExUnits <-
                           timeout 5_000_000 $ do
                             let res =
-                                  evaluatePlutusRunnableBudget pwcProtocolVersion P.Verbose cm plutusRunnable args
+                                  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 $
-                      evaluatePlutusRunnable pwcProtocolVersion P.Verbose cm eu plutusRunnable args
+                      evaluatePlutusRunnable (pwcProtocolVersion pwc) P.Verbose cm eu plutusRunnable args
 
 runPlutusScript :: PlutusWithContext c -> ScriptResult c
 runPlutusScript = snd . runPlutusScriptWithLogs

libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Language.hs

@@ -226,7 +226,7 @@ data Language
   = PlutusV1
   | PlutusV2
   | PlutusV3
-  deriving (Eq, Generic, Show, Ord, Enum, Bounded, Ix)
+  deriving (Eq, Generic, Show, Ord, Enum, Bounded, Ix, Read)
 
 instance NoThunks Language
 

libs/plutus-preprocessor/plutus-preprocessor.cabal

@@ -42,7 +42,7 @@ library
     bytestring,
     cardano-ledger-binary:testlib,
     cardano-ledger-core,
-    plutus-ledger-api >=1.37,
+    plutus-ledger-api ^>=1.37,
     plutus-tx,
     plutus-tx-plugin,
     template-haskell,