diff --git a/libs/cardano-ledger-core/app/CLI.hs b/libs/cardano-ledger-core/app/CLI.hs new file mode 100644 index 00000000000..899cab0f7a9 --- /dev/null +++ b/libs/cardano-ledger-core/app/CLI.hs @@ -0,0 +1,62 @@ +module CLI where + +import Cardano.Ledger.Binary (Version, mkVersion64) +import Cardano.Ledger.Plutus.Language (Language) +import Data.ByteString (ByteString) +import Data.Int (Int64) +import Numeric.Natural (Natural) +import Options.Applicative + +data Opts = Opts + { optsScriptWithContext :: !String + , optsScript :: !(Maybe ByteString) + , optsProtocolVersion :: !(Maybe Version) + , optsLanguage :: !(Maybe Language) + , optsCostModelValues :: !(Maybe [Int64]) + , optsExUnitsMem :: !(Maybe Natural) + , optsExUnitsSteps :: !(Maybe Natural) + } + deriving (Show) + +optsParser :: Parser Opts +optsParser = + Opts + <$> strArgument + (metavar "SCRIPT_WITH_CONTEXT(BASE64)") + <*> option + (Just <$> str) + ( long "script" + <> value Nothing + <> help "Plutus script" + ) + <*> 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 "" + ) diff --git a/libs/cardano-ledger-core/app/PlutusDebug.hs b/libs/cardano-ledger-core/app/PlutusDebug.hs index d597e413b04..ee4dcfa4486 100644 --- a/libs/cardano-ledger-core/app/PlutusDebug.hs +++ b/libs/cardano-ledger-core/app/PlutusDebug.hs @@ -1,11 +1,114 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} module Main where -import Cardano.Ledger.Crypto (StandardCrypto) -import Cardano.Ledger.Plutus.Evaluate (debugPlutus) -import Control.Monad ((<=<)) -import System.Environment (getArgs) +import CLI +import qualified Cardano.Ledger.Binary.Plain as Plain +import Cardano.Ledger.Crypto (Crypto, StandardCrypto) +import Cardano.Ledger.Plutus.CostModels ( + getCostModelLanguage, + getCostModelParams, + getEvaluationContext, + mkCostModel, + ) +import Cardano.Ledger.Plutus.Evaluate +import Cardano.Ledger.Plutus.ExUnits (ExUnits (..)) +import Cardano.Ledger.Plutus.Language ( + Plutus (..), + PlutusBinary (..), + PlutusLanguage (..), + ) +import Cardano.Ledger.Plutus.TxInfo +import Control.DeepSeq (force) +import Control.Exception (evaluate) +import Control.Monad (join) +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.Maybe (fromMaybe) +import Options.Applicative +import PlutusLedgerApi.Common as P +import System.Timeout (timeout) + +overrideContext :: PlutusWithContext c -> Opts -> PlutusWithContext c +overrideContext pwc@(PlutusWithContext {..}) Opts {..} = + pwc + { pwcProtocolVersion = fromMaybe pwcProtocolVersion optsProtocolVersion + , pwcScript = overrideScript + , pwcExUnits = overrideExUnits + , pwcCostModel = overrideCostModel + , -- TODO: Add support for overriding arguments. + -- Also note that this is needed in order to make GHC happy. + -- Due to the `PlutusLanguage l` constraint in `PlutusWithContext` + -- where `l` is an existential, without the line below GHC won't be able to + -- tell that the `l` before the record update is the same as the `l` after + -- the record update. + pwcArgs + } + where + overrideExUnits = + ExUnits + (fromMaybe (exUnitsMem pwcExUnits) optsExUnitsMem) + (fromMaybe (exUnitsSteps pwcExUnits) optsExUnitsSteps) + overrideCostModel = + fromRight pwcCostModel $ + mkCostModel + (fromMaybe (getCostModelLanguage pwcCostModel) optsLanguage) + (fromMaybe (getCostModelParams pwcCostModel) optsCostModelValues) + overrideScript = + case optsScript of + Nothing -> pwcScript + Just script -> + either error (Left . Plutus . PlutusBinary . SBS.toShort) . B16.decode $ BSC.filter (/= '\n') script + +debugPlutus :: Crypto c => Opts -> IO (PlutusDebugInfo c) +debugPlutus opts@Opts {..} = + case B64.decode (BSU.fromString optsScriptWithContext) of + Left e -> pure $ DebugBadHex (show e) + Right bs -> + case Plain.decodeFull' bs of + Left e -> pure $ 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 + 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 $ + evaluatePlutusRunnable (pwcProtocolVersion pwc) P.Verbose cm eu plutusRunnable args 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 various parts of the failed script " + <> "with the available command line options." + ) + <> footer "" + ) + debugPlutus @StandardCrypto opts >>= print diff --git a/libs/cardano-ledger-core/cardano-ledger-core.cabal b/libs/cardano-ledger-core/cardano-ledger-core.cabal index 4d5ccb5bbf9..c90165407c2 100644 --- a/libs/cardano-ledger-core/cardano-ledger-core.cabal +++ b/libs/cardano-ledger-core/cardano-ledger-core.cabal @@ -126,7 +126,6 @@ library text, time, transformers, - utf8-string, validation-selective, vector-map ^>=1.1 @@ -211,6 +210,8 @@ library testlib executable plutus-debug main-is: PlutusDebug.hs hs-source-dirs: app + other-modules: + CLI default-language: Haskell2010 ghc-options: -Wall -Wcompat -Wincomplete-record-updates @@ -219,7 +220,15 @@ executable plutus-debug build-depends: base >=4.14 && <5, - cardano-ledger-core + base16-bytestring, + base64-bytestring, + bytestring, + cardano-ledger-binary, + cardano-ledger-core, + deepseq, + optparse-applicative, + plutus-ledger-api, + utf8-string test-suite tests type: exitcode-stdio-1.0 diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Evaluate.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Evaluate.hs index 54066b5a1ea..e411b9f2541 100644 --- 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 #-} @@ -24,11 +23,11 @@ module Cardano.Ledger.Plutus.Evaluate ( scriptPass, scriptFail, PlutusDebugInfo (..), - debugPlutus, runPlutusScript, runPlutusScriptWithLogs, evaluatePlutusWithContext, explainPlutusEvaluationError, + withRunnablePlutusWithContext, ) where @@ -50,7 +49,7 @@ import Cardano.Ledger.Plutus.CostModels ( encodeCostModel, getEvaluationContext, ) -import Cardano.Ledger.Plutus.ExUnits (ExUnits) +import Cardano.Ledger.Plutus.ExUnits (ExUnits (..)) import Cardano.Ledger.Plutus.Language ( Plutus (..), PlutusLanguage (..), @@ -62,25 +61,21 @@ 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 qualified Data.ByteString.Base64 as B64 -import qualified Data.ByteString.UTF8 as BSU +import Control.DeepSeq (NFData (..)) +import Control.Monad (unless) 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 Prettyprinter (Pretty (..)) -import System.Timeout (timeout) -- | This type contains all that is necessary from Ledger to evaluate a plutus script. 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,33 +213,6 @@ data PlutusDebugInfo c (Maybe P.ExBudget) deriving (Show) -debugPlutus :: Crypto c => String -> IO (PlutusDebugInfo c) -debugPlutus db = - case B64.decode (BSU.fromString db) 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 - onDecoderError err = pure $ 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 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 - runPlutusScript :: PlutusWithContext c -> ScriptResult c runPlutusScript = snd . runPlutusScriptWithLogs diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Language.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Language.hs index d0f588c8512..6e7afe1075f 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Language.hs +++ b/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