Merge pull request #2430 from input-output-hk/jc/debug-help-for-plutus

Debug help for failed Plutus scripts
IntersectMBO · Aug 24, 2021 · 0686b71 · 0686b71
2 parents 5469ea9 + baef2ff
commit 0686b71
Show file tree

Hide file tree

Showing 8 changed files with 291 additions and 66 deletions.
diff --git a/alonzo/impl/cardano-ledger-alonzo.cabal b/alonzo/impl/cardano-ledger-alonzo.cabal
@@ -54,6 +54,7 @@ library
   build-depends:
     array,
     base-deriving-via,
+    base64-bytestring,
     bytestring,
     cardano-binary,
     cardano-crypto-class,
@@ -77,6 +78,7 @@ library
     strict-containers,
     text,
     time,
-    transformers
+    transformers,
+    utf8-string,
   hs-source-dirs:
     src
diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/PlutusScriptApi.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/PlutusScriptApi.hs
@@ -35,7 +35,14 @@ import Cardano.Ledger.Alonzo.Tx
     txdats',
   )
 import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo (TxBody (..), TxOut (..), vldt')
-import Cardano.Ledger.Alonzo.TxInfo (ScriptResult (..), andResult, runPLCScript, txInfo, valContext)
+import Cardano.Ledger.Alonzo.TxInfo
+  ( FailureDescription (..),
+    ScriptResult (..),
+    andResult,
+    runPLCScript,
+    txInfo,
+    valContext,
+  )
 import Cardano.Ledger.Alonzo.TxWitness (TxWitness (txwitsVKey'), txscripts', unTxDats)
 import Cardano.Ledger.BaseTypes (StrictMaybe (..))
 import qualified Cardano.Ledger.Core as Core
@@ -56,6 +63,7 @@ import Data.Proxy (Proxy (..))
 import Data.Sequence.Strict (StrictSeq)
 import Data.Set (Set)
 import qualified Data.Set as Set
+import Data.Text (pack)
 import GHC.Generics
 import GHC.Records (HasField (..))
 import NoThunks.Class (NoThunks)
@@ -225,7 +233,7 @@ evalScripts tx ((AlonzoScript.TimelockScript timelock, _, _, _) : rest) =
   where
     vhks = Set.map witKeyHash (txwitsVKey' (getField @"wits" tx))
     lift True = Passes
-    lift False = Fails ["Timelock: " ++ show timelock ++ " fails."]
+    lift False = Fails [OnePhaseFailure . pack . show $ timelock]
 evalScripts tx ((AlonzoScript.PlutusScript pscript, ds, units, cost) : rest) =
   runPLCScript (Proxy @era) cost pscript units (map getPlutusData ds) `andResult` evalScripts tx rest
 

diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -15,6 +16,7 @@ module Cardano.Ledger.Alonzo.Rules.Utxos
     UtxosPredicateFailure (..),
     constructValidated,
     lbl2Phase,
+    TagMismatchDescription (..),
   )
 where
 
@@ -34,7 +36,7 @@ import Cardano.Ledger.Alonzo.Tx
     txouts,
   )
 import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo
-import Cardano.Ledger.Alonzo.TxInfo (ScriptResult (..))
+import Cardano.Ledger.Alonzo.TxInfo (FailureDescription (..), ScriptResult (..))
 import qualified Cardano.Ledger.Alonzo.TxWitness as Alonzo
 import Cardano.Ledger.BaseTypes
   ( Globals,
@@ -59,7 +61,6 @@ import Data.Foldable (toList)
 import qualified Data.Map.Strict as Map
 import Data.Sequence.Strict (StrictSeq)
 import Data.Set (Set)
-import Data.Text
 import GHC.Generics (Generic)
 import GHC.Records (HasField (..))
 import NoThunks.Class (NoThunks)
@@ -183,7 +184,11 @@ scriptsValidateTransition = do
   case collectTwoPhaseScriptInputs ei sysSt pp tx utxo of
     Right sLst ->
       case evalScripts @era tx sLst of
-        Fails sss -> False ?!## ValidationTagMismatch (getField @"isValidating" tx) (pack (Prelude.unlines sss))
+        Fails sss ->
+          False
+            ?!## ValidationTagMismatch
+              (getField @"isValidating" tx)
+              (FailedUnexpectedly sss)
         Passes -> pure ()
     Left info -> failBecause (CollectErrors info)
   pup' <-
@@ -228,7 +233,7 @@ scriptsNotValidateTransition = do
   case collectTwoPhaseScriptInputs ei sysSt pp tx utxo of
     Right sLst ->
       case (evalScripts @era tx sLst) of
-        Passes -> False ?!## ValidationTagMismatch (getField @"isValidating" tx) (pack ("Script expected to fail, passes."))
+        Passes -> False ?!## ValidationTagMismatch (getField @"isValidating" tx) PassedUnexpectedly
         Fails _sss -> pure ()
     Left info -> failBecause (CollectErrors info)
   pure $
@@ -237,11 +242,27 @@ scriptsNotValidateTransition = do
         _fees = fees <> Val.coin (balance @era (eval (getField @"collateral" txb ◁ utxo)))
       }
 
+data TagMismatchDescription
+  = PassedUnexpectedly
+  | FailedUnexpectedly [FailureDescription]
+  deriving (Show, Eq, Generic, NoThunks)
+
+instance ToCBOR TagMismatchDescription where
+  toCBOR PassedUnexpectedly = encode (Sum PassedUnexpectedly 0)
+  toCBOR (FailedUnexpectedly fs) = encode (Sum FailedUnexpectedly 1 !> To fs)
+
+instance FromCBOR TagMismatchDescription where
+  fromCBOR = decode (Summands "TagMismatchDescription" dec)
+    where
+      dec 0 = SumD PassedUnexpectedly
+      dec 1 = SumD FailedUnexpectedly <! From
+      dec n = Invalid n
+
 data UtxosPredicateFailure era
   = -- | The 'isValid' tag on the transaction is incorrect. The tag given
     --   here is that provided on the transaction (whereas evaluation of the
     --   scripts gives the opposite.). The Text tries to explain why it failed.
-    ValidationTagMismatch IsValid Text
+    ValidationTagMismatch IsValid TagMismatchDescription
   | -- | We could not find all the necessary inputs for a Plutus Script.
     --         Previous PredicateFailure tests should make this impossible, but the
     --         consequences of not detecting this means scripts get dropped, so things
@@ -258,7 +279,7 @@ instance
   ) =>
   ToCBOR (UtxosPredicateFailure era)
   where
-  toCBOR (ValidationTagMismatch v txt) = encode (Sum ValidationTagMismatch 0 !> To v !> To txt)
+  toCBOR (ValidationTagMismatch v descr) = encode (Sum ValidationTagMismatch 0 !> To v !> To descr)
   toCBOR (CollectErrors cs) =
     encode (Sum (CollectErrors @era) 1 !> To cs)
   toCBOR (UpdateFailure pf) = encode (Sum (UpdateFailure @era) 2 !> To pf)
@@ -288,7 +309,7 @@ instance
   ) =>
   Eq (UtxosPredicateFailure era)
   where
-  (ValidationTagMismatch a _) == (ValidationTagMismatch b _) = a == b -- Do not compare the Text in an Eq check.
+  (ValidationTagMismatch a x) == (ValidationTagMismatch b y) = a == b && x == y
   (CollectErrors x) == (CollectErrors y) = x == y
   (UpdateFailure x) == (UpdateFailure y) = x == y
   _ == _ = False