Consolidate cost computation in a single executable

* Move hashing cost computation out of ContractSpec into `contract-cost` executbale * Move exe to hydra-node because of dependencies
input-output-hk · Jan 18, 2022 · df1a6f4 · df1a6f4
1 parent 90b8e8e
commit df1a6f4
Show file tree

Hide file tree

Showing 5 changed files with 147 additions and 149 deletions.
diff --git a/hydra-node/exe/tx-cost/Main.hs b/hydra-node/exe/tx-cost/Main.hs
@@ -2,35 +2,73 @@
 
 import Hydra.Prelude
 
+import Cardano.Api (NetworkId (Testnet), NetworkMagic (NetworkMagic))
 import qualified Cardano.Ledger.Alonzo as Ledger.Alonzo
 import qualified Cardano.Ledger.Alonzo.Data as Ledger
 import qualified Cardano.Ledger.Alonzo.PParams as Ledger
 import qualified Cardano.Ledger.Alonzo.Scripts as Ledger
 import qualified Cardano.Ledger.Alonzo.TxBody as Ledger.Alonzo
 import qualified Cardano.Ledger.Shelley.API as Ledger
 import qualified Cardano.Ledger.Val as Ledger
-import qualified Data.Map.Strict as Map
+import Control.Exception (ErrorCall)
+import qualified Data.ByteString as BS
+import qualified Data.Map as Map
+import Data.Maybe (fromJust)
 import Data.Maybe.Strict (StrictMaybe (..))
 import Hydra.Chain.Direct.Tx (fanoutTx, plutusScript, policyId, scriptAddr)
+import qualified Hydra.Contract.Hash as Hash
 import qualified Hydra.Contract.Head as Head
 import Hydra.Ledger.Cardano (
+  BuildTxWith (BuildTxWith),
   CardanoTx,
+  ExecutionUnits (..),
   LedgerEra,
+  PlutusScriptV1,
+  TxOut (..),
   Utxo,
+  Utxo' (Utxo),
   adaOnly,
+  addInputs,
+  emptyTxBody,
+  fromAlonzoExUnits,
   fromLedgerTx,
   fromLedgerUtxo,
+  fromPlutusScript,
   genKeyPair,
   genOneUtxoFor,
   hashTxOuts,
+  lovelaceToTxOutValue,
+  mkDatumForTxIn,
+  mkRedeemerForTxIn,
+  mkScriptAddress,
+  mkScriptWitness,
+  mkTxOutDatum,
   simplifyUtxo,
+  toCtxUTxOTxOut,
+  unsafeBuildTransaction,
  )
 import Hydra.Ledger.Cardano.Evaluate (evaluateTx, pparams)
+import Plutus.MerkleTree (rootHash)
+import qualified Plutus.MerkleTree as MT
+import Plutus.MerkleTreeValidator (merkleTreeValidator, mtBuilderValidator)
+import Plutus.Orphans ()
 import Plutus.V1.Ledger.Api (toBuiltin, toData)
+import qualified PlutusTx.Builtins as Plutus
+import Test.Plutus.Validator (
+  ExUnits (ExUnits),
+  defaultMaxExecutionUnits,
+  evaluateScriptExecutionUnits,
+ )
 import Test.QuickCheck (generate, vectorOf)
 
 main :: IO ()
 main = do
+  costOfFanOut
+  costOfMerkleTree
+  costOfHashing
+
+costOfFanOut :: IO ()
+costOfFanOut = do
   putStrLn "Cost of running the fanout validator"
   putStrLn "# UTXO  % max Mem   % max CPU"
   forM_ [1 .. 100] $ \numElems -> do
@@ -43,7 +81,7 @@ main = do
             <> showPad 12 (100 * fromIntegral mem / maxMem)
             <> showPad 12 (100 * fromIntegral cpu / maxCpu)
       _ ->
-        fail $ "Failed to evaluate transaction with " <> show numElems <> " elements."
+        pure ()
  where
   genSomeUtxo = genKeyPair >>= fmap (fmap adaOnly) . genOneUtxoFor . fst
   Ledger.ExUnits (fromIntegral @_ @Double -> maxMem) (fromIntegral @_ @Double -> maxCpu) =
@@ -77,3 +115,103 @@ mkHeadOutput headDatum =
   headAddress = scriptAddr $ plutusScript $ Head.validatorScript policyId
   headValue = Ledger.inject (Ledger.Coin 2_000_000)
   headDatumHash = Ledger.hashData @LedgerEra <$> headDatum
+
+costOfMerkleTree :: IO ()
+costOfMerkleTree = do
+  putStrLn "Cost of on-chain Merkle-Tree"
+  forM_ ([1 .. 10] <> [20, 30 .. 100] <> [120, 140 .. 500]) $ \numElems -> do
+    utxo <- fmap Plutus.toBuiltin <$> genFakeUtxos numElems
+
+    let (memberMem, memberCpu) = executionCostForMember utxo
+        ExUnits (fromIntegral @_ @Double -> maxMem) (fromIntegral @_ @Double -> maxCpu) =
+          defaultMaxExecutionUnits
+        (builderMem, builderCpu) = executionCostForBuilder utxo
+
+    putText $
+      show numElems
+        <> "\t"
+        <> show (100 * fromIntegral (fromIntegral memberMem `div` numElems) / maxMem)
+        <> "\t"
+        <> show (100 * fromIntegral (fromIntegral memberCpu `div` numElems) / maxCpu)
+    putTextLn
+      ( "\t"
+          <> show (100 * fromIntegral builderMem / maxMem)
+          <> "\t"
+          <> show (100 * fromIntegral builderCpu / maxCpu)
+      )
+      `catch` \(_ :: ErrorCall) ->
+        -- NOTE builder validator is likely to fail and thus raise an exception at low values
+        -- of numElems, so we put 0 instead
+        putTextLn "\t0\t0"
+ where
+  -- NOTE: assume size of a UTXO is around  60 bytes
+  genFakeUtxos numElems = generate (vectorOf numElems $ BS.pack <$> vectorOf 60 arbitrary)
+
+executionCostForMember :: [Plutus.BuiltinByteString] -> (Natural, Natural)
+executionCostForMember utxo =
+  let tree = MT.fromList utxo
+      accumulateCost e (curMem, curCpu) =
+        let proof = fromJust $ MT.mkProof e tree
+            ExUnits mem cpu = evaluateScriptExecutionUnits merkleTreeValidator (e, MT.rootHash tree, proof)
+         in (mem + curMem, cpu + curCpu)
+   in foldr accumulateCost (0, 0) utxo
+
+executionCostForBuilder :: [Plutus.BuiltinByteString] -> (Natural, Natural)
+executionCostForBuilder utxo =
+  let tree = MT.fromList utxo
+      root = rootHash tree
+      ExUnits mem cpu = evaluateScriptExecutionUnits mtBuilderValidator (utxo, root)
+   in (mem, cpu)
+
+costOfHashing :: IO ()
+costOfHashing = do
+  putStrLn "Cost of on-chain Hashing"
+  for_ [0 .. 5] $ \(power :: Integer) -> do
+    let n = 8 ^ power
+        s = n `quot` 8
+    putTextLn @IO $ "    n = " <> show n <> ", s = " <> show s
+    for_ [minBound .. maxBound] $ \algorithm ->
+      do
+        let ExecutionUnits
+              { executionSteps = baseCpu
+              , executionMemory = baseMem
+              } = calculateHashExUnits n Hash.Base
+            units@ExecutionUnits
+              { executionSteps = cpu
+              , executionMemory = mem
+              } = calculateHashExUnits n algorithm
+        putTextLn $
+          "      " <> show algorithm
+            <> ": "
+            <> show units
+            <> " Δcpu="
+            <> show (toInteger cpu - toInteger baseCpu)
+            <> " Δmem="
+            <> show (toInteger mem - toInteger baseMem)
+        `catch` \(_ :: ErrorCall) ->
+          -- NOTE: evaluation can fail and raise an error if it blows up limits, simply stop there
+          pure ()
+
+calculateHashExUnits :: Int -> Hash.HashAlgorithm -> ExecutionUnits
+calculateHashExUnits n algorithm =
+  case evaluateTx tx utxo of
+    Left basicFailure ->
+      error ("Basic failure: " <> show basicFailure)
+    Right report ->
+      case Map.elems report of
+        [Right units] ->
+          fromAlonzoExUnits units
+        _ ->
+          error $ "Too many redeemers in report: " <> show report
+ where
+  tx = unsafeBuildTransaction $ emptyTxBody & addInputs [(input, witness)]
+  utxo = Utxo $ Map.singleton input output
+  input = generateWith arbitrary 42
+  output = toCtxUTxOTxOut $ TxOut address value (mkTxOutDatum datum)
+  value = lovelaceToTxOutValue 1_000_000
+  address = mkScriptAddress @PlutusScriptV1 (Testnet $ NetworkMagic 42) script
+  witness = BuildTxWith $ mkScriptWitness script (mkDatumForTxIn datum) redeemer
+  script = fromPlutusScript Hash.validatorScript
+  datum = Hash.datum $ toBuiltin bytes
+  redeemer = mkRedeemerForTxIn $ Hash.redeemer algorithm
+  bytes = fold $ replicate n ("0" :: ByteString)
diff --git a/hydra-node/hydra-node.cabal b/hydra-node/hydra-node.cabal
@@ -193,17 +193,21 @@ executable tx-cost
   build-depends:
     , base
     , bytestring
-    , containers
+    , cardano-api
+    , cardano-binary
+    , cardano-crypto-class
     , cardano-ledger-alonzo
     , cardano-ledger-core
     , cardano-ledger-shelley
     , cardano-ledger-shelley-ma
+    , containers
     , hydra-node
-    , hydra-prelude
     , hydra-plutus
+    , hydra-prelude
     , hydra-test-utils
-    , plutus-tx
     , plutus-ledger-api
+    , plutus-merkle-tree
+    , plutus-tx
     , QuickCheck
     , strict-containers
 

diff --git a/hydra-node/test/Hydra/Chain/Direct/ContractSpec.hs b/hydra-node/test/Hydra/Chain/Direct/ContractSpec.hs
@@ -22,7 +22,6 @@ import qualified Data.ByteString.Base16 as Base16
 import qualified Data.Map as Map
 import Data.Maybe.Strict (StrictMaybe (..))
 import qualified Data.Sequence.Strict as StrictSeq
-import Hydra.Chain.Direct.Fixture (testNetworkId)
 import qualified Hydra.Chain.Direct.Fixture as Fixture
 import Hydra.Chain.Direct.Tx (
   closeTx,
@@ -34,7 +33,6 @@ import Hydra.Chain.Direct.Tx (
 import Hydra.Chain.Direct.TxSpec (mkHeadOutput)
 import qualified Hydra.Contract.Commit as Commit
 import Hydra.Contract.Encoding (serialiseTxOuts)
-import qualified Hydra.Contract.Hash as Hash
 import Hydra.Contract.Head (
   verifyPartySignature,
   verifySnapshotSignature,
@@ -45,25 +43,18 @@ import qualified Hydra.Data.Party as OnChain
 import qualified Hydra.Data.Party as Party
 import Hydra.Ledger.Cardano (
   AlonzoEra,
-  BuildTxWith (BuildTxWith),
   CardanoTx,
   CtxTx,
   CtxUTxO,
   Era,
-  ExecutionUnits (ExecutionUnits),
   LedgerEra,
-  PlutusScriptV1,
   Tx (Tx),
   TxBodyScriptData (TxBodyNoScriptData, TxBodyScriptData),
   TxIn,
   TxOut (..),
   Utxo,
-  Utxo' (Utxo),
   adaOnly,
-  addInputs,
   describeCardanoTx,
-  emptyTxBody,
-  fromAlonzoExUnits,
   fromLedgerTx,
   fromLedgerTxOut,
   fromLedgerUtxo,
@@ -159,54 +150,6 @@ spec = do
     prop "does not survive random adversarial mutations" $
       propMutation healthyFanoutTx genFanoutMutation
 
-  describe "Hash" $
-    it "runs with these ^ execution units over Baseline" $ do
-      for_ [0 .. 5] $ \(power :: Integer) -> do
-        let n = 8 ^ power
-            s = n `quot` 8
-        putTextLn @IO $ "    n = " <> show n <> ", s = " <> show s
-        for_ [minBound .. maxBound] $ \algorithm -> do
-          let ExecutionUnits
-                { executionSteps = baseCpu
-                , executionMemory = baseMem
-                } = calculateHashExUnits n Hash.Base
-              units@ExecutionUnits
-                { executionSteps = cpu
-                , executionMemory = mem
-                } = calculateHashExUnits n algorithm
-          putTextLn $
-            "      " <> show algorithm
-              <> ": "
-              <> show units
-              <> " Δcpu="
-              <> show (toInteger cpu - toInteger baseCpu)
-              <> " Δmem="
-              <> show (toInteger mem - toInteger baseMem)
-
-calculateHashExUnits :: Int -> Hash.HashAlgorithm -> ExecutionUnits
-calculateHashExUnits n algorithm =
-  case evaluateTx tx utxo of
-    Left basicFailure ->
-      error ("Basic failure: " <> show basicFailure)
-    Right report ->
-      case Map.elems report of
-        [Right units] ->
-          fromAlonzoExUnits units
-        _ ->
-          error $ "Too many redeemers in report: " <> show report
- where
-  tx = unsafeBuildTransaction $ emptyTxBody & addInputs [(input, witness)]
-  utxo = Utxo $ Map.singleton input output
-  input = generateWith arbitrary 42
-  output = toCtxUTxOTxOut $ TxOut address value (mkTxOutDatum datum)
-  value = lovelaceToTxOutValue 1_000_000
-  address = mkScriptAddress @PlutusScriptV1 testNetworkId script
-  witness = BuildTxWith $ mkScriptWitness script (mkDatumForTxIn datum) redeemer
-  script = fromPlutusScript Hash.validatorScript
-  datum = Hash.datum $ toBuiltin bytes
-  redeemer = mkRedeemerForTxIn $ Hash.redeemer algorithm
-  bytes = fold $ replicate n ("0" :: ByteString)
-
 --
 -- Properties
 --

diff --git a/plutus-merkle-tree/exe/contract-cost/Main.hs b/plutus-merkle-tree/exe/contract-cost/Main.hs