Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Analyse script events supports PlutusLedgerLanguage V3 #6300

Merged
merged 1 commit into from
Jul 11, 2024
Merged

Analyse script events supports PlutusLedgerLanguage V3 #6300

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
182 changes: 118 additions & 64 deletions plutus-ledger-api/exe/analyse-script-events/Main.hs
View file
Open in desktop
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