diff --git a/hydra-node/exe/tx-cost/Main.hs b/hydra-node/exe/tx-cost/Main.hs index d05c0a494c6..852b6e6b692 100644 --- a/hydra-node/exe/tx-cost/Main.hs +++ b/hydra-node/exe/tx-cost/Main.hs @@ -2,6 +2,7 @@ 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 @@ -9,28 +10,65 @@ 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 index 206128aaaf9..11afa103443 100644 --- 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 index 44e6abf7ba3..8b4983afeb2 100644 --- 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 deleted file mode 100644 index 2bbc3302960..00000000000 --- a/plutus-merkle-tree/exe/contract-cost/Main.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-type-defaults #-} - -import Hydra.Prelude - -import Control.Exception (ErrorCall) -import qualified Data.ByteString as BS -import Data.Maybe (fromJust) -import Plutus.MerkleTree (rootHash) -import qualified Plutus.MerkleTree as MT -import Plutus.MerkleTreeValidator (merkleTreeValidator, mtBuilderValidator) -import qualified PlutusTx.Builtins as Plutus -import Test.Plutus.Validator ( - ExUnits (ExUnits), - defaultMaxExecutionUnits, - evaluateScriptExecutionUnits, - ) -import Test.QuickCheck (generate, vectorOf) - -main :: IO () -main = - 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) diff --git a/plutus-merkle-tree/plutus-merkle-tree.cabal b/plutus-merkle-tree/plutus-merkle-tree.cabal index 93122683511..f12dfbd980a 100644 --- a/plutus-merkle-tree/plutus-merkle-tree.cabal +++ b/plutus-merkle-tree/plutus-merkle-tree.cabal @@ -117,26 +117,3 @@ test-suite unit Spec main-is: Main.hs - -executable contract-cost - import: project-config - hs-source-dirs: exe/contract-cost - main-is: Main.hs - build-depends: - , aeson - , base - , bytestring - , cardano-api - , containers - , data-default - , directory - , hydra-prelude - , hydra-test-utils - , optparse-applicative - , plutus-merkle-tree - , plutus-tx - , QuickCheck - , serialise - , text - - ghc-options: -threaded -rtsopts