Skip to content
This repository was archived by the owner on Dec 2, 2024. It is now read-only.

Commit 63123ff

Browse files
author
Evgenii Akentev
authored
Add mustPayWithDatumToPubKey (fix #146). (#154)
Add test
1 parent fe8f087 commit 63123ff

File tree

10 files changed

+3370
-1871
lines changed

10 files changed

+3370
-1871
lines changed

‎plutus-contract/test/Spec/Contract.hs‎

Lines changed: 21 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -29,6 +29,7 @@ import Ledger (Address, PubKeyHash)
2929
import Ledger qualified
3030
import Ledger.Ada qualified as Ada
3131
import Ledger.Constraints qualified as Constraints
32+
import Ledger.Scripts (datumHash)
3233
import Ledger.Tx (getCardanoTxId)
3334
import Plutus.Contract as Con
3435
import Plutus.Contract.State qualified as State
@@ -39,6 +40,8 @@ import Plutus.Trace qualified as Trace
3940
import Plutus.Trace.Emulator (ContractInstanceTag, EmulatorTrace, activateContract, activeEndpoints, callEndpoint)
4041
import Plutus.Trace.Emulator.Types (ContractInstanceLog (..), ContractInstanceMsg (..), ContractInstanceState (..),
4142
UserThreadMsg (..))
43+
import Plutus.V1.Ledger.Scripts (Datum (..), DatumHash)
44+
import Plutus.V1.Ledger.Tx (TxOut (..))
4245
import PlutusTx qualified
4346
import Prelude hiding (not)
4447
import Wallet.Emulator qualified as EM
@@ -192,6 +195,24 @@ tests =
192195
(assertDone theContract tag ((==) (Committed TxValid ())) "should be done")
193196
(activateContract w1 theContract tag >> void (Trace.waitNSlots 1))
194197

198+
, let c :: Contract [Maybe DatumHash] Schema ContractError () = do
199+
let w2PubKeyHash = walletPubKeyHash w2
200+
let payment = Constraints.mustPayWithDatumToPubKey w2PubKeyHash datum (Ada.adaValueOf 10)
201+
tx <- submitTx payment
202+
let txOuts = fmap fst $ Ledger.getCardanoTxOutRefs tx
203+
-- tell the tx out' datum hash that was specified by 'mustPayWithDatumToPubKey'
204+
tell [txOutDatumHash (txOuts !! 1)]
205+
206+
datum = Datum $ PlutusTx.toBuiltinData (23 :: Integer)
207+
isExpectedDatumHash [Just hash] = hash == datumHash datum
208+
isExpectedDatumHash _ = False
209+
210+
in run "mustPayWithDatumToPubKey produces datum in TxOut"
211+
( assertAccumState c tag isExpectedDatumHash "should be done"
212+
) $ do
213+
_ <- activateContract w1 c tag
214+
void (Trace.waitNSlots 2)
215+
195216
, let c :: Contract [TxOutStatus] Schema ContractError () = do
196217
-- Submit a payment tx of 10 lovelace to W2.
197218
let w2PubKeyHash = walletPubKeyHash w2

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@ module Ledger.Constraints(
66
-- * Defining constraints
77
, TC.mustPayToTheScript
88
, TC.mustPayToPubKey
9+
, TC.mustPayWithDatumToPubKey
910
, TC.mustMintCurrency
1011
, TC.mustMintCurrencyWithRedeemer
1112
, TC.mustMintValue

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

Lines changed: 7 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -48,6 +48,7 @@ module Ledger.Constraints.OffChain(
4848
) where
4949

5050
import Control.Lens (At (at), iforM_, makeLensesFor, over, use, view, (%=), (.=), (<>=))
51+
import Control.Monad (forM_)
5152
import Control.Monad.Except (MonadError (catchError, throwError), runExcept, unless)
5253
import Control.Monad.Reader (MonadReader (ask), ReaderT (runReaderT), asks)
5354
import Control.Monad.State (MonadState (get, put), execStateT, gets)
@@ -594,8 +595,12 @@ processConstraint = \case
594595
unbalancedTx . tx . Tx.mintScripts %= Set.insert mintingPolicyScript
595596
unbalancedTx . tx . Tx.mint <>= value i
596597
mintRedeemers . at mpsHash .= Just red
597-
MustPayToPubKey pk vl -> do
598-
unbalancedTx . tx . Tx.outputs %= (Tx.TxOut{txOutAddress=pubKeyHashAddress pk,txOutValue=vl,txOutDatumHash=Nothing} :)
598+
MustPayToPubKey pk mdv vl -> do
599+
-- if datum is presented, add it to 'datumWitnesses'
600+
forM_ mdv $ \dv -> do
601+
unbalancedTx . tx . Tx.datumWitnesses . at (datumHash dv) .= Just dv
602+
let hash = datumHash <$> mdv
603+
unbalancedTx . tx . Tx.outputs %= (Tx.TxOut{txOutAddress=pubKeyHashAddress pk,txOutValue=vl,txOutDatumHash=hash} :)
599604
valueSpentOutputs <>= provided vl
600605
MustPayToOtherScript vlh dv vl -> do
601606
let addr = Address.scriptHashAddress vlh

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

Lines changed: 9 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -11,7 +11,7 @@
1111
module Ledger.Constraints.OnChain where
1212

1313
import PlutusTx (ToData (toBuiltinData))
14-
import PlutusTx.Prelude (AdditiveSemigroup ((+)), Bool (False), Eq ((==)), Functor (fmap), Maybe (Just),
14+
import PlutusTx.Prelude (AdditiveSemigroup ((+)), Bool (False, True), Eq ((==)), Functor (fmap), Maybe (Just),
1515
Ord ((<=), (>=)), all, any, elem, isJust, isNothing, maybe, snd, traceIfFalse, ($), (&&), (.))
1616

1717
import Ledger qualified
@@ -85,9 +85,15 @@ checkTxConstraint ctx@ScriptContext{scriptContextTxInfo} = \case
8585
MustMintValue mps _ tn v ->
8686
traceIfFalse "L9" -- "Value minted not OK"
8787
$ Value.valueOf (txInfoMint scriptContextTxInfo) (Value.mpsSymbol mps) tn == v
88-
MustPayToPubKey pk vl ->
88+
MustPayToPubKey pk mdv vl ->
89+
let outs = V.txInfoOutputs scriptContextTxInfo
90+
hsh dv = V.findDatumHash dv scriptContextTxInfo
91+
checkOutput (Just dv) TxOut{txOutDatumHash=Just svh} = hsh dv == Just svh
92+
-- return 'True' by default meaning we fail only when the provided datum is not found
93+
checkOutput _ _ = True
94+
in
8995
traceIfFalse "La" -- "MustPayToPubKey"
90-
$ vl `leq` V.valuePaidTo scriptContextTxInfo pk
96+
$ vl `leq` V.valuePaidTo scriptContextTxInfo pk && any (checkOutput mdv) outs
9197
MustPayToOtherScript vlh dv vl ->
9298
let outs = V.txInfoOutputs scriptContextTxInfo
9399
hsh = V.findDatumHash dv scriptContextTxInfo

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

Lines changed: 11 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -48,7 +48,7 @@ data TxConstraint =
4848
| MustSpendPubKeyOutput TxOutRef
4949
| MustSpendScriptOutput TxOutRef Redeemer
5050
| MustMintValue MintingPolicyHash Redeemer TokenName Integer
51-
| MustPayToPubKey PubKeyHash Value
51+
| MustPayToPubKey PubKeyHash (Maybe Datum) Value
5252
| MustPayToOtherScript ValidatorHash Datum Value
5353
| MustHashDatum DatumHash Datum
5454
| MustSatisfyAnyOf [TxConstraint]
@@ -73,8 +73,8 @@ instance Pretty TxConstraint where
7373
hang 2 $ vsep ["must spend script output:", pretty ref, pretty red]
7474
MustMintValue mps red tn i ->
7575
hang 2 $ vsep ["must mint value:", pretty mps, pretty red, pretty tn <+> pretty i]
76-
MustPayToPubKey pk v ->
77-
hang 2 $ vsep ["must pay to pubkey:", pretty pk, pretty v]
76+
MustPayToPubKey pk datum v ->
77+
hang 2 $ vsep ["must pay to pubkey:", pretty pk, pretty datum, pretty v]
7878
MustPayToOtherScript vlh dv vl ->
7979
hang 2 $ vsep ["must pay to script:", pretty vlh, pretty dv, pretty vl]
8080
MustHashDatum dvh dv ->
@@ -194,7 +194,12 @@ mustPayToTheScript dt vl =
194194
{-# INLINABLE mustPayToPubKey #-}
195195
-- | Lock the value with a public key
196196
mustPayToPubKey :: forall i o. PubKeyHash -> Value -> TxConstraints i o
197-
mustPayToPubKey pk = singleton . MustPayToPubKey pk
197+
mustPayToPubKey pk = singleton . MustPayToPubKey pk Nothing
198+
199+
{-# INLINABLE mustPayWithDatumToPubKey #-}
200+
-- | Lock the value and datum with a public key
201+
mustPayWithDatumToPubKey :: forall i o. PubKeyHash -> Datum -> Value -> TxConstraints i o
202+
mustPayWithDatumToPubKey pk datum = singleton . MustPayToPubKey pk (Just datum)
198203

199204
{-# INLINABLE mustPayToOtherScript #-}
200205
-- | Lock the value with a public key
@@ -265,7 +270,7 @@ pubKeyPayments :: forall i o. TxConstraints i o -> [(PubKeyHash, Value)]
265270
pubKeyPayments TxConstraints{txConstraints} =
266271
Map.toList
267272
$ Map.fromListWith (<>)
268-
(txConstraints >>= \case { MustPayToPubKey pk vl -> [(pk, vl)]; _ -> [] })
273+
(txConstraints >>= \case { MustPayToPubKey pk _ vl -> [(pk, vl)]; _ -> [] })
269274

270275
-- | The minimum 'Value' that satisfies all 'MustSpendAtLeast' constraints
271276
{-# INLINABLE mustSpendAtLeastTotal #-}
@@ -310,7 +315,7 @@ modifiesUtxoSet TxConstraints{txConstraints, txOwnOutputs, txOwnInputs} =
310315
MustSpendPubKeyOutput{} -> True
311316
MustSpendScriptOutput{} -> True
312317
MustMintValue{} -> True
313-
MustPayToPubKey _ vl -> not (isZero vl)
318+
MustPayToPubKey _ _ vl -> not (isZero vl)
314319
MustPayToOtherScript _ _ vl -> not (isZero vl)
315320
MustSatisfyAnyOf xs -> any requiresInputOutput xs
316321
_ -> False

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

Lines changed: 15 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -419,24 +419,29 @@
419419
(fun
420420
(con bytestring)
421421
(fun
422-
[
423-
[
424-
(lam
425-
k (type) (lam v (type) [ List [ [ Tuple2 k ] v ] ])
426-
)
427-
(con bytestring)
428-
]
422+
[ Maybe (con data) ]
423+
(fun
429424
[
430425
[
431426
(lam
432427
k (type) (lam v (type) [ List [ [ Tuple2 k ] v ] ])
433428
)
434429
(con bytestring)
435430
]
436-
(con integer)
431+
[
432+
[
433+
(lam
434+
k
435+
(type)
436+
(lam v (type) [ List [ [ Tuple2 k ] v ] ])
437+
)
438+
(con bytestring)
439+
]
440+
(con integer)
441+
]
437442
]
438-
]
439-
TxConstraint
443+
TxConstraint
444+
)
440445
)
441446
)
442447
)

0 commit comments

Comments
 (0)