Run plutus scripts 'directly' -> not working

This is not covering creation of the 'TxInfo' / 'ScriptContext' so will never work for non-trivial validators
input-output-hk · Oct 12, 2021 · 1086a38 · 1086a38
1 parent 242b266
commit 1086a38
Show file tree

Hide file tree

Showing 2 changed files with 31 additions and 8 deletions.
diff --git a/hydra-node/test/Hydra/Chain/Direct/TxSpec.hs b/hydra-node/test/Hydra/Chain/Direct/TxSpec.hs
@@ -10,8 +10,11 @@ import Test.Hydra.Prelude
 import Cardano.Binary (serialize)
 import Cardano.Ledger.Alonzo (TxOut)
 import Cardano.Ledger.Alonzo.Data (Data (Data))
+import Cardano.Ledger.Alonzo.PlutusScriptApi (evalScripts)
+import Cardano.Ledger.Alonzo.Scripts (ExUnits (ExUnits), Script (PlutusScript))
 import Cardano.Ledger.Alonzo.Tx (ValidatedTx (ValidatedTx, body, wits), outputs)
 import Cardano.Ledger.Alonzo.TxBody (TxOut (TxOut))
+import Cardano.Ledger.Alonzo.TxInfo (ScriptResult (Fails, Passes))
 import Cardano.Ledger.Alonzo.TxWitness (TxWitness (txdats), nullDats, unTxDats)
 import Cardano.Ledger.Crypto (StandardCrypto)
 import Cardano.Ledger.Mary.Value (AssetName, PolicyID, Value (Value))
@@ -21,28 +24,42 @@ import Hydra.Chain (HeadParameters (..), PostChainTx (InitTx), toOnChainTx)
 import Hydra.Chain.Direct.Tx (constructTx, initTx, observeTx)
 import Hydra.Chain.Direct.Util (Era)
 import Hydra.Contract.Head (State (Initial))
+import qualified Hydra.Contract.Initial as Initial
 import Hydra.Data.ContestationPeriod (contestationPeriodFromDiffTime)
 import Hydra.Data.Party (partyFromVerKey)
 import Hydra.Ledger.Simple (SimpleTx)
 import Hydra.Party (vkey)
 import Plutus.V1.Ledger.Api (toBuiltinData, toData)
+import Test.Cardano.Ledger.Alonzo.PlutusScripts (defaultCostModel)
 import Test.Cardano.Ledger.Alonzo.Serialisation.Generators ()
-import Test.QuickCheck (counterexample, (===), (==>))
+import Test.QuickCheck (counterexample, property, (===), (==>))
 
 spec :: Spec
 spec =
   parallel $ do
     prop "observeTx . constructTx roundtrip" $ \postTx txIn time ->
-      isImplemented postTx
-        ==> observeTx (constructTx txIn postTx) === Just (toOnChainTx @SimpleTx time postTx) -- TODO(SN): test all constructors
+      isImplemented postTx -- TODO(SN): test all constructors
+        ==> observeTx (constructTx txIn postTx) === Just (toOnChainTx @SimpleTx time postTx)
     describe "initTx" $ do
-      prop "can construct & serialize unsigned initTx" $ \txIn params ->
+      prop "transaction size below limit" $ \txIn params ->
         let tx = initTx params txIn
             cbor = serialize tx
             len = LBS.length cbor
          in counterexample ("Tx: " <> show tx) $
               counterexample ("Tx serialized size: " <> show len) $
-                len < 16000 -- TODO(SN): use real max tx size
+                -- TODO(SN): use real max tx size
+                len < 16000
+
+      prop "validates against 'initial' script in haskell (unlimited budget)" $ \txIn params ->
+        let tx = initTx params txIn
+            -- TODO(SN): what units / cost model?
+            scripts = [(PlutusScript initialScriptCbor, [], ExUnits 100000000 10000000, costModel)]
+            costModel = fromMaybe (error "corrupt default cost model") defaultCostModel
+            initialScriptCbor = toShort . fromLazy $ serialize Initial.validatorScript
+         in case evalScripts tx scripts of
+              Passes -> property True
+              Fails errs -> counterexample ("Fails: " <> concat errs) $ property False
+
       prop "contains some datums" $ \txIn params ->
         let ValidatedTx{wits} = initTx params txIn
             dats = txdats wits
@@ -62,9 +79,10 @@ spec =
       prop "distributes participation tokens (expected failure)" $ \txIn params ->
         let ValidatedTx{body} = initTx params txIn
             nfts = foldMap txOutNFT $ outputs body
-         in counterexample ("NFTs: " <> show nfts) True
-
--- TODO(SN): re-enable length nfts == length (parties params)
+         in counterexample
+              ("NFTs: " <> show nfts)
+              -- TODO(SN): re-enable length nfts == length (parties params)
+              True
 
 isImplemented :: PostChainTx tx -> Bool
 isImplemented = \case

diff --git a/hydra-plutus/src/Hydra/Contract/Initial.hs b/hydra-plutus/src/Hydra/Contract/Initial.hs
@@ -105,3 +105,8 @@ mustPayToScript ::
   TxConstraints i o
 mustPayToScript policyId dependencies pubKey =
   mustPayToOtherScript validatorHash $ datum (policyId, dependencies, pubKey)
+
+-- | Get the actual plutus script. Mainly used to serialize and use in
+-- transactions.
+validatorScript :: Script
+validatorScript = unValidatorScript $ Scripts.validatorScript typedValidator