tx-generator: include PlutusV2 ledger API

IntersectMBO · Nov 25, 2022 · d54835f · d54835f
1 parent 02f5f01
commit d54835f
Show file tree

Hide file tree

Showing 2 changed files with 109 additions and 41 deletions.
diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Setup/Plutus.hs b/bench/tx-generator/src/Cardano/TxGenerator/Setup/Plutus.hs
@@ -11,6 +11,7 @@ module Cardano.TxGenerator.Setup.Plutus
        where
 
 import qualified Data.Map as Map
+import           GHC.Natural (Natural)
 
 import           Control.Monad.Trans.Except
 import           Control.Monad.Trans.Except.Extra
@@ -22,72 +23,138 @@ import           Cardano.Api.Shelley (PlutusScript (..), ProtocolParameters (..)
                    protocolParamCostModels, toPlutusData)
 import           Cardano.Ledger.Alonzo.TxInfo (exBudgetToExUnits)
 
-import qualified Plutus.V1.Ledger.Api as Plutus
-import           Plutus.V1.Ledger.Contexts (ScriptContext (..), ScriptPurpose (..), TxInfo (..),
-                   TxOutRef (..))
+import qualified Plutus.V1.Ledger.Api as PlutusV1
+import qualified Plutus.V2.Ledger.Api as PlutusV2
+import qualified PlutusTx.AssocMap as PlutusMap (empty)
 
 import           Cardano.TxGenerator.Types
 
 
 readPlutusScript :: FilePath -> IO (Either TxGenError ScriptInAnyLang)
 readPlutusScript fp
-  = do
-  res <- runExceptT $ readFileScriptInAnyLang fp
-  return $ case res of
-    Left err -> Left $ ApiError err
-    Right script@(ScriptInAnyLang (PlutusScriptLanguage _) _) -> Right script
-    Right (ScriptInAnyLang lang _) -> Left $ TxGenError $ "readPlutusScript: only PlutusScript supported, found: " ++ show lang
-
+  = runExceptT $ do
+    script <- firstExceptT ApiError $
+      readFileScriptInAnyLang fp
+    case script of
+      ScriptInAnyLang (PlutusScriptLanguage _) _ -> pure script
+      ScriptInAnyLang lang _ -> throwE $ TxGenError $ "readPlutusScript: only PlutusScript supported, found: " ++ show lang
 
 preExecutePlutusScript ::
      ProtocolParameters
   -> ScriptInAnyLang
   -> ScriptData
   -> ScriptData
   -> Either TxGenError ExecutionUnits
-preExecutePlutusScript protocolParameters (ScriptInAnyLang _ (PlutusScript lang (PlutusScriptSerialised script))) datum redeemer
+preExecutePlutusScript protocolParameters script@(ScriptInAnyLang scriptLang _) datum redeemer
   = runExcept $ do
-    CostModel costModel <-
-      let model = AnyPlutusScriptVersion lang
-      in hoistMaybe (TxGenError $ "preExecutePlutusScript: cost model unavailable for " ++ show model) $
-        model `Map.lookup` protocolParamCostModels protocolParameters
+    costModel <- hoistMaybe (TxGenError $ "preExecutePlutusScript: cost model unavailable for: " ++ show scriptLang) $
+      case script of
+        ScriptInAnyLang _ (PlutusScript lang _) ->
+          AnyPlutusScriptVersion lang `Map.lookup` protocolParamCostModels protocolParameters
+        _ -> Nothing
+
+    case script of
+      ScriptInAnyLang (PlutusScriptLanguage PlutusScriptV1) script' ->
+        preExecutePlutusV1 protocolVersion script' datum redeemer costModel
+      ScriptInAnyLang (PlutusScriptLanguage PlutusScriptV2) script' ->
+        preExecutePlutusV2 protocolVersion script' datum redeemer costModel
+      _ ->
+        throwE $ TxGenError $ "preExecutePlutusScript: script not supported: " ++ show scriptLang
+  where
+    protocolVersion = protocolParamProtocolVersion protocolParameters
+
+preExecutePlutusV1 ::
+     (Natural, Natural)
+  -> Script PlutusScriptV1
+  -> ScriptData
+  -> ScriptData
+  -> CostModel
+  -> Except TxGenError ExecutionUnits
+preExecutePlutusV1 (majVer, minVer) (PlutusScript _ (PlutusScriptSerialised script)) datum redeemer (CostModel costModel)
+  = do
+    evaluationContext <- firstExceptT PlutusError $
+      PlutusV1.mkEvaluationContext costModel
+
+    let
+      protocolVersion = PlutusV1.ProtocolVersion (fromIntegral majVer) (fromIntegral minVer)
+
+    exBudget <- firstExceptT PlutusError $
+      hoistEither $
+        snd $ PlutusV1.evaluateScriptCounting protocolVersion PlutusV1.Verbose evaluationContext script
+          [ toPlutusData datum
+          , toPlutusData redeemer
+          , PlutusV1.toData dummyContext
+          ]
+
+    x <- hoistMaybe (TxGenError "preExecutePlutusV1: could not convert to execution units") $
+      exBudgetToExUnits exBudget
+    return $ fromAlonzoExUnits x
+  where
+    dummyContext :: PlutusV1.ScriptContext
+    dummyContext = PlutusV1.ScriptContext dummyTxInfo (PlutusV1.Spending dummyOutRef)
+
+    dummyOutRef :: PlutusV1.TxOutRef
+    dummyOutRef = PlutusV1.TxOutRef (PlutusV1.TxId "") 0
+
+    dummyTxInfo :: PlutusV1.TxInfo
+    dummyTxInfo = PlutusV1.TxInfo
+      { PlutusV1.txInfoInputs = []
+      , PlutusV1.txInfoOutputs = []
+      , PlutusV1.txInfoFee = mempty
+      , PlutusV1.txInfoMint = mempty
+      , PlutusV1.txInfoDCert = []
+      , PlutusV1.txInfoWdrl = []
+      , PlutusV1.txInfoValidRange = PlutusV1.always
+      , PlutusV1.txInfoSignatories = []
+      , PlutusV1.txInfoData = []
+      , PlutusV1.txInfoId = PlutusV1.TxId ""
+      }
+
+preExecutePlutusV2 ::
+     (Natural, Natural)
+  -> Script PlutusScriptV2
+  -> ScriptData
+  -> ScriptData
+  -> CostModel
+  -> Except TxGenError ExecutionUnits
+preExecutePlutusV2 (majVer, minVer) (PlutusScript _ (PlutusScriptSerialised script)) datum redeemer (CostModel costModel)
+  = do
     evaluationContext <- firstExceptT PlutusError $
-      Plutus.mkEvaluationContext costModel
+      PlutusV2.mkEvaluationContext costModel
 
     let
-      protocolVersion = Plutus.ProtocolVersion (fromIntegral majVer) (fromIntegral minVer)
+      protocolVersion = PlutusV2.ProtocolVersion (fromIntegral majVer) (fromIntegral minVer)
 
     exBudget <- firstExceptT PlutusError $
       hoistEither $
-        snd $ Plutus.evaluateScriptCounting protocolVersion Plutus.Verbose evaluationContext script
+        snd $ PlutusV2.evaluateScriptCounting protocolVersion PlutusV2.Verbose evaluationContext script
           [ toPlutusData datum
           , toPlutusData redeemer
-          , Plutus.toData dummyContext
+          , PlutusV2.toData dummyContext
           ]
 
-    x <- hoistMaybe (TxGenError "preExecutePlutusScript: could not convert to execution units") $
+    x <- hoistMaybe (TxGenError "preExecutePlutusV2: could not convert to execution units") $
       exBudgetToExUnits exBudget
     return $ fromAlonzoExUnits x
   where
-    (majVer, minVer) = protocolParamProtocolVersion protocolParameters
-
-    dummyContext :: ScriptContext
-    dummyContext = ScriptContext dummyTxInfo (Spending dummyOutRef)
-
-    dummyOutRef :: TxOutRef
-    dummyOutRef = TxOutRef (Plutus.TxId "") 0
-    dummyTxInfo :: TxInfo
-    dummyTxInfo = TxInfo
-      { txInfoInputs = []
-      , txInfoOutputs = []
-      , txInfoFee = mempty
-      , txInfoMint = mempty
-      , txInfoDCert = []
-      , txInfoWdrl = []
-      , txInfoValidRange = Plutus.always
-      , txInfoSignatories = []
-      , txInfoData = []
-      , txInfoId = Plutus.TxId ""
+    dummyContext :: PlutusV2.ScriptContext
+    dummyContext = PlutusV2.ScriptContext dummyTxInfo (PlutusV2.Spending dummyOutRef)
+
+    dummyOutRef :: PlutusV2.TxOutRef
+    dummyOutRef = PlutusV2.TxOutRef (PlutusV2.TxId "") 0
+
+    dummyTxInfo :: PlutusV2.TxInfo
+    dummyTxInfo = PlutusV2.TxInfo
+      { PlutusV2.txInfoInputs = []
+      , PlutusV2.txInfoReferenceInputs = []
+      , PlutusV2.txInfoOutputs = []
+      , PlutusV2.txInfoFee = mempty
+      , PlutusV2.txInfoMint = mempty
+      , PlutusV2.txInfoDCert = []
+      , PlutusV2.txInfoWdrl = PlutusMap.empty
+      , PlutusV2.txInfoValidRange = PlutusV2.always
+      , PlutusV2.txInfoSignatories = []
+      , PlutusV2.txInfoRedeemers = PlutusMap.empty
+      , PlutusV2.txInfoData = PlutusMap.empty
+      , PlutusV2.txInfoId = PlutusV2.TxId ""
       }
-preExecutePlutusScript _ (ScriptInAnyLang lang _) _ _
-  = Left $ TxGenError $ "preExecutePlutusScript: only PlutusScript supported, found: " ++ show lang
diff --git a/bench/tx-generator/tx-generator.cabal b/bench/tx-generator/tx-generator.cabal
@@ -113,6 +113,7 @@ library
                      , ouroboros-network
                      , ouroboros-network-framework
                      , plutus-ledger-api
+                     , plutus-tx
                      , random
                      , serialise
                      , streaming