Evaluation job checks if a budget is not exceeded.

Author: Unisay

plutus-script-evaluation/lib/Database/Query.hs

@@ -2,6 +2,7 @@ module Database.Query where
 
 import Cardano.Slotting.Slot (SlotNo)
 import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)
+import Data.Function ((&))
 import Data.Profunctor.Product.Default (Default)
 import Database.Orphans ()
 import Database.PostgreSQL.Simple (Connection)
@@ -11,10 +12,12 @@ import Opaleye (
   Delete (..),
   Insert (Insert, iOnConflict, iReturning, iRows, iTable),
   ToFields,
+  asc,
   doNothing,
   limit,
   maybeFields,
   optional,
+  orderBy,
   rCount,
   runDelete,
   runInsert,
@@ -99,7 +102,9 @@ withScriptEvaluationEvents
   -> (a -> ScriptEvaluationRecord -> m a)
   -> m a
 withScriptEvaluationEvents conn a f = do
-  let select = selectTable scriptEvaluations
+  let select =
+        selectTable scriptEvaluations
+          & orderBy (asc seBlockNo)
   withRunInIO \runInIO ->
     runSelectFold conn select a \accum record ->
       runInIO (f accum record)

plutus-script-evaluation/lib/Evaluate.hs

@@ -1,6 +1,7 @@
 module Evaluate where
 
 import Codec.Serialise (deserialise)
+import Control.Monad (when)
 import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Control.Monad.Trans.Except (runExceptT)
 import Control.Monad.Trans.Writer (WriterT (runWriterT))
@@ -9,20 +10,25 @@ import Data.ByteString.Short qualified as BSS
 import Database qualified as Db
 import Database.PostgreSQL.Simple qualified as Postgres
 import Database.Schema (ScriptEvaluationRecord' (..))
+import Ouroboros.Consensus.Block (BlockNo)
 import PlutusLedgerApi.Common (
   Data,
   EvaluationContext (..),
   ExBudget (..),
   MajorProtocolVersion,
   PlutusLedgerLanguage (..),
   ScriptForEvaluation,
+  ScriptNamedDeBruijn (..),
   VerboseMode (Quiet),
   deserialiseScript,
+  deserialisedScript,
   evaluateScriptRestricting,
  )
 import PlutusLedgerApi.V1 qualified as V1
 import PlutusLedgerApi.V2 qualified as V2
 import PlutusLedgerApi.V3 qualified as V3
+import System.Exit (exitFailure)
+import Text.PrettyBy qualified as Pretty
 
 data ScriptEvaluationInput = MkScriptEvaluationInput
   { seiPlutusLedgerLanguage :: PlutusLedgerLanguage
@@ -31,6 +37,8 @@ data ScriptEvaluationInput = MkScriptEvaluationInput
   , seiData :: [Data]
   , seiScript :: ScriptForEvaluation
   , seiExBudget :: ExBudget
+  , seiEvaluationSuccess :: Bool
+  , seiBlock :: BlockNo
   }
 
 evaluateScripts
@@ -79,6 +87,8 @@ inputFromRecord MkScriptEvaluationRecord'{..} = do
             . maybe id (:) seDatum
             $ maybe id (:) seRedeemer [seScriptContext]
       , seiExBudget = ExBudget seExecBudgetCpu seExecBudgetMem
+      , seiEvaluationSuccess = seEvaluatedSuccessfully
+      , seiBlock = seBlockNo
       }
 
 onScriptEvaluationInput :: ScriptEvaluationInput -> ExBudget -> IO ExBudget
@@ -94,15 +104,43 @@ onScriptEvaluationInput MkScriptEvaluationInput{..} budget = do
         seiScript
         seiData
 
-  putStrLn ""
+  let evaluationSuccess =
+        either (const False) (const True) evaluationResult
+
+  print seiBlock
+
+  when (evaluationSuccess /= seiEvaluationSuccess) do
+    putStrLn $
+      "Script evaluation result ("
+        ++ show evaluationSuccess
+        ++ ") does not match the expected result ("
+        ++ show seiEvaluationSuccess
+        ++ "): "
+    let ScriptNamedDeBruijn uplc = deserialisedScript seiScript
+     in putStrLn $ Pretty.display uplc
+
   case evaluationResult of
-    Left err -> do
+    Left err ->
       putStrLn $ "Script evaluation was not successful: " <> show err
     Right (ExBudget cpu mem) -> do
-      putStrLn "Script evaluation was successful."
-      putStrLn
-        let ExBudget cpu' mem' = seiExBudget
-         in "Expected: " <> show cpu' <> ", " <> show mem'
-      putStrLn $ "Consumed: " <> show cpu <> ", " <> show mem
+      let ExBudget cpu' mem' = seiExBudget
+      if cpu > cpu' || mem > mem'
+        then do
+          putStrLn "Budget exceeded!"
+          putStrLn $ "Paid for: " <> show cpu' <> ", " <> show mem'
+          putStrLn $ "Consumed: " <> show cpu <> ", " <> show mem
+          exitFailure
+        else
+          if cpu == cpu' && mem == mem'
+            then do
+              putStrLn $
+                "Budget matches exactly: "
+                  <> show cpu
+                  <> ", "
+                  <> show mem
+            else do
+              putStrLn "Budget is sufficient:"
+              putStrLn $ "Paid for: " <> show cpu' <> ", " <> show mem'
+              putStrLn $ "Consumed: " <> show cpu <> ", " <> show mem
 
   pure budget

plutus-script-evaluation/plutus-script-evaluation.cabal

@@ -104,6 +104,7 @@ library
     , plutus-ledger-api
     , plutus-ledger-api:plutus-ledger-api-testlib
     , postgresql-simple
+    , prettyprinter-configurable
     , product-profunctors
     , serialise
     , some