Skip to content

Commit

Permalink
Analyse script events supports PlutusLedgerLanguage V3 (IntersectMBO#…
Browse files Browse the repository at this point in the history 
…6300)
  • Loading branch information
@Unisay @v0d1ch
Unisay authored and v0d1ch committed Dec 6, 2024
1 parent d635474 commit 4797397
Show file tree
Hide file tree
Showing 6 changed files with 308 additions and 301 deletions.
182 changes: 118 additions & 64 deletions plutus-ledger-api/exe/analyse-script-events/Main.hs
View file
Original file line number Diff line number Diff line change
@@ -1,17 +1,15 @@
-- editorconfig-checker-disable-file
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}

-- | Various analyses of events in mainnet script dumps.
-- This only deals with PlutusV1 and PlutusV2 script events because
-- PlutusLedgerApi.Test.EvaluationEvent (and hence the scriptdump job) doesn't
-- know about anything else yet.

module Main (main) where

import LoadScriptEvents (eventsOf, loadEvents)
Expand All @@ -25,9 +23,11 @@ import PlutusLedgerApi.Common
import PlutusLedgerApi.Test.EvaluationEvent
import PlutusLedgerApi.V1 qualified as V1
import PlutusLedgerApi.V2 qualified as V2
import PlutusLedgerApi.V3 qualified as V3
import PlutusTx.AssocMap qualified as M
import UntypedPlutusCore as UPLC

import Control.Exception (throwIO)
import Control.Lens hiding (List)
import Control.Monad.Primitive (PrimState)
import Control.Monad.Writer.Strict
Expand All @@ -52,17 +52,26 @@ type EventAnalyser
-- Script purpose: this is the same for V1 and V2, but changes in V3
stringOfPurposeV1 :: V1.ScriptPurpose -> String
stringOfPurposeV1 = \case
V1.Minting _ -> "V1 Minting" -- Script arguments are [redeemer, context]
V1.Spending _ -> "V1 Spending" -- Script arguments are [datum, redeemer, context]
V1.Rewarding _ -> "V1 Rewarding" -- Script arguments appear to be [redeemer, context]
V1.Certifying _ -> "V1 Certifying" -- Script arguments appear to be [redeemer, context]
V1.Minting _ -> "V1 Minting" -- Script arguments are [redeemer, context]
V1.Spending _ -> "V1 Spending" -- Script arguments are [datum, redeemer, context]
V1.Rewarding _ -> "V1 Rewarding" -- Script arguments appear to be [redeemer, context]
V1.Certifying _ -> "V1 Certifying" -- Script arguments appear to be [redeemer, context]

stringOfPurposeV2 :: V2.ScriptPurpose -> String
stringOfPurposeV2 = \case
V2.Minting _ -> "V2 Minting"
V2.Spending _ -> "V2 Spending"
V2.Rewarding _ -> "V2 Rewarding"
V2.Certifying _ -> "V2 Certifying"
V2.Minting _ -> "V2 Minting"
V2.Spending _ -> "V2 Spending"
V2.Rewarding _ -> "V2 Rewarding"
V2.Certifying _ -> "V2 Certifying"

stringOfPurposeV3 :: V3.ScriptInfo -> String
stringOfPurposeV3 = \case
V3.MintingScript{} -> "V3 Minting"
V3.SpendingScript{} -> "V3 Spending"
V3.RewardingScript{} -> "V3 Rewarding"
V3.CertifyingScript{} -> "V3 Certifying"
V3.VotingScript{} -> "V3 Voting"
V3.ProposingScript{} -> "V3 Proposing"

shapeOfValue :: V1.Value -> String
shapeOfValue (V1.Value m) =
Expand Down Expand Up @@ -98,18 +107,31 @@ analyseTxInfoV2 i = do
analyseValue $ V2.txInfoMint i
analyseOutputs (V2.txInfoOutputs i) V2.txOutValue

analyseTxInfoV3 :: V3.TxInfo -> IO ()
analyseTxInfoV3 i = do
putStr "Fee: "
print $ V3.txInfoFee i
putStr "Mint: "
analyseValue $ V3.txInfoMint i
analyseOutputs (V3.txInfoOutputs i) V3.txOutValue

analyseScriptContext :: EventAnalyser
analyseScriptContext _ctx _params ev = case ev of
PlutusV1Event ScriptEvaluationData{..} _expected ->
PlutusEvent PlutusV1 ScriptEvaluationData{..} _expected ->
case dataInputs of
[_,_,c] -> analyseCtxV1 c
[_,c] -> analyseCtxV1 c
l -> error $ printf "Unexpected number of V1 script arguments: %d" (length l)
PlutusV2Event ScriptEvaluationData{..} _expected ->
PlutusEvent PlutusV2 ScriptEvaluationData{..} _expected ->
case dataInputs of
[_,_,c] -> analyseCtxV2 c
[_,c] -> analyseCtxV2 c
l -> error $ printf "Unexpected number of V2 script arguments: %d" (length l)
PlutusEvent PlutusV3 ScriptEvaluationData{..} _expected ->
case dataInputs of
[_,_,c] -> analyseCtxV3 c
[_,c] -> analyseCtxV3 c
l -> error $ printf "Unexpected number of V3 script arguments: %d" (length l)
where
analyseCtxV1 c =
case V1.fromData @V1.ScriptContext c of
Expand All @@ -134,6 +156,22 @@ analyseScriptContext _ctx _params ev = case ev of
do putStrLn "* Successfully decoded V1 ScriptContext for V2 event"
printV1info p

analyseCtxV3 c =
case V3.fromData @V3.ScriptContext c of
Just p -> printV3info p
Nothing -> do
putStrLn "\n* Failed to decode V3 ScriptContext for V3 event: trying V2"
case V2.fromData @V2.ScriptContext c of
Just p -> do
putStrLn "* Successfully decoded V2 ScriptContext for V3 event"
printV2info p
Nothing -> putStrLn "* Failed to decode V3 ScriptContext for V2 event: trying V1\n"
case V1.fromData @V1.ScriptContext c of
Just p -> do
putStrLn "* Successfully decoded V1 ScriptContext for V3 event"
printV1info p
Nothing -> putStrLn "* Failed to decode V1 ScriptContext for V3 event: giving up\n"

printV1info p = do
putStrLn "----------------"
putStrLn $ stringOfPurposeV1 $ V1.scriptContextPurpose p
Expand All @@ -144,6 +182,10 @@ analyseScriptContext _ctx _params ev = case ev of
putStrLn $ stringOfPurposeV2 $ V2.scriptContextPurpose p
analyseTxInfoV2 $ V2.scriptContextTxInfo p

printV3info p = do
putStrLn "----------------"
putStrLn $ stringOfPurposeV3 $ V3.scriptContextScriptInfo p
analyseTxInfoV3 $ V3.scriptContextTxInfo p

-- Data object analysis

Expand Down Expand Up @@ -221,31 +263,21 @@ printDataInfoFor = printDataInfo <$> getDataInfo
analyseRedeemer :: EventAnalyser
analyseRedeemer _ctx _params ev = do
case ev of
PlutusV1Event ScriptEvaluationData{..} _expected ->
case dataInputs of
[_d, r,_c] -> printDataInfoFor r
[r,_c] -> printDataInfoFor r
l -> printf "* Unexpected number of V1 script arguments: %d" (length l)
PlutusV2Event ScriptEvaluationData{..} _expected ->
case dataInputs of
[_d, r,_c] -> printDataInfoFor r
[r,_c] -> printDataInfoFor r
l -> printf "* Unexpected number of V2 script arguments: %d" (length l)
PlutusEvent ledgerLanguage ScriptEvaluationData{..} _expected ->
case dataInputs of
[_d, r, _c] -> printDataInfoFor r
[r, _c] -> printDataInfoFor r
l -> printf "* Unexpected number of %s script arguments: %d" (show ledgerLanguage) (length l)

-- Analyse a datum (as a Data object) from a script evaluation event
analyseDatum :: EventAnalyser
analyseDatum _ctx _params ev = do
case ev of
PlutusV1Event ScriptEvaluationData{..} _expected ->
case dataInputs of
[d, _r,_c] -> printDataInfoFor d
[_r,_c] -> pure ()
l -> printf "* Unexpected number of V1 script arguments: %d" (length l)
PlutusV2Event ScriptEvaluationData{..} _expected ->
case dataInputs of
[d, _r,_c] -> printDataInfoFor d
[_r,_c] -> pure ()
l -> printf "* Unexpected number of V2 script arguments: %d" (length l)
PlutusEvent ledgerLanguage ScriptEvaluationData{..} _expected ->
case dataInputs of
[d, _r, _c] -> printDataInfoFor d
[_r, _c] -> pure ()
l -> printf "* Unexpected number of %s script arguments: %d" (show ledgerLanguage) (length l)

-- Print statistics about Data objects in a Term
analyseTermDataObjects :: Term NamedDeBruijn DefaultUni DefaultFun () -> IO ()
Expand Down Expand Up @@ -299,7 +331,7 @@ countBuiltins eventFiles = do
mapM_ (analyseOneFile (analyseUnappliedScript (countBuiltinsInTerm counts))) eventFiles
finalCounts <- P.freezePrimArray counts 0 numBuiltins
P.itraversePrimArray_ printEntry finalCounts
where printEntry i c = printf "%-35s %12d\n" (show (toEnum i :: DefaultFun)) c
where printEntry i = printf "%-35s %12d\n" (show (toEnum i :: DefaultFun))


data EvaluationResult = OK ExBudget | Failed | DeserialisationError
Expand All @@ -315,7 +347,7 @@ toRString = \case
analyseCosts :: EventAnalyser
analyseCosts ctx _ ev =
case ev of
PlutusV1Event ScriptEvaluationData{..} _ ->
PlutusEvent PlutusV1 ScriptEvaluationData{..} _ ->
let result =
case deserialiseScript PlutusV1 dataProtocolVersion dataScript of
Left _ -> DeserialisationError
Expand All @@ -333,7 +365,7 @@ analyseCosts ctx _ ev =
(_, Right cost) -> OK cost
in printCost result dataBudget

PlutusV2Event ScriptEvaluationData{..} _ ->
PlutusEvent PlutusV2 ScriptEvaluationData{..} _ ->
let result =
case deserialiseScript PlutusV2 dataProtocolVersion dataScript of
Left _ -> DeserialisationError
Expand All @@ -351,6 +383,27 @@ analyseCosts ctx _ ev =
(_, Right cost) -> OK cost
in printCost result dataBudget

PlutusEvent PlutusV3 ScriptEvaluationData{..} _ -> do
dataInput <-
case dataInputs of
[input] -> pure input
_ -> throwIO $ userError "PlutusV3 script expects exactly one input"
let result =
case deserialiseScript PlutusV3 dataProtocolVersion dataScript of
Left _ -> DeserialisationError
Right script -> do
case
V3.evaluateScriptRestricting
dataProtocolVersion
V3.Quiet
ctx
dataBudget
script
dataInput of
(_, Left _) -> Failed
(_, Right cost) -> OK cost
printCost result dataBudget

where printCost :: EvaluationResult -> ExBudget -> IO ()
printCost result claimedCost =
let (claimedCPU, claimedMem) = costAsInts claimedCost
Expand All @@ -363,23 +416,16 @@ analyseCosts ctx _ ev =
_ ->
printf "%15s %15d %15s %15d %2s\n" "NA" claimedCPU "NA" claimedMem (toRString result)
costAsInts :: ExBudget -> (Int, Int)
costAsInts (ExBudget (V2.ExCPU cpu) (V2.ExMemory mem)) = (fromSatInt cpu, fromSatInt mem)
costAsInts (ExBudget (V2.ExCPU cpu) (V2.ExMemory mem)) =
(fromSatInt cpu, fromSatInt mem)

-- Extract the script from an evaluation event and apply some analysis function
analyseUnappliedScript :: (Term NamedDeBruijn DefaultUni DefaultFun () -> IO ()) -> EventAnalyser
analyseUnappliedScript
:: (Term NamedDeBruijn DefaultUni DefaultFun () -> IO ())
-> EventAnalyser
analyseUnappliedScript analyse _ctx _params ev = do
case ev of
PlutusV1Event ScriptEvaluationData{..} _expected ->
go $ deserialiseScript PlutusV1 dataProtocolVersion dataScript
PlutusV2Event ScriptEvaluationData{..} _expected ->
go $ deserialiseScript PlutusV2 dataProtocolVersion dataScript
where go = \case
Left err -> putStrLn $ show err
Right s ->
let ScriptNamedDeBruijn (Program _ _ t) = deserialisedScript s
in analyse t
analyse _ctx _params (PlutusEvent plutusLedgerLanguage ScriptEvaluationData{..} _expected) =
case deserialiseScript plutusLedgerLanguage dataProtocolVersion dataScript of
Left err -> print err
Right (deserialisedScript -> ScriptNamedDeBruijn (Program _ _ t)) -> analyse t

-- | Run some analysis function over the events from a single event dump file
analyseOneFile
Expand All @@ -394,11 +440,13 @@ analyseOneFile analyse eventFile = do
-- analyses.
case ( mkContext V1.mkEvaluationContext (eventsCostParamsV1 events)
, mkContext V2.mkEvaluationContext (eventsCostParamsV2 events)
, mkContext V3.mkEvaluationContext (eventsCostParamsV2 events)
) of
(Right ctxV1, Right ctxV2) ->
mapM_ (runSingleEvent ctxV1 ctxV2) (eventsOf events)
(Left err, _) -> error $ display err
(_, Left err) -> error $ display err
(Right ctxV1, Right ctxV2, Right ctxV3) ->
mapM_ (runSingleEvent ctxV1 ctxV2 ctxV3) (eventsOf events)
(Left err, _, _) -> error $ display err
(_, Left err, _) -> error $ display err
(_, _, Left err) -> error $ display err
where
mkContext f = \case
Nothing -> Right Nothing
Expand All @@ -407,18 +455,23 @@ analyseOneFile analyse eventFile = do
runSingleEvent
:: Maybe (EvaluationContext, [Int64])
-> Maybe (EvaluationContext, [Int64])
-> Maybe (EvaluationContext, [Int64])
-> ScriptEvaluationEvent
-> IO ()
runSingleEvent ctxV1 ctxV2 event =
runSingleEvent ctxV1 ctxV2 ctxV3 event =
case event of
PlutusV1Event{} ->
PlutusEvent PlutusV1 _ _ ->
case ctxV1 of
Just (ctx, params) -> analyse ctx params event
Nothing -> putStrLn "*** ctxV1 missing ***"
PlutusV2Event{} ->
PlutusEvent PlutusV2 _ _ ->
case ctxV2 of
Just (ctx, params) -> analyse ctx params event
Nothing -> putStrLn "*** ctxV2 missing ***"
PlutusEvent PlutusV3 _ _ ->
case ctxV3 of
Just (ctx, params) -> analyse ctx params event
Nothing -> putStrLn "*** ctxV3 missing ***"


main :: IO ()
Expand Down Expand Up @@ -462,12 +515,13 @@ main =
where printDescription (n,h,_) = hPrintf stderr " %-16s: %s\n" n h

go name dir =
case find (\(n,_,_) -> n == name) analyses of
Nothing -> printf "Unknown analysis: %s\n" name >> usage
Just (_,_,analysis) ->
filter ("event" `isExtensionOf`) <$> listFiles dir >>= \case
[] -> printf "No .event files in %s\n" dir
eventFiles -> analysis eventFiles
case find (\(n, _, _) -> n == name) analyses of
Nothing -> printf "Unknown analysis: %s\n" name >> usage
Just (_, _, analysis) -> do
files <- listFiles dir
case filter ("event" `isExtensionOf`) files of
[] -> printf "No .event files in %s\n" dir
eventFiles -> analysis eventFiles

in getArgs >>= \case
[name] -> go name "."
Expand Down
Loading

0 comments on commit 4797397

Please sign in to comment.