tx-generator: fewer IO types

IntersectMBO · Aug 8, 2022 · 43fe509 · 43fe509
1 parent 2448873
commit 43fe509
Show file tree

Hide file tree

Showing 4 changed files with 22 additions and 18 deletions.
diff --git a/bench/tx-generator/src/Cardano/Benchmarking/FundSet.hs b/bench/tx-generator/src/Cardano/Benchmarking/FundSet.hs
@@ -142,8 +142,8 @@ liftAnyEra f x = case x of
   InAnyCardanoEra BabbageEra a  ->  InAnyCardanoEra BabbageEra $ f a  
 
 type FundSelector = FundSet -> Either String [Fund]
-type FundSource = IO (Either String [Fund])
-type FundToStore = [Fund] -> IO ()
+type FundSource m = m (Either String [Fund])
+type FundToStore m = [Fund] -> m ()
 
 -- Select Funds to cover a minimum value.
 -- TODO:

diff --git a/bench/tx-generator/src/Cardano/Benchmarking/ListBufferedSelector.hs b/bench/tx-generator/src/Cardano/Benchmarking/ListBufferedSelector.hs
@@ -18,7 +18,7 @@ mkBufferedSource ::
   -> Lovelace
   -> Maybe Variant
   -> Int
-  -> IO (Either String FundSource)
+  -> IO (Either String (FundSource IO))
 mkBufferedSource walletRef count minValue variant munch
   = mkWalletFundSource walletRef (selectToBuffer count minValue variant) >>= \case
     Left err -> return $ Left err

diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs
@@ -89,18 +89,21 @@ readSigningKey name filePath =
     Left err -> liftTxGenError err
     Right key -> setName name key
 
-defineSigningKey :: KeyName -> TextEnvelope -> ActionM ()
-defineSigningKey name descr
-  = case deserialiseFromTextEnvelopeAnyOf types descr of
-    Right key -> setName name key
-    Left err -> throwE $ ApiError $ show err
+parseSigningKey :: TextEnvelope -> Either TextEnvelopeError (SigningKey PaymentKey)
+parseSigningKey = deserialiseFromTextEnvelopeAnyOf types
   where
     types :: [FromSomeType HasTextEnvelope (SigningKey PaymentKey)]
     types =
       [ FromSomeType (AsSigningKey AsGenesisUTxOKey) castSigningKey
       , FromSomeType (AsSigningKey AsPaymentKey) id
       ]
 
+defineSigningKey :: KeyName -> TextEnvelope -> ActionM ()
+defineSigningKey name descr
+  = case parseSigningKey descr of
+    Right key -> setName name key
+    Left err -> throwE $ ApiError $ show err
+
 addFund :: AnyCardanoEra -> WalletName -> TxIn -> Lovelace -> KeyName -> ActionM ()
 addFund era wallet txIn lovelace keyName = do
   fundKey  <- getName keyName
@@ -382,7 +385,7 @@ createChangeInEra sourceWallet dstWallet submitMode payMode value count _era = d
   protocolParameters <- getProtocolParameters
   (toUTxO, addressMsg) <- interpretPayMode payMode
   let
-    createCoins :: FundSet.FundSource -> [Lovelace] -> ActionM (Either String (TxInMode CardanoMode))
+    createCoins :: FundSet.FundSource IO -> [Lovelace] -> ActionM (Either String (TxInMode CardanoMode))
     createCoins fundSource coins = do
       (tx :: Either String (Tx era)) <- liftIO $ sourceToStoreTransaction
                                                   (genTx protocolParameters (TxInsCollateralNone, [])
@@ -411,7 +414,7 @@ interpretPayMode payMode = do
 createChangeGeneric ::
      WalletName
   -> SubmitMode
-  -> (FundSet.FundSource -> [Lovelace] -> ActionM (Either String (TxInMode CardanoMode)))
+  -> (FundSet.FundSource IO -> [Lovelace] -> ActionM (Either String (TxInMode CardanoMode)))
   -> String
   -> Lovelace
   -> Int

diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Wallet.hs b/bench/tx-generator/src/Cardano/Benchmarking/Wallet.hs
@@ -66,22 +66,23 @@ walletExtractFunds w s
     Left err -> Left err
     Right funds -> Right (foldl (flip walletDeleteFund) w funds, funds)
 
-mkWalletFundSource :: WalletRef -> FundSelector -> FundSource
+mkWalletFundSource :: WalletRef -> FundSelector -> FundSource IO
 mkWalletFundSource walletRef selector
   = modifyWalletRefEither walletRef (\wallet -> return $ walletExtractFunds wallet selector)
 
-mkWalletFundStore :: WalletRef -> FundToStore
+mkWalletFundStore :: WalletRef -> FundToStore IO
 mkWalletFundStore walletRef funds = modifyWalletRef walletRef
   $ \wallet -> return (foldl (flip walletInsertFund) wallet funds, ())
 
 --TODO use Error monad
 sourceToStoreTransaction ::
-     TxGenerator era
-  -> FundSource
+     Monad m
+  => TxGenerator era
+  -> FundSource m
   -> ([Lovelace] -> [Lovelace])
   -> [ToUTxO era]
-  -> FundToStore
-  -> IO (Either String (Tx era))
+  -> FundToStore m
+  -> m (Either String (Tx era))
 sourceToStoreTransaction txGenerator fundSource inToOut mkTxOut fundToStore = do
   fundSource >>= \case
     Left err -> return $ Left err
@@ -223,10 +224,10 @@ benchmarkWalletScript :: forall era .
   => WalletRef
   -> TxGenerator era
   -> NumberOfTxs
-  -> (Target -> FundSource)
+  -> (Target -> FundSource IO)
   -> ([Lovelace] -> [Lovelace])
   -> ( Target -> SeqNumber -> [ToUTxO era])
-  -> FundToStore
+  -> FundToStore IO
   -> Target
   -> WalletScript era
 benchmarkWalletScript wRef txGenerator (NumberOfTxs maxCount) fundSource inOut toUTxO fundToStore targetNode