Add mustPayWithDatumToPubKey (fix #146). (#154)

Add test

plutus-contract/test/Spec/Contract.hs

@@ -29,6 +29,7 @@ import Ledger (Address, PubKeyHash)
 import Ledger qualified
 import Ledger.Ada qualified as Ada
 import Ledger.Constraints qualified as Constraints
+import Ledger.Scripts (datumHash)
 import Ledger.Tx (getCardanoTxId)
 import Plutus.Contract as Con
 import Plutus.Contract.State qualified as State
@@ -39,6 +40,8 @@ import Plutus.Trace qualified as Trace
 import Plutus.Trace.Emulator (ContractInstanceTag, EmulatorTrace, activateContract, activeEndpoints, callEndpoint)
 import Plutus.Trace.Emulator.Types (ContractInstanceLog (..), ContractInstanceMsg (..), ContractInstanceState (..),
                                     UserThreadMsg (..))
+import Plutus.V1.Ledger.Scripts (Datum (..), DatumHash)
+import Plutus.V1.Ledger.Tx (TxOut (..))
 import PlutusTx qualified
 import Prelude hiding (not)
 import Wallet.Emulator qualified as EM
@@ -192,6 +195,24 @@ tests =
             (assertDone theContract tag ((==) (Committed TxValid ())) "should be done")
             (activateContract w1 theContract tag >> void (Trace.waitNSlots 1))
 
+        , let c :: Contract [Maybe DatumHash] Schema ContractError () = do
+                let w2PubKeyHash = walletPubKeyHash w2
+                let payment = Constraints.mustPayWithDatumToPubKey w2PubKeyHash datum (Ada.adaValueOf 10)
+                tx <- submitTx payment
+                let txOuts = fmap fst $ Ledger.getCardanoTxOutRefs tx
+                -- tell the tx out' datum hash that was specified by 'mustPayWithDatumToPubKey'
+                tell [txOutDatumHash (txOuts !! 1)]
+
+              datum = Datum $ PlutusTx.toBuiltinData (23 :: Integer)
+              isExpectedDatumHash [Just hash] = hash == datumHash datum
+              isExpectedDatumHash _           = False
+
+          in run "mustPayWithDatumToPubKey produces datum in TxOut"
+            ( assertAccumState c tag isExpectedDatumHash "should be done"
+            ) $ do
+              _ <- activateContract w1 c tag
+              void (Trace.waitNSlots 2)
+
         , let c :: Contract [TxOutStatus] Schema ContractError () = do
                 -- Submit a payment tx of 10 lovelace to W2.
                 let w2PubKeyHash = walletPubKeyHash w2

plutus-ledger-constraints/src/Ledger/Constraints.hs

@@ -6,6 +6,7 @@ module Ledger.Constraints(
     -- * Defining constraints
     , TC.mustPayToTheScript
     , TC.mustPayToPubKey
+    , TC.mustPayWithDatumToPubKey
     , TC.mustMintCurrency
     , TC.mustMintCurrencyWithRedeemer
     , TC.mustMintValue

plutus-ledger-constraints/src/Ledger/Constraints/OffChain.hs

@@ -48,6 +48,7 @@ module Ledger.Constraints.OffChain(
     ) where
 
 import Control.Lens (At (at), iforM_, makeLensesFor, over, use, view, (%=), (.=), (<>=))
+import Control.Monad (forM_)
 import Control.Monad.Except (MonadError (catchError, throwError), runExcept, unless)
 import Control.Monad.Reader (MonadReader (ask), ReaderT (runReaderT), asks)
 import Control.Monad.State (MonadState (get, put), execStateT, gets)
@@ -594,8 +595,12 @@ processConstraint = \case
         unbalancedTx . tx . Tx.mintScripts %= Set.insert mintingPolicyScript
         unbalancedTx . tx . Tx.mint <>= value i
         mintRedeemers . at mpsHash .= Just red
-    MustPayToPubKey pk vl -> do
-        unbalancedTx . tx . Tx.outputs %= (Tx.TxOut{txOutAddress=pubKeyHashAddress pk,txOutValue=vl,txOutDatumHash=Nothing} :)
+    MustPayToPubKey pk mdv vl -> do
+        -- if datum is presented, add it to 'datumWitnesses'
+        forM_ mdv $ \dv -> do
+            unbalancedTx . tx . Tx.datumWitnesses . at (datumHash dv) .= Just dv
+        let hash = datumHash <$> mdv
+        unbalancedTx . tx . Tx.outputs %= (Tx.TxOut{txOutAddress=pubKeyHashAddress pk,txOutValue=vl,txOutDatumHash=hash} :)
         valueSpentOutputs <>= provided vl
     MustPayToOtherScript vlh dv vl -> do
         let addr = Address.scriptHashAddress vlh

plutus-ledger-constraints/src/Ledger/Constraints/OnChain.hs

@@ -11,7 +11,7 @@
 module Ledger.Constraints.OnChain where
 
 import PlutusTx (ToData (toBuiltinData))
-import PlutusTx.Prelude (AdditiveSemigroup ((+)), Bool (False), Eq ((==)), Functor (fmap), Maybe (Just),
+import PlutusTx.Prelude (AdditiveSemigroup ((+)), Bool (False, True), Eq ((==)), Functor (fmap), Maybe (Just),
                          Ord ((<=), (>=)), all, any, elem, isJust, isNothing, maybe, snd, traceIfFalse, ($), (&&), (.))
 
 import Ledger qualified
@@ -85,9 +85,15 @@ checkTxConstraint ctx@ScriptContext{scriptContextTxInfo} = \case
     MustMintValue mps _ tn v ->
         traceIfFalse "L9" -- "Value minted not OK"
         $ Value.valueOf (txInfoMint scriptContextTxInfo) (Value.mpsSymbol mps) tn == v
-    MustPayToPubKey pk vl ->
+    MustPayToPubKey pk mdv vl ->
+        let outs = V.txInfoOutputs scriptContextTxInfo
+            hsh dv = V.findDatumHash dv scriptContextTxInfo
+            checkOutput (Just dv) TxOut{txOutDatumHash=Just svh} = hsh dv == Just svh
+            -- return 'True' by default meaning we fail only when the provided datum is not found
+            checkOutput _ _                                      = True
+        in
         traceIfFalse "La" -- "MustPayToPubKey"
-        $ vl `leq` V.valuePaidTo scriptContextTxInfo pk
+        $ vl `leq` V.valuePaidTo scriptContextTxInfo pk && any (checkOutput mdv) outs
     MustPayToOtherScript vlh dv vl ->
         let outs = V.txInfoOutputs scriptContextTxInfo
             hsh = V.findDatumHash dv scriptContextTxInfo

plutus-ledger-constraints/src/Ledger/Constraints/TxConstraints.hs

@@ -48,7 +48,7 @@ data TxConstraint =
     | MustSpendPubKeyOutput TxOutRef
     | MustSpendScriptOutput TxOutRef Redeemer
     | MustMintValue MintingPolicyHash Redeemer TokenName Integer
-    | MustPayToPubKey PubKeyHash Value
+    | MustPayToPubKey PubKeyHash (Maybe Datum) Value
     | MustPayToOtherScript ValidatorHash Datum Value
     | MustHashDatum DatumHash Datum
     | MustSatisfyAnyOf [TxConstraint]
@@ -73,8 +73,8 @@ instance Pretty TxConstraint where
             hang 2 $ vsep ["must spend script output:", pretty ref, pretty red]
         MustMintValue mps red tn i ->
             hang 2 $ vsep ["must mint value:", pretty mps, pretty red, pretty tn <+> pretty i]
-        MustPayToPubKey pk v ->
-            hang 2 $ vsep ["must pay to pubkey:", pretty pk, pretty v]
+        MustPayToPubKey pk datum v ->
+            hang 2 $ vsep ["must pay to pubkey:", pretty pk, pretty datum, pretty v]
         MustPayToOtherScript vlh dv vl ->
             hang 2 $ vsep ["must pay to script:", pretty vlh, pretty dv, pretty vl]
         MustHashDatum dvh dv ->
@@ -194,7 +194,12 @@ mustPayToTheScript dt vl =
 {-# INLINABLE mustPayToPubKey #-}
 -- | Lock the value with a public key
 mustPayToPubKey :: forall i o. PubKeyHash -> Value -> TxConstraints i o
-mustPayToPubKey pk = singleton . MustPayToPubKey pk
+mustPayToPubKey pk = singleton . MustPayToPubKey pk Nothing
+
+{-# INLINABLE mustPayWithDatumToPubKey #-}
+-- | Lock the value and datum with a public key
+mustPayWithDatumToPubKey :: forall i o. PubKeyHash -> Datum -> Value -> TxConstraints i o
+mustPayWithDatumToPubKey pk datum = singleton . MustPayToPubKey pk (Just datum)
 
 {-# INLINABLE mustPayToOtherScript #-}
 -- | Lock the value with a public key
@@ -265,7 +270,7 @@ pubKeyPayments :: forall i o. TxConstraints i o -> [(PubKeyHash, Value)]
 pubKeyPayments TxConstraints{txConstraints} =
     Map.toList
     $ Map.fromListWith (<>)
-      (txConstraints >>= \case { MustPayToPubKey pk vl -> [(pk, vl)]; _ -> [] })
+      (txConstraints >>= \case { MustPayToPubKey pk _ vl -> [(pk, vl)]; _ -> [] })
 
 -- | The minimum 'Value' that satisfies all 'MustSpendAtLeast' constraints
 {-# INLINABLE mustSpendAtLeastTotal #-}
@@ -310,7 +315,7 @@ modifiesUtxoSet TxConstraints{txConstraints, txOwnOutputs, txOwnInputs} =
             MustSpendPubKeyOutput{}     -> True
             MustSpendScriptOutput{}     -> True
             MustMintValue{}             -> True
-            MustPayToPubKey _ vl        -> not (isZero vl)
+            MustPayToPubKey _ _ vl      -> not (isZero vl)
             MustPayToOtherScript _ _ vl -> not (isZero vl)
             MustSatisfyAnyOf xs         -> any requiresInputOutput xs
             _                           -> False

plutus-use-cases/test/Spec/future.pir

@@ -419,24 +419,29 @@
                 (fun
                   (con bytestring)
                   (fun
-                    [
-                      [
-                        (lam
-                          k (type) (lam v (type) [ List [ [ Tuple2 k ] v ] ])
-                        )
-                        (con bytestring)
-                      ]
+                    [ Maybe (con data) ]
+                    (fun
                       [
                         [
                           (lam
                             k (type) (lam v (type) [ List [ [ Tuple2 k ] v ] ])
                           )
                           (con bytestring)
                         ]
-                        (con integer)
+                        [
+                          [
+                            (lam
+                              k
+                              (type)
+                              (lam v (type) [ List [ [ Tuple2 k ] v ] ])
+                            )
+                            (con bytestring)
+                          ]
+                          (con integer)
+                        ]
                       ]
-                    ]
-                    TxConstraint
+                      TxConstraint
+                    )
                   )
                 )
               )