tx-generator: type TxGenPlutusResolvedTo documenting origin of a script

Author: mgmeier

bench/tx-generator/CHANGELOG.md

@@ -5,6 +5,7 @@
 * A new cabal flag `withplutuslib` is added, enabling import and re-compilation of Plutus scripts from `plutus-scripts-bench` - default: false; use for dev/test of new benchmarks only.
 * Port `ProtocolParameters` type and typeclass instances from `cardano-api` into new module `Cardano.Api.Internal`, removing dependency on the deprecated API type.
 * A new executable `calibrate-script` which is a tool aimed at auto-calibrating Plutus benchmarking scripts to best fit scaled execution budgets and provides developer-friendly CSV reports of the process.
+* Better document how a Plutus script name was resolved by new type `TxGenPlutusResolvedTo`.
 * Bump for Node 10.3
 
 ## 2.14.2 -- Oct 2024

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

@@ -155,11 +155,14 @@ runPlutus s@TargetBlockExpenditure{} _ _ _ _
   = putStrLn $ "--> fitting strategy currently unsupported: " ++ show s
 runPlutus strategy budgetType protoParamFile plutusDef@PlutusOn{..} scales
   = do
-    script <- either (error . show) pure =<< readPlutusScript plutusScript
-    putStrLn $ "--> read Plutus script: " ++ scriptNameExt
     protocolParameters <- readProtocolParametersOrDie protoParamFile
+    (script, resolvedTo) <- either (error . show) pure =<< readPlutusScript plutusScript
 
-    let redeemerDef = Right plutusDef
+    let
+      redeemerDef   = Right plutusDef
+      scriptNameExt = show resolvedTo
+      scriptName    = takeWhile (/= '.') . drop 1 . dropWhile (not . isSpace) $ scriptNameExt
+    putStrLn $ "--> got script " ++ scriptNameExt
 
     redeemer :: ScriptData <-
       resolveRedeemer redeemerDef >>= either
@@ -186,13 +189,9 @@ runPlutus strategy budgetType protoParamFile plutusDef@PlutusOn{..} scales
       jsonName  = "summaries_" ++ scriptName <.> "json"
       csvName   = "scaling_" ++ scriptName <.> "csv"
 
-
     summariesWithApprox <- mapM (approximateTxProperties script protocolParameters) summaries
     writeResultsJSON jsonName summariesWithApprox
     writeResultsCSV csvName summariesWithApprox
-  where
-    scriptNameExt = either (++ " (known script)") (++ " (from file)") plutusScript
-    scriptName    = takeWhile (not . isSpace) scriptNameExt
 
 runPlutus _ _ _ _ _ = error "calibrate-script: implementation error"
 

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

@@ -427,7 +427,7 @@ makePlutusContext :: forall era. IsShelleyBasedEra era
   -> ActionM (Witness WitCtxTxIn era, ScriptInAnyLang, ScriptData, L.Coin)
 makePlutusContext ScriptSpec{..} = do
   protocolParameters <- getProtocolParameters
-  script <- liftIOSafe $ Plutus.readPlutusScript scriptSpecFile
+  (script, resolvedTo) <- liftIOSafe $ Plutus.readPlutusScript scriptSpecFile
 
   executionUnitPrices <- case protocolParamPrices protocolParameters of
     Just x -> return x
@@ -470,7 +470,7 @@ makePlutusContext ScriptSpec{..} = do
           , autoBudgetRedeemer = unsafeHashableScriptData $ scriptDataModifyNumber (const 1_000_000) (getScriptData redeemer)
           , autoBudgetUpperBoundHint = Nothing
           }
-        scriptInfo = (either ("builtin: " ++) ("plutus file: " ++) scriptSpecFile, show strategy)
+        scriptInfo = (show resolvedTo, show strategy)
       traceDebug $ "Plutus auto mode : Available budget per Tx: " ++ show perTxBudget
                    ++ " -- split between inputs per Tx: " ++ show txInputs
 

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

@@ -35,11 +35,13 @@ import qualified PlutusLedgerApi.V3 as PlutusV3
 import qualified PlutusTx.AssocMap as AssocMap (empty)
 
 import           Cardano.TxGenerator.ProtocolParameters (ProtocolParameters(..))
-import           Cardano.TxGenerator.Types (TxGenError (..))
+import           Cardano.TxGenerator.Types (TxGenError (..), TxGenPlutusResolvedTo (..))
 #ifdef WITH_LIBRARY
 import           Cardano.Benchmarking.PlutusScripts (findPlutusScript)
 #endif
 import           Control.Exception (SomeException (..), try)
+import           System.FilePath ((<.>), (</>))
+
 import           Paths_tx_generator
 
 type ProtocolVersion = (Int, Int)
@@ -58,19 +60,22 @@ resolveFromLibrary = const Nothing
 -- What the @WITH_LIBRARY@ flag signifies is to use a set of statically-
 -- defined (via TH) scripts for the script name lookups instead of a
 -- set of library files.
-readPlutusScript :: Either String FilePath -> IO (Either TxGenError ScriptInAnyLang)
+readPlutusScript :: Either String FilePath -> IO (Either TxGenError (ScriptInAnyLang, TxGenPlutusResolvedTo))
 readPlutusScript (Left s)
   = case resolveFromLibrary s of
-      Just s' -> pure $ Right s'
-      Nothing -> try (getDataFileName $ "scripts-fallback/" ++ s ++ ".plutus") >>= either
+      Just s' -> pure $ Right (s', ResolvedToLibrary s)
+      Nothing -> try (getDataFileName $ "scripts-fallback" </> asFileName) >>= either
         (\(SomeException e) -> pure $ Left $ TxGenError $ show e)
-        (readPlutusScript . Right)
+        doLoad
+  where
+    asFileName = s <.> "plutus"
+    doLoad fp  = second (second (const $ ResolvedToFallback asFileName)) <$> readPlutusScript (Right fp)
 readPlutusScript (Right fp)
   = runExceptT $ do
     script <- firstExceptT ApiError $
       readFileScriptInAnyLang fp
     case script of
-      ScriptInAnyLang (PlutusScriptLanguage _) _ -> pure script
+      ScriptInAnyLang (PlutusScriptLanguage _) _ -> pure (script, ResolvedToFileName fp)
       ScriptInAnyLang lang _ -> throwE $ TxGenError $ "readPlutusScript: only PlutusScript supported, found: " ++ show lang
 
 -- | 'preExecutePlutusScript' is a front end for the internal

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

@@ -93,7 +93,7 @@ data TxGenPlutusType
 data TxGenPlutusParams
   = PlutusOn                                    -- ^ Generate Plutus Txs for given script
       { plutusType        :: !TxGenPlutusType
-      , plutusScript      :: !(Either String FilePath) -- ^ Path to the Plutus script
+      , plutusScript      :: !(Either String FilePath) -- ^ name or path of the Plutus script
       , plutusDatum       :: !(Maybe FilePath)  -- ^ Datum passed to the Plutus script (JSON file in ScriptData schema)
       , plutusRedeemer    :: !(Maybe FilePath)  -- ^ Redeemer passed to the Plutus script (JSON file in ScriptData schema)
       , plutusExecMemory  :: !(Maybe Natural)   -- ^ Max. memory for ExecutionUnits (overriding corresponding protocol parameter)
@@ -102,6 +102,19 @@ data TxGenPlutusParams
   | PlutusOff                                   -- ^ Do not generate Plutus Txs
   deriving (Show, Eq)
 
+-- | Documents how the `plutusScript` parameter above was eventually resolved
+data TxGenPlutusResolvedTo
+  = ResolvedToLibrary     String      -- ^ source is the library from the plutus-scripts-bench package
+  | ResolvedToFallback    FilePath    -- ^ source it the tx-generator's scripts-fallback data directory
+  | ResolvedToFileName    FilePath    -- ^ source is a .plutus file
+  deriving Eq
+
+instance Show TxGenPlutusResolvedTo where
+  show = \case
+    ResolvedToLibrary n ->   "builtin: " ++ n
+    ResolvedToFallback f  -> "fallback: " ++ f
+    ResolvedToFileName f  -> "file: " ++ f
+
 isPlutusMode :: TxGenPlutusParams -> Bool
 isPlutusMode
   = (/= PlutusOff)

bench/tx-generator/test/ApiTest.hs

@@ -185,8 +185,8 @@ checkPlutusLoop ::
   -> IO ()
 checkPlutusLoop protoParamFile (Just _plutusDef@PlutusOn{..})
   = do
-    script <- either (die . show) pure =<< readPlutusScript plutusScript
-    putStrLn $ "--> Read plutus script: " ++ scriptName
+    (script, resolvedTo) <- either (die . show) pure =<< readPlutusScript plutusScript
+    putStrLn $ "--> Got script " ++ show resolvedTo
     protocolParameters <- readProtocolParametersOrDie protoParamFile
 
     let count = 1_792       -- arbitrary counter for a loop script; should respect mainnet limits

bench/tx-generator/tx-generator.cabal

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