Update ScriptErrorEvaluationFailed with DebugPlutusFailure

cardano-api/cardano-api.cabal

@@ -123,6 +123,7 @@ library internal
     Cardano.Api.NetworkId
     Cardano.Api.OperationalCertificate
     Cardano.Api.Orphans
+    Cardano.Api.Plutus
     Cardano.Api.Pretty
     Cardano.Api.Protocol
     Cardano.Api.ProtocolParameters
@@ -161,6 +162,7 @@ library internal
     attoparsec,
     base16-bytestring >=1.0,
     base58-bytestring,
+    base64-bytestring,
     bech32 >=1.1.0,
     bytestring,
     cardano-binary,
@@ -278,6 +280,7 @@ library gen
     Test.Hedgehog.Roundtrip.CBOR
 
   build-depends:
+    Diff,
     QuickCheck,
     aeson >=1.5.6.0,
     base16-bytestring,
@@ -293,6 +296,7 @@ library gen
     cardano-ledger-core:{cardano-ledger-core, testlib} >=1.14,
     cardano-ledger-shelley >=1.13,
     containers,
+    directory,
     filepath,
     hedgehog >=1.1,
     hedgehog-extras,
@@ -380,6 +384,7 @@ test-suite cardano-api-golden
   type: exitcode-stdio-1.0
   build-depends:
     aeson,
+    base64-bytestring,
     bech32 >=1.1.0,
     bytestring,
     cardano-api,
@@ -391,6 +396,7 @@ test-suite cardano-api-golden
     cardano-ledger-alonzo,
     cardano-ledger-api ^>=1.9,
     cardano-ledger-babbage >=1.9,
+    cardano-ledger-binary,
     cardano-ledger-core:{cardano-ledger-core, testlib} >=1.14,
     cardano-ledger-shelley,
     cardano-ledger-shelley-test >=1.2.0.1,
@@ -403,7 +409,7 @@ test-suite cardano-api-golden
     microlens,
     parsec,
     plutus-core ^>=1.36,
-    plutus-ledger-api ^>=1.36,
+    plutus-ledger-api,
     tasty,
     tasty-hedgehog,
     text,

cardano-api/gen/Test/Hedgehog/Golden/ErrorMessage.hs

@@ -1,17 +1,32 @@
+{-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Test.Hedgehog.Golden.ErrorMessage where
 
 import           Cardano.Api (Error (..))
 import           Cardano.Api.Pretty
 
+import qualified Control.Concurrent.QSem as IO
+import           Control.Exception (bracket_)
+import           Control.Monad
+import           Control.Monad.IO.Class
+import           Data.Algorithm.Diff (PolyDiff (Both), getGroupedDiff)
+import           Data.Algorithm.DiffOutput (ppDiff)
 import           Data.Data
+import qualified Data.List as List
+import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
 import           GHC.Stack (HasCallStack, withFrozenCallStack)
-import           System.FilePath ((</>))
+import qualified GHC.Stack as GHC
+import qualified System.Directory as IO
+import qualified System.Environment as IO
+import           System.FilePath (takeDirectory, (</>))
+import qualified System.IO as IO
+import qualified System.IO.Unsafe as IO
 
 import           Hedgehog
-import qualified Hedgehog.Extras.Test.Base as H
-import qualified Hedgehog.Extras.Test.Golden as H
+import qualified Hedgehog.Extras.Test as H
+import qualified Hedgehog.Internal.Property as H
 import           Test.Tasty
 import           Test.Tasty.Hedgehog
 
@@ -97,6 +112,114 @@ testErrorMessage_ goldenFilesLocation moduleName typeName constructorName err =
   let fqtn = moduleName <> "." <> typeName
   testProperty constructorName . withTests 1 . property $ do
     H.note_ "Incorrect error message in golden file"
-    H.diffVsGoldenFile
-      (docToString (prettyError err))
+    H.note_ "What the value looks like in memory"
+    let pErr = docToString (prettyError err)
+    H.note_ $ show pErr
+    diffVsGoldenFile
+      pErr
       (goldenFilesLocation </> fqtn </> constructorName <> ".txt")
+
+-- TODO: Upstream all to hedgehog-extras
+diffVsGoldenFile
+  :: HasCallStack
+  => (MonadIO m, MonadTest m)
+  => String
+  -- ^ Actual content
+  -> FilePath
+  -- ^ Reference file
+  -> m ()
+diffVsGoldenFile actualContent goldenFile = GHC.withFrozenCallStack $ do
+  forM_ mGoldenFileLogFile $ \logFile ->
+    liftIO $ semBracket $ IO.appendFile logFile $ goldenFile <> "\n"
+
+  fileExists <- liftIO $ IO.doesFileExist goldenFile
+
+  if
+    | recreateGoldenFiles -> writeGoldenFile goldenFile actualContent
+    | fileExists          -> checkAgainstGoldenFile goldenFile actualLines
+    | createGoldenFiles   -> writeGoldenFile goldenFile actualContent
+    | otherwise           -> reportGoldenFileMissing goldenFile
+ where
+  actualLines = List.lines actualContent
+
+writeGoldenFile
+  :: ()
+  => HasCallStack
+  => MonadIO m
+  => MonadTest m
+  => FilePath
+  -> String
+  -> m ()
+writeGoldenFile goldenFile actualContent = GHC.withFrozenCallStack $ do
+  H.note_ $ "Creating golden file " <> goldenFile
+  H.createDirectoryIfMissing_ (takeDirectory goldenFile)
+  writeFile' goldenFile actualContent
+
+recreateGoldenFiles :: Bool
+recreateGoldenFiles = IO.unsafePerformIO $ do
+  value <- IO.lookupEnv "RECREATE_GOLDEN_FILES"
+  return $ value == Just "1"
+
+createGoldenFiles :: Bool
+createGoldenFiles = IO.unsafePerformIO $ do
+  value <- IO.lookupEnv "CREATE_GOLDEN_FILES"
+  return $ value == Just "1"
+
+writeFile' :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> String -> m ()
+writeFile' filePath contents = GHC.withFrozenCallStack $ do
+  void . H.annotate $ "Writing file: " <> filePath
+  H.evalIO $ IO.withFile filePath IO.WriteMode $ \handle -> do
+    IO.hSetEncoding handle IO.utf8
+    IO.hPutStr handle contents
+
+checkAgainstGoldenFile
+  :: ()
+  => HasCallStack
+  => MonadIO m
+  => MonadTest m
+  => FilePath
+  -> [String]
+  -> m ()
+checkAgainstGoldenFile goldenFile actualLines = GHC.withFrozenCallStack $ do
+  referenceLines <- liftIO $ IO.withFile goldenFile IO.ReadMode $ \handle -> do
+    IO.hSetEncoding handle IO.utf8
+    List.lines . Text.unpack <$> Text.hGetContents handle
+  let difference = getGroupedDiff actualLines referenceLines
+  case difference of
+    [] -> pure ()
+    [Both{}] -> pure ()
+    _ -> do
+      H.note_ $
+        unlines
+          [ "Golden test failed against the golden file."
+          , "To recreate golden file, run with RECREATE_GOLDEN_FILES=1."
+          ]
+      H.failMessage GHC.callStack $ ppDiff difference
+
+sem :: IO.QSem
+sem = IO.unsafePerformIO $ IO.newQSem 1
+{-# NOINLINE sem #-}
+
+semBracket :: IO a -> IO a
+semBracket = bracket_ (IO.waitQSem sem) (IO.signalQSem sem)
+
+mGoldenFileLogFile :: Maybe FilePath
+mGoldenFileLogFile =
+  IO.unsafePerformIO $
+    IO.lookupEnv "GOLDEN_FILE_LOG_FILE"
+
+reportGoldenFileMissing
+  :: ()
+  => HasCallStack
+  => MonadIO m
+  => MonadTest m
+  => FilePath
+  -> m ()
+reportGoldenFileMissing goldenFile = GHC.withFrozenCallStack $ do
+  H.note_ $
+    unlines
+      [ "Golden file " <> goldenFile <> " does not exist."
+      , "To create it, run with CREATE_GOLDEN_FILES=1."
+      , "To recreate it, run with RECREATE_GOLDEN_FILES=1."
+      ]
+  H.failure

cardano-api/internal/Cardano/Api/Fees.hs

@@ -59,6 +59,7 @@ import           Cardano.Api.Eras.Core
 import           Cardano.Api.Error
 import           Cardano.Api.Feature
 import qualified Cardano.Api.Ledger.Lens as A
+import           Cardano.Api.Plutus
 import           Cardano.Api.Pretty
 import           Cardano.Api.ProtocolParameters
 import           Cardano.Api.Query
@@ -80,7 +81,6 @@ import qualified Cardano.Ledger.Keys as Ledger
 import qualified Cardano.Ledger.Plutus.Language as Plutus
 import qualified Cardano.Ledger.Val as L
 import qualified Ouroboros.Consensus.HardFork.History as Consensus
-import qualified PlutusLedgerApi.V1 as Plutus
 
 import           Control.Monad
 import           Data.Bifunctor (bimap, first, second)
@@ -95,7 +95,6 @@ import           Data.Ratio
 import           Data.Set (Set)
 import qualified Data.Set as Set
 import           Data.Text (Text)
-import qualified Data.Text as Text
 import           GHC.Exts (IsList (..))
 import           Lens.Micro ((.~), (^.))
 
@@ -536,7 +535,7 @@ data ScriptExecutionError
     -- (which is not possible for 'evaluateTransactionExecutionUnits' since
     -- the whole point of it is to discover how many execution units are
     -- needed).
-    ScriptErrorEvaluationFailed Plutus.EvaluationError [Text.Text]
+    ScriptErrorEvaluationFailed DebugPlutusFailure
   | -- | The execution units overflowed a 64bit word. Congratulations if
     -- you encounter this error. With the current style of cost model this
     -- would need a script to run for over 7 months, which is somewhat more
@@ -577,11 +576,8 @@ instance Error ScriptExecutionError where
         [ "The Plutus script witness has the wrong datum (according to the UTxO). "
         , "The expected datum value has hash " <> pshow dh
         ]
-    ScriptErrorEvaluationFailed evalErr logs ->
-      mconcat
-        [ "The Plutus script evaluation failed: " <> pretty evalErr
-        , "\nScript debugging logs: " <> mconcat (map (\t -> pretty $ t `Text.append` "\n") logs)
-        ]
+    ScriptErrorEvaluationFailed plutusDebugFailure ->
+      pretty $ renderDebugPlutusFailure plutusDebugFailure
     ScriptErrorExecutionUnitsOverflow ->
       mconcat
         [ "The execution units required by this Plutus script overflows a 64bit "
@@ -736,9 +732,8 @@ evaluateTransactionExecutionUnitsShelley sbe systemstart epochInfo (LedgerProtoc
        where
         txin' = fromShelleyTxIn txin
       L.MissingDatum dh -> ScriptErrorWrongDatum (ScriptDataHash dh)
-      L.ValidationFailure _ evalErr logs _ ->
-        -- TODO: Include additional information from ValidationFailure
-        ScriptErrorEvaluationFailed evalErr logs
+      L.ValidationFailure execUnits evalErr logs scriptWithContext ->
+        ScriptErrorEvaluationFailed $ DebugPlutusFailure evalErr scriptWithContext execUnits logs
       L.IncompatibleBudget _ -> ScriptErrorExecutionUnitsOverflow
       L.RedeemerPointsToUnknownScriptHash rdmrPtr ->
         ScriptErrorRedeemerPointsToUnknownScriptHash $ toScriptIndex aOnwards rdmrPtr

cardano-api/internal/Cardano/Api/Plutus.hs

@@ -0,0 +1,82 @@
+-- | This module provides an error to conveniently render plutus related failures.
+module Cardano.Api.Plutus
+  ( DebugPlutusFailure (..)
+  , renderDebugPlutusFailure
+  )
+where
+
+import           Cardano.Api.Pretty
+
+import qualified Cardano.Ledger.Api as L
+import           Cardano.Ledger.Binary.Encoding (serialize')
+import           Cardano.Ledger.Binary.Plain (serializeAsHexText)
+import qualified Cardano.Ledger.Plutus.Evaluate as Plutus
+import qualified Cardano.Ledger.Plutus.ExUnits as Plutus
+import qualified Cardano.Ledger.Plutus.Language as Plutus
+import qualified PlutusLedgerApi.V1 as Plutus
+
+import qualified Data.ByteString.Base64 as B64
+import           Data.ByteString.Short as BSS
+import           Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import           Prettyprinter
+
+-- | A structured representation of Plutus script validation failures,
+-- providing detailed information about the failed execution for debugging purposes.
+-- This type contains the same information as the data constructor
+-- 'Cardano.Ledger.Alonzo.Plutus.Evaluate.TransactionScriptFailure.ValidationFailure'
+-- but with named fields and fixed crypto parameters for easier debugging and
+-- error reporting.
+data DebugPlutusFailure
+  = DebugPlutusFailure
+  { dpfEvaluationError :: Plutus.EvaluationError
+  , dpfScriptWithContext :: Plutus.PlutusWithContext L.StandardCrypto
+  , dpfExecutionUnits :: Plutus.ExUnits
+  , dpfExecutionLogs :: [Text]
+  }
+  deriving (Eq, Show)
+
+renderDebugPlutusFailure :: DebugPlutusFailure -> Text
+renderDebugPlutusFailure dpf =
+  let pwc = dpfScriptWithContext dpf
+      lang = case pwc of
+        Plutus.PlutusWithContext{Plutus.pwcScript = script} ->
+          either Plutus.plutusLanguage Plutus.plutusLanguage script
+
+      scriptArgs = case pwc of
+        Plutus.PlutusWithContext{Plutus.pwcArgs = args} ->
+          line <> indent 3 (pretty args)
+      protocolVersion = Plutus.pwcProtocolVersion pwc
+      scriptArgsBase64 = case pwc of
+        Plutus.PlutusWithContext{Plutus.pwcArgs = args} ->
+          Text.decodeUtf8 $ B64.encode $ serialize' protocolVersion args
+      evalError = dpfEvaluationError dpf
+      binaryScript = case pwc of
+        Plutus.PlutusWithContext{Plutus.pwcScript = scr} ->
+          let Plutus.Plutus bytes = either id Plutus.plutusFromRunnable scr
+           in Text.decodeUtf8 . B64.encode . BSS.fromShort $ Plutus.unPlutusBinary bytes
+   in Text.unlines
+        [ "Script hash: " <> serializeAsHexText (Plutus.pwcScriptHash pwc)
+        , "Script language: " <> Text.pack (show lang)
+        , "Protocol version: " <> Text.pack (show protocolVersion)
+        , "Script arguments: " <> docToText scriptArgs
+        , "Script evaluation error: " <> docToText (pretty evalError)
+        , "Script execution logs: " <> Text.unlines (dpfExecutionLogs dpf)
+        , "Script base64 encoded arguments: " <> scriptArgsBase64
+        , "Script base64 encoded bytes: " <> binaryScript
+        ]
+
+{-
+-- Should be used on `dpfExecutionLogs dpf`. Disabled until next plutus release.
+See: https://github.com/IntersectMBO/cardano-api/pull/672#issuecomment-2455909946
+
+PlutusTx.ErrorCodes.plutusPreludeErrorCodes
+
+lookupPlutusErrorCode :: Text -> Text
+lookupPlutusErrorCode code =
+  let codeString = PlutusTx.stringToBuiltinString $ Text.unpack code
+   in case Map.lookup codeString plutusPreludeErrorCodes of
+        Just err -> Text.pack err
+        Nothing -> "Unknown error code: " <> code
+-}