Spike: costs of hashing

hydra-node/test/Hydra/Chain/Direct/ContractSpec.hs

@@ -1,5 +1,5 @@
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE TypeApplications #-}
-{-# OPTIONS_GHC -Wno-deprecations #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Hydra.Chain.Direct.ContractSpec where
@@ -24,30 +24,48 @@ import qualified Cardano.Ledger.Shelley.API as Ledger
 import qualified Data.ByteString as BS
 import qualified Data.Map as Map
 import Data.Maybe.Strict (StrictMaybe (..))
+import Hydra.Chain.Direct.Fixture (testNetworkId)
 import qualified Hydra.Chain.Direct.Fixture as Fixture
 import Hydra.Chain.Direct.Tx (closeRedeemer, closeTx, policyId)
 import Hydra.Chain.Direct.TxSpec (mkHeadOutput)
+import qualified Hydra.Contract.Hash as Hash
 import Hydra.Contract.MockHead (naturalToCBOR, verifyPartySignature, verifySnapshotSignature)
 import qualified Hydra.Contract.MockHead as MockHead
 import Hydra.Data.Party (partyFromVerKey)
 import Hydra.Ledger.Cardano (
   AlonzoEra,
+  BuildTxWith (BuildTxWith),
   CardanoTx,
   CtxUTxO,
   Era,
+  ExecutionUnits (ExecutionUnits),
   LedgerCrypto,
   LedgerEra,
+  PlutusScriptV1,
   Tx (Tx),
   TxBody (ShelleyTxBody),
   TxBodyScriptData (TxBodyNoScriptData, TxBodyScriptData),
   TxOut (..),
   Utxo,
+  Utxo' (Utxo),
+  addInputs,
   describeCardanoTx,
+  emptyTxBody,
+  fromAlonzoExUnits,
   fromLedgerTx,
   fromLedgerUtxo,
+  fromPlutusScript,
+  lovelaceToTxOutValue,
+  mkDatumForTxIn,
+  mkRedeemerForTxIn,
+  mkScriptAddress,
+  mkScriptWitness,
+  mkTxOutDatum,
   mkTxOutDatumHash,
+  toCtxUTxOTxOut,
   toLedgerTx,
   toLedgerUtxo,
+  unsafeBuildTransaction,
  )
 import qualified Hydra.Ledger.Cardano as Api
 import Hydra.Ledger.Simple (SimpleTx)
@@ -81,7 +99,7 @@ import Test.QuickCheck (
 import Test.QuickCheck.Instances ()
 
 spec :: Spec
-spec = describe "On-chain contracts" $ do
+spec = do
   prop "correctly encode 'small' integer to CBOR" prop_encode16BitsNaturalToCBOROnChain
   describe "Signature validator" $ do
     prop
@@ -100,6 +118,54 @@ spec = describe "On-chain contracts" $ do
     prop "does not survive random adversarial mutations" $
       propMutation healthyCloseTx genCloseMutation
 
+  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
 --

hydra-plutus/exe/inspect-script/Main.hs

@@ -8,6 +8,7 @@ import qualified Data.Aeson as Aeson
 import qualified Data.ByteString.Lazy as BL
 import Data.Text (pack)
 import Hydra.Contract.Commit as Commit
+import qualified Hydra.Contract.Hash as Hash
 import Hydra.Contract.Initial as Initial
 import Hydra.Contract.MockHead as MockHead
 import Ledger (Datum (..), datumHash)
@@ -64,6 +65,7 @@ main = do
     [ (headScript policyId, "headScript")
     , (initialScript, "initialScript")
     , (commitScript, "commitScript")
+    , (hashScript, "hashScript")
     ]
 
   headScript policyId = MockHead.validatorScript policyId
@@ -72,6 +74,8 @@ main = do
 
   initialScript = Initial.validatorScript
 
+  hashScript = Hash.validatorScript
+
   datums =
     [ (headDatum, "headDatum")
     , (abortDatum, "abortDatum")

hydra-plutus/hydra-plutus.cabal

@@ -72,6 +72,7 @@ library
   import:          project-config
   exposed-modules:
     Hydra.Contract.Commit
+    Hydra.Contract.Hash
     Hydra.Contract.Initial
     Hydra.Contract.MockCommit
     Hydra.Contract.MockHead

hydra-plutus/src/Hydra/Contract/Hash.hs

@@ -0,0 +1,76 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -fno-specialize #-}
+
+-- | An experimental validator which simply hashes a bytestring stored in the
+-- datum using one of three supported algorithms.
+module Hydra.Contract.Hash where
+
+import Ledger hiding (validatorHash)
+import PlutusTx.Prelude
+
+import qualified Hydra.Prelude as Haskell
+
+import Ledger.Typed.Scripts (TypedValidator, ValidatorType, ValidatorTypes (..))
+import qualified Ledger.Typed.Scripts as Scripts
+import PlutusTx (CompiledCode)
+import qualified PlutusTx
+import PlutusTx.Builtins (equalsByteString)
+import PlutusTx.IsData.Class (ToData (..))
+
+data Hash
+
+data HashAlgorithm
+  = Base
+  | SHA2
+  | SHA3
+  -- Blake2b
+  deriving (Haskell.Show, Haskell.Generic, Haskell.Enum, Haskell.Bounded)
+
+PlutusTx.unstableMakeIsData ''HashAlgorithm
+
+instance Haskell.Arbitrary HashAlgorithm where
+  arbitrary = Haskell.genericArbitrary
+
+instance Scripts.ValidatorTypes Hash where
+  type DatumType Hash = BuiltinByteString
+  type RedeemerType Hash = HashAlgorithm
+
+-- NOTE: Plutus is strict, thus this still occurs cost for hashing
+validator :: DatumType Hash -> RedeemerType Hash -> ScriptContext -> Bool
+validator bytes algorithm _ctx =
+  case algorithm of
+    Base -> equalsByteString bytes bytes
+    SHA2 -> not . equalsByteString bytes $ sha2_256 bytes
+    SHA3 -> not . equalsByteString bytes $ sha3_256 bytes
+
+-- Blake2b -> not . equalsByteString "" $ blake2b_256 bytes
+
+compiledValidator :: CompiledCode (ValidatorType Hash)
+compiledValidator = $$(PlutusTx.compile [||validator||])
+
+{- ORMOLU_DISABLE -}
+typedValidator :: TypedValidator Hash
+typedValidator = Scripts.mkTypedValidator @Hash
+  compiledValidator
+  $$(PlutusTx.compile [|| wrap ||])
+ where
+  wrap = Scripts.wrapValidator @(DatumType Hash) @(RedeemerType Hash)
+{- ORMOLU_ENABLE -}
+
+-- | Get the actual plutus script. Mainly used to serialize and use in
+-- transactions.
+validatorScript :: Script
+validatorScript = unValidatorScript $ Scripts.validatorScript typedValidator
+
+validatorHash :: ValidatorHash
+validatorHash = Scripts.validatorHash typedValidator
+
+datum :: DatumType Hash -> Datum
+datum a = Datum (toBuiltinData a)
+
+redeemer :: RedeemerType Hash -> Redeemer
+redeemer a = Redeemer (toBuiltinData a)
+
+address :: Address
+address = scriptHashAddress validatorHash