Merge #4292

4292: tx-generator cleanups r=MarcFontaine a=MarcFontaine

* Replace `IO` with `Monad m => m` in some types.
* reintroduce `ToUTxOList`.
* Remove legacy tx-set based `FundSet`. (Use `type FundSet = [ Fund ]` for now.)

Co-authored-by: MarcFontaine <[email protected]>

Author: iohk-bors[bot]

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 "collaeral_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
+      collateralWallet <- newWallet "collateral_wallet"
+      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

@@ -0,0 +1,32 @@
+module Cardano.Benchmarking.Fifo
+where
+import           Prelude
+
+-- This is to be used single threaded behind an MVar.
+
+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
+
+insert :: Fifo a -> a -> Fifo a
+insert (Fifo x y) e = Fifo x $ e:y
+
+remove :: Fifo a -> Maybe (Fifo a, a)
+remove fifo = case fifo of
+  Fifo [] [] -> Nothing
+  Fifo (h:t) y -> Just (Fifo t y, h)
+  Fifo [] y -> case reverse y of
+    (h:t) -> Just (Fifo t [], h)
+    [] -> error "unreachable"
+
+removeN :: Int -> Fifo a -> Maybe (Fifo a, [a])
+removeN 0 f = return (f, [])
+removeN n f = do
+  (a, h) <- remove f
+  (r, t) <- removeN (pred n) a
+  return (r, h:t)

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

@@ -2,7 +2,6 @@
 {-# Language DataKinds #-}
 {-# Language FlexibleInstances #-}
 {-# Language GADTs #-}
-{-# Language GeneralizedNewtypeDeriving #-}
 {-# Language MultiParamTypeClasses #-}
 {-# Language RankNTypes #-}
 {-# Language TypeApplications #-}
@@ -12,12 +11,10 @@ module Cardano.Benchmarking.FundSet
 where
 import           Prelude
 
-import           Data.IxSet.Typed as IxSet
-import           Data.Proxy
-
-import           Control.Applicative ((<|>))
 import           Cardano.Api as Api
 
+import Cardano.Benchmarking.Fifo as Fifo
+
 -- Outputs that are available for spending.
 -- When building a new TX they provide the TxIn parts.
 
@@ -26,50 +23,27 @@ data FundInEra era = FundInEra {
   , _fundWitness :: Witness WitCtxTxIn era
   , _fundVal  :: !(TxOutValue era)
   , _fundSigningKey :: !(Maybe (SigningKey PaymentKey))
-  , _fundVariant :: !Variant
-  , _fundValidity :: !Validity
   } deriving (Show)
 
-data Variant
-  = PlainOldFund
-  -- maybe better use the script itself instead of the filePath
-  | PlutusScriptFund
-  -- A collateralFund is just a regular (PlainOldFund) on the chain,
-  -- but tagged in the wallet so that it is not selected for spending.
-  | CollateralFund
-  deriving  (Show, Eq, Ord)
-
-data Validity
-  = Confirmed
-  | InFlight !Target !SeqNumber
-  deriving  (Show, Eq, Ord)
-
-newtype Target = Target String
-  deriving  (Show, Eq, Ord)
-
-newtype SeqNumber = SeqNumber Int
-  deriving  (Show, Eq, Ord, Enum)
-
 newtype Fund = Fund {unFund :: InAnyCardanoEra FundInEra}
 
-getFundVariant :: Fund -> Variant
-getFundVariant (Fund (InAnyCardanoEra _ a)) = _fundVariant a
+type FundSet = Fifo Fund
+
+type FundSource m = m (Either String [Fund])
+type FundToStore m = Fund -> m ()
+type FundToStoreList m = [Fund] -> m ()
 
 getFundTxIn :: Fund -> TxIn
 getFundTxIn (Fund (InAnyCardanoEra _ a)) = _fundTxIn a
 
 getFundKey :: Fund -> Maybe (SigningKey PaymentKey)
 getFundKey (Fund (InAnyCardanoEra _ a)) = _fundSigningKey a
 
-getFundValidity :: Fund -> Validity
-getFundValidity (Fund (InAnyCardanoEra _ a)) = _fundValidity a
-
 getFundLovelace :: Fund -> Lovelace
 getFundLovelace (Fund (InAnyCardanoEra _ a)) = case _fundVal a of
   TxOutAdaOnly _era l -> l
   TxOutValue _era v -> selectLovelace v
 
-
 -- This effectively rules out era-transitions for transactions !
 -- This is not what we want !!
 getFundWitness :: forall era. IsShelleyBasedEra era => Fund -> Witness WitCtxTxIn era
@@ -85,14 +59,6 @@ getFundWitness fund = case (cardanoEra @ era, fund) of
 -- It should be possible to cast KeyWitnesses from one era to an other !
   (_ , _) -> error "getFundWitness: era mismatch"
 
-data IsConfirmed = IsConfirmed | IsNotConfirmed
-  deriving  (Show, Eq, Ord)
-
-isConfirmed :: Fund -> IsConfirmed
-isConfirmed f = case getFundValidity f of
-  Confirmed -> IsConfirmed
-  InFlight _ _ -> IsNotConfirmed
-
 instance Show Fund where
   show (Fund (InAnyCardanoEra _ f)) = show f
 
@@ -105,32 +71,11 @@ instance Eq Fund where
 instance Ord Fund where
   compare a b = compare (getFundTxIn a) (getFundTxIn b)
 
-type FundIndices = '[ TxIn, IsConfirmed, Target, SeqNumber, Lovelace, Variant ]
-type FundSet = IxSet FundIndices Fund
-
-instance Indexable FundIndices Fund where
-  indices = ixList
-    (ixFun $ \f -> [ getFundTxIn f ])
-    (ixFun $ \f -> [ isConfirmed f ])
-    (ixFun $ \f -> case getFundValidity f of
-      Confirmed -> []
-      InFlight t _ -> [t]
-    )
-    (ixFun $ \f -> case getFundValidity f of
-      Confirmed -> [SeqNumber (-1) ] -- Confirmed Txs get SeqNumber -1
-      InFlight _ n -> [ n ]
-    )
-    (ixFun $ \f -> [ getFundLovelace f ])
-    (ixFun $ \f -> [ getFundVariant f ])
-
-emptyFunds :: FundSet
-emptyFunds = IxSet.empty
+emptyFundSet :: FundSet
+emptyFundSet = Fifo.emptyFifo
 
 insertFund :: FundSet -> Fund -> FundSet
-insertFund s f = updateIx (getFundTxIn f) f s
-
-deleteFund :: FundSet -> Fund -> FundSet
-deleteFund s f = deleteIx (getFundTxIn f) s
+insertFund = Fifo.insert
 
 liftAnyEra :: ( forall era. IsCardanoEra era => f1 era -> f2 era ) -> InAnyCardanoEra f1 -> InAnyCardanoEra f2
 liftAnyEra f x = case x of
@@ -141,126 +86,6 @@ liftAnyEra f x = case x of
   InAnyCardanoEra AlonzoEra a  ->   InAnyCardanoEra AlonzoEra $ f a
   InAnyCardanoEra BabbageEra a  ->  InAnyCardanoEra BabbageEra $ f a  
 
-type FundSelector = FundSet -> Either String [Fund]
-type FundSource = IO (Either String [Fund])
-type FundToStore = [Fund] -> IO ()
-
--- Select Funds to cover a minimum value.
--- TODO:
--- This fails unless there is a single fund with the required value
--- Extend this to really return a list of funds.
-selectMinValue :: Lovelace -> FundSet -> Either String [Fund]
-selectMinValue minValue fs = case coins of
-    [] -> Left $ "findSufficientCoin: no single coin with min value >= " ++ show minValue
-    (c:_) -> Right [c]
-    where coins = toAscList ( Proxy :: Proxy Lovelace) (fs @=PlainOldFund @= IsConfirmed @>= minValue)
-
-selectCollateral :: FundSet -> Either String [Fund]
-selectCollateral fs = case coins of
-  [] -> Left "no matching none-Plutus fund found"
-  (c:_) -> Right [c]
- where
-  coins = toAscList ( Proxy :: Proxy Lovelace) (fs @=CollateralFund @= IsConfirmed )
-
-data AllowRecycle
-  = UseConfirmedOnly
-  | ReuseSameTarget
--- ReuseAny can cause none-deterministic runtime errors !
--- The problematic case is the reuse of an UTxO/Tx that is not yet confirmed
--- and still waits in the mempool of an other target-node.
-  | ReuseAny
-  | ConfirmedBeforeReuse -- useful for testing
-  deriving (Eq, Ord, Enum, Show)
-
--- There are many possible heuristics to implement the selectInputs function.
--- TODO: Check that the complexity of selectInputs is good enough.
-selectInputs ::
-     AllowRecycle
-  -> Int
-  -> Lovelace
-  -> Variant
-  -> Target
-  -> FundSet
-  -> Either String [Fund]
-selectInputs allowRecycle count minTotalValue variant targetNode fs
-  = case allowRecycle of
-    UseConfirmedOnly     -> selectConfirmed
-    ReuseSameTarget      -> reuseSameTarget <|> selectConfirmed
-    ReuseAny             -> reuseSameTarget <|> selectConfirmed <|> reuseAnyCoin
-    ConfirmedBeforeReuse -> selectConfirmed <|> reuseSameTarget
-  where
-  selectConfirmed = selectConfirmedSmallValue <|> selectConfirmedBigValue
-
-  isSufficientCoins coins = length coins == count && sum (map getFundLovelace coins) >= minTotalValue
-
-  checkCoins :: String -> [Fund] -> Either String [Fund]
-  checkCoins err coins
-    = if isSufficientCoins coins then Right coins else Left err
-
-  -- Share intermediate results for variantIxSet confirmedIxSet and targetIxSet
-  -- TODO: it unclear if this helps on the complexity or it it is even harmful.
-  variantIxSet   = fs @= variant
-  confirmedIxSet = variantIxSet @= IsConfirmed
-  targetIxSet    = variantIxSet @= targetNode
-
-  confirmedBigValueList = toDescList (Proxy :: Proxy Lovelace) confirmedIxSet
-  sameTargetList = toAscList (Proxy :: Proxy SeqNumber) targetIxSet
-
-  selectConfirmedSmallValue
-    = checkCoins
-        "selectConfirmedSmall: not enough coins available"
-        (take count $ toAscList (Proxy :: Proxy Lovelace) confirmedIxSet)
-
-  selectConfirmedBigValue
-    = checkCoins
-        "selectConfirmedSmall: not enough coins available"
-        (take count confirmedBigValueList)
-
-  -- reuseSameTargetStrict is problematic: It fails if the coins in the queues are too small. But it will never consume the small coins.
-  -- therefore: (reuseSameTargetStrict <|> reuseSameTargetWithBackup)
-  reuseSameTargetStrict
-    = checkCoins
-        "reuseSameTargetStrict: not enough coins available"
-        (take count sameTargetList)
-
-  -- reuseSameTargetWithBackup can collect some dust.
-  -- reuseSameTargetWithBackup works fine if there is at least one sufficient confirmed UTxO available.
-  reuseSameTargetWithBackup = checkCoins "reuseSameTargetWithBackup: not enough coins available" (backupCoin ++ targetCoins)
-    where
-      -- targetCoins and backupCoins must be disjoint.
-      -- This is case because IsConfirmed \= InFlight target.
-      backupCoin = take 1 $ toAscList (Proxy :: Proxy Lovelace) (confirmedIxSet @> minTotalValue)
-      targetCoins = take (count - 1) sameTargetList
-
-  reuseSameTarget = reuseSameTargetStrict <|> reuseSameTargetWithBackup
-
-  -- reuseAnyCoin is the last resort !
-  reuseAnyCoin
-    = checkCoins
-        "reuseAnyTarget: not enough coins available"
-        (take count $ confirmedBigValueList ++ inFlightCoins)
-    where
-      -- inFlightCoins and confirmedCoins are disjoint
-      inFlightCoins = toAscList (Proxy :: Proxy SeqNumber) (variantIxSet @=IsNotConfirmed)
-
-selectToBuffer ::
-     Int
-  -> Lovelace
-  -> Maybe Variant
-  -> FundSet
-  -> Either String [Fund]
-selectToBuffer count minValue variant fs
-  = if length coins < count
-    then Left $ concat
-      [ "selectToBuffer: not enough coins found: count: ", show count
-      , " minValue: ", show minValue
-      , " variant: ", show variant
-      ]
-    else Right coins
- where
-  coins = case variant of
-    Just v -> take count $ toAscList ( Proxy :: Proxy Lovelace) (fs @=v @= IsConfirmed @>= minValue)
-    Nothing -> take count $ toAscList ( Proxy :: Proxy Lovelace) (fs @= IsConfirmed @>= minValue)
 -- Todo: check sufficient funds and minimumValuePerUtxo
 inputsToOutputsWithFee :: Lovelace -> Int -> [Lovelace] -> [Lovelace]
 inputsToOutputsWithFee fee count inputs = map (quantityToLovelace . Quantity) outputs

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

@@ -39,7 +39,6 @@ import           Ouroboros.Consensus.Shelley.Eras (StandardShelley)
 
 import           Cardano.Api hiding (txFee)
 
-import qualified Cardano.Benchmarking.FundSet as FundSet
 import           Cardano.Benchmarking.GeneratorTx.Error
 import           Cardano.Benchmarking.GeneratorTx.Genesis
 import           Cardano.Benchmarking.GeneratorTx.NodeToNode
@@ -152,7 +151,7 @@ walletBenchmark :: forall era. IsShelleyBasedEra era
   -> SubmissionErrorPolicy
   -> AsType era
   -> NumberOfTxs
-  -> (FundSet.Target -> WalletScript era)
+  -> WalletScript era
   -> ExceptT TxGenError IO AsyncBenchmarkControl
 walletBenchmark
   traceSubmit
@@ -184,7 +183,7 @@ walletBenchmark
           client = txSubmissionClient
                      traceN2N
                      traceSubmit
-                     (walletTxSource (walletScript (FundSet.Target $ show remoteAddr)) tpsThrottle)
+                     (walletTxSource walletScript tpsThrottle)
                      (submitSubmissionThreadStats reportRef)
       async $ handle errorHandler (connectClient remoteAddr client)