tx-generator: make good use of multiple wallets.

This commit allow one to sort the outputs of a transaction
into multiple destinct wallets.
In particular it makes it possible to put change outputs and
collaterals in one wallet and the split-outputs in a other wallet.

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

@@ -48,8 +48,8 @@ compileToScript = do
   emit . StartProtocol =<< askNixOption getNodeConfigFile
   genesisWallet <- newWallet "genesis_wallet"
   importGenesisFunds genesisWallet
-  splitWallet <- splittingPhase genesisWallet
   collateralWallet <- addCollaterals genesisWallet
+  splitWallet <- splittingPhase genesisWallet
   benchmarkingPhase splitWallet collateralWallet
 
 initConstants :: Compiler ()
@@ -78,11 +78,13 @@ addCollaterals src = do
   isAnyPlutusMode >>= \case
     False -> return Nothing
     True -> do      
-      tx_fee <- askNixOption _nix_tx_fee
       safeCollateral <- _safeCollateral <$> evilFeeMagic
       collateralWallet <- newWallet "collateral_wallet"
-      emit $ CreateChange era src src LocalSocket (PayToAddr $ KeyName "pass-partout") (safeCollateral + tx_fee) 1
-      emit $ CreateChange era src collateralWallet LocalSocket (PayToCollateral $ KeyName "pass-partout") safeCollateral 1
+      emit $ CreateChange era src LocalSocket
+               (PayToAddr (KeyName "pass-partout") collateralWallet)
+               (PayToAddr (KeyName "pass-partout") src)
+               safeCollateral
+               1
       return $ Just collateralWallet
 
 splittingPhase :: SrcWallet -> Compiler DstWallet
@@ -99,7 +101,7 @@ splittingPhase srcWallet = do
  where
   createChange :: AnyCardanoEra -> SplitStep -> Compiler DstWallet
   createChange era (src, dst, value, count) = do
-     emit $ CreateChange era src dst LocalSocket (PayToAddr $ KeyName "pass-partout") value count
+     emit $ CreateChange era src LocalSocket (PayToAddr (KeyName "pass-partout") dst ) (PayToAddr  (KeyName "pass-partout") src) value count
      delay
      return dst
 
@@ -116,7 +118,7 @@ splittingPhase srcWallet = do
                      <*> (ScriptDataNumber <$> askNixOption _nix_plutusRedeemer)
                      <*> pure executionUnits
          ScriptSpec <$> askNixOption _nix_plutusScript <*> pure budget
-     emit $ CreateChange era src dst LocalSocket (PayToScript scriptSpec) value count
+     emit $ CreateChange era src LocalSocket (PayToScript scriptSpec dst) (PayToScript scriptSpec src) value count
      delay
      return dst
 

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

@@ -9,6 +9,7 @@ data Fifo a = Fifo ![a] ![a]
 emptyFifo :: Fifo a
 emptyFifo = Fifo [] []
 
+-- Warning : bad complexity when used as a persistent data structure.
 toList :: Fifo a -> [a]
 toList (Fifo x y) = x ++ reverse y
 

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

@@ -31,7 +31,8 @@ newtype Fund = Fund {unFund :: InAnyCardanoEra FundInEra}
 type FundSet = Fifo Fund
 
 type FundSource m = m (Either String [Fund])
-type FundToStore m = [Fund] -> m ()
+type FundToStore m = Fund -> m ()
+type FundToStoreList m = [Fund] -> m ()
 
 getFundTxIn :: Fund -> TxIn
 getFundTxIn (Fund (InAnyCardanoEra _ a)) = _fundTxIn a

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

@@ -21,7 +21,7 @@ action a = case a of
   AddFund era wallet txIn lovelace keyName -> addFund era wallet txIn lovelace keyName
   Delay t -> delay t
   ImportGenesisFund era wallet submitMode genesisKey fundKey -> importGenesisFund era wallet submitMode genesisKey fundKey
-  CreateChange era sourceWallet dstWallet payMode submitMode value count -> createChange era sourceWallet dstWallet payMode submitMode value count
+  CreateChange era sourceWallet payMode changeMode submitMode value count -> createChange era sourceWallet payMode changeMode submitMode value count
   RunBenchmark era sourceWallet submitMode thread auxArgs collateralWallet tps
     -> runBenchmark era sourceWallet submitMode thread auxArgs collateralWallet tps
   WaitBenchmark thread -> waitBenchmark thread

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

@@ -242,6 +242,7 @@ localSubmitTx tx = do
 -- It should be possible to exit the tx-generator with an exception and also get the log messages.
 -- Problem 1: When doing throwE $ ApiError msg logmessages get lost !
 -- Problem 2: Workbench restarts the tx-generator -> this may be the reason for loss of messages
+
 makeMetadata :: forall era. IsShelleyBasedEra era => ActionM (TxMetadataInEra era)
 makeMetadata = do
   payloadSize <- getUser TTxAdditionalSize
@@ -282,7 +283,6 @@ runBenchmarkInEra sourceWallet submitMode (ThreadName threadName) shape collater
   let fundSource = walletSource walletRefSrc (auxInputsPerTx shape)
 
   collaterals <- selectCollateralFunds collateralWallet
-
   let
     inToOut :: [Lovelace] -> [Lovelace]
     inToOut = FundSet.inputsToOutputsWithFee (auxFee shape) (auxOutputsPerTx shape)
@@ -292,12 +292,12 @@ runBenchmarkInEra sourceWallet submitMode (ThreadName threadName) shape collater
     toUTxO :: [ ToUTxO era ]
     toUTxO = repeat $ Wallet.mkUTxOVariant networkId fundKey
 
-    fundToStore = mkWalletFundStore walletRefDst
+    fundToStore = mkWalletFundStoreList walletRefDst
 
     walletScript :: WalletScript era
     walletScript = benchmarkWalletScript walletRefSrc txGenerator (NumberOfTxs $ auxTxCount shape)
                      fundSource inToOut toUTxO fundToStore
-
+  
   case submitMode of
     NodeToNode targetNodes -> do
       connectClient <- getConnectClient
@@ -364,51 +364,49 @@ importGenesisFund era wallet submitMode genesisKeyName destKey = do
 initWallet :: WalletName -> ActionM ()
 initWallet name = liftIO Wallet.initWallet >>= setName name
 
-createChange :: AnyCardanoEra -> WalletName -> WalletName -> SubmitMode -> PayMode -> Lovelace -> Int -> ActionM ()
-createChange era sourceWallet dstWallet submitMode payMode value count
-  = withEra era $ createChangeInEra sourceWallet dstWallet submitMode payMode value count
+createChange :: AnyCardanoEra -> WalletName -> SubmitMode -> PayMode -> PayMode -> Lovelace -> Int -> ActionM ()
+createChange era sourceWallet submitMode payMode changeMode value count
+  = withEra era $ createChangeInEra sourceWallet submitMode payMode changeMode value count
 
 createChangeInEra :: forall era. IsShelleyBasedEra era
   => WalletName
-  -> WalletName
   -> SubmitMode
   -> PayMode
+  -> PayMode  
   -> Lovelace
   -> Int
   -> AsType era
   -> ActionM ()
-createChangeInEra sourceWallet dstWallet submitMode payMode value count _era = do
-  walletRef <- getName dstWallet
+createChangeInEra sourceWallet submitMode payMode changeMode value count _era = do
   fee <- getUser TFee
   protocolParameters <- getProtocolParameters
   (toUTxO, addressMsg) <- interpretPayMode payMode
+  (toUTxOChange, _) <- interpretPayMode changeMode  
   let
     createCoins :: FundSet.FundSource IO -> [Lovelace] -> ActionM (Either String (TxInMode CardanoMode))
     createCoins fundSource coins = do
-      (tx :: Either String (Tx era)) <- liftIO $ sourceToStoreTransaction
+      (tx :: Either String (Tx era)) <- liftIO $ sourceToStoreTransactionNew
                                                   (genTx protocolParameters (TxInsCollateralNone, [])
                                                    (mkFee fee) TxMetadataNone )
-                                                  fundSource (Wallet.includeChange fee coins)
-                                                  (makeToUTxOList $ repeat toUTxO)
-                                                  (mkWalletFundStore walletRef)
+                                                  fundSource
+                                                  (Wallet.includeChangeNew fee coins)
+                                                  (mangleWithChange toUTxOChange toUTxO)
       return $ fmap txInModeCardano tx
   createChangeGeneric sourceWallet submitMode createCoins addressMsg value count
 
-interpretPayMode :: forall era. IsShelleyBasedEra era => PayMode -> ActionM (ToUTxO era, String)
+interpretPayMode :: forall era. IsShelleyBasedEra era => PayMode -> ActionM (CreateAndStore IO era, String)
 interpretPayMode payMode = do
   networkId <- getUser TNetworkId
   case payMode of
-    PayToAddr keyName -> do
-      fundKey <- getName keyName
-      return ( Wallet.mkUTxOVariant networkId fundKey
-             , Text.unpack $ serialiseAddress $ keyAddress @ era networkId fundKey)
-    PayToCollateral keyName -> do
+    PayToAddr keyName destWallet -> do
       fundKey <- getName keyName
-      return ( Wallet.mkUTxOVariant networkId fundKey
+      walletRef <- getName destWallet
+      return ( createAndStore (Wallet.mkUTxOVariant networkId fundKey) (mkWalletFundStore walletRef)
              , Text.unpack $ serialiseAddress $ keyAddress @ era networkId fundKey)
-    PayToScript scriptSpec -> do
+    PayToScript scriptSpec destWallet -> do
+      walletRef <- getName destWallet      
       (witness, script, scriptData, _scriptFee) <- makePlutusContext scriptSpec
-      return ( mkUTxOScript networkId (script, scriptData) witness
+      return ( createAndStore (mkUTxOScript networkId (script, scriptData) witness) (mkWalletFundStore walletRef)
                , Text.unpack $ serialiseAddress $ makeShelleyAddress networkId (PaymentCredentialByScript $ hashScript script) NoStakeAddress )
 
 createChangeGeneric ::

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

@@ -66,9 +66,9 @@ testScript protocolFile submitMode =
     era = AnyCardanoEra AllegraEra
     wallet = WalletName "test-wallet"
     key = KeyName "pass-partout"
-    addr = PayToAddr key
+    payMode = PayToAddr key wallet
     createChange val count
-      = CreateChange era wallet wallet submitMode addr (Lovelace val) count
+      = CreateChange era wallet submitMode payMode payMode (Lovelace val) count
     extraArgs = RunBenchmarkAux {
         auxTxCount = 4000
       , auxFee = 1000000

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

@@ -34,7 +34,7 @@ data Action where
   DefineSigningKey   :: !KeyName -> !TextEnvelope -> Action
   AddFund            :: !AnyCardanoEra -> !WalletName -> !TxIn -> !Lovelace -> !KeyName -> Action
   ImportGenesisFund  :: !AnyCardanoEra -> !WalletName -> !SubmitMode -> !KeyName -> !KeyName -> Action
-  CreateChange       :: !AnyCardanoEra -> !WalletName -> !WalletName -> !SubmitMode -> !PayMode -> !Lovelace -> !Int -> Action
+  CreateChange       :: !AnyCardanoEra -> !WalletName -> !SubmitMode -> !PayMode -> !PayMode -> !Lovelace -> !Int -> Action
   RunBenchmark       :: !AnyCardanoEra -> !WalletName -> !SubmitMode -> !ThreadName -> !RunBenchmarkAux -> Maybe WalletName -> !TPSRate -> Action
   WaitBenchmark      :: !ThreadName -> Action
   CancelBenchmark    :: !ThreadName -> Action
@@ -59,9 +59,8 @@ data SubmitMode where
 deriving instance Generic SubmitMode
 
 data PayMode where
-  PayToAddr :: !KeyName -> PayMode
-  PayToCollateral :: !KeyName  -> PayMode
-  PayToScript :: !ScriptSpec -> PayMode
+  PayToAddr :: !KeyName -> !WalletName -> PayMode
+  PayToScript :: !ScriptSpec -> !WalletName -> PayMode
   deriving (Show, Eq)
 deriving instance Generic PayMode
 

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

@@ -27,12 +27,21 @@ type WalletRef = MVar FundSet
 type TxGenerator era = [Fund] -> [TxOut CtxTx era] -> Either String (Tx era, TxId)
 
 type ToUTxO era = Lovelace -> (TxOut CtxTx era, TxIx -> TxId -> Fund)
+type ToUTxOList era split = split -> ([TxOut CtxTx era], TxId -> [Fund])
+
+type CreateAndStore m era = Lovelace -> (TxOut CtxTx era, TxIx -> TxId -> m ())
+
+type CreateAndStoreList m era split = split -> ([TxOut CtxTx era], TxId -> m ())
 
---todo: inline inToOut :: [Lovelace] -> [Lovelace] and FundToStore
-type ToUTxOList era = [Lovelace] -> ([TxOut CtxTx era], TxId -> [Fund])
 -- 'ToUTxOList era' is more powerful than '[ ToUTxO era ]' but
 -- '[ ToUTxO era ]` is easier to construct.
 
+createAndStore :: ToUTxO era -> (Fund -> m ()) -> CreateAndStore m era
+createAndStore create store lovelace = (utxo, toStore)
+  where
+    (utxo, mkFund) = create lovelace
+    toStore txIx txId = store $ mkFund txIx txId
+
 initWallet :: IO WalletRef
 initWallet = newMVar emptyFundSet
 
@@ -44,16 +53,20 @@ askWalletRef r f = do
 walletRefInsertFund :: WalletRef -> Fund -> IO ()
 walletRefInsertFund ref fund = modifyMVar_  ref $ \w -> return $ FundSet.insertFund w fund
 
-mkWalletFundStore :: WalletRef -> FundToStore IO
-mkWalletFundStore walletRef funds = modifyMVar_  walletRef
+mkWalletFundStoreList :: WalletRef -> FundToStoreList IO
+mkWalletFundStoreList walletRef funds = modifyMVar_  walletRef
   $ \wallet -> return (foldl FundSet.insertFund wallet funds)
 
+mkWalletFundStore :: WalletRef -> FundToStore IO
+mkWalletFundStore walletRef fund = modifyMVar_  walletRef
+  $ \wallet -> return $ FundSet.insertFund wallet fund
+
 walletSource :: WalletRef -> Int -> FundSource IO
 walletSource ref munch = modifyMVar ref $ \fifo -> return $ case Fifo.removeN munch fifo of
   Nothing -> (fifo, Left "WalletSource: out of funds")
   Just (newFifo, funds) -> (newFifo, Right funds) 
 
-makeToUTxOList :: [ ToUTxO era ] -> ToUTxOList era
+makeToUTxOList :: [ ToUTxO era ] -> ToUTxOList era [ Lovelace ]
 makeToUTxOList fkts values 
   = (outs, \txId -> map (\f -> f txId) fs)
   where
@@ -62,14 +75,32 @@ makeToUTxOList fkts values
       = let (o, f ) = toUTxO value
          in  (o, f idx) 
 
+data PayWithChange
+  = PayExact [Lovelace]
+  | PayWithChange Lovelace [Lovelace]
+
+mangleWithChange :: Monad m => CreateAndStore m era -> CreateAndStore m era -> CreateAndStoreList m era PayWithChange
+mangleWithChange mkChange mkPayment outs = case outs of
+  PayExact l -> mangle (repeat mkPayment) l
+  PayWithChange change payments -> mangle (mkChange : repeat mkPayment) (change : payments)
+
+mangle :: Monad m => [ CreateAndStore m era ] -> CreateAndStoreList m era [ Lovelace ]
+mangle fkts values 
+  = (outs, \txId -> mapM_ (\f -> f txId) fs)
+  where
+    (outs, fs) =unzip $ map worker $ zip3 fkts values [TxIx 0 ..]
+    worker (toUTxO, value, idx)
+      = let (o, f ) = toUTxO value
+         in  (o, f idx) 
+
 --TODO use Error monad
 --TODO need to break this up
 sourceToStoreTransaction ::
      TxGenerator era
   -> FundSource IO         
-  -> ([Lovelace] -> [Lovelace]) --inline to ToUTxOList
-  -> ToUTxOList era
-  -> FundToStore IO                --inline to ToUTxOList
+  -> ([Lovelace] -> split)
+  -> ToUTxOList era split
+  -> FundToStoreList IO                --inline to ToUTxOList
   -> IO (Either String (Tx era))
 sourceToStoreTransaction txGenerator fundSource inToOut mkTxOut fundToStore = do
   fundSource >>= \case
@@ -86,13 +117,41 @@ sourceToStoreTransaction txGenerator fundSource inToOut mkTxOut fundToStore = do
           fundToStore $ toFunds txId
           return $ Right tx
 
+sourceToStoreTransactionNew ::
+     TxGenerator era
+  -> FundSource IO         
+  -> ([Lovelace] -> split)
+  -> CreateAndStoreList IO era split
+  -> IO (Either String (Tx era))
+sourceToStoreTransactionNew txGenerator fundSource valueSplitter toStore = do
+  fundSource >>= \case
+    Left err -> return $ Left err
+    Right inputFunds -> work inputFunds
+ where
+  work inputFunds = do
+    let
+      split = valueSplitter $ map getFundLovelace inputFunds
+      (outputs, storeAction) = toStore split
+    case txGenerator inputFunds outputs of
+        Left err -> return $ Left err
+        Right (tx, txId) -> do
+          storeAction txId
+          return $ Right tx
+
 includeChange :: Lovelace -> [Lovelace] -> [Lovelace] -> [Lovelace]
 includeChange fee spend have = case compare changeValue 0 of
   GT -> changeValue : spend
   EQ -> spend
   LT -> error "genTX: Bad transaction: insufficient funds"
   where changeValue = sum have - sum spend - fee
 
+includeChangeNew :: Lovelace -> [Lovelace] -> [Lovelace] -> PayWithChange
+includeChangeNew fee spend have = case compare changeValue 0 of
+  GT -> PayWithChange changeValue spend
+  EQ -> PayExact spend
+  LT -> error "genTX: Bad transaction: insufficient funds"
+  where changeValue = sum have - sum spend - fee
+
 mkUTxOVariant :: forall era. IsShelleyBasedEra era
   => NetworkId
   -> SigningKey PaymentKey
@@ -205,7 +264,7 @@ benchmarkWalletScript :: forall era .
   -> FundSource IO
   -> ([Lovelace] -> [Lovelace])
   -> [ToUTxO era]
-  -> FundToStore IO
+  -> FundToStoreList IO
   -> WalletScript era
 benchmarkWalletScript wRef txGenerator totalCount fundSource inOut toUTxO fundToStore
   = WalletScript $ walletStep totalCount