Update tx-generator to not use deprecated cardano-api api

Author: carbolymer

.gitignore

@@ -77,3 +77,4 @@ cardano-tracer/cardano-tracer-test
 .idea/
 
 .codex
+.serena/

bench/tx-generator/app/calibrate-script.hs

@@ -1,16 +1,33 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 
-import           Cardano.Api
+import           Cardano.Api hiding (eraProtVerHigh)
+import           Cardano.Api.Experimental (AnyWitness (..), IsEra (useEra),
+                   PlutusScriptDatum (..), PlutusScriptPurpose (..), SignedTx (..),
+                   eraProtVerHigh, makeKeyWitness, makeUnsignedTx,
+                   obtainCommonConstraints, signTx, toPlutusSLanguage)
+import           Cardano.Api.Experimental.AnyScriptWitness (AnyPlutusScriptWitness (..),
+                   createPlutusSpendingScriptWitness)
+import qualified Cardano.Api.Experimental as Exp (PlutusScriptInEra (..),
+                   PlutusScriptOrReferenceInput (..), PlutusScriptWitness (..),
+                   evaluateTransactionFee)
+import           Cardano.Api.Experimental.Plutus (AnyPlutusScript (..),
+                   plutusScriptInEraSLanguage)
+import qualified Cardano.Api.Experimental.Tx as Exp
+
+import qualified Cardano.Ledger.Plutus.Language as L (PlutusLanguage, Plutus (..), PlutusBinary (..),
+                   SLanguage (..), decodePlutusRunnable)
 
 import           Cardano.Benchmarking.Compiler (keyBenchmarkInputs)
 import           Cardano.Benchmarking.GeneratorTx.SizedMetadata (mkMetadata)
@@ -19,21 +36,22 @@ import           Cardano.Benchmarking.PlutusScripts (listPlutusScripts)
 #endif
 import           Cardano.TxGenerator.Calibrate.Utils
 import           Cardano.TxGenerator.PlutusContext
-import           Cardano.TxGenerator.ProtocolParameters ( ProtocolParameters (..), convertToLedgerProtocolParameters, 
-                   toLedgerPParams)
+import           Cardano.TxGenerator.ProtocolParameters (ProtocolParameters (..),
+                   convertToLedgerProtocolParameters)
 import           Cardano.TxGenerator.Setup.Plutus
 import           Cardano.TxGenerator.Tx (txSizeInBytes)
 import           Cardano.TxGenerator.Types
 import           Cardano.TxGenerator.Utils (keyAddress, mkTxIn)
 
 import           Control.Exception
+import           Data.Typeable (Typeable)
 import           Data.Aeson (decodeFileStrict')
 import qualified Data.ByteString.Lazy.Char8 as BSL (writeFile)
+
 import           Data.Char
 import           Data.Function (on, (&))
 import           Data.List (nub, sort, transpose)
 import           Data.List.Extra (split)
-
 import           Data.Map.Strict as Map (Map, empty, fromList, union)
 import           Data.Maybe
 import qualified Data.Text as T
@@ -157,6 +175,17 @@ runPlutus strategy budgetType protoParamFile plutusDef@PlutusOn{..} scales
   = do
     protocolParameters <- readProtocolParametersOrDie protoParamFile
     (script, resolvedTo) <- either (error . show) pure =<< readPlutusScript plutusScript
+    let era = useEra @ConwayEra
+    anyPlutusScript <- obtainCommonConstraints era $
+      case script of
+        ScriptInAnyLang _lang (PlutusScript version (PlutusScriptSerialised sbs)) -> do
+          let slang = toPlutusSLanguage version
+              decode :: forall l. (L.PlutusLanguage l, Typeable l) => L.SLanguage l -> IO (AnyPlutusScript (ShelleyLedgerEra ConwayEra))
+              decode _ = case L.decodePlutusRunnable @l (eraProtVerHigh era) (L.Plutus (L.PlutusBinary sbs)) of
+                Left err -> throwIO $ userError $ "script decode failed: " ++ show err
+                Right runnable -> pure $ AnyPlutusScript (Exp.PlutusScriptInEra runnable)
+          obtainLangConstraints slang $ decode slang
+        _ -> throwIO $ userError "expected a Plutus script"
 
     let
       redeemerDef   = Right plutusDef
@@ -189,7 +218,10 @@ runPlutus strategy budgetType protoParamFile plutusDef@PlutusOn{..} scales
       jsonName  = "summaries_" ++ scriptName <.> "json"
       csvName   = "scaling_" ++ scriptName <.> "csv"
 
-    summariesWithApprox <- mapM (approximateTxProperties script protocolParameters) summaries
+    ledgerProtocolParameters <-
+          either (error . docToString . prettyError) pure
+            $ convertToLedgerProtocolParameters shelleyBasedEra protocolParameters
+    summariesWithApprox <- mapM (approximateTxProperties anyPlutusScript ledgerProtocolParameters) summaries
     writeResultsJSON jsonName summariesWithApprox
     writeResultsCSV csvName summariesWithApprox
 
@@ -481,75 +513,76 @@ writeResultsJSON jsonName summaries = do
 -- | Builds a dummy transaction that resembles the ones submitted during some Plutus benchmark and
 --   uses it to augment the budget summary with txn size and fee.
 --   * If anything fails to evaluate, the summary is returned unchanged.
---   * This function is currently monorphic in the ledger era and will resolve era parameters to Conway.
-approximateTxProperties :: ScriptInAnyLang -> ProtocolParameters -> (PlutusBudgetSummary, ScriptRedeemer) -> IO PlutusBudgetSummary
-approximateTxProperties script protocolParameters (summary, redeemer) = do
+--   * This function is currently monomorphic in the ledger era and will resolve era parameters to Conway.
+approximateTxProperties :: AnyPlutusScript (ShelleyLedgerEra ConwayEra) -> LedgerProtocolParameters ConwayEra -> (PlutusBudgetSummary, ScriptRedeemer) -> IO PlutusBudgetSummary
+approximateTxProperties (AnyPlutusScript ps) ledgerProtocolParameters (summary, redeemer) = do
   putStrLn $ "--> approximating txn size and fee for: " ++ messageId summary
-  evaluate $ summary
-    { projectedTxSize = Just $ txSizeInBytes dummyTx
-    , projectedTxFee  = Just $ evaluateTransactionFee era ledgerPParams2 (getTxBody dummyTx) 2 0 0  -- 1 (script witness) + 1 (collateral) = 2
-    }
-
-  `catch` \(SomeException e) -> do
-    putStrLn $ "approximation failed: " ++ show e
-            ++ "\n--> using unmodified summary"
-    pure summary
-  where
-    era = ShelleyBasedEraConway
-
-    ledgerPParams1 :: LedgerProtocolParameters ConwayEra
-    ledgerPParams1 =
-      either (error . docToString . prettyError) id
-        $ convertToLedgerProtocolParameters era protocolParameters
-
-    ledgerPParams2 =
-      either (error . docToString . prettyError) id
-        $ toLedgerPParams era protocolParameters
-
-    witness :: Witness WitCtxTxIn ConwayEra
-    witness =
-      fromMaybe (error "could not get PlutusScriptWitness")
-        $ case script of
-            ScriptInAnyLang lang (PlutusScript version script') -> do
-              scriptLang <- scriptLanguageSupportedInEra era lang
-              pure
-                $ ScriptWitness ScriptWitnessForSpending
-                  $ PlutusScriptWitness
-                      scriptLang
-                      version
-                      (PScript script')
-                      (ScriptDatumForTxIn $ Just $ unsafeHashableScriptData $ ScriptDataNumber 0)
-                      redeemer
-                      (budgetUsedPerTxInput summary)
-            _ -> Nothing
-
-    -- build a dummy tx akin to what we'd get in the tx-generator's benchmarking workload;
-    -- it just needs to be sufficient to get our approximations.
-    dummyTx :: Tx ConwayEra
-    dummyTx
-      = signShelleyTransaction era txbody [WitnessPaymentKey keyBenchmarkInputs]
-      where
-        txbody =
-          either (error . docToString . prettyError) id
-            $ createTransactionBody era content
-
-        content =
-          defaultTxBodyContent era
-            & setTxIns [(dummyTxIn 0, BuildTxWith witness)]
-            & setTxInsCollateral (TxInsCollateral AlonzoEraOnwardsConway [dummyTxIn 1])
-            & setTxOuts [dummyTxOut]
-            & setTxValidityLowerBound TxValidityNoLowerBound
-            & setTxValidityUpperBound (defaultTxValidityUpperBound era)
-            & setTxMetadata dummyMetadata
-            & setTxFee (TxFeeExplicit era 1_000_000)
-            & setTxProtocolParams (BuildTxWith (Just ledgerPParams1))
-
+  let
+    era = useEra @ConwayEra
+    pparams = unLedgerProtocolParameters ledgerProtocolParameters
+    slang = plutusScriptInEraSLanguage ps
+    dummyDatum = unsafeHashableScriptData $ ScriptDataNumber 0
+    datum = mkSpendingScriptDatum slang dummyDatum
+    anyWitness =
+      let witness = Exp.PlutusScriptWitness slang (Exp.PScript ps) datum redeemer (budgetUsedPerTxInput summary)
+      in AnyPlutusScriptWitness (AnyPlutusSpendingScriptWitness (createPlutusSpendingScriptWitness slang witness))
+  obtainCommonConstraints era (do
     -- Corresponds to the metadata inserted in benchmarking workloads, which is why it's needed for the estimate.
     -- default value taken from: `add_tx_size` in nix/nixos/tx-generator-service.nix
-    dummyMetadata :: TxMetadataInEra ConwayEra
-    dummyMetadata = either error id $ mkMetadata 100
+    dummyMetadata <- either (\e -> throwIO $ userError $ "approximateTxProperties: mkMetadata: " ++ e) pure
+                       $ mkMetadata @ConwayEra 100
+    let
+      expMetadata = case dummyMetadata of
+        TxMetadataNone      -> mempty
+        TxMetadataInEra _ m -> m
+
+      -- just placeholders
+      dummyTxIn ix = mkTxIn $ "900fc5da77a0747da53f7675cbb7d149d46779346dea2f879ab811ccc72a2162#" <> textShow @Int ix
+      dummyTxOut   = TxOut (keyAddress (Testnet (NetworkMagic 42)) keyBenchmarkInputs) (lovelaceToTxOutValue shelleyBasedEra 1_000_000) TxOutDatumNone ReferenceScriptNone
+
+      -- build a dummy tx akin to what we'd get in the tx-generator's benchmarking workload;
+      -- it just needs to be sufficient to get our approximations.
+      txBodyContent =
+        Exp.defaultTxBodyContent
+          & Exp.setTxIns [(dummyTxIn 0, anyWitness)]
+          & Exp.setTxInsCollateral [dummyTxIn 1]
+          & Exp.setTxOuts [Exp.TxOut $ toShelleyTxOutAny shelleyBasedEra dummyTxOut]
+          & Exp.setTxFee (Coin 1_000_000)
+          & Exp.setTxMetadata expMetadata
+          & Exp.setTxProtocolParams pparams
+
+    unsignedTx <- either (\err -> throwIO $ userError $ "approximateTxProperties: " ++ show err) pure
+                    $ makeUnsignedTx era txBodyContent
+
+    let
+      witVKey = makeKeyWitness era unsignedTx (WitnessPaymentKey keyBenchmarkInputs)
+      dummyTx :: Tx ConwayEra
+      dummyTx =
+        case signTx era [] [witVKey] unsignedTx of
+          SignedTx signedLedgerTx -> ShelleyTx shelleyBasedEra signedLedgerTx
 
-    -- just placeholders
-    dummyTxIn ix = mkTxIn $ "900fc5da77a0747da53f7675cbb7d149d46779346dea2f879ab811ccc72a2162#" <> textShow @Int ix
-    dummyTxOut   = TxOut (keyAddress (Testnet (NetworkMagic 42)) keyBenchmarkInputs) (lovelaceToTxOutValue era 1_000_000) TxOutDatumNone ReferenceScriptNone
+    pure summary
+      { projectedTxSize = Just $ txSizeInBytes dummyTx
+      , projectedTxFee  = Just $ Exp.evaluateTransactionFee pparams unsignedTx 2 0 0  -- 1 (script witness) + 1 (collateral) = 2
+      }
+    ) `catch` \(SomeException e) -> do
+      putStrLn $ "approximation failed: " ++ show e
+              ++ "\n--> using unmodified summary"
+      pure summary
+
+-- TODO: remove these vendored functions and import from
+-- Cardano.Api.Experimental when the published cardano-api version includes them.
+
+obtainLangConstraints :: L.SLanguage lang -> ((L.PlutusLanguage lang, Typeable lang) => a) -> a
+obtainLangConstraints L.SPlutusV1 f = f
+obtainLangConstraints L.SPlutusV2 f = f
+obtainLangConstraints L.SPlutusV3 f = f
+obtainLangConstraints L.SPlutusV4 f = f
+
+mkSpendingScriptDatum :: L.SLanguage lang -> HashableScriptData -> PlutusScriptDatum lang 'SpendingScript
+mkSpendingScriptDatum = \case
+  L.SPlutusV1 -> SpendingScriptDatum
+  L.SPlutusV2 -> SpendingScriptDatum
+  L.SPlutusV3 -> SpendingScriptDatum . Just
+  L.SPlutusV4 -> SpendingScriptDatum . Just
 

bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 {-# OPTIONS_GHC -Wno-all-missed-specialisations #-}
@@ -19,7 +20,8 @@ module Cardano.Benchmarking.GeneratorTx
   , waitBenchmark
   ) where
 
-import           Cardano.Api hiding (txFee, label)
+import           Cardano.Api hiding (label, txFee)
+import           Cardano.Api.Experimental (IsEra, obtainCommonConstraints, useEra)
 
 import           Cardano.Benchmarking.GeneratorTx.NodeToNode
 import           Cardano.Benchmarking.GeneratorTx.Submission
@@ -110,7 +112,7 @@ handleTxSubmissionClientError
       LogErrors   -> traceWith traceSubmit $
         TraceBenchTxSubError (pack errDesc)
 
-walletBenchmark :: forall era. IsShelleyBasedEra era
+walletBenchmark :: forall era. IsEra era
   => Trace IO (TraceBenchTxSubmit TxId)
   -> Trace IO NodeToNodeSubmissionTrace
   -> ConnectClient
@@ -137,7 +139,7 @@ walletBenchmark
   _era
   count
   txSource
-  = liftIO $ do
+  = obtainCommonConstraints (useEra @era) $ liftIO $ do
   traceDebug "******* Tx generator, phase 2: pay to recipients *******"
 
   let numTargets :: Natural = fromIntegral $ NE.length targets