Add CloseTx cost benchmark to tx-cost and similar test suites

hydra-node/exe/tx-cost/Main.hs

@@ -26,6 +26,7 @@ import System.FilePath ((</>))
 import System.IO.Unsafe (unsafePerformIO)
 import TxCost (
   computeAbortCost,
+  computeCloseCost,
   computeCollectComCost,
   computeCommitCost,
   computeFanOutCost,
@@ -78,11 +79,26 @@ writeTransactionCostMarkdown hdl = do
   initC <- costOfInit
   commitC <- costOfCommit
   collectComC <- costOfCollectCom
+  closeC <- costOfClose
   abortC <- costOfAbort
   fanout <- costOfFanOut
   mt <- costOfMerkleTree
   let h = costOfHashing
-  hPut hdl $ encodeUtf8 $ unlines $ pageHeader <> intersperse "" [initC, commitC, collectComC, abortC, fanout, mt, h]
+  hPut hdl $
+    encodeUtf8 $
+      unlines $
+        pageHeader
+          <> intersperse
+            ""
+            [ initC
+            , commitC
+            , collectComC
+            , closeC
+            , abortC
+            , fanout
+            , mt
+            , h
+            ]
 
 pageHeader :: [Text]
 pageHeader =
@@ -173,6 +189,29 @@ costOfCollectCom = markdownCollectComCost <$> computeCollectComCost
           )
           stats
 
+costOfClose :: IO Text
+costOfClose = markdownClose <$> computeCloseCost
+ where
+  markdownClose stats =
+    unlines $
+      [ "## Cost of Close Transaction"
+      , ""
+      , "| # Parties | Tx. size | % max Mem |   % max CPU |"
+      , "| :-------- | -------: | --------: | ----------: |"
+      ]
+        <> fmap
+          ( \(numParties, txSize, mem, cpu) ->
+              "| " <> show numParties
+                <> "| "
+                <> show txSize
+                <> " | "
+                <> show (100 * fromIntegral mem / maxMem)
+                <> " | "
+                <> show (100 * fromIntegral cpu / maxCpu)
+                <> " |"
+          )
+          stats
+
 costOfAbort :: IO Text
 costOfAbort = markdownAbortCost <$> computeAbortCost
  where

hydra-node/exe/tx-cost/TxCost.hs

@@ -55,13 +55,20 @@ import Hydra.Chain.Direct.Context (
   HydraContext (ctxVerificationKeys),
   ctxHeadParameters,
   executeCommits,
+  genCloseTx,
+  genCollectComTx,
   genCommits,
   genHydraContextFor,
   genInitTx,
   genStIdle,
   genStInitialized,
  )
-import Hydra.Chain.Direct.State (abort, collect, commit, getKnownUTxO, initialize)
+import Hydra.Chain.Direct.State (
+  abort,
+  commit,
+  getKnownUTxO,
+  initialize,
+ )
 import Hydra.Chain.Direct.Tx (fanoutTx)
 import qualified Hydra.Contract.Hash as Hash
 import qualified Hydra.Contract.Head as Head
@@ -180,25 +187,35 @@ computeCollectComCost =
     <$> forM
       [1 .. 100]
       ( \numParties -> do
-          (tx, knownUtxo) <- generate $ genCollectComTx numParties
+          (st, tx) <- generate $ genCollectComTx numParties
+          let utxo = getKnownUTxO st
           let txSize = LBS.length $ serialize tx
           if txSize < fromIntegral (Ledger._maxTxSize pparams)
-            then case evaluateTx tx knownUtxo of
+            then case evaluateTx tx utxo of
+              (Right (mconcat . rights . Map.elems -> (Ledger.ExUnits mem cpu)))
+                | fromIntegral mem <= maxMem && fromIntegral cpu <= maxCpu ->
+                  pure $ Just (NumParties numParties, TxSize txSize, MemUnit mem, CpuUnit cpu)
+              _ -> pure Nothing
+            else pure Nothing
+      )
+
+computeCloseCost :: IO [(NumParties, TxSize, MemUnit, CpuUnit)]
+computeCloseCost =
+  catMaybes
+    <$> forM
+      [1 .. 100]
+      ( \numParties -> do
+          (st, tx) <- generate $ genCloseTx numParties
+          let utxo = getKnownUTxO st
+          let txSize = LBS.length $ serialize tx
+          if txSize < fromIntegral (Ledger._maxTxSize pparams)
+            then case evaluateTx tx utxo of
               (Right (mconcat . rights . Map.elems -> (Ledger.ExUnits mem cpu)))
                 | fromIntegral mem <= maxMem && fromIntegral cpu <= maxCpu ->
                   pure $ Just (NumParties numParties, TxSize txSize, MemUnit mem, CpuUnit cpu)
               _ -> pure Nothing
             else pure Nothing
       )
- where
-  genCollectComTx numParties = do
-    genHydraContextFor numParties
-      >>= \ctx ->
-        genInitTx ctx >>= \initTx ->
-          genCommits ctx initTx >>= \commits ->
-            genStIdle ctx >>= \stIdle ->
-              let stInitialized = executeCommits initTx commits stIdle
-               in pure (collect stInitialized, getKnownUTxO stInitialized)
 
 computeAbortCost :: IO [(NumParties, TxSize, MemUnit, CpuUnit)]
 computeAbortCost =

hydra-node/src/Hydra/Chain/Direct/Context.hs

@@ -18,13 +18,17 @@ import Hydra.Chain.Direct.State (
   HeadStateKind (..),
   ObserveTx,
   OnChainHeadState,
+  close,
+  collect,
   commit,
   idleOnChainHeadState,
   initialize,
   observeTx,
  )
 import Hydra.Ledger.Cardano (genOneUTxOFor, genTxIn, genVerificationKey, renderTx)
 import Hydra.Party (Party)
+import qualified Hydra.Party as Hydra
+import Hydra.Snapshot (genConfirmedSnapshot)
 import Test.QuickCheck (choose, elements, frequency, vector)
 
 -- | Define some 'global' context from which generators can pick
@@ -36,17 +40,20 @@ import Test.QuickCheck (choose, elements, frequency, vector)
 -- be coherent.
 data HydraContext = HydraContext
   { ctxVerificationKeys :: [VerificationKey PaymentKey]
-  , ctxParties :: [Party]
+  , ctxHydraSigningKeys :: [Hydra.SigningKey]
   , ctxNetworkId :: NetworkId
   , ctxContestationPeriod :: DiffTime
   }
   deriving (Show)
 
+ctxParties :: HydraContext -> [Party]
+ctxParties = fmap Hydra.deriveParty . ctxHydraSigningKeys
+
 ctxHeadParameters ::
   HydraContext ->
   HeadParameters
-ctxHeadParameters HydraContext{ctxContestationPeriod, ctxParties} =
-  HeadParameters ctxContestationPeriod ctxParties
+ctxHeadParameters ctx@HydraContext{ctxContestationPeriod} =
+  HeadParameters ctxContestationPeriod (ctxParties ctx)
 
 --
 -- Generators
@@ -62,22 +69,22 @@ genHydraContext maxParties = choose (1, maxParties) >>= genHydraContextFor
 genHydraContextFor :: Int -> Gen HydraContext
 genHydraContextFor n = do
   ctxVerificationKeys <- replicateM n genVerificationKey
-  ctxParties <- vector n
+  ctxHydraSigningKeys <- fmap Hydra.generateKey <$> vector n
   ctxNetworkId <- Testnet . NetworkMagic <$> arbitrary
   ctxContestationPeriod <- arbitrary
   pure $
     HydraContext
       { ctxVerificationKeys
-      , ctxParties
+      , ctxHydraSigningKeys
       , ctxNetworkId
       , ctxContestationPeriod
       }
 
 genStIdle ::
   HydraContext ->
   Gen (OnChainHeadState 'StIdle)
-genStIdle HydraContext{ctxVerificationKeys, ctxNetworkId, ctxParties} = do
-  ownParty <- elements ctxParties
+genStIdle ctx@HydraContext{ctxVerificationKeys, ctxNetworkId} = do
+  ownParty <- elements (ctxParties ctx)
   ownVerificationKey <- elements ctxVerificationKeys
   let peerVerificationKeys = ctxVerificationKeys \\ [ownVerificationKey]
   pure $ idleOnChainHeadState ctxNetworkId peerVerificationKeys ownVerificationKey ownParty
@@ -118,6 +125,32 @@ genCommit =
     , (10, genVerificationKey >>= genOneUTxOFor)
     ]
 
+genCollectComTx :: Int -> Gen (OnChainHeadState 'StInitialized, Tx)
+genCollectComTx numParties = do
+  ctx <- genHydraContextFor numParties
+  initTx <- genInitTx ctx
+  commits <- genCommits ctx initTx
+  stIdle <- genStIdle ctx
+  let stInitialized = executeCommits initTx commits stIdle
+  pure (stInitialized, collect stInitialized)
+
+genCloseTx :: Int -> Gen (OnChainHeadState 'StOpen, Tx)
+genCloseTx numParties = do
+  ctx <- genHydraContextFor numParties
+  stOpen <- genStOpen ctx
+  snapshot <- genConfirmedSnapshot (ctxHydraSigningKeys ctx)
+  pure (stOpen, close snapshot stOpen)
+
+genStOpen ::
+  HydraContext ->
+  Gen (OnChainHeadState 'StOpen)
+genStOpen ctx = do
+  initTx <- genInitTx ctx
+  commits <- genCommits ctx initTx
+  stInitialized <- executeCommits initTx commits <$> genStIdle ctx
+  let collectComTx = collect stInitialized
+  pure $ snd $ unsafeObserveTx @_ @ 'StOpen collectComTx stInitialized
+
 --
 -- Here be dragons
 --

hydra-node/src/Hydra/Snapshot.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module Hydra.Snapshot where
@@ -10,6 +9,8 @@ import Cardano.Crypto.Util (SignableRepresentation (..))
 import Data.Aeson (object, withObject, (.:), (.=))
 import Hydra.Ledger (IsTx (..))
 import Hydra.Party (MultiSigned)
+import qualified Hydra.Party as Hydra
+import Test.QuickCheck (frequency)
 
 type SnapshotNumber = Natural
 
@@ -105,4 +106,29 @@ isInitialSnapshot = \case
   ConfirmedSnapshot{} -> False
 
 instance (Arbitrary tx, Arbitrary (UTxOType tx)) => Arbitrary (ConfirmedSnapshot tx) where
-  arbitrary = genericArbitrary
+  arbitrary = do
+    ks <- fmap Hydra.generateKey <$> arbitrary
+    genConfirmedSnapshot ks
+
+genConfirmedSnapshot ::
+  (Arbitrary tx, Arbitrary (UTxOType tx)) =>
+  [Hydra.SigningKey] ->
+  Gen (ConfirmedSnapshot tx)
+genConfirmedSnapshot sks =
+  frequency
+    [ (1, initialSnapshot)
+    , (9, confirmedSnapshot)
+    ]
+ where
+  initialSnapshot = do
+    s <- arbitrary
+    -- FIXME: The fact that we need to set a constant 0 here is a code smell.
+    -- Initial snapshots with a different snapshot number are not valid and we
+    -- should model 'InitialSnapshot' differently, i.e not holding a
+    -- SnapshotNumber
+    pure InitialSnapshot{snapshot = s{number = 0}}
+
+  confirmedSnapshot = do
+    snapshot <- arbitrary
+    let signatures = Hydra.aggregate $ fmap (`Hydra.sign` snapshot) sks
+    pure $ ConfirmedSnapshot{snapshot, signatures}