tx-generator: Add named wallets

tx-generator script can now use multiple named wallets
to control which UTxO is spend in which benchmarking phase.
Before all UTxOs were managed in a single wallet.

Author: MarcFontaine

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

@@ -18,35 +18,39 @@ import           Cardano.Api
 import           Cardano.Benchmarking.Types
 import           Cardano.Benchmarking.NixOptions
 import           Cardano.Benchmarking.Script.Setters
-import           Cardano.Benchmarking.Script.Store (Name(..))
+import           Cardano.Benchmarking.Script.Store (Name(..), WalletName)
 import           Cardano.Benchmarking.Script.Types
 
 data CompileError where
   SomeCompilerError :: CompileError
   deriving (Show)
-type Compiler a = RWST NixServiceOptions (DList Action) () (Except CompileError) a
+type Compiler a = RWST NixServiceOptions (DList Action) Int (Except CompileError) a
+
+type SrcWallet = WalletName
+type DstWallet = WalletName
 
 compileOptions :: NixServiceOptions -> Either CompileError [Action]
-compileOptions = runCompiler compileToScript
+compileOptions opts = runCompiler opts compileToScript
 
-runCompiler :: Compiler () -> NixServiceOptions -> Either CompileError [Action]
-runCompiler c o = case runExcept $ runRWST c o () of
+runCompiler ::NixServiceOptions -> Compiler () -> Either CompileError [Action]
+runCompiler o c = case runExcept $ runRWST c o 0 of
   Left err -> Left err
   Right ((), _ , l) -> Right $ DL.toList l
 
-testCompiler :: Compiler a -> NixServiceOptions -> Either CompileError (a, (), [Action])
-testCompiler c o = case runExcept $ runRWST c o () of
+testCompiler :: NixServiceOptions -> Compiler a -> Either CompileError (a, Int, [Action])
+testCompiler o c = case runExcept $ runRWST c o 0 of
   Left err -> Left err
   Right (a, s , l) -> Right (a, s, DL.toList l)
 
 compileToScript :: Compiler ()
 compileToScript = do
   initConstants
   emit . StartProtocol =<< askNixOption _nix_nodeConfigFile
-  importGenesisFunds
-  initCollaterals
-  splittingPhase
-  benchmarkingPhase
+  genesisWallet <- newWallet "genesis_wallet"
+  importGenesisFunds genesisWallet
+  splitWallet <- splittingPhase genesisWallet
+  addCollaterals genesisWallet splitWallet
+  benchmarkingPhase splitWallet
 
 initConstants :: Compiler ()
 initConstants = do
@@ -67,61 +71,78 @@ initConstants = do
     setN :: Tag v -> (NixServiceOptions -> v) -> Compiler ()
     setN key s = askNixOption s >>= setConst key
 
-importGenesisFunds :: Compiler ()
-importGenesisFunds = do
+importGenesisFunds :: DstWallet -> Compiler ()
+importGenesisFunds wallet = do
   cmd1 (ReadSigningKey $ KeyName "pass-partout") _nix_sigKey
-  emit $ ImportGenesisFund LocalSocket (KeyName "pass-partout") (KeyName "pass-partout")
+  emit $ ImportGenesisFund wallet LocalSocket (KeyName "pass-partout") (KeyName "pass-partout")
   delay
 
-initCollaterals :: Compiler ()
-initCollaterals = do
+addCollaterals :: SrcWallet -> DstWallet -> Compiler ()
+addCollaterals src dest = do
   isAnyPlutusMode >>= \case
     False -> return ()
     True -> do
       tx_fee <- askNixOption _nix_tx_fee
       safeCollateral <- _safeCollateral <$> evilFeeMagic
-      emit $ CreateChange LocalSocket (PayToAddr $ KeyName "pass-partout") (safeCollateral + tx_fee) 1
-      emit $ CreateChange LocalSocket (PayToCollateral $ KeyName "pass-partout") safeCollateral 1
+      emit $ CreateChange src src LocalSocket (PayToAddr $ KeyName "pass-partout") (safeCollateral + tx_fee) 1
+      emit $ CreateChange src dest LocalSocket (PayToCollateral $ KeyName "pass-partout") safeCollateral 1
 
-splittingPhase :: Compiler ()
-splittingPhase = do
+splittingPhase :: SrcWallet -> Compiler DstWallet
+splittingPhase srcWallet = do
   (NumberOfTxs tx_count) <- askNixOption _nix_tx_count
   (NumberOfInputsPerTx inputs_per_tx) <- askNixOption _nix_inputs_per_tx
+  tx_fee <- askNixOption _nix_tx_fee
   minValuePerInput <- _minValuePerInput <$> evilFeeMagic
+  splitSteps <- splitSequenceWalletNames srcWallet srcWallet $ unfoldSplitSequence tx_fee minValuePerInput (tx_count * inputs_per_tx)
+  forM_ (init splitSteps) createChange
   plutus <- isAnyPlutusMode
-  if plutus then createChangeRecursivePlutus minValuePerInput (tx_count * inputs_per_tx)
-            else createChangeRecursive       minValuePerInput (tx_count * inputs_per_tx)
+  (if plutus then createChangePlutus else createChange) $ last splitSteps
  where
-  createChangeRecursive :: Lovelace -> Int -> Compiler ()
-  createChangeRecursive value count = do
-    when (count > 30) $ do
-      tx_fee <- askNixOption _nix_tx_fee
-      createChangeRecursive (value * 30 + tx_fee) (count `div` 30 + 1)
-    createChange value count
-
-  createChangeRecursivePlutus :: Lovelace -> Int -> Compiler ()
-  createChangeRecursivePlutus value count = do
-    when (count > 30) $ do
-      tx_fee <- askNixOption _nix_tx_fee
-      createChangeRecursive (value * 30 + tx_fee) (count `div` 30 + 1)
-    createChangePlutus value count
-  
-  createChange :: Lovelace -> Int -> Compiler ()
-  createChange value count = do
-     emit $ CreateChange LocalSocket (PayToAddr $ KeyName "pass-partout") value count
+  createChange :: SplitStep -> Compiler DstWallet
+  createChange (src, dst, value, count) = do
+     emit $ CreateChange src dst LocalSocket (PayToAddr $ KeyName "pass-partout") value count
      delay
+     return dst
 
-  createChangePlutus :: Lovelace -> Int -> Compiler ()
-  createChangePlutus value count = do
+  createChangePlutus :: SplitStep -> Compiler DstWallet
+  createChangePlutus (src, dst, value, count) = do
      autoMode <- isPlutusAutoMode
      plutusTarget <- if autoMode
        then PayToScript <$> askNixOption _nix_plutusLoopScript <*> pure (ScriptDataNumber 0)
        else PayToScript <$> askNixOption _nix_plutusScript     <*> (ScriptDataNumber <$> askNixOption _nix_plutusData)
-     emit $ CreateChange LocalSocket plutusTarget value count
+     emit $ CreateChange src dst LocalSocket plutusTarget value count
      delay
-
-benchmarkingPhase :: Compiler ()
-benchmarkingPhase = do
+     return dst
+
+-- Generate src and dst wallet names for a splitSequence.
+-- testCompiler (error "opts") $ splitSequenceWalletNames (WalletName "w1") (WalletName "w2") (unfoldSplitSequence 1 1000 10000)
+type SplitStep = (SrcWallet, DstWallet, Lovelace, Int)
+
+splitSequenceWalletNames :: SrcWallet -> DstWallet -> [(Lovelace, Int)] -> Compiler [ SplitStep ]
+splitSequenceWalletNames _src _dst [] = return []
+splitSequenceWalletNames src dst [ (val,count) ] = return [( src, dst, val, count)]
+splitSequenceWalletNames src dst ((val, count):rest) = do
+  nextDst <- newWallet "change_wallet"
+  l <- splitSequenceWalletNames dst nextDst rest
+  return $ [( src, dst, val, count)] ++ l
+
+-- Return a list of splitSteps.
+unfoldSplitSequence :: Lovelace -> Lovelace -> Int -> [(Lovelace, Int)]
+unfoldSplitSequence fee value count
+  = if count < maxOutputs
+    then [
+           -- Add an extra transaction that just contains the desired output and possible fees.
+           (value * fromIntegral count + fee, 1)
+         , (value, count )
+         ]
+    else unfoldSplitSequence fee (value * fromIntegral maxOutputs + fee) (count `div` maxOutputs + 1) ++ [ (value, count) ]
+  where
+    -- maximal number of outputs in a TX.
+    -- todo: this must be in sync with Scipt/Core.hs
+    maxOutputs = 30
+    
+benchmarkingPhase :: WalletName -> Compiler ()
+benchmarkingPhase wallet = do
   debugMode <- askNixOption _nix_debugMode
   plutusMode <- askNixOption _nix_plutusMode
   plutusAutoMode <- askNixOption _nix_plutusAutoMode
@@ -140,7 +161,7 @@ benchmarkingPhase = do
                   <*> (ScriptDataNumber <$> askNixOption _nix_plutusData)
                   <*> (ScriptDataNumber <$> askNixOption _nix_plutusRedeemer)
     (False,False) ->  return SpendOutput
-  emit $ RunBenchmark target spendMode (ThreadName "tx-submit-benchmark") tx_count tps
+  emit $ RunBenchmark wallet target spendMode (ThreadName "tx-submit-benchmark") tx_count tps
   unless debugMode $ do
     emit $ WaitBenchmark $ ThreadName "tx-submit-benchmark"
 
@@ -191,3 +212,17 @@ isPlutusAutoMode = askNixOption _nix_plutusAutoMode
 
 isAnyPlutusMode :: Compiler Bool
 isAnyPlutusMode = liftA2 (||) isPlutusMode isPlutusAutoMode
+
+newIdentifier :: String -> Compiler String
+newIdentifier prefix = do
+  n <- get
+  put $ succ n
+  return $ prefix ++ "_" ++ show n
+
+newWallet :: String -> Compiler WalletName
+newWallet n = do
+  name <- WalletName <$> newIdentifier n
+  emit $ InitWallet name
+  return name
+
+  

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

@@ -19,7 +19,7 @@ import           Cardano.Node.Configuration.Logging (shutdownLoggingLayer)
 import           Cardano.Benchmarking.Tracer (createDebugTracers)
 import           Cardano.Benchmarking.Script.Action
 import           Cardano.Benchmarking.Script.Aeson (parseScriptFileAeson)
-import           Cardano.Benchmarking.Script.Core (initGlobalWallet, setProtocolParameters)
+import           Cardano.Benchmarking.Script.Core (setProtocolParameters)
 import           Cardano.Benchmarking.Script.Env
 import           Cardano.Benchmarking.Script.Store
 import           Cardano.Benchmarking.Script.Types
@@ -40,7 +40,6 @@ runScript script iom = runActionM execScript iom >>= \case
   cleanup s a = void $ runActionMEnv s a iom
   execScript = do
     set BenchTracers createDebugTracers
-    initGlobalWallet
     setProtocolParameters QueryLocalNode
     forM_ script action
 

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

@@ -12,15 +12,16 @@ import           Cardano.Benchmarking.Script.Types
 action :: Action -> ActionM ()
 action a = case a of
   Set (key :=> (Identity val)) -> set (User key) val
+  InitWallet name -> initWallet name
   SetProtocolParameters p -> setProtocolParameters p
   StartProtocol filePath -> startProtocol filePath
   ReadSigningKey name filePath -> readSigningKey name filePath
   DefineSigningKey name descr -> defineSigningKey name descr
-  AddFund txIn lovelace keyName -> addFund txIn lovelace keyName
+  AddFund wallet txIn lovelace keyName -> addFund wallet txIn lovelace keyName
   Delay t -> delay t
-  ImportGenesisFund submitMode genesisKey fundKey -> importGenesisFund submitMode genesisKey fundKey
-  CreateChange payMode submitMode value count -> createChange payMode submitMode value count
-  RunBenchmark submitMode spendMode thread count tps -> runBenchmark submitMode spendMode thread count tps
+  ImportGenesisFund wallet submitMode genesisKey fundKey -> importGenesisFund wallet submitMode genesisKey fundKey
+  CreateChange sourceWallet dstWallet payMode submitMode value count -> createChange sourceWallet dstWallet payMode submitMode value count
+  RunBenchmark sourceWallet submitMode spendMode thread count tps -> runBenchmark sourceWallet submitMode spendMode thread count tps
   WaitBenchmark thread -> waitBenchmark thread
   CancelBenchmark thread -> cancelBenchmark thread
   WaitForEra era -> waitForEra era

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

@@ -143,10 +143,12 @@ readProtocolParametersFile = parseJSONFile fromJSON
 
 instance ToJSON KeyName         where toJSON (KeyName a) = toJSON a
 instance ToJSON ThreadName      where toJSON (ThreadName a) = toJSON a
+instance ToJSON WalletName      where toJSON (WalletName a) = toJSON a
 instance ToJSON SigningKeyFile  where toJSON (SigningKeyFile a) = toJSON a
 
 instance FromJSON KeyName         where parseJSON a = KeyName <$> parseJSON a
 instance FromJSON ThreadName      where parseJSON a = ThreadName <$> parseJSON a
+instance FromJSON WalletName      where parseJSON a = WalletName <$> parseJSON a
 instance FromJSON SigningKeyFile  where parseJSON a = SigningKeyFile <$> parseJSON a
 
 instance ToJSON NetworkId where