Skip to content

Commit d7ec3b0

Browse files
mgmeiermgmeier
authored
Merge pull request #5425 from input-output-hk/nadia.chambers/tx-gen-bugfix-01
Revert Tx.hs monadic cleanup
2 parents 42f85e9 + e9d0e0e commit d7ec3b0

File tree

9 files changed

+131
-146
lines changed

9 files changed

+131
-146
lines changed

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

Lines changed: 10 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -3,8 +3,8 @@
33
Module : Cardano.Benchmarking.Script.Action
44
Description : Convert an 'Action' to a monadic 'ActionM'.
55
6-
This is just exporting 'action' in order to avoid circular
7-
module dependencies.
6+
This is just exporting 'action', and 'liftToAction' is tough
7+
to use because of the risk of circular imports.
88
-}
99

1010
module Cardano.Benchmarking.Script.Action
@@ -16,13 +16,15 @@ module Cardano.Benchmarking.Script.Action
1616
import qualified Data.Text as Text (unpack)
1717

1818
import Control.Monad.IO.Class
19+
import Control.Monad.Trans.Except.Extra
1920

2021
import Cardano.Benchmarking.OuroborosImports as Core (protocolToNetworkId)
2122
import Cardano.Benchmarking.Script.Core
2223
import Cardano.Benchmarking.Script.Env
2324
import Cardano.Benchmarking.Script.Types
2425
import Cardano.Benchmarking.Tracer
2526
import Cardano.TxGenerator.Setup.NodeConfig
27+
import Cardano.TxGenerator.Types (TxGenError)
2628

2729

2830
-- | 'action' has as its sole callers
@@ -51,6 +53,12 @@ action a = case a of
5153
LogMsg txt -> traceDebug $ Text.unpack txt
5254
Reserved options -> reserved options
5355

56+
-- | 'liftToAction' first lifts from IO, then converts an 'Either'
57+
-- to an 'Control.Monad.Trans.Except.ExceptT' and then transforms
58+
-- the error type to 'Cardano.Benchmarking.Script.Env.Error'.
59+
liftToAction :: IO (Either TxGenError a) -> ActionM a
60+
liftToAction = firstExceptT TxGenError . newExceptT . liftIO
61+
5462
-- | 'startProtocol' sets up the protocol for the transaction
5563
-- generator from the first argument, @configFile@ and optionally
5664
-- traces to the second, @tracerSocket@.

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

Lines changed: 25 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -310,14 +310,14 @@ evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} era = do
310310
(toUTxOChange, addressChange) <- interpretPayMode payModeChange
311311
traceDebug $ "split change address : " ++ addressChange
312312
let
313-
inToOut = return . Utils.includeChange fee coins
313+
fundSource = walletSource wallet 1
314+
inToOut = Utils.includeChange fee coins
314315
txGenerator = genTx (cardanoEra @era) protocolParameters (TxInsCollateralNone, []) feeInEra TxMetadataNone
315-
inputFunds <- liftToAction $ walletSource wallet 1
316-
sourceToStore <- withTxGenError . sourceToStoreTransactionNew txGenerator inputFunds inToOut $ mangleWithChange (liftIOCreateAndStore toUTxOChange) (liftIOCreateAndStore toUTxO)
317-
return . Streaming.effect . pure . Streaming.yield $ Right sourceToStore
316+
sourceToStore = sourceToStoreTransactionNew txGenerator fundSource inToOut $ mangleWithChange toUTxOChange toUTxO
317+
return $ Streaming.effect (Streaming.yield <$> sourceToStore)
318318

319319
-- The 'SplitN' case's call chain is somewhat elaborate.
320-
-- The division is done in 'Utils.inputsToOutputsWithFee'
320+
-- The division is done in 'Utils.inputsToOutputsWithFee'
321321
-- but things are threaded through
322322
-- 'Cardano.Benchmarking.Wallet.mangle' and packed into
323323
-- the transaction assembled by 'sourceToStoreTransactionNew'.
@@ -326,39 +326,37 @@ evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} era = do
326326
(toUTxO, addressOut) <- interpretPayMode payMode
327327
traceDebug $ "SplitN output address : " ++ addressOut
328328
let
329-
inToOut = withExceptT TxGenError . Utils.inputsToOutputsWithFee fee count
329+
fundSource = walletSource wallet 1
330+
inToOut = Utils.inputsToOutputsWithFee fee count
330331
txGenerator = genTx (cardanoEra @era) protocolParameters (TxInsCollateralNone, []) feeInEra TxMetadataNone
331-
inputFunds <- liftToAction $ walletSource wallet 1
332-
sourceToStore <- withTxGenError $ sourceToStoreTransactionNew txGenerator inputFunds inToOut (mangle . repeat $ liftIOCreateAndStore toUTxO)
333-
return . Streaming.effect . pure . Streaming.yield $ Right sourceToStore
332+
sourceToStore = sourceToStoreTransactionNew txGenerator fundSource inToOut (mangle $ repeat toUTxO)
333+
return $ Streaming.effect (Streaming.yield <$> sourceToStore)
334334

335335
NtoM walletName payMode inputs outputs metadataSize collateralWallet -> do
336336
wallet <- getEnvWallets walletName
337337
collaterals <- selectCollateralFunds collateralWallet
338338
(toUTxO, addressOut) <- interpretPayMode payMode
339339
traceDebug $ "NtoM output address : " ++ addressOut
340340
let
341-
inToOut = withExceptT TxGenError . Utils.inputsToOutputsWithFee fee outputs
341+
fundSource = walletSource wallet inputs
342+
inToOut = Utils.inputsToOutputsWithFee fee outputs
342343
txGenerator = genTx (cardanoEra @era) protocolParameters collaterals feeInEra (toMetadata metadataSize)
343-
previewCatcher err = do
344-
traceDebug $ "Error creating Tx preview: " ++ show err
345-
throwE err
346-
inputFunds <- liftToAction $ walletSource wallet inputs
347-
sourceToStore <- withTxGenError $ sourceToStoreTransactionNew txGenerator inputFunds inToOut (mangle . repeat $ liftIOCreateAndStore toUTxO)
344+
sourceToStore = sourceToStoreTransactionNew txGenerator fundSource inToOut (mangle $ repeat toUTxO)
348345

349346
fundPreview <- liftIO $ walletPreview wallet inputs
350-
preview <- withTxGenError (sourceTransactionPreview txGenerator fundPreview inToOut (mangle . repeat $ liftIOCreateAndStore toUTxO))
351-
`catchE` previewCatcher
352-
let txSize = txSizeInBytes preview
353-
traceDebug $ "Projected Tx size in bytes: " ++ show txSize
354-
summary_ <- getEnvSummary
355-
forM_ summary_ $ \summary -> do
356-
let summary' = summary {projectedTxSize = Just txSize}
357-
setEnvSummary summary'
358-
traceBenchTxSubmit TraceBenchPlutusBudgetSummary summary'
359-
dumpBudgetSummaryIfExisting
360-
361-
return . Streaming.effect . pure . Streaming.yield $ Right sourceToStore
347+
case sourceTransactionPreview txGenerator fundPreview inToOut (mangle $ repeat toUTxO) of
348+
Left err -> traceDebug $ "Error creating Tx preview: " ++ show err
349+
Right tx -> do
350+
let txSize = txSizeInBytes tx
351+
traceDebug $ "Projected Tx size in bytes: " ++ show txSize
352+
summary_ <- getEnvSummary
353+
forM_ summary_ $ \summary -> do
354+
let summary' = summary {projectedTxSize = Just txSize}
355+
setEnvSummary summary'
356+
traceBenchTxSubmit TraceBenchPlutusBudgetSummary summary'
357+
dumpBudgetSummaryIfExisting
358+
359+
return $ Streaming.effect (Streaming.yield <$> sourceToStore)
362360

363361
Sequence l -> do
364362
gList <- forM l $ \g -> evalGenerator g txParams era
@@ -376,10 +374,6 @@ evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} era = do
376374

377375
where
378376
feeInEra = Utils.mkTxFee fee
379-
-- 'liftIOCreateAndStore' is supposed to be some indication that 'liftIO'
380-
-- is applied to a 'CreateAndStore'.
381-
-- This could be golfed as @((liftIO .) .)@ but it's unreadable.
382-
liftIOCreateAndStore cas = second (\f x y -> liftIO (f x y)) . cas
383377

384378
selectCollateralFunds :: forall era. IsShelleyBasedEra era
385379
=> Maybe String
@@ -403,8 +397,6 @@ dumpToFileIO filePath tx = appendFile filePath ('\n' : show tx)
403397
initWallet :: String -> ActionM ()
404398
initWallet name = liftIO Wallet.initWallet >>= setEnvWallets name
405399

406-
-- The inner monad being 'IO' creates some programming overhead above.
407-
-- Something like 'MonadIO' would be helpful, but the typing is tricky.
408400
interpretPayMode :: forall era. IsShelleyBasedEra era => PayMode -> ActionM (CreateAndStore IO era, String)
409401
interpretPayMode payMode = do
410402
networkId <- getEnvNetworkId

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

Lines changed: 1 addition & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -30,10 +30,8 @@ module Cardano.Benchmarking.Script.Env (
3030
, Error(..)
3131
, runActionM
3232
, runActionMEnv
33-
, liftToAction
3433
, liftTxGenError
3534
, liftIOSafe
36-
, withTxGenError
3735
, askIOManager
3836
, traceDebug
3937
, traceError
@@ -133,7 +131,7 @@ runActionM = runActionMEnv emptyEnv
133131
runActionMEnv :: Env -> ActionM ret -> IOManager -> IO (Either Error ret, Env, ())
134132
runActionMEnv env action iom = RWS.runRWST (runExceptT action) iom env
135133

136-
-- | 'Error' adds two cases to 'Cardano.TxGenerator.Types.TxGenError'
134+
-- | 'Error' adds two cases to 'Cardano.TxGenerator.Types.TxGenError'
137135
-- which in turn wraps 'Cardano.Api.Error' implicit contexts to a
138136
-- couple of its constructors. These represent errors that might arise
139137
-- in the execution of a transaction with some distinctions as to the
@@ -150,17 +148,6 @@ data Error where
150148

151149
deriving instance Show Error
152150

153-
-- | This abbreviates access to the fully-qualified constructor name
154-
-- for `Cardano.Benchmarking.Script.Env.TxGenError` and the repetitive
155-
-- usage of `withExceptT` with that as its first argument.
156-
withTxGenError :: Monad m => ExceptT TxGenError m a -> ExceptT Error m a
157-
withTxGenError = withExceptT Cardano.Benchmarking.Script.Env.TxGenError
158-
159-
-- | This injects an `IO` action using `Either` as hand-rolled
160-
-- exceptions into the `ActionM` monad.
161-
liftToAction :: IO (Either TxGenError a) -> ActionM a
162-
liftToAction = withTxGenError . ExceptT . liftIO
163-
164151
-- | This throws a `TxGenError` in the `ActionM` monad.
165152
liftTxGenError :: TxGenError -> ActionM a
166153
liftTxGenError = throwE . Cardano.Benchmarking.Script.Env.TxGenError

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -98,7 +98,7 @@ data Action where
9898
AddFund :: !AnyCardanoEra -> !String -> !TxIn -> !Lovelace -> !String -> Action
9999
-- | 'WaitBenchmark' signifies a 'Control.Concurrent.Async.waitCatch'
100100
-- on the 'Cardano.Benchmarking.GeneratorTx.AsyncBenchmarkControl'
101-
-- associated with the ID and also folds tracers into the completion.
101+
-- associated with the ID and also folds tracers into the completion.
102102
WaitBenchmark :: !String -> Action
103103
-- | 'Submit' mostly wraps
104104
-- 'Cardano.Benchamrking.Script.Core.benchmarkTxStream'
@@ -108,7 +108,7 @@ data Action where
108108
-- 'Cardano.Benchmarking.GeneratorTx.SubmissionClient.txSubmissionClient'
109109
-- and functions local to that like @requestTxs@.
110110
Submit :: !AnyCardanoEra -> !SubmitMode -> !TxGenTxParams -> !Generator -> Action
111-
-- | 'CancelBenchmark' wraps a callback from the
111+
-- | 'CancelBenchmark' wraps a callback from the
112112
-- 'Cardano.Benchmarking.GeneratorTx.AsyncBenchmarkControl' type,
113113
-- which is a shutdown action.
114114
CancelBenchmark :: !String -> Action

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -10,8 +10,8 @@ module Cardano.Benchmarking.Types
1010
( module Cardano.Benchmarking.Types
1111
) where
1212

13-
import GHC.Generics (Generic)
1413
import Data.Aeson (ToJSON)
14+
import GHC.Generics (Generic)
1515

1616

1717
-- | Transactions we decided to announce now.

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

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -13,14 +13,14 @@ module Cardano.Benchmarking.Wallet
1313
where
1414
import Prelude
1515

16-
import Streaming
1716
import Control.Concurrent.MVar
17+
import Streaming
1818

1919
import Cardano.Api
2020

2121
import Cardano.TxGenerator.FundQueue as FundQueue
22-
import Cardano.TxGenerator.Types
2322
import Cardano.TxGenerator.Tx
23+
import Cardano.TxGenerator.Types
2424
import Cardano.TxGenerator.UTxO
2525

2626
-- | All the actual functionality of Wallet / WalletRef has been removed
@@ -122,10 +122,10 @@ mangleWithChange mkChange mkPayment outs = case outs of
122122
-- as the first @fkts@ argument is 'mangleWithChange' above. This
123123
-- is likely worth refactoring for the sake of maintainability.
124124
mangle :: Monad m => [ CreateAndStore m era ] -> CreateAndStoreList m era [ Lovelace ]
125-
mangle fkts values
125+
mangle fkts values
126126
= (outs, \txId -> mapM_ (\f -> f txId) fs)
127127
where
128-
(outs, fs) = unzip $ zipWith3 worker fkts values [TxIx 0 ..]
129-
worker toUTxO value idx
128+
(outs, fs) = unzip $ map worker $ zip3 fkts values [TxIx 0 ..]
129+
worker (toUTxO, value, idx)
130130
= let (o, f ) = toUTxO value
131-
in (o, f idx)
131+
in (o, f idx)

‎bench/tx-generator/src/Cardano/TxGenerator/PureExample.hs‎

Lines changed: 13 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,4 @@
11
{-# LANGUAGE RecordWildCards #-}
2-
{-# LANGUAGE ScopedTypeVariables #-}
32
{-# LANGUAGE TypeFamilies #-}
43
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
54

@@ -8,10 +7,8 @@ module Cardano.TxGenerator.PureExample
87
where
98

109
import Control.Monad (foldM)
11-
import Control.Monad.Trans.Except
1210
import Control.Monad.Trans.State.Strict
1311
import Data.Either (fromRight)
14-
import Data.Functor.Identity (runIdentity)
1512
import Data.List (foldl')
1613
import Data.String (fromString)
1714
import System.Exit (die)
@@ -95,16 +92,13 @@ type Generator = State FundQueue
9592
generateTx ::
9693
TxEnvironment BabbageEra
9794
-> Generator (Either TxGenError (Tx BabbageEra))
98-
generateTx TxEnvironment{..} = do
99-
funds' <- consumeInputFunds
100-
case funds' of
101-
Left err -> pure $ Left err
102-
Right funds -> runExceptT $ sourceToStoreTransaction
103-
generator
104-
funds
105-
computeOutputValues
106-
(makeToUTxOList $ repeat computeUTxO)
107-
addNewOutputFunds
95+
generateTx TxEnvironment{..}
96+
= sourceToStoreTransaction
97+
generator
98+
consumeInputFunds
99+
computeOutputValues
100+
(makeToUTxOList $ repeat computeUTxO)
101+
addNewOutputFunds
108102
where
109103
TxFeeExplicit _ fee = txEnvFee
110104

@@ -125,8 +119,8 @@ generateTx TxEnvironment{..} = do
125119
addNewOutputFunds :: [Fund] -> Generator ()
126120
addNewOutputFunds = put . foldl' insertFund emptyFundQueue
127121

128-
computeOutputValues :: Monad m => [Lovelace] -> ExceptT TxGenError m [Lovelace]
129-
computeOutputValues = withExceptT TxGenError . inputsToOutputsWithFee fee numOfOutputs
122+
computeOutputValues :: [Lovelace] -> [Lovelace]
123+
computeOutputValues = inputsToOutputsWithFee fee numOfOutputs
130124
where numOfOutputs = 2
131125

132126
computeUTxO = mkUTxOVariant txEnvNetworkId signingKey
@@ -148,8 +142,6 @@ generateTxPure ::
148142
-> Either TxGenError (Tx BabbageEra, FundQueue)
149143
generateTxPure TxEnvironment{..} inQueue
150144
= do
151-
outValues <- runIdentity . runExceptT . withExcept TxGenError . computeOutputValues $ map getFundLovelace inputs
152-
let (outputs, toFunds) = makeToUTxOList (repeat computeUTxO) outValues
153145
(tx, txId) <- generator inputs outputs
154146
let outQueue = foldl' insertFund emptyFundQueue (toFunds txId)
155147
pure (tx, outQueue)
@@ -164,7 +156,10 @@ generateTxPure TxEnvironment{..} inQueue
164156
collateralFunds :: (TxInsCollateral BabbageEra, [Fund])
165157
collateralFunds = (TxInsCollateralNone, [])
166158

167-
computeOutputValues :: Monad m => [Lovelace] -> ExceptT String m [Lovelace]
159+
outValues = computeOutputValues $ map getFundLovelace inputs
160+
(outputs, toFunds) = makeToUTxOList (repeat computeUTxO) outValues
161+
162+
computeOutputValues :: [Lovelace] -> [Lovelace]
168163
computeOutputValues = inputsToOutputsWithFee fee numOfOutputs
169164
where numOfOutputs = 2
170165

0 commit comments

Comments
 (0)