diff --git a/marlowe-test/src/Spec/Marlowe/Plutus/Specification.hs b/marlowe-test/src/Spec/Marlowe/Plutus/Specification.hs index 7ba097ee0c..7aee07445e 100644 --- a/marlowe-test/src/Spec/Marlowe/Plutus/Specification.hs +++ b/marlowe-test/src/Spec/Marlowe/Plutus/Specification.hs @@ -22,7 +22,7 @@ module Spec.Marlowe.Plutus.Specification tests ) where -import Control.Lens (use, uses, (%=), (<>=), (<~), (^.)) +import Control.Lens (use, uses, (%=), (.=), (<>=), (<~), (^.)) import Control.Monad.State (lift) import Data.Bifunctor (bimap) import Data.List (nub) @@ -204,6 +204,11 @@ tests referencePaths = [ testProperty "Invalid other validators during payment" $ checkOtherValidators referencePaths ] + , testGroup "Constraint 19. No duplicates" + [ + testProperty "Invalid duplicate accounts in input state" checkInputDuplicates + -- TODO: This test on the output state requires instrumenting the Plutus script. For now, this constraint is enforced manually by code inspection. + ] , testProperty "Script hash matches reference hash" $ checkValidatorHash semanticsScriptHash -- DO NOT ALTER THE FOLLOWING VALUE UNLESS YOU ARE COMMITTING @@ -503,6 +508,48 @@ checkInputDuplicates referencePaths = checkSemanticsTransaction referencePaths modifyBefore noModify hasDuplicates False False +-- | Add a duplicate entry to an assocation list. +addDuplicate :: Arbitrary v => AM.Map k v -> Gen (AM.Map k v) +addDuplicate am = + do + let + am' = AM.toList am + key <- elements $ fst <$> am' + value <- arbitrary + AM.fromList <$> Q.shuffle ((key, value) : am') + + +-- | Check for the detection of duplicates in input state +checkInputDuplicates :: Property +checkInputDuplicates = + let + hasDuplicates tx = + let + hasDuplicate am = length (AM.keys am) /= length (nub $ AM.keys am) + M.State{..} = tx ^. inputState + in + hasDuplicate accounts + || hasDuplicate choices + || hasDuplicate boundValues + makeDuplicates am = + if AM.null am + then pure am + else oneof [pure am, addDuplicate am] + modifyBefore = + do + M.State{..} <- use inputState + state' <- + lift + $ M.State + <$> makeDuplicates accounts + <*> makeDuplicates choices + <*> makeDuplicates boundValues + <*> pure minTime + inputState .= state' + in + checkSemanticsTransaction modifyBefore noModify hasDuplicates False False + + -- | Check that output datum to a script matches its semantic output. checkDatumOutput :: [ReferencePath] -> (MarloweData -> Gen MarloweData) -> Property checkDatumOutput referencePaths perturb =