diff --git a/hydra-node/test/Hydra/Chain/Direct/ContractSpec.hs b/hydra-node/test/Hydra/Chain/Direct/ContractSpec.hs index e99048d7c26..730050ed4a2 100644 --- a/hydra-node/test/Hydra/Chain/Direct/ContractSpec.hs +++ b/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 -- diff --git a/hydra-plutus/exe/inspect-script/Main.hs b/hydra-plutus/exe/inspect-script/Main.hs index c3847b4e05f..aba4f4406c3 100644 --- a/hydra-plutus/exe/inspect-script/Main.hs +++ b/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") diff --git a/hydra-plutus/hydra-plutus.cabal b/hydra-plutus/hydra-plutus.cabal index 05487f3ba2a..c2f04771653 100644 --- a/hydra-plutus/hydra-plutus.cabal +++ b/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 diff --git a/hydra-plutus/src/Hydra/Contract/Hash.hs b/hydra-plutus/src/Hydra/Contract/Hash.hs new file mode 100644 index 00000000000..4ec90d8a70c --- /dev/null +++ b/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