Merge pull request IntersectMBO#5048 from input-output-hk/nyc-plutus-…

…bench-01 use TH-generated plutus scripts
zeme-wana · Apr 11, 2023 · 26af241 · 26af241
2 parents 2dd271b + 2fe2c43
commit 26af241
Show file tree

Hide file tree

Showing 14 changed files with 121 additions and 59 deletions.
diff --git a/bench/plutus-scripts-bench/plutus-scripts-bench.cabal b/bench/plutus-scripts-bench/plutus-scripts-bench.cabal
@@ -56,6 +56,7 @@ library
   exposed-modules:
     Cardano.Benchmarking.PlutusScripts
     Cardano.Benchmarking.PlutusScripts.CustomCallTypes
+    Cardano.Benchmarking.ScriptAPI
 
   other-modules:
     Cardano.Benchmarking.PlutusScripts.CustomCall
@@ -76,6 +77,8 @@ library
   -- Non-IOG dependencies
   ------------------------
   build-depends:
+    , filepath
     , bytestring
     , serialise
     , template-haskell
+    , text
diff --git a/bench/plutus-scripts-bench/src/Cardano/Benchmarking/PlutusScripts.hs b/bench/plutus-scripts-bench/src/Cardano/Benchmarking/PlutusScripts.hs
@@ -10,39 +10,47 @@ module Cardano.Benchmarking.PlutusScripts
     , findPlutusScript
     , getAllScripts
     , listPlutusScripts
+    , asAnyLang
+    , normalizeModuleName
     ) where
 
 import           Prelude
 
 import           Data.ByteString.Lazy as LBS (ByteString)
+import           Data.Text(split, pack)
+import           Data.List(find)
+import           System.FilePath(takeBaseName)
 
 import           Cardano.Api
 
 import qualified Cardano.Benchmarking.PlutusScripts.CustomCall as CustomCall
 import qualified Cardano.Benchmarking.PlutusScripts.EcdsaSecp256k1Loop as ECDSA
 import qualified Cardano.Benchmarking.PlutusScripts.Loop as Loop
 import qualified Cardano.Benchmarking.PlutusScripts.SchnorrSecp256k1Loop as Schnorr
+import           Cardano.Benchmarking.ScriptAPI
 
 
-getAllScripts ::
-     [(String, ScriptInAnyLang)]
+getAllScripts :: [PlutusBenchScript]
 getAllScripts =
-  [ (normalizeModuleName CustomCall.scriptName, asAnyLang CustomCall.scriptSerialized)
-  , (normalizeModuleName ECDSA.scriptName     , asAnyLang ECDSA.scriptSerialized)
-  , (normalizeModuleName Loop.scriptName      , asAnyLang Loop.scriptSerialized)
-  , (normalizeModuleName Schnorr.scriptName   , asAnyLang Schnorr.scriptSerialized)
+  [ CustomCall.script
+  , ECDSA.script
+  , Loop.script
+  , Schnorr.script
   ]
 
 listPlutusScripts ::
      [String]
 listPlutusScripts
-  = fst <$> getAllScripts
+  = psName <$> getAllScripts
 
 findPlutusScript ::
      String
   -> Maybe ScriptInAnyLang
-findPlutusScript
-  = (`lookup` getAllScripts)
+findPlutusScript s
+  =   psScript
+  <$> find (\x -> last (split (=='.') . pack . psName $ x) == s') getAllScripts
+  where
+    s' = pack $ takeBaseName s
 
 encodePlutusScript ::
      ScriptInAnyLang

diff --git a/bench/plutus-scripts-bench/src/Cardano/Benchmarking/PlutusScripts/CustomCall.hs b/bench/plutus-scripts-bench/src/Cardano/Benchmarking/PlutusScripts/CustomCall.hs
@@ -7,28 +7,28 @@
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
-module Cardano.Benchmarking.PlutusScripts.CustomCall
-  ( scriptName
-  , scriptSerialized
-  ) where
+module Cardano.Benchmarking.PlutusScripts.CustomCall (script) where
 
 import           Language.Haskell.TH
 import           Language.Haskell.TH.Syntax
 import           Prelude as Haskell (String, (.), (<$>))
 
-import           Cardano.Api (PlutusScript, PlutusScriptV2)
-import           Cardano.Api.Shelley (PlutusScript (..))
+import           Cardano.Api (PlutusScriptV2, toScriptInAnyLang, Script(..))
+import           Cardano.Api.Shelley (PlutusScript (..), PlutusScriptVersion (..))
 import qualified Data.ByteString.Short as SBS
 import qualified PlutusLedgerApi.V2 as PlutusV2
 import qualified PlutusTx
 import           PlutusTx.Prelude as Plutus hiding (Semigroup (..), (.), (<$>))
 
+import           Cardano.Benchmarking.ScriptAPI
 import           Cardano.Benchmarking.PlutusScripts.CustomCallTypes
 
+script :: PlutusBenchScript
+script = mkPlutusBenchScript scriptName (toScriptInAnyLang (PlutusScript PlutusScriptV2 scriptSerialized))
 
 scriptName :: Haskell.String
 scriptName
-  = $(LitE . StringL . loc_module <$> qLocation)
+  = prepareScriptName $(LitE . StringL . loc_module <$> qLocation)
 
 
 instance Plutus.Eq CustomCallData where

diff --git a/bench/plutus-scripts-bench/src/Cardano/Benchmarking/PlutusScripts/EcdsaSecp256k1Loop.hs b/bench/plutus-scripts-bench/src/Cardano/Benchmarking/PlutusScripts/EcdsaSecp256k1Loop.hs
@@ -4,16 +4,14 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 
-module Cardano.Benchmarking.PlutusScripts.EcdsaSecp256k1Loop
-  ( scriptName
-  , scriptSerialized
-  ) where
+module Cardano.Benchmarking.PlutusScripts.EcdsaSecp256k1Loop (script) where
 
 import           Language.Haskell.TH
 import           Language.Haskell.TH.Syntax
 
-import           Cardano.Api (PlutusScript, PlutusScriptV2)
-import           Cardano.Api.Shelley (PlutusScript (..))
+import           Cardano.Api (PlutusScript, PlutusScriptV2, Script(..), toScriptInAnyLang)
+import           Cardano.Api.Shelley (PlutusScript (..), PlutusScriptVersion (..))
+import           Cardano.Benchmarking.ScriptAPI
 import qualified Data.ByteString.Short as SBS
 import qualified PlutusLedgerApi.V2 as PlutusV2
 import qualified PlutusTx
@@ -24,7 +22,10 @@ import           Prelude as Haskell (String, (.), (<$>))
 
 scriptName :: Haskell.String
 scriptName
-  = $(LitE . StringL . loc_module <$> qLocation)
+  = prepareScriptName $(LitE . StringL . loc_module <$> qLocation)
+
+script :: PlutusBenchScript
+script = mkPlutusBenchScript scriptName (toScriptInAnyLang (PlutusScript PlutusScriptV2 scriptSerialized))
 
 
 {-# INLINEABLE mkValidator #-}

diff --git a/bench/plutus-scripts-bench/src/Cardano/Benchmarking/PlutusScripts/Loop.hs b/bench/plutus-scripts-bench/src/Cardano/Benchmarking/PlutusScripts/Loop.hs
@@ -4,17 +4,14 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 
-module Cardano.Benchmarking.PlutusScripts.Loop
-  ( scriptName
-  , scriptSerialized
-  ) where
+module Cardano.Benchmarking.PlutusScripts.Loop (script) where
 
 import           Language.Haskell.TH
 import           Language.Haskell.TH.Syntax
 import           Prelude hiding (pred, ($), (&&), (<), (==))
 
-import           Cardano.Api.Shelley (PlutusScript (..), PlutusScriptV1)
-
+import           Cardano.Api.Shelley (PlutusScript (..), PlutusScriptV1, Script(..), toScriptInAnyLang, PlutusScriptVersion(..))
+import           Cardano.Benchmarking.ScriptAPI
 import qualified Data.ByteString.Short as SBS
 
 import qualified PlutusLedgerApi.V2 as PlutusV2
@@ -25,7 +22,10 @@ import           PlutusTx.Prelude hiding (Semigroup (..), unless, (.), (<$>))
 
 scriptName :: String
 scriptName
-  = $(LitE . StringL . loc_module <$> qLocation)
+  = prepareScriptName $(LitE . StringL . loc_module <$> qLocation)
+
+script :: PlutusBenchScript
+script = mkPlutusBenchScript scriptName (toScriptInAnyLang (PlutusScript PlutusScriptV1 scriptSerialized))
 
 
 {-# INLINABLE mkValidator #-}

diff --git a/bench/plutus-scripts-bench/src/Cardano/Benchmarking/PlutusScripts/SchnorrSecp256k1Loop.hs b/bench/plutus-scripts-bench/src/Cardano/Benchmarking/PlutusScripts/SchnorrSecp256k1Loop.hs
@@ -4,16 +4,14 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 
-module Cardano.Benchmarking.PlutusScripts.SchnorrSecp256k1Loop
-  ( scriptName
-  , scriptSerialized
-  ) where
+module Cardano.Benchmarking.PlutusScripts.SchnorrSecp256k1Loop (script) where
 
 import           Language.Haskell.TH
 import           Language.Haskell.TH.Syntax
 
-import           Cardano.Api (PlutusScript, PlutusScriptV2)
-import           Cardano.Api.Shelley (PlutusScript (..))
+import           Cardano.Api (PlutusScript, PlutusScriptV2, Script(..), toScriptInAnyLang)
+import           Cardano.Api.Shelley (PlutusScript (..), PlutusScriptVersion (..))
+import           Cardano.Benchmarking.ScriptAPI
 import qualified Data.ByteString.Short as SBS
 import qualified PlutusLedgerApi.V2 as PlutusV2
 import qualified PlutusTx
@@ -24,7 +22,10 @@ import           Prelude as Haskell (String, (.), (<$>))
 
 scriptName :: Haskell.String
 scriptName
-  = $(LitE . StringL . loc_module <$> qLocation)
+  = prepareScriptName $(LitE . StringL . loc_module <$> qLocation)
+
+script :: PlutusBenchScript
+script = mkPlutusBenchScript scriptName (toScriptInAnyLang (PlutusScript PlutusScriptV2 scriptSerialized))
 
 
 {-# INLINEABLE mkValidator #-}

diff --git a/bench/plutus-scripts-bench/src/Cardano/Benchmarking/ScriptAPI.hs b/bench/plutus-scripts-bench/src/Cardano/Benchmarking/ScriptAPI.hs
@@ -0,0 +1,42 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Cardano.Benchmarking.ScriptAPI
+  ( PlutusBenchScript
+  , psName
+  , psScript
+  , mkPlutusBenchScript
+  , prepareScriptName
+  ) where
+
+import           Prelude as Haskell (String, ($))
+import           Data.Char (isUpper)
+import           Data.Maybe (fromMaybe)
+import           System.FilePath (splitExtension, stripExtension, takeFileName)
+import           Cardano.Api (ScriptInAnyLang)
+
+data PlutusBenchScript
+  = PlutusBenchScript
+    { psName   :: String
+    , psScript :: ScriptInAnyLang
+    }
+
+mkPlutusBenchScript :: String -> ScriptInAnyLang -> PlutusBenchScript
+mkPlutusBenchScript = PlutusBenchScript
+
+-- This is doing two or three sorts of normalisation at once:
+-- It strips leading / -separated components, drops the ".hs" suffix
+-- if present, then chooses the last . -separated component.
+-- If there is a suffix different from .hs that begins with a capital
+-- letter, that is returned.
+-- e.g. "Data/List/System.FilePath.Text.hs" --> "Text"
+--      "Data/List/System.FilePath.Text"    --> "Text"
+prepareScriptName :: String -> String
+prepareScriptName script
+  = case splitExtension file' of
+      (s, "")                      -> s     -- no dots so take it as-is
+      (_, '.':s@(c:_)) | isUpper c -> s     -- take last dot-separated component
+      _                            -> file' -- shouldn't happen
+  where
+    file  = takeFileName script -- ignore leading directories
+    -- no trailing .hs so use filename as-is
+    file' = fromMaybe file $ stripExtension "hs" file
diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs
@@ -23,7 +23,6 @@ import           Control.Monad.Trans.Except
 import           Control.Monad.Trans.Except.Extra
 import           "contra-tracer" Control.Tracer (nullTracer)
 import           Data.ByteString.Lazy.Char8 as BSL (writeFile)
-import           Data.List (isSuffixOf)
 import           Data.Ratio ((%))
 
 import           Streaming
@@ -55,7 +54,6 @@ import           Cardano.TxGenerator.Setup.SigningKey
 
 import           Cardano.Benchmarking.OuroborosImports as Core (LocalSubmitTx, SigningKeyFile,
                    makeLocalConnectInfo, protocolToCodecConfig)
-import           Cardano.Benchmarking.PlutusScripts (findPlutusScript)
 
 import           Cardano.Benchmarking.LogTypes as Core (TraceBenchTxSubmit (..), btConnect_, btN2N_,
                    btSubmission2_, btTxSubmit_)
@@ -409,12 +407,7 @@ makePlutusContext :: forall era. IsShelleyBasedEra era
   -> ActionM (Witness WitCtxTxIn era, ScriptInAnyLang, ScriptData, Lovelace)
 makePlutusContext ScriptSpec{..} = do
   protocolParameters <- getProtocolParameters
-  script <- if ".hs" `isSuffixOf` scriptSpecFile
-    then maybe
-          (liftTxGenError $ TxGenError $ "Plutus script not included: " ++ scriptSpecFile)
-          return
-          (findPlutusScript scriptSpecFile)
-    else liftIOSafe $ Plutus.readPlutusScript scriptSpecFile
+  script <- liftIOSafe $ Plutus.readPlutusScript scriptSpecFile
 
   executionUnitPrices <- case protocolParamPrices protocolParameters of
     Just x -> return x
@@ -458,15 +451,15 @@ makePlutusContext ScriptSpec{..} = do
       traceDebug $ "Plutus auto mode : Available budget per Tx: " ++ show perTxBudget
                    ++ " -- split between inputs per Tx: " ++ show txInputs
 
-      case plutusAutoScaleBlockfit protocolParameters scriptSpecFile script autoBudget strategy txInputs of
+      case plutusAutoScaleBlockfit protocolParameters (either ("builtin: "++) ("plutus file: "++) scriptSpecFile) script autoBudget strategy txInputs of
         Left err -> liftTxGenError err
         Right (summary, PlutusAutoBudget{..}, preRun) -> do
           setEnvSummary summary
           dumpBudgetSummaryIfExisting
           return (unsafeHashableScriptData autoBudgetDatum, autoBudgetRedeemer, preRun)
 
   let msg = mconcat [ "Plutus Benchmark :"
-                    , " Script: ", scriptSpecFile
+                    , " Script: ", show scriptSpecFile
                     , ", Datum: ", show scriptData
                     , ", Redeemer: ", show scriptRedeemer
                     , ", StatedBudget: ", show executionUnits

diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Types.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Types.hs
@@ -108,7 +108,7 @@ deriving instance Generic ScriptBudget
 
 data ScriptSpec = ScriptSpec
   {
-    scriptSpecFile :: !FilePath
+    scriptSpecFile :: !(Either String FilePath)
   , scriptSpecBudget :: !ScriptBudget
   , scriptSpecPlutusType :: !TxGenPlutusType
   }

diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Setup/Plutus.hs b/bench/tx-generator/src/Cardano/TxGenerator/Setup/Plutus.hs
@@ -27,14 +27,20 @@ import           Cardano.Ledger.Alonzo.TxInfo (exBudgetToExUnits)
 import qualified PlutusLedgerApi.V1 as PlutusV1
 import qualified PlutusLedgerApi.V2 as PlutusV2
 
+import           Cardano.Benchmarking.PlutusScripts(findPlutusScript)
 import           Cardano.TxGenerator.Types
 
 
 type ProtocolVersion = (Int, Int)
 
 
-readPlutusScript :: FilePath -> IO (Either TxGenError ScriptInAnyLang)
-readPlutusScript fp
+readPlutusScript :: Either String FilePath -> IO (Either TxGenError ScriptInAnyLang)
+readPlutusScript (Left s)
+  = pure
+  $ maybe (Left . TxGenError $ "readPlutusScript: " ++ s ++ " not found.")
+          Right
+          (findPlutusScript s)
+readPlutusScript (Right fp)
   = runExceptT $ do
     script <- firstExceptT ApiError $
       readFileScriptInAnyLang fp

diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Types.hs b/bench/tx-generator/src/Cardano/TxGenerator/Types.hs
@@ -90,7 +90,7 @@ data TxGenPlutusType
 data TxGenPlutusParams
   = PlutusOn                                    -- ^ Generate Plutus Txs for given script
       { plutusType        :: !TxGenPlutusType
-      , plutusScript      :: !FilePath          -- ^ Path to the Plutus script
+      , plutusScript      :: !(Either String FilePath) -- ^ Path to 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)

diff --git a/bench/tx-generator/test/ApiTest.hs b/bench/tx-generator/test/ApiTest.hs
@@ -10,6 +10,7 @@
 
 module Main (main) where
 
+import           Control.Arrow
 import           Control.Monad
 import           Control.Monad.Trans.Except
 import           Control.Monad.Trans.Except.Extra
@@ -155,7 +156,7 @@ checkPlutusLoop ::
 checkPlutusLoop (Just PlutusOn{..})
   = do
     script <- either (die . show) pure =<< readPlutusScript plutusScript
-    putStrLn $ "--> Read plutus script: " ++ plutusScript
+    putStrLn $ "--> Read plutus script: " ++ (id ||| id) plutusScript
     protocolParameters <- readProtocolParametersOrDie
 
     let count = 1_792        -- arbitrary counter for a loop script; should respect mainnet limits
@@ -202,9 +203,11 @@ checkPlutusLoop (Just PlutusOn{..})
     mul :: Natural -> Double -> Natural
     mul n d = floor $ d * fromIntegral n
 
-    getRedeemerFile =
-      let redeemerPath = (<.> ".redeemer.json") $ dropExtension $ takeFileName plutusScript
-      in getDataFileName $ "data" </> redeemerPath
+    getRedeemerFile
+      = case plutusScript of
+          Right file -> let redeemerPath = (<.> ".redeemer.json") $ dropExtension $ takeFileName file
+                        in getDataFileName $ "data" </> redeemerPath
+          Left _ -> getDataFileName "data/loop.redeemer.json"
 checkPlutusLoop _
   = putStrLn "--> No plutus script defined."
 

diff --git a/nix/nixos/tx-generator-service.nix b/nix/nixos/tx-generator-service.nix
@@ -5,7 +5,12 @@ let
       plutus = if (cfg.plutus.type or null) == null then null else
         {
           inherit (cfg.plutus) type;
-          script = "${pkgs.plutus-scripts}/generated-plutus-scripts/${cfg.plutus.script}";
+          ## Basically do something like:
+          ## script = "${pkgs.plutus-scripts}/generated-plutus-scripts/${cfg.plutus.script}";
+          ## except for having to weave the Either through things
+          ## To refer to a plutus script file, do something like:
+          ## { Right = pkgs.plutus-scripts + "/generated-plutus-scripts/" + cfg.plutus.script; }
+          script = { Left = cfg.plutus.script; };
           redeemer = pkgs.writeText "plutus-redeemer.json" (__toJSON cfg.plutus.redeemer);
           datum    = if cfg.plutus.datum == null then null else
                      pkgs.writeText "plutus-datum.json"    (__toJSON cfg.plutus.datum);