Skip to content

Commit

Permalink
Analyse script events supports PlutusLedgerLanguage V3
Browse files Browse the repository at this point in the history
  • Loading branch information
@Unisay
Unisay committed Jul 10, 2024
1 parent 42d08e0 commit c94e73f
Show file tree
Hide file tree
Showing 6 changed files with 296 additions and 300 deletions.
174 changes: 111 additions & 63 deletions plutus-ledger-api/exe/analyse-script-events/Main.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -6,12 +6,9 @@
{-# 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,6 +22,7 @@ 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

Expand Down Expand Up @@ -52,17 +50,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 +105,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 +154,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 +180,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 +261,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 +329,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 +345,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 +363,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 +381,24 @@ analyseCosts ctx _ ev =
(_, Right cost) -> OK cost
in printCost result dataBudget

PlutusEvent PlutusV3 ScriptEvaluationData{..} _ ->
let result =
case deserialiseScript PlutusV3 dataProtocolVersion dataScript of
Left _ -> DeserialisationError
Right script ->
case
V3.evaluateScriptRestricting
dataProtocolVersion
V3.Quiet
ctx
dataBudget
script
(head dataInputs)
of
(_, Left _) -> Failed
(_, Right cost) -> OK cost
in printCost result dataBudget

where printCost :: EvaluationResult -> ExBudget -> IO ()
printCost result claimedCost =
let (claimedCPU, claimedMem) = costAsInts claimedCost
Expand All @@ -366,20 +414,12 @@ analyseCosts ctx _ ev =
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 +434,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 +449,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 +509,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
75 changes: 4 additions & 71 deletions plutus-ledger-api/exe/common/LoadScriptEvents.hs
View file
Original file line number Diff line number Diff line change
@@ -1,81 +1,14 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TypeApplications #-}

module LoadScriptEvents (eventsOf, loadEvents)
where
module LoadScriptEvents (eventsOf, loadEvents) where

import PlutusLedgerApi.Common
import Codec.Serialise (readFileDeserialise)
import Data.List.NonEmpty (toList)
import PlutusLedgerApi.Test.EvaluationEvent

import Codec.Serialise (Serialise, readFileDeserialise)
import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty, toList)
import GHC.Generics (Generic)


{- The ScriptEvaluationData type used to contain a ProtocolVersion but now
contains only a MajorProtocolVersion. The program which dumps the mainnet
scripts still writes both the major and minor protocol version numbers, so here
we provide some adaptor types which allow us to read the old format and convert
it to the new format. We expect that this program will be subsumed by Marconi
eventually, so we just go for a quick fix here for the time being instead of
rewriting the script-dumper; also this strategy allows us to process existing
files without having to re-dump all of the scripts from the history of the
chain.
-}

-- Adaptor types

data ProtocolVersion = ProtocolVersion
{ pvMajor :: Int -- ^ the major component
, pvMinor :: Int -- ^ the minor component
}
deriving stock (Show, Eq, Generic)
deriving anyclass Serialise

data ScriptEvaluationData2 = ScriptEvaluationData2
{ dataProtocolVersion2 :: ProtocolVersion
, dataBudget2 :: ExBudget
, dataScript2 :: SerialisedScript
, dataInputs2 :: [Data]
}
deriving stock (Show, Generic)
deriving anyclass (Serialise)

data ScriptEvaluationEvent2
= PlutusV1Event2 ScriptEvaluationData2 ScriptEvaluationResult
| PlutusV2Event2 ScriptEvaluationData2 ScriptEvaluationResult
deriving stock (Show, Generic)
deriving anyclass (Serialise)

data ScriptEvaluationEvents2 = ScriptEvaluationEvents2
{ eventsCostParamsV1' :: Maybe [Int64]
-- ^ Cost parameters shared by all PlutusV1 evaluation events in `eventsEvents`, if any.
, eventsCostParamsV2' :: Maybe [Int64]
-- ^ Cost parameters shared by all PlutusV2 evaluation events in `eventsEvents`, if any.
, eventsEvents2 :: NonEmpty ScriptEvaluationEvent2
}
deriving stock (Show, Generic)
deriving anyclass Serialise

-- Conversion functions

data2toData :: ScriptEvaluationData2 -> ScriptEvaluationData
data2toData (ScriptEvaluationData2 (ProtocolVersion v _) b s i) =
ScriptEvaluationData (MajorProtocolVersion v) b s i

event2toEvent :: ScriptEvaluationEvent2 -> ScriptEvaluationEvent
event2toEvent (PlutusV1Event2 d r) = PlutusV1Event (data2toData d) r
event2toEvent (PlutusV2Event2 d r) = PlutusV2Event (data2toData d) r

events2toEvents :: ScriptEvaluationEvents2 -> ScriptEvaluationEvents
events2toEvents (ScriptEvaluationEvents2 cpV1 cpV2 evs) =
ScriptEvaluationEvents cpV1 cpV2 (fmap event2toEvent evs)

-- Loading events from a file
loadEvents :: FilePath -> IO ScriptEvaluationEvents
loadEvents eventFile =
events2toEvents <$> readFileDeserialise @ScriptEvaluationEvents2 eventFile
loadEvents = readFileDeserialise @ScriptEvaluationEvents

eventsOf :: ScriptEvaluationEvents -> [ScriptEvaluationEvent]
eventsOf = toList . eventsEvents
Loading

0 comments on commit c94e73f

Please sign in to comment.