Merge pull request IntersectMBO#5296 from input-output-hk/nadia.chamb…

…ers/tx-gen-cleanups-01

tx-generator TODO cleanups

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

@@ -68,12 +68,12 @@ data TraceBenchTxSubmit txid
   | TraceBenchTxSubRecv [txid]
   -- ^ Received from generator.
   | TraceBenchTxSubStart [txid]
-  -- ^ The @txid@ has been submitted to `TxSubmission`
+  -- ^ The @txid@ has been submitted to `TxSubmission2`
   --   protocol peer.
   | SubmissionClientReplyTxIds [txid]
   -- ^ Announcing txids in response for server's request.
   | TraceBenchTxSubServReq [txid]
-  -- ^ Request for @tx@ received from `TxSubmission` protocol
+  -- ^ Request for @tx@ received from `TxSubmission2` protocol
   --   peer.
   | SubmissionClientDiscardAcknowledged [txid]
   -- ^ An ack (window moved over) received for these transactions.

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

@@ -1,4 +1,11 @@
 {-# LANGUAGE GADTs #-}
+{-|
+Module      : Cardano.Benchmarking.Script.Action
+Description : Convert an 'Action' to a monadic 'ActionM'.
+
+This is just exporting 'action' in order to avoid circular
+module dependencies.
+-}
 
 module Cardano.Benchmarking.Script.Action
        ( action
@@ -9,17 +16,23 @@ module Cardano.Benchmarking.Script.Action
 import qualified Data.Text as Text (unpack)
 
 import           Control.Monad.IO.Class
-import           Control.Monad.Trans.Except.Extra
 
 import           Cardano.Benchmarking.OuroborosImports as Core (protocolToNetworkId)
 import           Cardano.Benchmarking.Script.Core
 import           Cardano.Benchmarking.Script.Env
 import           Cardano.Benchmarking.Script.Types
 import           Cardano.Benchmarking.Tracer
 import           Cardano.TxGenerator.Setup.NodeConfig
-import           Cardano.TxGenerator.Types (TxGenError)
 
 
+-- | 'action' has as its sole callers
+-- 'Cardano.Benchmark.Script.runScript' from "Cardano.Benchmark.Script"
+-- and 'Cardano.Benchmark.Script.Selftest' from
+-- "Cardano.Benchmark.Script.Selftest".
+-- It translates the various cases of the 'Action' to monadic values
+-- which execute the specified actions when evaluated. It passes all
+-- the cases' fields to functions with very similar names to the
+-- constructors.
 action :: Action -> ActionM ()
 action a = case a of
   SetNetworkId val -> setEnvNetworkId val
@@ -38,9 +51,9 @@ action a = case a of
   LogMsg txt -> traceDebug $ Text.unpack txt
   Reserved options -> reserved options
 
-liftToAction :: IO (Either TxGenError a) -> ActionM a
-liftToAction = firstExceptT TxGenError . newExceptT . liftIO
-
+-- | 'startProtocol' sets up the protocol for the transaction
+-- generator from the first argument, @configFile@ and optionally
+-- traces to the second, @tracerSocket@.
 startProtocol :: FilePath -> Maybe FilePath -> ActionM ()
 startProtocol configFile tracerSocket = do
   nodeConfig <- liftToAction $ mkNodeConfig configFile

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

@@ -298,55 +298,67 @@ evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} era = do
           return $ Right tx
       return $ Streaming.effect (Streaming.yield <$> gen)
 
+    -- 'Split' combines regular payments and payments for change.
+    -- There are lists of payments buried in the 'PayWithChange'
+    -- type conditionally sent back by 'Utils.includeChange', to
+    -- then be used while partially applied as the @valueSplitter@
+    -- in 'sourceToStoreTransactionNew'.
     Split walletName payMode payModeChange coins -> do
       wallet <- getEnvWallets walletName
       (toUTxO, addressOut) <- interpretPayMode payMode
       traceDebug $ "split output address : " ++ addressOut
       (toUTxOChange, addressChange) <- interpretPayMode payModeChange
       traceDebug $ "split change address : " ++ addressChange
       let
-        fundSource = walletSource wallet 1
-        inToOut = Utils.includeChange fee coins
+        inToOut = return . Utils.includeChange fee coins
         txGenerator = genTx (cardanoEra @era) protocolParameters (TxInsCollateralNone, []) feeInEra TxMetadataNone
-        sourceToStore = sourceToStoreTransactionNew txGenerator fundSource inToOut $ mangleWithChange toUTxOChange toUTxO
-      return $ Streaming.effect (Streaming.yield <$> sourceToStore)
-
+      inputFunds <- liftToAction $ walletSource wallet 1
+      sourceToStore <- withTxGenError . sourceToStoreTransactionNew txGenerator inputFunds inToOut $ mangleWithChange (liftIOCreateAndStore toUTxOChange) (liftIOCreateAndStore toUTxO)
+      return . Streaming.effect . pure . Streaming.yield $ Right sourceToStore
+
+    -- The 'SplitN' case's call chain is somewhat elaborate.
+    -- The division is done in 'Utils.inputsToOutputsWithFee' 
+    -- but things are threaded through
+    -- 'Cardano.Benchmarking.Wallet.mangle' and packed into
+    -- the transaction assembled by 'sourceToStoreTransactionNew'.
     SplitN walletName payMode count -> do
       wallet <- getEnvWallets walletName
       (toUTxO, addressOut) <- interpretPayMode payMode
       traceDebug $ "SplitN output address : " ++ addressOut
       let
-        fundSource = walletSource wallet 1
-        inToOut = Utils.inputsToOutputsWithFee fee count
+        inToOut = withExceptT TxGenError . Utils.inputsToOutputsWithFee fee count
         txGenerator = genTx (cardanoEra @era) protocolParameters (TxInsCollateralNone, []) feeInEra TxMetadataNone
-        sourceToStore = sourceToStoreTransactionNew txGenerator fundSource inToOut (mangle $ repeat toUTxO)
-      return $ Streaming.effect (Streaming.yield <$> sourceToStore)
+      inputFunds <- liftToAction $ walletSource wallet 1
+      sourceToStore <- withTxGenError $ sourceToStoreTransactionNew txGenerator inputFunds inToOut (mangle . repeat $ liftIOCreateAndStore toUTxO)
+      return . Streaming.effect . pure . Streaming.yield $ Right sourceToStore
 
     NtoM walletName payMode inputs outputs metadataSize collateralWallet -> do
       wallet <- getEnvWallets walletName
       collaterals <- selectCollateralFunds collateralWallet
       (toUTxO, addressOut) <- interpretPayMode payMode
       traceDebug $ "NtoM output address : " ++ addressOut
       let
-        fundSource = walletSource wallet inputs
-        inToOut = Utils.inputsToOutputsWithFee fee outputs
+        inToOut = withExceptT TxGenError . Utils.inputsToOutputsWithFee fee outputs
         txGenerator = genTx (cardanoEra @era) protocolParameters collaterals feeInEra (toMetadata metadataSize)
-        sourceToStore = sourceToStoreTransactionNew txGenerator fundSource inToOut (mangle $ repeat toUTxO)
+        previewCatcher err = do
+          traceDebug $ "Error creating Tx preview: " ++ show err
+          throwE err
+      inputFunds <- liftToAction $ walletSource wallet inputs
+      sourceToStore <- withTxGenError $ sourceToStoreTransactionNew txGenerator inputFunds inToOut (mangle . repeat $ liftIOCreateAndStore toUTxO)
 
       fundPreview <- liftIO $ walletPreview wallet inputs
-      case sourceTransactionPreview txGenerator fundPreview inToOut (mangle $ repeat toUTxO) of
-        Left err -> traceDebug $ "Error creating Tx preview: " ++ show err
-        Right tx -> do
-          let txSize = txSizeInBytes tx
-          traceDebug $ "Projected Tx size in bytes: " ++ show txSize
-          summary_ <- getEnvSummary
-          forM_ summary_ $ \summary -> do
-            let summary' = summary {projectedTxSize = Just txSize}
-            setEnvSummary summary'
-            traceBenchTxSubmit TraceBenchPlutusBudgetSummary summary'
-          dumpBudgetSummaryIfExisting
-
-      return $ Streaming.effect (Streaming.yield <$> sourceToStore)
+      preview <- withTxGenError (sourceTransactionPreview txGenerator fundPreview inToOut (mangle . repeat $ liftIOCreateAndStore toUTxO))
+                   `catchE` previewCatcher
+      let txSize = txSizeInBytes preview
+      traceDebug $ "Projected Tx size in bytes: " ++ show txSize
+      summary_ <- getEnvSummary
+      forM_ summary_ $ \summary -> do
+        let summary' = summary {projectedTxSize = Just txSize}
+        setEnvSummary summary'
+        traceBenchTxSubmit TraceBenchPlutusBudgetSummary summary'
+      dumpBudgetSummaryIfExisting
+
+      return . Streaming.effect . pure . Streaming.yield $ Right sourceToStore
 
     Sequence l -> do
       gList <- forM l $ \g -> evalGenerator g txParams era
@@ -364,6 +376,10 @@ evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} era = do
 
   where
     feeInEra = Utils.mkTxFee fee
+    -- 'liftIOCreateAndStore' is supposed to be some indication that 'liftIO'
+    -- is applied to a 'CreateAndStore'.
+    -- This could be golfed as @((liftIO .) .)@ but it's unreadable.
+    liftIOCreateAndStore cas = second (\f x y -> liftIO (f x y)) . cas
 
 selectCollateralFunds :: forall era. IsShelleyBasedEra era
   => Maybe String
@@ -387,6 +403,8 @@ dumpToFileIO filePath tx = appendFile filePath ('\n' : show tx)
 initWallet :: String -> ActionM ()
 initWallet name = liftIO Wallet.initWallet >>= setEnvWallets name
 
+-- The inner monad being 'IO' creates some programming overhead above.
+-- Something like 'MonadIO' would be helpful, but the typing is tricky.
 interpretPayMode :: forall era. IsShelleyBasedEra era => PayMode -> ActionM (CreateAndStore IO era, String)
 interpretPayMode payMode = do
   networkId <- getEnvNetworkId