Provide 'MustSatisfyAnyOf' constructor for TxContraints. (#3706)

* Provide 'MustSatisfyAnyOf' constructor for TxContraints. It is actually useful in some cases to be able to perform a disjunction of constraints, and while it is possible to resort to 'Bool' in some cases, when using internal libraries like e.g. the state-machine, we are stuck with the TxConstraints API and therefore, unable to express some useful conditions. * re-generate the plutus-use-cases tests as needed.
IntersectMBO · Aug 12, 2021 · 0e75f03 · 0e75f03
1 parent 9e1c04a
commit 0e75f03
Show file tree

Hide file tree

Showing 8 changed files with 31,447 additions and 29,844 deletions.
diff --git a/plutus-ledger/src/Ledger/Constraints/OffChain.hs b/plutus-ledger/src/Ledger/Constraints/OffChain.hs
@@ -414,6 +414,7 @@ data MkTxError =
     | OwnPubKeyMissing
     | TypedValidatorMissing
     | DatumWrongHash DatumHash Datum
+    | CannotSatisfyAny
     deriving stock (Eq, Show, Generic)
     deriving anyclass (ToJSON, FromJSON)
 
@@ -428,6 +429,7 @@ instance Pretty MkTxError where
         OwnPubKeyMissing        -> "Own public key is missing"
         TypedValidatorMissing   -> "Script instance is missing"
         DatumWrongHash h d      -> "Wrong hash for datum" <+> pretty d <> colon <+> pretty h
+        CannotSatisfyAny        -> "Cannot satisfy any of the required constraints"
 
 lookupTxOutRef
     :: ( MonadReader (ScriptLookups a) m
@@ -538,3 +540,10 @@ processConstraint = \case
         unless (datumHash dv == dvh)
             (throwError $ DatumWrongHash dvh dv)
         unbalancedTx . tx . Tx.datumWitnesses . at dvh .= Just dv
+    MustSatisfyAnyOf xs -> do
+        s <- get
+        let tryNext [] =
+                throwError CannotSatisfyAny
+            tryNext (h:q) = do
+                processConstraint h `catchError` \_ -> put s >> tryNext q
+        tryNext xs
diff --git a/plutus-ledger/src/Ledger/Constraints/OnChain.hs b/plutus-ledger/src/Ledger/Constraints/OnChain.hs
@@ -48,7 +48,7 @@ checkOwnOutputConstraint ctx@ScriptContext{scriptContextTxInfo} OutputConstraint
 
 {-# INLINABLE checkTxConstraint #-}
 checkTxConstraint :: ScriptContext -> TxConstraint -> Bool
-checkTxConstraint ScriptContext{scriptContextTxInfo} = \case
+checkTxConstraint ctx@ScriptContext{scriptContextTxInfo} = \case
     MustIncludeDatum dv ->
         traceIfFalse "L2" -- "Missing datum"
         $ dv `elem` fmap snd (txInfoData scriptContextTxInfo)
@@ -92,6 +92,9 @@ checkTxConstraint ScriptContext{scriptContextTxInfo} = \case
     MustHashDatum dvh dv ->
         traceIfFalse "Lc" -- "MustHashDatum"
         $ V.findDatum dvh scriptContextTxInfo == Just dv
+    MustSatisfyAnyOf xs ->
+        traceIfFalse "Ld" -- "MustSatisfyAnyOf"
+        $ any (checkTxConstraint ctx) xs
 
 {-# INLINABLE checkScriptContext #-}
 -- | Does the 'ScriptContext' satisfy the constraints?

diff --git a/plutus-ledger/src/Ledger/Constraints/TxConstraints.hs b/plutus-ledger/src/Ledger/Constraints/TxConstraints.hs
@@ -50,6 +50,7 @@ data TxConstraint =
     | MustPayToPubKey PubKeyHash Value
     | MustPayToOtherScript ValidatorHash Datum Value
     | MustHashDatum DatumHash Datum
+    | MustSatisfyAnyOf [TxConstraint]
     deriving stock (Haskell.Show, Generic, Haskell.Eq)
     deriving anyclass (ToJSON, FromJSON)
 
@@ -77,6 +78,8 @@ instance Pretty TxConstraint where
             hang 2 $ vsep ["must pay to script:", pretty vlh, pretty dv, pretty vl]
         MustHashDatum dvh dv ->
             hang 2 $ vsep ["must hash datum:", pretty dvh, pretty dv]
+        MustSatisfyAnyOf xs ->
+            hang 2 $ vsep ["must satisfy any of:", prettyList xs]
 
 data InputConstraint a =
     InputConstraint
@@ -244,6 +247,10 @@ mustSpendScriptOutput txOutref = singleton . MustSpendScriptOutput txOutref
 mustHashDatum :: DatumHash -> Datum -> TxConstraints i o
 mustHashDatum dvh = singleton . MustHashDatum dvh
 
+{-# INLINABLE mustSatisfyAnyOf #-}
+mustSatisfyAnyOf :: forall i o. [TxConstraints i o] -> TxConstraints i o
+mustSatisfyAnyOf = singleton . MustSatisfyAnyOf . concatMap txConstraints
+
 {-# INLINABLE isSatisfiable #-}
 -- | Are the constraints satisfiable?
 isSatisfiable :: forall i o. TxConstraints i o -> Bool
@@ -304,6 +311,7 @@ modifiesUtxoSet TxConstraints{txConstraints, txOwnOutputs, txOwnInputs} =
             MustMintValue{}             -> True
             MustPayToPubKey _ vl        -> not (isZero vl)
             MustPayToOtherScript _ _ vl -> not (isZero vl)
+            MustSatisfyAnyOf xs         -> any requiresInputOutput xs
             _                           -> False
     in any requiresInputOutput txConstraints
         || not (null txOwnOutputs)