[wip] Generating more transactions for benchmark

hydra-node/hydra-node.cabal

@@ -132,6 +132,7 @@ library
     , plutus-ledger
     , plutus-pab
     , prometheus
+    , QuickCheck
     , req
     , shelley-spec-ledger
     , shelley-spec-ledger-test

hydra-node/src/Hydra/Ledger/Simple.hs

@@ -10,13 +10,15 @@
 module Hydra.Ledger.Simple where
 
 import Hydra.Prelude
+import Test.QuickCheck (Gen, choose, sublistOf)
 
 import Data.Aeson (
   object,
   withObject,
   (.:),
   (.=),
  )
+import Data.List (maximum)
 import qualified Data.Set as Set
 import Hydra.Ledger
 
@@ -88,3 +90,27 @@ simpleLedger =
             else Left ValidationError
     , initUTxO = mempty
     }
+
+-- * Generators
+
+listOfCommittedUtxos :: Integer -> Gen [UTxO SimpleTx]
+listOfCommittedUtxos numCommits =
+  pure $ Set.singleton . TxIn <$> [1 .. numCommits]
+
+genSequenceOfValidTransactions :: UTxO SimpleTx -> Gen [SimpleTx]
+genSequenceOfValidTransactions initialUtxo = do
+  let maxId = if Set.null initialUtxo then 0 else unTxIn (maximum initialUtxo)
+  numTxs <- choose (1, 10)
+  foldlM newTx (maxId, initialUtxo, mempty) [1 .. numTxs] >>= \(_, _, txs) -> pure (reverse txs)
+ where
+  newTx :: (Integer, UTxO SimpleTx, [SimpleTx]) -> Integer -> Gen (Integer, UTxO SimpleTx, [SimpleTx])
+  newTx (maxId, utxo, txs) txid = do
+    (newMax, ins, outs) <- genInputsAndOutputs maxId utxo
+    pure (newMax, (utxo Set.\\ ins) `Set.union` outs, SimpleTx txid ins outs : txs)
+
+  genInputsAndOutputs :: Integer -> Set TxIn -> Gen (Integer, Set TxIn, Set TxIn)
+  genInputsAndOutputs maxId utxo = do
+    ins <- sublistOf (Set.toList utxo)
+    numOuts <- choose (1, 10)
+    let outs = fmap (+ maxId) [1 .. numOuts]
+    pure (maximum outs, Set.fromList ins, Set.fromList $ fmap TxIn outs)

hydra-node/test/Hydra/Ledger/SimpleSpec.hs

@@ -17,30 +17,8 @@ spec = describe "Simple Ledger" $ do
 
 prop_validateCorrectTransactions :: Property
 prop_validateCorrectTransactions =
-  forAllShrink (sequenceOfValidTransactions mempty) shrinkSequence $ \txs ->
+  forAllShrink (genSequenceOfValidTransactions mempty) shrinkSequence $ \txs ->
     isRight (applyTransactions simpleLedger mempty txs)
 
 shrinkSequence :: [SimpleTx] -> [[SimpleTx]]
 shrinkSequence = shrinkList (const [])
-
-listOfCommittedUtxos :: Integer -> Gen [UTxO SimpleTx]
-listOfCommittedUtxos numCommits =
-  pure $ Set.singleton . TxIn <$> [1 .. numCommits]
-
-sequenceOfValidTransactions :: UTxO SimpleTx -> Gen [SimpleTx]
-sequenceOfValidTransactions initialUtxo = do
-  let maxId = if Set.null initialUtxo then 0 else unTxIn (maximum initialUtxo)
-  numTxs <- choose (1, 10)
-  foldlM newTx (maxId, initialUtxo, mempty) [1 .. numTxs] >>= \(_, _, txs) -> pure (reverse txs)
-
-newTx :: (Integer, UTxO SimpleTx, [SimpleTx]) -> Integer -> Gen (Integer, UTxO SimpleTx, [SimpleTx])
-newTx (maxId, utxo, txs) txid = do
-  (newMax, ins, outs) <- genInputsAndOutputs maxId utxo
-  pure (newMax, (utxo Set.\\ ins) `Set.union` outs, SimpleTx txid ins outs : txs)
-
-genInputsAndOutputs :: Integer -> Set TxIn -> Gen (Integer, Set TxIn, Set TxIn)
-genInputsAndOutputs maxId utxo = do
-  ins <- sublistOf (Set.toList utxo)
-  numOuts <- choose (1, 10)
-  let outs = fmap (+ maxId) [1 .. numOuts]
-  pure (maximum outs, Set.fromList ins, Set.fromList $ fmap TxIn outs)

local-cluster/bench/Bench/EndToEnd.hs

@@ -22,7 +22,7 @@ import Data.Aeson.Lens (key, _Array, _Number)
 import Data.ByteString.Lazy (hPut)
 import qualified Data.Map as Map
 import Data.Scientific (floatingOrInteger)
-import Hydra.Ledger (TxId)
+import Hydra.Ledger (Tx, TxId)
 import Hydra.Ledger.Simple (SimpleTx)
 import HydraNode (
   HydraClient,
@@ -73,14 +73,18 @@ bench = do
 
             waitFor 3 [n1, n2, n3] $ output "headIsOpen" ["utxo" .= [int 1, 2, 3]]
 
-            let txId = 42
-            tx <- newTx registry n1 txId [1] [4]
+            let initialUtxo = [1, 2, 3]
 
-            txs <- waitMatch n1 $ \v -> do
-              guard (v ^? key "output" == Just "snapshotConfirmed")
-              v ^? key "snapshot" . key "confirmedTransactions" . _Array
+            txs <- genSequenceOfValidTransactions initialUtxo
 
-            mapM_ (confirmTx registry) txs
+            for_ txs $ \tx -> do
+              tx <- newTx registry n1 tx
+
+              txs <- waitMatch n1 $ \v -> do
+                guard (v ^? key "output" == Just "snapshotConfirmed")
+                v ^? key "snapshot" . key "confirmedTransactions" . _Array
+
+              mapM_ (confirmTx registry) txs
 
             send n1 $ input "getUtxo" []
             waitFor 10 [n1] $ output "utxo" ["utxo" .= [int 2, 3, 4]]
@@ -113,13 +117,12 @@ type TransactionInput = Int
 type TransactionOutput = Int
 
 newTx ::
-  TVar IO (Map.Map (TxId SimpleTx) Event) ->
+  Tx tx =>
+  TVar IO (Map.Map (TxId tx) Event) ->
   HydraClient ->
-  TransactionId ->
-  [TransactionInput] ->
-  [TransactionOutput] ->
-  IO Value
-newTx registry client txId inputs outputs = do
+  tx ->
+  IO ()
+newTx registry client tx = do
   now <- getCurrentTime
   atomically $
     modifyTVar registry $
@@ -128,9 +131,7 @@ newTx registry client txId inputs outputs = do
           { submittedAt = now
           , confirmedAt = Nothing
           }
-  let tx = object ["id" .= txId, "inputs" .= inputs, "outputs" .= outputs]
   send client $ input "newTransaction" ["transaction" .= tx]
-  pure tx
 
 confirmTx ::
   TVar IO (Map.Map (TxId SimpleTx) Event) ->