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

Commit 6e7bfb4

Browse files
koslambroukoslambrou
committed
PLT-1034 Fixed SealedBidAuction failing quickcheck test case.
* Fixed the SealedBidAuction failing quickcheck test case * Documented the issue concerning validity intervals and outlined the issue with cardano-ledger. * Added a global limit of 100 for number of generated test cases for quickcheck. This can be override on individual property tests using 'withMaxSuccess'. * Added a test case for Crowdfunding to verify that we can't make a contribution if the deadline is elapsed.
1 parent 6efc2e1 commit 6e7bfb4

16 files changed

+3466
-1757
lines changed

‎plutus-use-cases/src/Plutus/Contracts.hs‎

Lines changed: 24 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -43,12 +43,31 @@ inputs.
4343

4444
{- Note [Validity Interval's upper bound]
4545
46-
During the transition from plutus validation rules to cardano-ledger validation rules
47-
we have found that the cardan-ledger has a problem with validity interval's upper bound.
46+
During the transition from `plutus-apps` ledger validation rules to
47+
`cardano-ledger` validation rules we have found that the `cardano-ledger` has a
48+
problem with the translation from the transaction's upper bound slot to the
49+
'TxInfo' validity range upper bound time. By definition, as given by the ledger
50+
specification, the upper bound should be open (exclusive) but they convert it
51+
as a closed bound.
4852
49-
They don't convert it properly. By definition the top should be open but they convert it as
50-
a closed bound. Because of that we have to do double 'pred' or '-2' operation to make
53+
We encountered this issue by getting a Phase 2 validation error when doing:
54+
55+
@
56+
txValidityTimeRange `contains` txInfoValidRange scriptContextTxInfo
57+
@
58+
59+
in a Plutus validation script if 'txValidityTimeRange' does not define a lower
60+
bound (using 'NegInf').
61+
62+
Because of that, we have to do 'pred . pred' or '-2' operation to make the
5163
'to' function behaviour as expected.
64+
For more info on the bug, see https://github.com/input-output-hk/cardano-ledger/issues/3043.
65+
Note that this bug will be fixed in a future HF (next HF after Vasil -> PlutusV3 or later).
5266
53-
https://github.com/input-output-hk/cardano-ledger/issues/3043
67+
IMPORTANT OUTLINE: This bug is ONLY triggered in the following conditions:
68+
* you submit a transaction which tries to spend a script output or mints a value
69+
* the transaction does not define a lower bound (uses 'NegInf')
70+
* the transaction's Plutus script does a comparison between a provided time
71+
range with the 'TxInfo' valid range. Something like:
72+
'txValidityTimeRange `contains` txInfoValidRange scriptContextTxInfo'
5473
-}

‎plutus-use-cases/src/Plutus/Contracts/Crowdfunding.hs‎

Lines changed: 8 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -59,6 +59,7 @@ import Ledger (PaymentPubKeyHash (unPaymentPubKeyHash), getCardanoTxId)
5959
import Ledger qualified
6060
import Ledger.Ada qualified as Ada
6161
import Ledger.Constraints qualified as Constraints
62+
import Ledger.Interval (Extended (NegInf), Interval (Interval), LowerBound (LowerBound))
6263
import Ledger.Interval qualified as Interval
6364
import Ledger.TimeSlot qualified as TimeSlot
6465
import Ledger.Typed.Scripts qualified as Scripts hiding (validatorHash)
@@ -123,8 +124,9 @@ mkCampaign ddl collectionDdl ownerWallet =
123124
{-# INLINABLE collectionRange #-}
124125
collectionRange :: Campaign -> PV1.POSIXTimeRange
125126
collectionRange cmp =
126-
-- We have to subtract '2', see Note [Validity Interval's upper bound]
127-
Interval.interval (campaignDeadline cmp) (campaignCollectionDeadline cmp - 2)
127+
Interval
128+
(Interval.lowerBound $ campaignDeadline cmp)
129+
(Interval.strictUpperBound $ campaignCollectionDeadline cmp)
128130

129131
-- | The 'POSIXTimeRange' during which a refund may be claimed
130132
{-# INLINABLE refundRange #-}
@@ -206,9 +208,11 @@ contribute cmp = endpoint @"contribute" $ \Contribution{contribValue} -> do
206208
logInfo @Text $ "Contributing " <> Text.pack (Haskell.show contribValue)
207209
contributor <- ownFirstPaymentPubKeyHash
208210
let inst = typedValidator cmp
211+
validityTimeRange =
212+
Interval (LowerBound NegInf True)
213+
(Interval.strictUpperBound $ campaignDeadline cmp)
209214
tx = Constraints.mustPayToTheScriptWithDatumInTx contributor contribValue
210-
-- We have to subtract '2', see Note [Validity Interval's upper bound]
211-
<> Constraints.mustValidateIn (Interval.to (campaignDeadline cmp))
215+
<> Constraints.mustValidateIn validityTimeRange
212216
txid <- fmap getCardanoTxId $ mkTxConstraints (Constraints.typedValidatorLookups inst) tx
213217
>>= adjustUnbalancedTx >>= submitUnbalancedTx
214218

‎plutus-use-cases/src/Plutus/Contracts/Escrow.hs‎

Lines changed: 18 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -292,24 +292,28 @@ redeem ::
292292
-> Contract w s e RedeemSuccess
293293
redeem inst escrow = mapError (review _EscrowError) $ do
294294
let addr = Scripts.validatorAddress inst
295-
current <- currentTime
296295
unspentOutputs <- utxosAt addr
297-
let
298-
-- We have to do 'pred' twice, see Note [Validity Interval's upper bound]
299-
valRange = Interval.to (Haskell.pred $ Haskell.pred $ escrowDeadline escrow)
300-
tx = Constraints.collectFromTheScript unspentOutputs Redeem
301-
<> foldMap mkTx (escrowTargets escrow)
302-
<> Constraints.mustValidateIn valRange
296+
current <- currentTime
303297
if current >= escrowDeadline escrow
304298
then throwing _RedeemFailed DeadlinePassed
305299
else if foldMap (view Tx.ciTxOutValue) unspentOutputs `lt` targetTotal escrow
306-
then throwing _RedeemFailed NotEnoughFundsAtAddress
307-
else do
308-
utx <- mkTxConstraints ( Constraints.typedValidatorLookups inst
309-
<> Constraints.unspentOutputs unspentOutputs
310-
) tx
311-
adjusted <- adjustUnbalancedTx utx
312-
RedeemSuccess . getCardanoTxId <$> submitUnbalancedTx adjusted
300+
then throwing _RedeemFailed NotEnoughFundsAtAddress
301+
else do
302+
let
303+
-- Correct validity interval should be:
304+
-- @
305+
-- Interval (LowerBound NegInf True) (Interval.scriptUpperBound $ escrowDeadline escrow)
306+
-- @
307+
-- See Note [Validity Interval's upper bound]
308+
validityTimeRange = Interval.to (Haskell.pred $ Haskell.pred $ escrowDeadline escrow)
309+
tx = Constraints.collectFromTheScript unspentOutputs Redeem
310+
<> foldMap mkTx (escrowTargets escrow)
311+
<> Constraints.mustValidateIn validityTimeRange
312+
utx <- mkTxConstraints ( Constraints.typedValidatorLookups inst
313+
<> Constraints.unspentOutputs unspentOutputs
314+
) tx
315+
adjusted <- adjustUnbalancedTx utx
316+
RedeemSuccess . getCardanoTxId <$> submitUnbalancedTx adjusted
313317

314318
newtype RefundSuccess = RefundSuccess TxId
315319
deriving newtype (Haskell.Eq, Haskell.Show, Generic)

‎plutus-use-cases/src/Plutus/Contracts/Governance.hs‎

Lines changed: 7 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -181,9 +181,14 @@ transition Params{..} State{ stateData = s, stateValue} i = case (s, i) of
181181

182182
(GovState law mph (Just (Voting p oldMap)), AddVote tokenName vote) ->
183183
let newMap = AssocMap.insert tokenName vote oldMap
184+
-- Correct validity interval should be:
185+
-- @
186+
-- Interval (LowerBound NegInf True) (Interval.scriptUpperBound $ votingDeadline p)
187+
-- @
188+
-- See Note [Validity Interval's upper bound]
189+
validityTimeRange = Interval.to (votingDeadline p - 2)
184190
constraints = ownsVotingToken mph tokenName
185-
-- We have to subtract '2', see Note [Validity Interval's upper bound]
186-
<> Constraints.mustValidateIn (Interval.to (votingDeadline p - 2))
191+
<> Constraints.mustValidateIn validityTimeRange
187192
in Just (constraints, State (GovState law mph (Just (Voting p newMap))) stateValue)
188193

189194
(GovState oldLaw mph (Just (Voting p votes)), FinishVoting) ->

‎plutus-use-cases/src/Plutus/Contracts/MultiSigStateMachine.hs‎

Lines changed: 7 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -221,9 +221,14 @@ transition params State{ stateData =s, stateValue=currentValue} i = case (s, i)
221221
(CollectingSignatures payment pkh, Pay)
222222
| proposalAccepted params pkh ->
223223
let Payment{paymentAmount, paymentRecipient, paymentDeadline} = payment
224+
-- Correct validity interval should be:
225+
-- @
226+
-- Interval (LowerBound NegInf True) (Interval.scriptUpperBound $ paymentDeadline p)
227+
-- @
228+
-- See Note [Validity Interval's upper bound]
229+
validityTimeRange = Interval.to $ paymentDeadline - 2
224230
constraints =
225-
-- We have to subtract '2', see Note [Validity Interval's upper bound]
226-
Constraints.mustValidateIn (Interval.to $ paymentDeadline - 2)
231+
Constraints.mustValidateIn validityTimeRange
227232
<> Constraints.mustPayToPubKey paymentRecipient paymentAmount
228233
newValue = currentValue - paymentAmount
229234
in Just ( constraints

‎plutus-use-cases/src/Plutus/Contracts/SealedBidAuction.hs‎

Lines changed: 20 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -37,6 +37,7 @@ import Ledger (POSIXTime, PaymentPubKeyHash, Value)
3737
import Ledger.Ada qualified as Ada
3838
import Ledger.Constraints qualified as Constraints
3939
import Ledger.Constraints.TxConstraints (TxConstraints)
40+
import Ledger.Interval (Interval (Interval))
4041
import Ledger.Interval qualified as Interval
4142
import Ledger.Typed.Scripts qualified as Scripts
4243
import Ledger.Value qualified as Value
@@ -175,8 +176,13 @@ auctionTransition AuctionParams{apOwner, apAsset, apEndTime, apPayoutTime} State
175176
-- A new bid is placed, a bidder is only allowed to bid once
176177
(Ongoing bids, PlaceBid bid)
177178
| sealedBidBidder bid `notElem` map sealedBidBidder bids ->
178-
-- We have to subtract '2', see Note [Validity Interval's upper bound]
179-
let constraints = Constraints.mustValidateIn (Interval.to $ apEndTime - 2)
179+
-- Correct validity interval should be:
180+
-- @
181+
-- Interval (LowerBound NegInf True) (Interval.scriptUpperBound apEndTime)
182+
-- @
183+
-- See Note [Validity Interval's upper bound]
184+
let validityTimeRange = Interval.to $ apEndTime - 2
185+
constraints = Constraints.mustValidateIn validityTimeRange
180186
newState =
181187
State
182188
{ stateData = Ongoing (bid:bids)
@@ -187,8 +193,11 @@ auctionTransition AuctionParams{apOwner, apAsset, apEndTime, apPayoutTime} State
187193
-- The first bid is revealed
188194
(Ongoing bids, RevealBid bid)
189195
| sealBid bid `elem` bids ->
190-
-- We have to subtract '2', see Note [Validity Interval's upper bound]
191-
let constraints = Constraints.mustValidateIn (Interval.interval apEndTime (apPayoutTime - 2))
196+
let validityTimeRange =
197+
Interval
198+
(Interval.lowerBound apEndTime)
199+
(Interval.strictUpperBound apPayoutTime)
200+
constraints = Constraints.mustValidateIn validityTimeRange
192201
newState =
193202
State
194203
{ stateData = AwaitingPayout bid (filter (/= sealBid bid) bids)
@@ -212,8 +221,13 @@ auctionTransition AuctionParams{apOwner, apAsset, apEndTime, apPayoutTime} State
212221
(AwaitingPayout highestBid sealedBids, RevealBid bid)
213222
| revealedBid bid > revealedBid highestBid
214223
&& sealBid bid `elem` sealedBids ->
215-
-- We have to subtract '2', see Note [Validity Interval's upper bound]
216-
let constraints = Constraints.mustValidateIn (Interval.to $ apPayoutTime - 2)
224+
-- Correct validity interval should be:
225+
-- @
226+
-- Interval (LowerBound NegInf True) (Interval.scriptUpperBound apPayoutTime)
227+
-- @
228+
-- See Note [Validity Interval's upper bound]
229+
let validityTimeRange = Interval.to $ apPayoutTime - 2
230+
constraints = Constraints.mustValidateIn validityTimeRange
217231
<> Constraints.mustPayToPubKey (revealedBidBidder highestBid) (valueOfBid highestBid)
218232
newState =
219233
State

‎plutus-use-cases/src/Plutus/Contracts/SimpleEscrow.hs‎

Lines changed: 12 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -125,7 +125,11 @@ validate params action ScriptContext{scriptContextTxInfo=txInfo} =
125125
-- requirement that the transaction validates before the 'deadline'.
126126
lockEp :: Promise () EscrowSchema EscrowError ()
127127
lockEp = endpoint @"lock" $ \params -> do
128-
-- We have to do 'pred' twice, see Note [Validity Interval's upper bound]
128+
-- Correct validity interval should be:
129+
-- @
130+
-- Interval (LowerBound NegInf True) (Interval.scriptUpperBound $ deadline params)
131+
-- @
132+
-- See Note [Validity Interval's upper bound]
129133
let valRange = Interval.to (Haskell.pred $ Haskell.pred $ deadline params)
130134
tx = Constraints.mustPayToTheScriptWithDatumInTx params (paying params)
131135
<> Constraints.mustValidateIn valRange
@@ -143,9 +147,14 @@ redeemEp = endpoint @"redeem" redeem
143147
unspentOutputs <- utxosAt escrowAddress
144148

145149
let value = foldMap (view Tx.ciTxOutValue) unspentOutputs
150+
-- Correct validity interval should be:
151+
-- @
152+
-- Interval (LowerBound NegInf True) (Interval.scriptUpperBound $ deadline params)
153+
-- @
154+
-- See Note [Validity Interval's upper bound]
155+
validityTimeRange = Interval.to (Haskell.pred $ Haskell.pred $ deadline params)
146156
tx = Constraints.collectFromTheScript unspentOutputs Redeem
147-
-- We have to do 'pred' twice, see Note [Validity Interval's upper bound]
148-
<> Constraints.mustValidateIn (Interval.to (Haskell.pred $ Haskell.pred $ deadline params))
157+
<> Constraints.mustValidateIn validityTimeRange
149158
-- Pay me the output of this script
150159
<> Constraints.mustPayToPubKey pk value
151160
-- Pay the payee their due

‎plutus-use-cases/test/Spec.hs‎

Lines changed: 10 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -25,19 +25,22 @@ import Spec.Vesting qualified
2525

2626
import Test.Tasty
2727
import Test.Tasty.Hedgehog (HedgehogTestLimit (..))
28+
import Test.Tasty.QuickCheck (QuickCheckTests (QuickCheckTests))
2829

2930
main :: IO ()
3031
main = defaultMain tests
3132

32-
-- | Number of successful tests for each hedgehog property.
33-
-- The default is 100 but we use a smaller number here in order to speed up
34-
-- the test suite.
35-
--
36-
limit :: HedgehogTestLimit
37-
limit = HedgehogTestLimit (Just 5)
33+
-- | Number of successful tests for each property test.
34+
-- You can override this number for a specific property test by using
35+
-- 'Test.Tasty.Quickcheck.withMaxSuccess'.
36+
limit :: Int
37+
limit = 100
3838

3939
tests :: TestTree
40-
tests = localOption limit $ testGroup "use cases" [
40+
tests =
41+
localOption (HedgehogTestLimit (Just $ fromIntegral limit))
42+
$ localOption (QuickCheckTests limit)
43+
$ testGroup "use cases" [
4144
Spec.Crowdfunding.tests,
4245
Spec.Vesting.tests,
4346
Spec.ErrorHandling.tests,

‎plutus-use-cases/test/Spec/Auction.hs‎

Lines changed: 2 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -363,10 +363,8 @@ tests =
363363
.&&. walletFundsChange w2 (inv (Ada.toValue trace2WinningBid) <> theToken)
364364
.&&. walletFundsChange w3 mempty)
365365
auctionTrace2
366-
, testProperty "QuickCheck property FinishAuction" $
367-
withMaxSuccess 100 prop_FinishAuction
368-
, testProperty "QuickCheck property Auction" $
369-
withMaxSuccess 100 prop_Auction
366+
, testProperty "QuickCheck property FinishAuction" prop_FinishAuction
367+
, testProperty "QuickCheck property Auction" prop_Auction
370368
, testProperty "NLFP fails" $ expectFailure $ noShrinking prop_NoLockedFunds
371369
, testProperty "prop_Reactive" $
372370
withMaxSuccess 1000 (propSanityCheckReactive @AuctionModel)

‎plutus-use-cases/test/Spec/Crowdfunding.hs‎

Lines changed: 13 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -88,6 +88,18 @@ tests = testGroup "crowdfunding"
8888
(walletFundsChange w1 (Ada.adaValueOf 22.5))
8989
successfulCampaign
9090

91+
, checkPredicate "cannot make contribution after campaign dealine"
92+
(walletFundsChange w1 PlutusTx.zero
93+
.&&. assertFailedTransaction (\_ err ->
94+
case err of
95+
Ledger.CardanoLedgerValidationError msg ->
96+
"OutsideValidityIntervalUTxO" `Text.isInfixOf` msg
97+
_ -> False
98+
))
99+
$ do
100+
void $ Trace.waitUntilSlot $ Slot 20
101+
makeContribution w1 (Ada.adaValueOf 10)
102+
91103
, checkPredicate "cannot collect money too late"
92104
(walletFundsChange w1 PlutusTx.zero
93105
.&&. assertFailedTransaction (\_ err ->
@@ -159,8 +171,7 @@ tests = testGroup "crowdfunding"
159171

160172
-- TODO: Linked to https://github.com/input-output-hk/plutus-apps/issues/754
161173
-- Re-activate once issue is resolved
162-
-- , testProperty "QuickCheck ContractModel" $ withMaxSuccess 100 prop_Crowdfunding
163-
174+
-- , testProperty "QuickCheck ContractModel" prop_Crowdfunding
164175
]
165176

166177
where

0 commit comments

Comments
 (0)