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

Commit

Permalink
Fix mustSatisfyAnyOf logic (fix #101).
Browse files Browse the repository at this point in the history 
add contract test

Use any instead of or and map
  • Loading branch information
Evgenii Akentev committed Dec 8, 2021
1 parent a53bfca commit 40b63ed
Show file tree
Hide file tree
Showing 9 changed files with 186 additions and 97 deletions.
7 changes: 7 additions & 0 deletions plutus-contract/test/Spec/Contract.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -300,6 +300,13 @@ tests =
void $ Trace.assert "Always fails" $ const False
void $ Trace.waitNSlots 10
in checkEmulatorFails "assert throws error" (defaultCheckOptions & minLogLevel .~ Debug) (waitingForSlot theContract tag 10) emTrace

, let c :: Contract () Schema ContractError () = do
let payment = Constraints.mustSatisfyAnyOf [mempty]
void $ submitTx payment
in run "mustSatisfyAnyOf [mempty] works"
( assertDone c tag (const True) "should be done"
) $ (void $ activateContract w1 c tag)
]

checkpointContract :: Contract () Schema ContractError ()
Expand Down
4 changes: 2 additions & 2 deletions plutus-ledger-constraints/src/Ledger/Constraints/OffChain.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -616,6 +616,6 @@ processConstraint = \case
s <- get
let tryNext [] =
throwError CannotSatisfyAny
tryNext (h:q) = do
processConstraint h `catchError` \_ -> put s >> tryNext q
tryNext (hs:qs) = do
(traverse_ processConstraint hs) `catchError` \_ -> put s >> tryNext qs
tryNext xs
2 changes: 1 addition & 1 deletion plutus-ledger-constraints/src/Ledger/Constraints/OnChain.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -113,7 +113,7 @@ checkTxConstraint ctx@ScriptContext{scriptContextTxInfo} = \case
$ V.findDatum dvh scriptContextTxInfo == Just dv
MustSatisfyAnyOf xs ->
traceIfFalse "Ld" -- "MustSatisfyAnyOf"
$ any (checkTxConstraint ctx) xs
$ any (all (checkTxConstraint ctx)) xs

{-# INLINABLE checkScriptContext #-}
-- | Does the 'ScriptContext' satisfy the constraints?
Expand Down
10 changes: 5 additions & 5 deletions plutus-ledger-constraints/src/Ledger/Constraints/TxConstraints.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -25,8 +25,8 @@ import Prettyprinter (Pretty (pretty, prettyList), hang, viaShow, vsep, (<+>))
import PlutusTx qualified
import PlutusTx.AssocMap qualified as AssocMap
import PlutusTx.Prelude (Bool (False, True), Foldable (foldMap), Functor (fmap), Integer, JoinSemiLattice ((\/)),
Maybe (Just, Nothing), Monoid (mempty), Semigroup ((<>)), any, concatMap, foldl, mapMaybe, not,
null, ($), (.), (>>=), (||))
Maybe (Just, Nothing), Monoid (mempty), Semigroup ((<>)), any, concat, foldl, map, mapMaybe,
not, null, ($), (.), (>>=), (||))

import Plutus.V1.Ledger.Crypto (PubKeyHash)
import Plutus.V1.Ledger.Interval qualified as I
Expand All @@ -51,7 +51,7 @@ data TxConstraint =
| MustPayToPubKey PubKeyHash (Maybe Datum) Value
| MustPayToOtherScript ValidatorHash Datum Value
| MustHashDatum DatumHash Datum
| MustSatisfyAnyOf [TxConstraint]
| MustSatisfyAnyOf [[TxConstraint]]
deriving stock (Haskell.Show, Generic, Haskell.Eq)
deriving anyclass (ToJSON, FromJSON)

Expand Down Expand Up @@ -255,7 +255,7 @@ mustHashDatum dvh = singleton . MustHashDatum dvh

{-# INLINABLE mustSatisfyAnyOf #-}
mustSatisfyAnyOf :: forall i o. [TxConstraints i o] -> TxConstraints i o
mustSatisfyAnyOf = singleton . MustSatisfyAnyOf . concatMap txConstraints
mustSatisfyAnyOf = singleton . MustSatisfyAnyOf . map txConstraints

{-# INLINABLE isSatisfiable #-}
-- | Are the constraints satisfiable?
Expand Down Expand Up @@ -317,7 +317,7 @@ modifiesUtxoSet TxConstraints{txConstraints, txOwnOutputs, txOwnInputs} =
MustMintValue{} -> True
MustPayToPubKey _ _ vl -> not (isZero vl)
MustPayToOtherScript _ _ vl -> not (isZero vl)
MustSatisfyAnyOf xs -> any requiresInputOutput xs
MustSatisfyAnyOf xs -> any requiresInputOutput $ concat xs
_ -> False
in any requiresInputOutput txConstraints
|| not (null txOwnOutputs)
Expand Down
3 changes: 2 additions & 1 deletion plutus-use-cases/test/Spec/future.pir
View file
Original file line number Diff line number Diff line change
Expand Up @@ -467,7 +467,8 @@
)
)
(vardecl
MustSatisfyAnyOf (fun [ List TxConstraint ] TxConstraint)
MustSatisfyAnyOf
(fun [ List [ List TxConstraint ] ] TxConstraint)
)
(vardecl
MustSpendAtLeast
Expand Down
45 changes: 35 additions & 10 deletions plutus-use-cases/test/Spec/gameStateMachine.pir
View file
Original file line number Diff line number Diff line change
Expand Up @@ -5636,7 +5636,7 @@
)
(vardecl
MustSatisfyAnyOf
(fun [ List TxConstraint ] TxConstraint)
(fun [ List [ List TxConstraint ] ] TxConstraint)
)
(vardecl
MustSpendAtLeast
Expand Down Expand Up @@ -10799,7 +10799,7 @@
]
(lam
xs
[ List TxConstraint ]
[ List [ List TxConstraint ] ]
{
[
[
Expand All @@ -10817,24 +10817,49 @@
Bool
]
}
TxConstraint
[
List TxConstraint
]
}
[
{ fMonoidSum Bool }
fAdditiveMonoidBool
]
]
(lam
w
TxConstraint
[
[
{
{
fFoldableNil_cfoldMap
[
(lam
a (type) a
)
Bool
]
}
TxConstraint
}
[
wcheckTxConstraint
ww
{
fMonoidProduct
Bool
}
fMultiplicativeMonoidBool
]
w
]
)
(lam
w
TxConstraint
[
[
wcheckTxConstraint
ww
]
w
]
)
]
]
xs
]
Expand Down
50 changes: 40 additions & 10 deletions plutus-use-cases/test/Spec/governance.pir
View file
Original file line number Diff line number Diff line change
Expand Up @@ -6506,7 +6506,9 @@
)
(vardecl
MustSatisfyAnyOf
(fun [ List TxConstraint ] TxConstraint)
(fun
[ List [ List TxConstraint ] ] TxConstraint
)
)
(vardecl
MustSpendAtLeast
Expand Down Expand Up @@ -11830,7 +11832,7 @@
]
(lam
xs
[ List TxConstraint ]
[ List [ List TxConstraint ] ]
{
[
[
Expand All @@ -11852,7 +11854,10 @@
Bool
]
}
TxConstraint
[
List
TxConstraint
]
}
[
{
Expand All @@ -11862,17 +11867,42 @@
fAdditiveMonoidBool
]
]
(lam
w
TxConstraint
[
[
{
{
fFoldableNil_cfoldMap
[
(lam
a
(type)
a
)
Bool
]
}
TxConstraint
}
[
wcheckTxConstraint
ww
{
fMonoidProduct
Bool
}
fMultiplicativeMonoidBool
]
w
]
)
(lam
w
TxConstraint
[
[
wcheckTxConstraint
ww
]
w
]
)
]
]
xs
]
Expand Down
46 changes: 36 additions & 10 deletions plutus-use-cases/test/Spec/multisigStateMachine.pir
View file
Original file line number Diff line number Diff line change
Expand Up @@ -6069,7 +6069,7 @@
)
(vardecl
MustSatisfyAnyOf
(fun [ List TxConstraint ] TxConstraint)
(fun [ List [ List TxConstraint ] ] TxConstraint)
)
(vardecl
MustSpendAtLeast
Expand Down Expand Up @@ -11291,7 +11291,7 @@
]
(lam
xs
[ List TxConstraint ]
[ List [ List TxConstraint ] ]
{
[
[
Expand All @@ -11311,7 +11311,10 @@
Bool
]
}
TxConstraint
[
List
TxConstraint
]
}
[
{
Expand All @@ -11320,17 +11323,40 @@
fAdditiveMonoidBool
]
]
(lam
w
TxConstraint
[
[
{
{
fFoldableNil_cfoldMap
[
(lam
a (type) a
)
Bool
]
}
TxConstraint
}
[
wcheckTxConstraint
ww
{
fMonoidProduct
Bool
}
fMultiplicativeMonoidBool
]
w
]
)
(lam
w
TxConstraint
[
[
wcheckTxConstraint
ww
]
w
]
)
]
]
xs
]
Expand Down
Loading

0 comments on commit 40b63ed

Please sign in to comment.