IntersectMBO · JaredCorduan · Aug 2, 2021 · Jul 16, 2021
@@ -38,7 +38,7 @@ import Cardano.Ledger.Alonzo.Tx
     txdats',
   )
 import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo (TxBody (..), TxOut (..), vldt')
-import Cardano.Ledger.Alonzo.TxInfo (runPLCScript, txInfo, valContext)
+import Cardano.Ledger.Alonzo.TxInfo (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
@@ -55,6 +55,7 @@ import Data.Functor.Identity (Identity, runIdentity)
 import Data.List (foldl')
 import qualified Data.Map as Map
 import Data.Maybe (isJust)
+import Data.Proxy (Proxy (..))
 import Data.Sequence.Strict (StrictSeq)
 import Data.Set (Set)
 import qualified Data.Set as Set
@@ -214,19 +215,22 @@ evalScripts ::
   forall era tx.
   ( Era era,
     Alonzo.TxBody era ~ Core.TxBody era,
+    Show (AlonzoScript.Script era),
     HasField "body" tx (Core.TxBody era),
     HasField "wits" tx (TxWitness era)
   ) =>
   tx ->
   [(AlonzoScript.Script era, [Data era], ExUnits, CostModel)] ->
-  Bool
-evalScripts _tx [] = True
+  ScriptResult
+evalScripts _tx [] = Passes
 evalScripts tx ((AlonzoScript.TimelockScript timelock, _, _, _) : rest) =
-  evalTimelock vhks (Alonzo.vldt' (getField @"body" tx)) timelock && evalScripts tx rest
+  (lift $ evalTimelock vhks (Alonzo.vldt' (getField @"body" tx)) timelock) `andResult` evalScripts tx rest
   where
     vhks = Set.map witKeyHash (txwitsVKey' (getField @"wits" tx))
+    lift True = Passes
+    lift False = Fails ["Timelock: " ++ show timelock ++ " fails."]
 evalScripts tx ((AlonzoScript.PlutusScript pscript, ds, units, cost) : rest) =
-  runPLCScript cost pscript units (map getPlutusData ds) && evalScripts tx rest
+  runPLCScript (Proxy @era) cost pscript units (map getPlutusData ds) `andResult` evalScripts tx rest
 
 -- ===================================================================
 -- From Specification, Figure 12 "UTXOW helper functions"

@@ -34,6 +34,7 @@ import Cardano.Ledger.Alonzo.Tx
     txouts,
   )
 import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo
+import Cardano.Ledger.Alonzo.TxInfo (ScriptResult (..))
 import qualified Cardano.Ledger.Alonzo.TxWitness as Alonzo
 import Cardano.Ledger.BaseTypes
   ( Globals,
@@ -45,7 +46,7 @@ import Cardano.Ledger.BaseTypes
   )
 import Cardano.Ledger.Coin (Coin)
 import qualified Cardano.Ledger.Core as Core
-import Cardano.Ledger.Era (Crypto, Era)
+import Cardano.Ledger.Era (Crypto, Era, ValidateScript)
 import Cardano.Ledger.Mary.Value (Value)
 import Cardano.Ledger.Rules.ValidationMode (lblStatic)
 import qualified Cardano.Ledger.Val as Val
@@ -58,6 +59,7 @@ 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)
@@ -90,6 +92,7 @@ instance
     Core.Value era ~ Value (Crypto era),
     Core.TxOut era ~ Alonzo.TxOut era,
     Core.TxBody era ~ Alonzo.TxBody era,
+    ValidateScript era,
     HasField "_keyDeposit" (Core.PParams era) Coin,
     HasField "_poolDeposit" (Core.PParams era) Coin,
     HasField "_costmdls" (Core.PParams era) (Map.Map Language CostModel),
@@ -107,8 +110,7 @@ instance
 
 utxosTransition ::
   forall era.
-  ( Era era,
-    Core.Script era ~ Script era,
+  ( Core.Script era ~ Script era,
     Environment (Core.EraRule "PPUP" era) ~ PPUPEnv era,
     State (Core.EraRule "PPUP" era) ~ PPUPState era,
     Signal (Core.EraRule "PPUP" era) ~ Maybe (Update era),
@@ -120,6 +122,7 @@ utxosTransition ::
     Core.TxOut era ~ Alonzo.TxOut era,
     Core.Value era ~ Value (Crypto era),
     Core.TxBody era ~ Alonzo.TxBody era,
+    ValidateScript era,
     HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))),
     HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))),
     HasField "_keyDeposit" (Core.PParams era) Coin,
@@ -150,6 +153,7 @@ scriptsValidateTransition ::
     Core.TxBody era ~ Alonzo.TxBody era,
     Core.TxOut era ~ Alonzo.TxOut era,
     Core.Value era ~ Value (Crypto era),
+    ValidateScript era,
     HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))),
     HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))),
     HasField "_keyDeposit" (Core.PParams era) Coin,
@@ -177,8 +181,9 @@ scriptsValidateTransition = do
   ei <- liftSTS $ asks epochInfo
   case collectTwoPhaseScriptInputs ei sysSt pp tx utxo of
     Right sLst ->
-      evalScripts @era tx sLst
-        ?!## ValidationTagMismatch (getField @"isValid" tx)
+      case evalScripts @era tx sLst of
+        Fails sss -> False ?!## ValidationTagMismatch (getField @"isValidating" tx) (pack (Prelude.unlines sss))
+        Passes -> pure ()
     Left info -> failBecause (CollectErrors info)
   pup' <-
     trans @(Core.EraRule "PPUP" era) $
@@ -203,6 +208,7 @@ scriptsNotValidateTransition ::
     State (Core.EraRule "PPUP" era) ~ PPUPState era,
     Signal (Core.EraRule "PPUP" era) ~ Maybe (Update era),
     Embed (Core.EraRule "PPUP" era) (UTXOS era),
+    ValidateScript era,
     Core.Script era ~ Script era,
     Core.TxBody era ~ Alonzo.TxBody era,
     Core.TxOut era ~ Alonzo.TxOut era,
@@ -220,8 +226,9 @@ scriptsNotValidateTransition = do
   ei <- liftSTS $ asks epochInfo
   case collectTwoPhaseScriptInputs ei sysSt pp tx utxo of
     Right sLst ->
-      not (evalScripts @era tx sLst)
-        ?!## ValidationTagMismatch (getField @"isValid" tx)
+      case (evalScripts @era tx sLst) of
+        Passes -> False ?!## ValidationTagMismatch (getField @"isValidating" tx) (pack ("Script expected to fail, passes."))
+        Fails _sss -> pure ()
     Left info -> failBecause (CollectErrors info)
   pure $
     us
@@ -232,8 +239,8 @@ scriptsNotValidateTransition = do
 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.)
-    ValidationTagMismatch IsValid
+    --   scripts gives the opposite.). The Text tries to explain why it failed.
+    ValidationTagMismatch IsValid Text
   | -- | 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
@@ -250,7 +257,7 @@ instance
   ) =>
   ToCBOR (UtxosPredicateFailure era)
   where
-  toCBOR (ValidationTagMismatch v) = encode (Sum ValidationTagMismatch 0 !> To v)
+  toCBOR (ValidationTagMismatch v txt) = encode (Sum ValidationTagMismatch 0 !> To v !> To txt)
   toCBOR (CollectErrors cs) =
     encode (Sum (CollectErrors @era) 1 !> To cs)
   toCBOR (UpdateFailure pf) = encode (Sum (UpdateFailure @era) 2 !> To pf)
@@ -263,7 +270,7 @@ instance
   where
   fromCBOR = decode (Summands "UtxosPredicateFailure" dec)
     where
-      dec 0 = SumD ValidationTagMismatch <! From
+      dec 0 = SumD ValidationTagMismatch <! From <! From
       dec 1 = SumD (CollectErrors @era) <! From
       dec 2 = SumD UpdateFailure <! From
       dec n = Invalid n
@@ -274,11 +281,16 @@ deriving stock instance
   ) =>
   Show (UtxosPredicateFailure era)
 
-deriving stock instance
+instance
   ( Shelley.TransUTxOState Eq era,
     Eq (PredicateFailure (Core.EraRule "PPUP" era))
   ) =>
   Eq (UtxosPredicateFailure era)
+  where
+  (ValidationTagMismatch a _) == (ValidationTagMismatch b _) = a == b -- Do not compare the Text in an Eq check.
+  (CollectErrors x) == (CollectErrors y) = x == y
+  (UpdateFailure x) == (UpdateFailure y) = x == y
+  _ == _ = False
 
 instance
   ( Shelley.TransUTxOState NoThunks era,
@@ -306,12 +318,12 @@ instance
 constructValidated ::
   forall era m.
   ( MonadError [UtxosPredicateFailure era] m,
-    Era era,
     Core.Script era ~ Script era,
     Core.TxOut era ~ Alonzo.TxOut era,
     Core.Value era ~ Value (Crypto era),
     Core.TxBody era ~ Alonzo.TxBody era,
     Core.Witnesses era ~ Alonzo.TxWitness era,
+    ValidateScript era,
     HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))),
     HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))),
     HasField "datahash" (Core.TxOut era) (StrictMaybe (DataHash (Crypto era))),
@@ -332,13 +344,15 @@ constructValidated globals (UtxoEnv _ pp _ _) st tx =
             ValidatedTx
               (getField @"body" tx)
               (getField @"wits" tx)
-              (IsValid scriptEvalResult)
+              (IsValid (lift scriptEvalResult))
               (getField @"auxiliaryData" tx)
        in pure vTx
   where
     utxo = _utxo st
     sysS = systemStart globals
     ei = epochInfo globals
+    lift Passes = True -- Convert a ScriptResult into a Bool
+    lift (Fails _) = False
 
 --------------------------------------------------------------------------------
 -- 2-phase checks

@@ -47,10 +47,11 @@ import Data.Fixed (HasResolution (resolution))
 import qualified Data.Map as Map
 import Data.Maybe (mapMaybe)
 import qualified Data.Set as Set
+-- Instances only
+import Data.Text.Prettyprint.Doc (Pretty (..))
 import Data.Time.Clock (nominalDiffTimeToSeconds)
 import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
-import Data.Typeable (Typeable)
-import Debug.Trace (trace)
+import Data.Typeable (Proxy (..), Typeable)
 import GHC.Records (HasField (..))
 import qualified Plutus.V1.Ledger.Api as P
   ( Address (..),
@@ -60,6 +61,7 @@ import qualified Plutus.V1.Ledger.Api as P
     Data (..),
     Datum (..),
     DatumHash (..),
+    EvaluationError (..),
     ExBudget (..),
     ExCPU (..),
     ExMemory (..),
@@ -85,6 +87,7 @@ import qualified Plutus.V1.Ledger.Api as P
     dataToBuiltinData,
     evaluateScriptRestricting,
     from,
+    fromData,
     lowerBound,
     singleton,
     strictUpperBound,
@@ -93,6 +96,7 @@ import qualified Plutus.V1.Ledger.Api as P
     unionWith,
     validateScript,
   )
+import Plutus.V1.Ledger.Contexts ()
 import Shelley.Spec.Ledger.Scripts (ScriptHash (..))
 import Shelley.Spec.Ledger.TxBody
   ( DCert (..),
@@ -356,21 +360,114 @@ valContext ::
   Data era
 valContext txinfo sp = Data (P.toData (P.ScriptContext txinfo (transScriptPurpose sp)))
 
+data ScriptResult = Passes | Fails ![String]
+
+andResult :: ScriptResult -> ScriptResult -> ScriptResult
+andResult Passes Passes = Passes
+andResult Passes ans = ans
+andResult ans Passes = ans
+andResult (Fails xs) (Fails ys) = Fails (xs ++ ys)
+
+instance Semigroup ScriptResult where
+  (<>) = andResult
+
 -- The runPLCScript in the Specification has a slightly different type
 -- than the one in the implementation below. Made necessary by the the type
--- of P.evaluateScriptRestricting which is the interface to Plutus
+-- of P.evaluateScriptRestricting which is the interface to Plutus, and in the impementation
+-- we try to track why a script failed (if it does) by the [String] in the Fails constructor of ScriptResut.
 
 -- | Run a Plutus Script, given the script and the bounds on resources it is allocated.
-runPLCScript :: CostModel -> SBS.ShortByteString -> ExUnits -> [P.Data] -> Bool
-runPLCScript (CostModel cost) scriptbytestring units ds =
+runPLCScript ::
+  forall era.
+  Show (Script era) =>
+  Proxy era ->
+  CostModel ->
+  SBS.ShortByteString ->
+  ExUnits ->
+  [P.Data] ->
+  ScriptResult
+runPLCScript proxy (CostModel cost) scriptbytestring units ds =
   case P.evaluateScriptRestricting
     P.Quiet
     cost
     (transExUnits units)
     scriptbytestring
     ds of
-    (_, Left _e) -> trace ("\nrunPLC fails " ++ show _e ++ "\nData = " ++ show ds) False
-    (_, Right ()) -> True
+    (_, Left e) -> explain_plutus_failure proxy scriptbytestring e ds
+    (_, Right ()) -> Passes
+
+-- | Explin why a script might fail. Scripts come in two flavors. 1) with 3  data arguments [data,redeemer,context]
+--   and  2) with 2 data arguments [redeemer,context]. It pays to decode the context data into a real context
+--   because that provides way more information. But there is no guarantee the context data really can be decoded.
+explain_plutus_failure :: forall era. Show (Script era) => Proxy era -> SBS.ShortByteString -> P.EvaluationError -> [P.Data] -> ScriptResult
+explain_plutus_failure _proxy scriptbytestring e [dat, redeemer, info] =
+  -- A three data argument script.
+  let ss :: Script era
+      ss = PlutusScript scriptbytestring
+      name :: String
+      name = show ss
+   in case P.fromData info of
+        Nothing -> Fails [line]
+          where
+            line =
+              unlines
+                [ "\nThe 3 arg plutus script (" ++ name ++ ") fails.",
+                  show e,
+                  "The data is: " ++ show dat,
+                  "The redeemer is: " ++ show redeemer,
+                  "The third data argument, does not decode to a context\n" ++ show info
+                ]
+        Just info2 -> Fails [line]
+          where
+            info3 = show (pretty (info2 :: P.ScriptContext))
+            line =
+              unlines
+                [ "\nThe 3 arg plutus script (" ++ name ++ ") fails.",
+                  show e,
+                  "The data is: " ++ show dat,
+                  "The redeemer is: " ++ show redeemer,
+                  "The context is:\n" ++ info3
+                ]
+explain_plutus_failure _proxy scriptbytestring e [redeemer, info] =
+  -- A two data argument script.
+  let ss :: Script era
+      ss = PlutusScript scriptbytestring
+      name :: String
+      name = show ss
+   in case P.fromData info of
+        Nothing -> Fails [line]
+          where
+            line =
+              unlines
+                [ "\nThe 2 arg plutus script (" ++ name ++ ") fails.",
+                  show e,
+                  "The redeemer is: " ++ show redeemer,
+                  "The second data argument, does not decode to a context\n" ++ show info
+                ]
+        Just info2 -> Fails [line]
+          where
+            info3 = show (pretty (info2 :: P.ScriptContext))
+            line =
+              unlines
+                [ "\nThe 2 arg plutus script (" ++ name ++ ") fails.",
+                  show e,
+                  "The redeemer is: " ++ show redeemer,
+                  "The context is:\n" ++ info3
+                ]
+explain_plutus_failure _proxy scriptbytestring e ds = Fails [line] -- A script with the wrong number of arguments
+  where
+    ss :: Script era
+    ss = PlutusScript scriptbytestring
+    name :: String
+    name = show ss
+    line =
+      unlines
+        ( [ "\nThe plutus script (" ++ name ++ ") fails.",
+            show e,
+            "It was passed these " ++ show (Prelude.length ds) ++ " data arguments."
+          ]
+            ++ map show ds
+        )
 
 validPlutusdata :: P.Data -> Bool
 validPlutusdata (P.Constr _n ds) = all validPlutusdata ds

@@ -42,6 +42,7 @@ import Cardano.Ledger.Shelley.Constraints (UsesScript, UsesValue)
 import Data.Map (Map)
 import qualified Data.Map as Map
 import qualified Data.Set as Set
+import Data.Text (pack)
 import qualified Data.Text as T (pack)
 import Numeric.Natural (Natural)
 import qualified PlutusTx as Plutus
@@ -261,7 +262,7 @@ instance Arbitrary (PParamsUpdate era) where
 instance Mock c => Arbitrary (UtxosPredicateFailure (AlonzoEra c)) where
   arbitrary =
     oneof
-      [ ValidationTagMismatch <$> arbitrary,
+      [ ValidationTagMismatch <$> arbitrary <*> (pack <$> arbitrary),
         UpdateFailure <$> arbitrary
       ]