diff --git a/README.md b/README.md index 7354e8e..593694b 100644 --- a/README.md +++ b/README.md @@ -1,17 +1,17 @@ -Plutus Scripts Evaluation -=== +# Plutus Scripts Evaluation Tools used to: + 1. Accumulate Plutus script evaluation events by replaying blockchain folding over the Ledger state and extracting `PlutusScriptEvaluationEvent`s. 2. Record accumulated events: - 1. On the file system as "dump" files. - 2. In the PostgreSQL database. + 1. On the file system as "dump" files. + 2. In the PostgreSQL database. ## How to use 0. Initialise the PostgreSQL database and connection using files in the `database` folder: - * There is a [pgModeler](https://pgmodeler.io/) (Open-source tool) project for it, - * As well as the DDL statements. + - There is a [pgModeler](https://pgmodeler.io/) (Open-source tool) project for it, + - As well as the DDL statements. 1. Create `.envrc.local` with the following content (adjust the paths as needed): ```sh export CARDANO_NODE_SOCKET_PATH="/home/projects/cardano/node/node-state/mainnet/node.sock" @@ -21,3 +21,21 @@ Tools used to: 2. Enter the `nix` shell using either `nix develop` command or `direnv` hooked to your shell. 3. See available commands by entering `info` in the shell. 4. Run the script dump job using the `dump` command or script upload job with the `load` command. + +## How to re-evaluate recorded Plutus Script evaluations locally + +The database contains plutus script evaluation events from Mainnet which can be replayed locally to re-evaluate the scripts. + +There is less value in re-evaluating scripts without any changes, as one would +simply re-obtain results that are already known. However, this can be useful +when the script evaluation logic has changed, and one wants to compare results +produced by the new logic with the old results. + +The repository contains a program that can be used to re-evaluate the scripts +locally. You can use this program as a basis for your own re-evaluation, where +you can modify various parameters to suit your needs: + +- The [Main module](plutus-script-evaluation/evaluate-scripts/Main.hs) of the `evaluate-scripts` executable. +- The main workhorse, function `evaluateScripts` in the [Evaluation module](plutus-script-evaluation/evaluate-scripts/Evaluation.hs) does the boring parts (aggregating relevant script evaluation inputs, streaming the data from DB to a local computer, decoding CBOR, forking worker threads) so that you can do the interesting part: traverse script evaluations from the Mainnet accessing all of the original evaluation inputs to re-interpret them accordingly to your task; + +If a task requires maintaining local state (accumulator) during the evaluation, you can use the `accumulateScripts` function in the [Evaluation module](plutus-script-evaluation/evaluate-scripts/Evaluation.hs). This function is a more general version of `evaluateScripts` that allows you to maintain local state during the evaluation. diff --git a/cabal.project b/cabal.project index e5b5e4b..d03c695 100644 --- a/cabal.project +++ b/cabal.project @@ -34,4 +34,3 @@ packages: package postgresql-libpq flags: +use-pkg-config - diff --git a/database/db.dbm b/database/db.dbm index bf68d63..9a461f6 100644 --- a/database/db.dbm +++ b/database/db.dbm @@ -3,8 +3,8 @@ CAUTION: Do not modify this file unless you know what you are doing. Unexpected results may occur if the code is changed deliberately. --> - do - _result <- evaluateScripts conn mempty onScriptEvaluationInput + evaluateScripts conn startBlock onScriptEvaluationInput putStrLn "Done evaluating scripts" displaySqlError :: IO () -> IO () diff --git a/plutus-script-evaluation/evaluate-scripts/Options.hs b/plutus-script-evaluation/evaluate-scripts/Options.hs index 78c1b28..aec1acd 100644 --- a/plutus-script-evaluation/evaluate-scripts/Options.hs +++ b/plutus-script-evaluation/evaluate-scripts/Options.hs @@ -8,10 +8,14 @@ module Options ( ) where +import Cardano.Slotting.Block (BlockNo (BlockNo)) import Data.ByteString (ByteString) import Options.Applicative qualified as O -newtype Options = Options {optsDatabaseConnStr :: ByteString} +data Options = Options + { optsDatabaseConnStr :: ByteString + , startBlock :: BlockNo + } deriving (Show) options :: O.Parser Options @@ -27,6 +31,15 @@ options = do \/docs/current/libpq-connect.html#LIBPQ-CONNSTRING" ] ) + startBlock <- + O.option + (O.maybeReader (Just . BlockNo . read)) + ( mconcat + [ O.long "start-block" + , O.metavar "BLOCK_NO" + , O.help "Block number to start from" + ] + ) pure Options{..} parserInfo :: O.ParserInfo Options diff --git a/plutus-script-evaluation/lib/Database/Query.hs b/plutus-script-evaluation/lib/Database/Query.hs index e776704..c7652de 100644 --- a/plutus-script-evaluation/lib/Database/Query.hs +++ b/plutus-script-evaluation/lib/Database/Query.hs @@ -1,6 +1,8 @@ module Database.Query where +import Cardano.Slotting.Block (BlockNo (..)) import Cardano.Slotting.Slot (SlotNo) +import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) import Data.Profunctor.Product.Default (Default) import Database.Orphans () import Database.PostgreSQL.Simple (Connection) @@ -10,10 +12,12 @@ import Opaleye ( Delete (..), Insert (Insert, iOnConflict, iReturning, iRows, iTable), ToFields, + asc, doNothing, limit, maybeFields, optional, + orderBy, rCount, runDelete, runInsert, @@ -25,6 +29,7 @@ import Opaleye ( (.==), (.>=), ) +import Opaleye.Internal.Column (SqlNum (pgFromInteger)) insertCostModelValues :: (Default ToFields CostModelValuesRecord CostModelValuesRecordFields) @@ -92,13 +97,21 @@ selectSerialisedScriptsBatch conn count = pure serialised withScriptEvaluationEvents - :: Connection + :: (MonadUnliftIO m) + => Connection + -> BlockNo -> a - -> (a -> ScriptEvaluationRecord -> IO a) - -> IO a -withScriptEvaluationEvents conn a f = do - let select = selectTable scriptEvaluations - runSelectFold conn select a f + -> (a -> ScriptEvaluationRecord -> m a) + -> m a +withScriptEvaluationEvents conn blockNo a f = do + let startBlock = pgFromInteger (fromIntegral (unBlockNo blockNo)) + select = orderBy (asc seBlockNo) do + res <- selectTable scriptEvaluations + where_ (seBlockNo res .>= startBlock) + pure res + withRunInIO \runInIO -> + runSelectFold conn select a \accum record -> + runInIO (f accum record) insertScriptEvaluationEvents :: (Default ToFields EvaluationEventRecord WriteEvaluationEventRecordFields) diff --git a/plutus-script-evaluation/lib/Database/Schema.hs b/plutus-script-evaluation/lib/Database/Schema.hs index 7640b1e..84eeaac 100644 --- a/plutus-script-evaluation/lib/Database/Schema.hs +++ b/plutus-script-evaluation/lib/Database/Schema.hs @@ -193,6 +193,7 @@ data datum redeemer scriptContext + costModelKey costModel = MkScriptEvaluationRecord' { sePk :: pk @@ -207,6 +208,7 @@ data , seDatum :: datum , seRedeemer :: redeemer , seScriptContext :: scriptContext + , seCostModelKey :: costModelKey , seCostModelParams :: costModel } deriving (Show, Eq) @@ -225,6 +227,7 @@ type ScriptEvaluationRecord = (Maybe ByteString) -- datum (Maybe ByteString) -- redeemer ByteString -- script_context + Hash64 -- cost_model_key [Int64] -- cost_model_params type ScriptEvaluationRecordFields = @@ -237,10 +240,11 @@ type ScriptEvaluationRecordFields = (Field SqlBool) -- evaluated_successfully (Field SqlInt4) -- exec_budget_cpu (Field SqlInt4) -- exec_budget_mem - (Field SqlBytea) -- script_hash + (Field SqlBytea) -- script (FieldNullable SqlBytea) -- datum (FieldNullable SqlBytea) -- redeemer (Field SqlBytea) -- script_context + (Field SqlInt8) -- cost_model_params (Field (SqlArray SqlInt8)) -- cost_model_params -------------------------------------------------------------------------------- @@ -292,10 +296,11 @@ scriptEvaluations = , seEvaluatedSuccessfully = tableField "evaluated_successfully" , seExecBudgetCpu = tableField "exec_budget_cpu" , seExecBudgetMem = tableField "exec_budget_mem" - , seScript = tableField "serialised" + , seScript = tableField "script_serialised" , seDatum = tableField "datum" , seRedeemer = tableField "redeemer" , seScriptContext = tableField "script_context" + , seCostModelKey = tableField "cost_model_key" , seCostModelParams = tableField "cost_model_param_values" } diff --git a/plutus-script-evaluation/lib/Evaluate.hs b/plutus-script-evaluation/lib/Evaluate.hs index c16885f..9ead6d5 100644 --- a/plutus-script-evaluation/lib/Evaluate.hs +++ b/plutus-script-evaluation/lib/Evaluate.hs @@ -1,15 +1,28 @@ -{-# LANGUAGE PartialTypeSignatures #-} - module Evaluate where +import Cardano.Slotting.Block (unBlockNo) import Codec.Serialise (deserialise) +import Control.Concurrent (getNumCapabilities) +import Control.Monad (when) +import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Trans.Except (runExceptT) import Control.Monad.Trans.Writer (WriterT (runWriterT)) import Data.ByteString qualified as BSL import Data.ByteString.Short qualified as BSS +import Data.Digest.Murmur64 (Hash64) +import Data.Either (isRight) +import Data.Int (Int64) +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Maybe (fromMaybe) +import Data.Text qualified as Text +import Data.Text.IO qualified as TIO +import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds) +import Data.Word (Word32) 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 (..), @@ -17,70 +30,191 @@ import PlutusLedgerApi.Common ( 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 (ExitCode (..), exitWith) +import Text.PrettyBy qualified as Pretty +import UnliftIO (IORef, MonadIO, atomicModifyIORef', liftIO, newIORef, readIORef, writeIORef) +import UnliftIO.Concurrent (forkFinally, threadDelay) data ScriptEvaluationInput = MkScriptEvaluationInput - { seiPlutusLedgerLanguage :: PlutusLedgerLanguage - , seiMajorProtocolVersion :: MajorProtocolVersion - , seiEvaluationContext :: EvaluationContext + { seiPlutusLedgerLanguage :: !PlutusLedgerLanguage + , seiMajorProtocolVersion :: !MajorProtocolVersion + , seiEvaluationContext :: !EvaluationContext , seiData :: [Data] - , seiScript :: ScriptForEvaluation - , seiExBudget :: ExBudget + , seiScript :: !ScriptForEvaluation + , seiExBudget :: !ExBudget + , seiEvaluationPk :: Int64 + , seiEvaluationSuccess :: !Bool + , seiBlock :: !BlockNo } -evaluateScripts - :: Postgres.Connection +renderScriptEvaluationInput :: ScriptEvaluationInput -> String +renderScriptEvaluationInput MkScriptEvaluationInput{..} = + "\n\nseiPlutusLedgerLanguage = " + ++ show seiPlutusLedgerLanguage + ++ "\n\nseiMajorProtocolVersion = " + ++ show seiMajorProtocolVersion + ++ "\n\nseiEvaluationContext = " + ++ "\n\nseiExBudget = " + ++ show seiExBudget + ++ "\n\nseiEvaluationSuccess = " + ++ show seiEvaluationSuccess + ++ "\n\nseiBlock = " + ++ show seiBlock + ++ "\n\nseiData = " + ++ Pretty.display seiData + ++ "\n\nseiScript = " + ++ ( let ScriptNamedDeBruijn uplc = deserialisedScript seiScript + in Pretty.display uplc + ) + +accumulateScripts + :: (MonadFail m, MonadUnliftIO m) + => Postgres.Connection -- ^ Database connection + -> BlockNo + -- ^ Block number to start from -> a -- ^ Initial accumulator - -> (ScriptEvaluationInput -> a -> IO a) + -> (ScriptEvaluationInput -> a -> m a) -- ^ Accumulation function - -> IO a -evaluateScripts conn initialAccum accumulate = - Db.withScriptEvaluationEvents conn initialAccum \accum record -> do - scriptInput <- inputFromRecord record + -> m a +accumulateScripts conn startBlock initialAccum accumulate = do + evaluationContexts <- newIORef Map.empty + Db.withScriptEvaluationEvents conn startBlock initialAccum \accum record -> do + scriptInput <- inputFromRecord evaluationContexts record accumulate scriptInput accum +evaluateScripts + :: forall m + . (MonadFail m, MonadUnliftIO m) + => Postgres.Connection + -- ^ Database connection + -> BlockNo + -- ^ Block number to start from + -> (ScriptEvaluationInput -> m ()) + -- ^ Callback + -> m () +evaluateScripts conn startBlock callback = do + maxThreads <- liftIO getNumCapabilities + st <- + newIORef + ( 0 -- current number of threads + , 0 -- number of evaluated scripts + , 0 -- average processing time (millis) + , 0 -- average evaluation time (millis) + ) + evalContexts <- newIORef Map.empty -- cashed evaluation contexts + Db.withScriptEvaluationEvents conn startBlock () \_unit record -> do + startProcessing <- liftIO getCurrentTime + waitForAFreeThread maxThreads st + atomicModifyIORef' st \(threads, n, a, s) -> + ((threads + 1, n, a, s), ()) + let work = do + input <- inputFromRecord evalContexts record + startEvaluation <- liftIO getCurrentTime + callback input + end <- liftIO getCurrentTime + pure + ( nominalDiffTimeToMillis (end `diffUTCTime` startProcessing) + , nominalDiffTimeToMillis (end `diffUTCTime` startEvaluation) + ) + _threadId <- forkFinally work \case + Left err -> liftIO do + putStrLn $ "Failed to evaluate script: " <> show err + exitWith (ExitFailure 1) + Right (!dtp, !dte) -> do + atomicModifyIORef' st \(threads, n, pt, et) -> + let pt' = + if pt == 0 + then dtp + else + round @Double @Word32 $ + fromIntegral (pt * (n - 1) + dtp) / fromIntegral n + et' = + if et == 0 + then dte + else + round @Double @Word32 $ + fromIntegral (et * (n - 1) + dte) / fromIntegral n + in ((threads - 1, n + 1, pt', et'), ()) + pure () + where + waitForAFreeThread :: Int -> IORef (Int, Word32, Word32, Word32) -> m () + waitForAFreeThread maxThreads counter = do + (threadCount, _, _, _) <- readIORef counter + when (threadCount >= maxThreads) do + threadDelay 1_000 -- wait for 1ms + waitForAFreeThread maxThreads counter + + nominalDiffTimeToMillis :: NominalDiffTime -> Word32 + nominalDiffTimeToMillis dt = round (1000 * nominalDiffTimeToSeconds dt) + inputFromRecord - :: (MonadFail m) => Db.ScriptEvaluationRecord -> m ScriptEvaluationInput -inputFromRecord MkScriptEvaluationRecord'{..} = do + :: (MonadFail m, MonadIO m) + => IORef (Map Hash64 EvaluationContext) + -> Db.ScriptEvaluationRecord + -> m ScriptEvaluationInput +inputFromRecord evalCtxRef MkScriptEvaluationRecord'{..} = do let mkEvalCtx f = runExceptT (runWriterT f) >>= \case Left e -> fail $ "Failed to create evaluation context: " <> show e Right (ctx, _warnings) -> pure ctx - seiEvaluationContext <- - mkEvalCtx case seLedgerLanguage of - PlutusV1 -> V1.mkEvaluationContext seCostModelParams - PlutusV2 -> V2.mkEvaluationContext seCostModelParams - PlutusV3 -> V3.mkEvaluationContext seCostModelParams + seiEvaluationContext <- do + keyedEvalCtxs <- liftIO $ readIORef evalCtxRef + case Map.lookup seCostModelKey keyedEvalCtxs of + Just ctx -> pure ctx + Nothing -> do + ctx <- mkEvalCtx case seLedgerLanguage of + PlutusV1 -> V1.mkEvaluationContext seCostModelParams + PlutusV2 -> V2.mkEvaluationContext seCostModelParams + PlutusV3 -> V3.mkEvaluationContext seCostModelParams + let keyedEvalCtxs' = Map.insert seCostModelKey ctx keyedEvalCtxs + liftIO $ writeIORef evalCtxRef keyedEvalCtxs' + pure ctx seiScript <- case deserialiseScript seLedgerLanguage seMajorProtocolVersion (BSS.toShort seScript) of - Left err -> fail $ "Failed to deserialise script: " <> show err + Left err -> + fail $ + "Failed to deserialise script (" + <> show sePk + <> "): " + <> show err Right script -> pure script + + let seiData :: [Data] + seiData = + let addRedeemerDatum = + case seLedgerLanguage of + PlutusV3 -> id + _ -> maybe id (:) seDatum . maybe id (:) seRedeemer + in deserialise . BSL.fromStrict <$> addRedeemerDatum [seScriptContext] pure MkScriptEvaluationInput { seiPlutusLedgerLanguage = seLedgerLanguage , seiMajorProtocolVersion = seMajorProtocolVersion , seiEvaluationContext , seiScript - , seiData = - (deserialise . BSL.fromStrict <$>) - . maybe id (:) seDatum - $ maybe id (:) seRedeemer [seScriptContext] + , seiData , seiExBudget = ExBudget seExecBudgetCpu seExecBudgetMem + , seiEvaluationPk = fromMaybe (-1) sePk + , seiEvaluationSuccess = seEvaluatedSuccessfully + , seiBlock = seBlockNo } -onScriptEvaluationInput :: ScriptEvaluationInput -> ExBudget -> IO ExBudget -onScriptEvaluationInput MkScriptEvaluationInput{..} budget = do +onScriptEvaluationInput :: ScriptEvaluationInput -> IO () +onScriptEvaluationInput input@MkScriptEvaluationInput{..} = do let (_logOutput, evaluationResult) = evaluateScriptRestricting @@ -88,22 +222,41 @@ onScriptEvaluationInput MkScriptEvaluationInput{..} budget = do seiMajorProtocolVersion Quiet seiEvaluationContext - (ExBudget maxBound maxBound) + seiExBudget seiScript seiData - putStrLn "" + let b = unBlockNo seiBlock + when (b `mod` 100 == 0) (print seiEvaluationPk) + + let evaluationSuccess = isRight evaluationResult + + when (evaluationSuccess /= seiEvaluationSuccess) do + let msg = + "Script evaluation (pk = " + ++ show seiEvaluationPk + ++ ") result (" + ++ show evaluationSuccess + ++ ") does not match the recorded result (" + ++ show seiEvaluationSuccess + ++ ")" + ++ "\n\nEvaluation result:\n" + ++ show evaluationResult + ++ "\n\nScript evaluation inputs:\n" + ++ renderScriptEvaluationInput input + ++ "\n\n" + putStr msg + + nonce <- getCurrentTime + let logFile = show (unBlockNo seiBlock) ++ "_" ++ show nonce ++ ".log" + putStrLn $ "Writing log to " ++ logFile + TIO.writeFile logFile (Text.pack msg) + case evaluationResult of - Left err -> do - putStrLn $ "Script evaluation was not successful: " <> show err - Right (ExBudget cpu mem) -> do - putStrLn $ - "Script evaluation was successful.\nConsumed: " - <> show cpu - <> ", " - <> show mem + Right _spentExBudget -> pure () + Left err -> putStrLn $ - let ExBudget cpu' mem' = seiExBudget - in "Expected: " <> show cpu' <> ", " <> show mem' - - pure budget + "Script evaluation (pk = " + <> show seiEvaluationPk + <> ") was not successful: " + <> show err diff --git a/plutus-script-evaluation/plutus-script-evaluation.cabal b/plutus-script-evaluation/plutus-script-evaluation.cabal index 51be8ac..dc263ec 100644 --- a/plutus-script-evaluation/plutus-script-evaluation.cabal +++ b/plutus-script-evaluation/plutus-script-evaluation.cabal @@ -104,12 +104,16 @@ library , plutus-ledger-api , plutus-ledger-api:plutus-ledger-api-testlib , postgresql-simple + , prettyprinter-configurable , product-profunctors , serialise , some , string-interpolate ^>=0.3 , text + , time , transformers + , unliftio + , unliftio-core , vector executable dump-script-events @@ -155,8 +159,10 @@ executable evaluate-scripts import: lang, deps-exe hs-source-dirs: evaluate-scripts main-is: Main.hs - ghc-options: -threaded -rtsopts + ghc-options: -threaded -with-rtsopts=-N other-modules: Options build-depends: - , cardano-api ^>=10.4 + , cardano-api ^>=10.4 + , cardano-slotting , text + , unliftio-core