Add testcase

plutus-ledger-constraints/plutus-ledger-constraints.cabal

@@ -62,9 +62,16 @@ test-suite plutus-ledger-constraints-test
     default-extensions: ImportQualifiedPost
     build-depends:
         base >=4.9 && <5,
+        bytestring -any,
+        containers -any,
+        data-default -any,
         hedgehog -any,
+        lens -any,
+        mtl -any,
         plutus-ledger -any,
         plutus-ledger-constraints -any,
         plutus-tx -any,
+        plutus-tx-plugin -any,
         tasty -any,
         tasty-hedgehog -any,
+        template-haskell -any,

plutus-ledger-constraints/test/Spec.hs

@@ -1,29 +1,42 @@
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE TypeApplications  #-}
 
 module Main(main) where
 
+import Control.Lens (toListOf)
 import Control.Monad (forM_, guard, replicateM, void)
 import Control.Monad.IO.Class (MonadIO (liftIO))
+import Control.Monad.Reader (ask)
+import Data.ByteString qualified as BS
+import Data.Default (def)
+import Data.Map qualified as Map
 import Data.Maybe (mapMaybe)
 import Data.Void (Void)
 import Hedgehog (Property, forAll, property, (===))
 import Hedgehog qualified
 import Hedgehog.Gen qualified as Gen
 import Hedgehog.Range qualified as Range
+import Language.Haskell.TH.Syntax
 import Ledger qualified
 import Ledger.Ada qualified as Ada
 import Ledger.Address (StakePubKeyHash (StakePubKeyHash), addressStakingCredential)
 import Ledger.Constraints as Constraints
 import Ledger.Constraints.OffChain qualified as OC
-import Ledger.Credential (Credential (PubKeyCredential), StakingCredential (StakingHash))
+import Ledger.Credential (Credential (PubKeyCredential, ScriptCredential), StakingCredential (StakingHash))
 import Ledger.Crypto (PubKeyHash (PubKeyHash))
 import Ledger.Generators qualified as Gen
 import Ledger.Tx (Tx (txOutputs), TxOut (TxOut, txOutAddress))
+import Ledger.Typed.Scripts qualified as Scripts
 import Ledger.Value (CurrencySymbol, Value (Value))
 import Ledger.Value qualified as Value
+import PlutusTx qualified
 import PlutusTx.AssocMap qualified as AMap
+import PlutusTx.Builtins.Internal (BuiltinByteString (..))
+import PlutusTx.Prelude qualified as Pl
 import Test.Tasty (TestTree, defaultMain, testGroup)
 import Test.Tasty.Hedgehog (testProperty)
 
@@ -34,6 +47,7 @@ tests :: TestTree
 tests = testGroup "all tests"
     [ testProperty "missing value spent" missingValueSpentProp
     , testProperty "mustPayToPubKeyAddress should create output addresses with stake pub key hash" mustPayToPubKeyAddressStakePubKeyNotNothingProp
+    , testProperty "mustSpendScriptOutputWithMatchingDatumAndValue" testMustSpendScriptOutputWithMatchingDatumAndValue
     ]
 
 -- | Reduce one of the elements in a 'Value' by one.
@@ -90,7 +104,7 @@ mustPayToPubKeyAddressStakePubKeyNotNothingProp = property $ do
         txE = mkTx @Void mempty (Constraints.mustPayToPubKeyAddress pkh skh (Ada.toValue Ledger.minAdaTxOut))
     case txE of
       Left _ ->
-          Hedgehog.assert False
+          Hedgehog.failure
       Right utx -> do
           let outputs = txOutputs (OC.unBalancedTxTx utx)
           let stakingCreds = mapMaybe stakePaymentPubKeyHash outputs
@@ -103,3 +117,72 @@ mustPayToPubKeyAddressStakePubKeyNotNothingProp = property $ do
           case stakeCred of
             StakingHash (PubKeyCredential pkh) -> Just $ StakePubKeyHash pkh
             _                                  -> Nothing
+
+
+-- | Make a transaction with the given constraints and check the validity of the inputs of that transaction.
+testScriptInputs
+    :: ( PlutusTx.FromData (Scripts.DatumType a)
+       , PlutusTx.ToData (Scripts.DatumType a)
+       , PlutusTx.ToData (Scripts.RedeemerType a))
+    => ScriptLookups a
+    -> TxConstraints (Scripts.RedeemerType a) (Scripts.DatumType a)
+    -> Property
+testScriptInputs lookups txc = property $ do
+    tx <- either (\err -> do Hedgehog.annotateShow err; Hedgehog.failure)
+                 (pure . unBalancedTxTx)
+                 $ mkTx lookups txc
+    let valM = do
+            Ledger.checkValidInputs (toListOf (Ledger.inputs . Ledger.scriptTxIns)) tx
+            idx <- Ledger.vctxIndex <$> ask
+            pure (Nothing, idx)
+    case Ledger.runValidation valM (Ledger.ValidationCtx (Ledger.UtxoIndex (Ledger.toTxOut <$> Constraints.slTxOutputs lookups)) def) of
+        ((Nothing, _), _) -> pure ()
+        ((Just err, _), _) -> do
+            Hedgehog.annotateShow err
+            Hedgehog.failure
+
+
+txOut0 :: Ledger.ChainIndexTxOut
+txOut0 = Ledger.ScriptChainIndexTxOut (Ledger.Address (ScriptCredential Gen.alwaysSucceedValidatorHash) Nothing) (Left Gen.alwaysSucceedValidatorHash) (Right Ledger.unitDatum) mempty
+
+txOutRef0 :: Ledger.TxOutRef
+txOutRef0 = Ledger.TxOutRef (Ledger.TxId "") 0
+
+validator1 :: Scripts.TypedValidator Gen.UnitTest
+validator1 = Scripts.mkTypedValidator
+    ($$(PlutusTx.compile [|| \vh _ _ -> checkScriptContext @() @() (constraints1 vh) ||])
+        `PlutusTx.applyCode` PlutusTx.liftCode Gen.alwaysSucceedValidatorHash)
+    $$(PlutusTx.compile [|| wrap ||])
+    where
+        wrap = Scripts.wrapValidator
+
+validatorHash1 :: Ledger.ValidatorHash
+validatorHash1 = Scripts.validatorHash validator1
+
+txOut1 :: Ledger.ChainIndexTxOut
+txOut1 = Ledger.ScriptChainIndexTxOut (Ledger.Address (ScriptCredential validatorHash1) Nothing) (Left validatorHash1) (Right Ledger.unitDatum) mempty
+
+txOutRef1 :: Ledger.TxOutRef
+txOutRef1 = Ledger.TxOutRef (Ledger.TxId "") 1
+
+utxo1 :: Map.Map Ledger.TxOutRef Ledger.ChainIndexTxOut
+utxo1 = Map.fromList [(txOutRef0, txOut0), (txOutRef1, txOut1)]
+
+{-# INLINABLE constraints1 #-}
+constraints1 :: Ledger.ValidatorHash -> TxConstraints () ()
+constraints1 vh =
+    Constraints.mustSpendScriptOutputWithMatchingDatumAndValue
+        vh
+        (Pl.== Ledger.unitDatum)
+        (Pl.const True)
+        Ledger.unitRedeemer
+    <> Constraints.mustSpendScriptOutput txOutRef1 Ledger.unitRedeemer
+
+lookups1 :: ScriptLookups Gen.UnitTest
+lookups1
+    = Constraints.unspentOutputs utxo1
+    <> Constraints.otherScript (Scripts.validatorScript Gen.alwaysSucceedValidator)
+    <> Constraints.otherScript (Scripts.validatorScript validator1)
+
+testMustSpendScriptOutputWithMatchingDatumAndValue :: Property
+testMustSpendScriptOutputWithMatchingDatumAndValue = testScriptInputs lookups1 (constraints1 Gen.alwaysSucceedValidatorHash)

plutus-ledger/src/Ledger/Generators.hs

@@ -47,7 +47,11 @@ module Ledger.Generators(
     validateMockchain,
     signAll,
     knownPaymentPublicKeys,
-    someTokenValue
+    someTokenValue,
+    alwaysSucceedPolicy,
+    alwaysSucceedValidator,
+    alwaysSucceedValidatorHash,
+    UnitTest
     ) where
 
 import Cardano.Api qualified as C
@@ -86,6 +90,7 @@ import Ledger.Fee (FeeConfig (fcScriptsFeeFactor), calcFees)
 import Ledger.Index qualified as Index
 import Ledger.TimeSlot (SlotConfig)
 import Ledger.TimeSlot qualified as TimeSlot
+import Ledger.Typed.Scripts qualified as Scripts
 import Ledger.Value qualified as Value
 import Plutus.V1.Ledger.Ada qualified as Ada
 import Plutus.V1.Ledger.Contexts qualified as Contexts
@@ -249,6 +254,19 @@ genValidTransactionSpending' g feeCfg ins totalVal = do
             pure (signAll tx)
         else Gen.discard
 
+data UnitTest
+instance Scripts.ValidatorTypes UnitTest
+
+alwaysSucceedValidator :: Scripts.TypedValidator UnitTest
+alwaysSucceedValidator = Scripts.mkTypedValidator
+    $$(PlutusTx.compile [|| \_ _ _ -> True ||])
+    $$(PlutusTx.compile [|| wrap ||])
+    where
+        wrap = Scripts.wrapValidator
+
+alwaysSucceedValidatorHash :: Ledger.ValidatorHash
+alwaysSucceedValidatorHash = Scripts.validatorHash alwaysSucceedValidator
+
 alwaysSucceedPolicy :: MintingPolicy
 alwaysSucceedPolicy = mkMintingPolicyScript $$(PlutusTx.compile [|| \_ _ -> () ||])
 

plutus-ledger/src/Ledger/Index.hs

@@ -38,6 +38,7 @@ module Ledger.Index(
     -- * Actual validation
     validateTransaction,
     validateTransactionOffChain,
+    checkValidInputs,
     -- * Script validation events
     ScriptType(..),
     ScriptValidationEvent(..),