tx-generator: parametrizable script redeemer

bench/tx-generator/data/ecdsa-secp256k1-loop.redeemer.json

@@ -1 +1 @@
-{"constructor":0,"fields":[{"int":1000000},{"bytes":"c990a0510345c7ac576d5e612afd41a7da65c228dde536db0d6c680350134bcdf23988c04e666cf5d478c3ba8dc81a4af9466dbf441c07906f77e16efd02828d"},{"bytes":"315f5bdb76d078c43b8ac0064e4a0164612b1fce77c869345bfc94c75894edd3"},{"bytes":"ed651a9436ae022a3ac25be76a0caf22c2cc5b346f65df7a7f76b396556320df875ebc95693a8d1ec53f95161d008299621af3fdd5ead19bf8e578f64753103d"}]}
+{"constructor":0,"fields":[{"int":1000000},{"bytes":"0392d7b94bc6a11c335a043ee1ff326b6eacee6230d3685861cd62bce350a172e0"},{"bytes":"16e0bf1f85594a11e75030981c0b670370b3ad83a43f49ae58a2fd6f6513cde9"},{"bytes":"5fb12954b28be6456feb080cfb8467b6f5677f62eb9ad231de7a575f4b6857512754fb5ef7e0e60e270832e7bb0e2f0dc271012fa9c46c02504aa0e798be6295"}]}

bench/tx-generator/data/schnorr-secp256k1-loop.redeemer.json

@@ -1 +1 @@
-{"constructor":0,"fields":[{"int":1000000},{"bytes":"5e516dff32f8dd97e00a3b1eba5e494f6e762704a84c6dacf1d76c3fb85fb46b888794a3e9f98104fe93fb4d91f685de7a6fba97ca8053dce28f84cf550bce6e"},{"bytes":"315f5bdb76d078c43b8ac0064e4a0164612b1fce77c869345bfc94c75894edd3"},{"bytes":"070135e16157c952dd84da758639805051ba8a80d13487997023ea3bf6ba55f31947373a8519b1bb133270831170de7ec109de5c4ec71328323fbefdd6366f2c"}]}
+{"constructor":0,"fields":[{"int":1000000},{"bytes":"599de3e582e2a3779208a210dfeae8f330b9af00a47a7fb22e9bb8ef596f301b"},{"bytes":"30303030303030303030303030303030303030303030303030303030303030303030303030303030303030303030303030303030303030303030303030303030"},{"bytes":"5a56da88e6fd8419181dec4d3dd6997bab953d2fc71ab65e23cfc9e7e3d1a310613454a60f6703819a39fdac2a410a094442afd1fc083354443e8d8bb4461a9b"}]}

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

@@ -134,7 +134,11 @@ splittingPhase srcWallet = do
   plutusPayMode dst = do
     autoMode <- isPlutusAutoMode
     scriptSpec <- if autoMode
-      then ScriptSpec <$> askNixOption _nix_plutusLoopScript <*> pure AutoScript
+      then askNixOption _nix_plutusRedeemerSerialized >>= \case
+        Nothing -> throwCompileError $ SomeCompilerError "Plutus loop autoscript requires a filepath to .json as plutusRedeemerSerialized"
+        Just redeemer -> do
+          autoScript <- AutoScript redeemer <$> askNixOption _nix_inputs_per_tx
+          ScriptSpec <$> askNixOption _nix_plutusLoopScript <*> pure autoScript
       else do
         executionUnits <- ExecutionUnits <$> askNixOption _nix_executionMemory <*> askNixOption _nix_executionSteps
         debugMode <- askNixOption _nix_debugMode

bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs

@@ -8,10 +8,10 @@
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-}
 
 module Cardano.Benchmarking.Script.Core
 where
@@ -50,6 +50,7 @@ import           Cardano.Benchmarking.GeneratorTx.NodeToNode (ConnectClient,
                    benchmarkConnectTxSubmit)
 import           Cardano.Benchmarking.GeneratorTx.SizedMetadata (mkMetadata)
 import qualified Cardano.TxGenerator.Genesis as Genesis
+import           Cardano.TxGenerator.PlutusContext
 import           Cardano.TxGenerator.Setup.SigningKey
 
 import           Cardano.Benchmarking.OuroborosImports as Core (LocalSubmitTx, SigningKeyFile,
@@ -373,62 +374,13 @@ interpretPayMode payMode = do
           return ( createAndStore (mkUTxOScript networkId (script, scriptData) witness) (mkWalletFundStore walletRef)
                  , Text.unpack $ serialiseAddress $ makeShelleyAddress networkId (PaymentCredentialByScript $ hashScript script') NoStakeAddress )
 
-{-
-Use a binary search to find a loop counter that maxes out the available per transaction Plutus budget.
-It is intended to be used with the the loop script from cardano-node/plutus-examples/...
-loopScriptFile is the FilePath to the Plutus script that implements the delay loop. (for example in /nix/store/).
-spendAutoScript relies on a particular calling convention of the loop script.
--}
-
-spendAutoScript ::
-     ProtocolParameters
-  -> ScriptInAnyLang
-  -> ActionM (ScriptData, ScriptRedeemer)
-spendAutoScript protocolParameters script = do
-  perTxBudget <- case protocolParamMaxTxExUnits protocolParameters of
-    Nothing -> liftTxGenError $ TxGenError "Cannot determine protocolParamMaxTxExUnits"
-    Just b -> return b
-  traceDebug $ "Plutus auto mode : Available budget per TX: " ++ show perTxBudget
-
-  let
-    budget = ExecutionUnits
-                 (executionSteps perTxBudget `div`  2) -- TODO FIX - use _nix_inputs_per_tx
-                 (executionMemory perTxBudget `div` 2)
-  traceDebug $ "Plutus auto mode : Available budget per script run: " ++ show budget
-
-  let
-    isInLimits :: Integer -> Either TxGenError Bool
-    isInLimits n = case preExecutePlutusScript protocolParameters script (ScriptDataNumber 0) (toLoopArgument n) of
-      Left err -> Left err
-      Right use -> Right $ (executionSteps use <= executionSteps budget) && (executionMemory use <= executionMemory budget)
-    searchUpperBound = 100000 -- The highest loop count that is tried. (This is about 50 times the current mainnet limit.)
-  redeemer <- case startSearch isInLimits 0 searchUpperBound of
-    Left err -> liftTxGenError $ TxGenError "cannot find fitting redeemer: " <> err
-    Right n -> return $ toLoopArgument n
-  return (ScriptDataNumber 0, redeemer)
-  where
-    -- This is the hardcoded calling convention of the loop.plutus script.
-    -- To loop n times one has to pass n + 1_000_000 as redeemer.
-    toLoopArgument n = ScriptDataNumber $ n + 1000000
-    startSearch f a b = do
-      l <- f a
-      h <- f b
-      if l && not h then search f a b
-        else Left $ TxGenError $ "Binary search: Bad initial bounds: " ++ show (a,l,b,h)
-    search f a b
-      = if a + 1 == b then Right a
-           else do
-             let m = (a + b) `div` 2
-             test <- f m
-             if test then search f m b else search f a m
-
 makePlutusContext :: forall era. IsShelleyBasedEra era
   => ScriptSpec
   -> ActionM (Witness WitCtxTxIn era, ScriptInAnyLang, ScriptData, Lovelace)
 makePlutusContext scriptSpec = do
   protocolParameters <- getProtocolParameters
-  script_ <- liftIO $ Plutus.readPlutusScript $ scriptSpecFile scriptSpec
-  script <- either liftTxGenError pure script_
+  script <- either liftTxGenError pure =<<
+    liftIO (Plutus.readPlutusScript $ scriptSpecFile scriptSpec)
 
   executionUnitPrices <- case protocolParamPrices protocolParameters of
     Just x -> return x
@@ -444,16 +396,37 @@ makePlutusContext scriptSpec = do
     CheckScriptBudget sdata redeemer unitsWant -> do
       unitsPreRun <- preExecuteScriptAction protocolParameters script sdata redeemer
       if unitsWant == unitsPreRun
-         then return (sdata, redeemer, unitsWant )
+         then return (sdata, redeemer, unitsWant)
          else throwE $ WalletError $ concat [
               " Stated execution Units do not match result of pre execution. "
             , " Stated value : ", show unitsWant
             , " PreExecution result : ", show unitsPreRun
             ]
-    AutoScript -> do
-      (sdata, redeemer) <- spendAutoScript protocolParameters script
-      preRun <- preExecuteScriptAction protocolParameters script sdata redeemer
-      return (sdata, redeemer, preRun)
+    AutoScript redeemerFile budgetFraction -> do
+      redeemer <- either liftTxGenError pure =<<
+        liftIO (readRedeemer redeemerFile)
+      let
+        budget = ExecutionUnits
+                    (executionSteps perTxBudget  `div` fromIntegral budgetFraction)
+                    (executionMemory perTxBudget `div` fromIntegral budgetFraction)
+
+        -- reflects properties hard-coded into the loop scripts for benchmarking:
+        -- 1. script datum is not used
+        -- 2. the loop terminates at 1_000_000 when counting down
+        -- 3. the loop's initial value is the first numerical value in the redeemer argument structure
+        autoBudget = PlutusAutoBudget
+          { autoBudgetUnits = budget
+          , autoBudgetDatum = ScriptDataNumber 0
+          , autoBudgetRedeemer = scriptDataModifyNumber (const 1_000_000) redeemer
+          }
+      traceDebug $ "Plutus auto mode : Available budget per Tx input / script run: " ++ show budget
+                   ++ " -- fraction of protocolParamMaxTxExUnits budget: 1/" ++ show budgetFraction
+
+      case plutusAutoBudgetMaxOut protocolParameters script autoBudget of
+        Left err -> liftTxGenError err
+        Right PlutusAutoBudget{..} -> do
+          preRun <- preExecuteScriptAction protocolParameters script autoBudgetDatum autoBudgetRedeemer
+          return (autoBudgetDatum, autoBudgetRedeemer, preRun)
 
   let msg = mconcat [ "Plutus Benchmark :"
                     , " Script: ", scriptSpecFile scriptSpec

bench/tx-generator/src/Cardano/Benchmarking/Script/Types.hs

@@ -103,7 +103,7 @@ deriving instance Generic PayMode
 data ScriptBudget where
   StaticScriptBudget :: !ScriptData -> !ScriptRedeemer -> !ExecutionUnits -> ScriptBudget
   CheckScriptBudget  :: !ScriptData -> !ScriptRedeemer -> !ExecutionUnits -> ScriptBudget
-  AutoScript :: ScriptBudget --todo: add fraction of total available budget to use (==2 with 2 inputs !)
+  AutoScript :: !FilePath -> !Int -> ScriptBudget
   deriving (Show, Eq)
 deriving instance Generic ScriptBudget
 

bench/tx-generator/src/Cardano/TxGenerator/PlutusContext.hs

@@ -1,33 +1,55 @@
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module  Cardano.TxGenerator.PlutusContext
-        ( module Cardano.TxGenerator.PlutusContext
+        ( plutusAutoBudgetMaxOut
+        , readRedeemer
+        , scriptDataModifyNumber
         )
         where
 
+import           Control.Monad.Trans.Except.Extra
 import           Data.Aeson as Aeson
-import           System.Exit
-import           System.FilePath
 
 import           Cardano.Api
+import           Cardano.Api.Shelley (ProtocolParameters)
 
-import           Paths_tx_generator
+import           Cardano.TxGenerator.Setup.Plutus (preExecutePlutusScript)
+import           Cardano.TxGenerator.Types
 
 
--- load a redeemer for the script
--- TODO the redeemer serialization JSON file should be provided, not resolved inside tx-generator
-readRedeemer :: FilePath -> IO ScriptData
-readRedeemer scriptPath
-  = do
-    redeemer <- getDataFileName $ "data" </> redeemerFile
+-- | load a redeemer for the script
+readRedeemer :: FilePath -> IO (Either TxGenError ScriptRedeemer)
+readRedeemer redeemerPath
+  = runExceptT $ do
     sData :: Aeson.Value <-
-      either die pure =<< eitherDecodeFileStrict' redeemer
-    case scriptDataFromJson ScriptDataJsonDetailedSchema sData of
-      Left e -> die (show e)
-      Right sData' -> putStrLn ("--> read redeemer: " ++ redeemerFile) >> return sData'
+      firstExceptT TxGenError . hoistEither =<<
+        handleIOExceptT (TxGenError . show) (eitherDecodeFileStrict' redeemerPath)
+    firstExceptT ApiError . hoistEither $
+       scriptDataFromJson ScriptDataJsonDetailedSchema sData
+
+-- | Use a binary search to find a loop counter that maxes out the available script execution units.
+--   plutusAutoBudgetMaxOut makes two assumptions about the loop / PlutusAuto script:
+--   1. The redeemer passed in is a valid one, and encodes i.a. the loop's
+--      termination value when counting down.
+--   2. In the redeemer's argument structure, this value is the first numerical value
+--      that's encountered during traversal.
+plutusAutoBudgetMaxOut :: ProtocolParameters -> ScriptInAnyLang -> PlutusAutoBudget -> Either TxGenError PlutusAutoBudget
+plutusAutoBudgetMaxOut protocolParams script pab@PlutusAutoBudget{..}
+  = do
+    redeemer' <- toLoopArgument <$> binarySearch isInLimits 0 searchUpperBound
+    pure $ pab {autoBudgetRedeemer = redeemer'}
   where
-    redeemerFile = (<.> ".redeemer.json") $ dropExtension $ takeFileName scriptPath
+    -- The highest loop counter that is tried - this is about 10 times the current mainnet limit.
+    searchUpperBound = 20000
+
+    toLoopArgument n = scriptDataModifyNumber (+ n) autoBudgetRedeemer
+
+    isInLimits :: Integer -> Either TxGenError Bool
+    isInLimits n = do
+      used <- preExecutePlutusScript protocolParams script autoBudgetDatum (toLoopArgument n)
+      pure $ executionSteps used <= executionSteps autoBudgetUnits && executionMemory used <= executionMemory autoBudgetUnits
 
 -- modifies the first ScriptDataNumber encountered during traversal to the value provided
 scriptDataModifyNumber :: (Integer -> Integer) -> ScriptData -> ScriptData
@@ -45,3 +67,18 @@ scriptDataModifyNumber f
     goList [] = []
     goList (x:xs) =
       let x' = go x in if x' == x then x : goList xs else x' : xs
+
+binarySearch :: (Integral n, Show n) => (n -> Either TxGenError Bool) -> n -> n -> Either TxGenError n
+binarySearch f a_ b_ = do
+  l <- f a_
+  h <- f b_
+  if l && not h
+    then go a_ b_
+    else Left $ TxGenError $ "binarySearch: bad initial bounds: " ++ show (a_,l,b_,h)
+  where
+    go a b
+      | a + 1 == b = Right a
+      | otherwise = do
+          let m = (a + b) `div` 2
+          test <- f m
+          if test then go m b else go a m

bench/tx-generator/src/Cardano/TxGenerator/Setup/NixService.hs

@@ -42,6 +42,7 @@ data NixServiceOptions = NixServiceOptions {
   , _nix_plutusScript     :: String
   , _nix_plutusData       :: Integer
   , _nix_plutusRedeemer   :: Integer
+  , _nix_plutusRedeemerSerialized :: Maybe FilePath     -- ^ a .json file conforming to Cadano.Api.ScriptData (ScriptDataJsonDetailedSchema)
   , _nix_executionMemory  :: Natural
   , _nix_executionSteps   :: Natural
   , _nix_nodeConfigFile       :: Maybe FilePath

bench/tx-generator/src/Cardano/TxGenerator/Setup/Plutus.hs

@@ -43,7 +43,7 @@ preExecutePlutusScript ::
      ProtocolParameters
   -> ScriptInAnyLang
   -> ScriptData
-  -> ScriptData
+  -> ScriptRedeemer
   -> Either TxGenError ExecutionUnits
 preExecutePlutusScript protocolParameters script@(ScriptInAnyLang scriptLang _) datum redeemer
   = runExcept $ do
@@ -67,7 +67,7 @@ preExecutePlutusV1 ::
      (Natural, Natural)
   -> Script PlutusScriptV1
   -> ScriptData
-  -> ScriptData
+  -> ScriptRedeemer
   -> CostModel
   -> Except TxGenError ExecutionUnits
 preExecutePlutusV1 (majVer, minVer) (PlutusScript _ (PlutusScriptSerialised script)) datum redeemer (CostModel costModel)
@@ -114,7 +114,7 @@ preExecutePlutusV2 ::
      (Natural, Natural)
   -> Script PlutusScriptV2
   -> ScriptData
-  -> ScriptData
+  -> ScriptRedeemer
   -> CostModel
   -> Except TxGenError ExecutionUnits
 preExecutePlutusV2 (majVer, minVer) (PlutusScript _ (PlutusScriptSerialised script)) datum redeemer (CostModel costModel)

bench/tx-generator/src/Cardano/TxGenerator/Types.hs

@@ -85,12 +85,19 @@ data TxGenPlutusParams =
       , plutusExecMemory  :: !Natural   -- ^ Max. memory available for the Plutus script
       , plutusExecSteps   :: !Natural   -- ^ Max. execution steps available for the Plutus script
       }
-  | PlutusAuto                          -- ^ Generate Txs for a Plutus script, choosing settings to max out per Tx script budget
+  | PlutusAuto                          -- ^ Generate Txs for a Plutus loop script, choosing settings to max out per Tx script budget
       { plutusAutoScript  :: !FilePath  -- ^ Path to the Plutus script
       }
   | PlutusOff                           -- ^ Do not generate Plutus Txs
   deriving (Show, Eq)
 
+data PlutusAutoBudget
+  = PlutusAutoBudget                           -- ^ Specifies a budget and parameters for a PlutusAuto loop script
+    { autoBudgetUnits     :: !ExecutionUnits   -- ^ execution units available per Tx input / script run
+    , autoBudgetDatum     :: !ScriptData       -- ^ datum for the auto script
+    , autoBudgetRedeemer  :: !ScriptRedeemer   -- ^ valid redeemer for the auto script
+    }
+    deriving (Show, Eq)
 
 data TxGenError where
   ApiError        :: Cardano.Api.Error e => !e -> TxGenError

bench/tx-generator/test/ApiTest.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -16,9 +18,10 @@ import           Options.Applicative.Common as Opt (runParserInfo)
 
 import           System.Environment (getArgs)
 import           System.Exit (die, exitSuccess)
-import           System.FilePath (isRelative, (</>))
+import           System.FilePath
 
 import           Cardano.Api
+import           Cardano.Api.Shelley (protocolParamMaxTxExUnits)
 import           Cardano.Node.Configuration.POM (NodeConfiguration (..))
 import           Cardano.Node.Types (AdjustFilePaths (..), GenesisFile (..))
 
@@ -89,8 +92,8 @@ main
     case setup of
       Left err -> die (show err)
       Right (nixService, _nc, genesis, sigKey) -> do
-        putStrLn $ "Did I manage to extract a genesis fund?\n--> " ++ show (checkFund genesis sigKey)
-        putStrLn "Can I pre-execute a plutus script?"
+        putStrLn $ "* Did I manage to extract a genesis fund?\n--> " ++ show (checkFund genesis sigKey)
+        putStrLn "* Can I pre-execute a plutus script?"
         checkPlutusLoop (_nix_plutusLoopScript nixService)
         exitSuccess
 
@@ -114,12 +117,32 @@ checkPlutusLoop scriptPath
 
     let count = 1792        -- arbitrary counter for a loop script; should respect mainnet limits
 
-    redeemer <- scriptDataModifyNumber (+ count) <$> readRedeemer scriptPath
+    redeemerFile <- getRedeemerFile
+    redeemer <- readRedeemer redeemerFile >>= \case
+      Left err -> die (show err)
+      Right redeemer -> do
+        putStrLn $ "--> read redeemer: " ++ redeemerFile
+        return $ scriptDataModifyNumber (+ count) redeemer
 
     case preExecutePlutusScript protocolParameters script (ScriptDataNumber 0) redeemer of
       Left err -> putStrLn $ "--> execution failed: " ++ show err
       Right units -> putStrLn $ "--> execution successful; got units: " ++ show units
 
+    putStrLn "* What does the redeemer look like when the loop counter is maxed out?"
+    let
+        ~(Just budget) = protocolParamMaxTxExUnits protocolParameters
+        autoBudget = PlutusAutoBudget
+          { autoBudgetUnits = budget
+          , autoBudgetDatum = ScriptDataNumber 0
+          , autoBudgetRedeemer = scriptDataModifyNumber (const 1_000_000) redeemer
+          }
+    putStrLn $ "--> " ++ show (plutusAutoBudgetMaxOut protocolParameters script autoBudget)
+
+  where
+    getRedeemerFile =
+      let redeemerPath = (<.> ".redeemer.json") $ dropExtension $ takeFileName scriptPath
+      in getDataFileName $ "data" </> redeemerPath
+
 
 readFileJson :: FromJSON a => FilePath -> ExceptT TxGenError IO a
 readFileJson f = handleIOExceptT (TxGenError . show) (eitherDecodeFileStrict' f) >>= firstExceptT TxGenError . hoistEither

bench/tx-generator/tx-generator.cabal

@@ -103,7 +103,6 @@ library
                      , constraints-extras
                      , dlist
                      , extra
-                     , filepath
                      , formatting
                      , generic-monoid
                      , ghc-prim