test(standing_bid): fix positive test for NewBid redeemer

Author: errfrom

Makefile

@@ -7,7 +7,7 @@ build:
 	cabal v2-build all
 
 test:
-	cabal v2-test
+	cabal v2-test --test-show-details=streaming --test-options="--quickcheck-tests=100"
 
 repl:
 	cabal v2-repl hydra-auction-onchain --ghc-options '-Wno-missing-import-lists'

src/HydraAuctionOnchain/Types/BidTerms.hs

@@ -73,7 +73,7 @@ bidderSignatureMessage
       )
 bidderSignatureMessage = phoistAcyclic $
   plam $ \auctionCs bidPrice bidderPkh ->
-    (pserialise # auctionCs) <> (pserialise # bidPrice) <> (pserialise # bidderPkh)
+    (pserialise # auctionCs) <> (pserialise # bidderPkh) <> (pserialise # bidPrice)
 
 sellerSignatureMessage :: Term s (PCurrencySymbol :--> PByteString :--> PByteString)
 sellerSignatureMessage = phoistAcyclic $

test/Spec/HydraAuctionOnchain/Helpers.hs

@@ -1,5 +1,6 @@
 module Spec.HydraAuctionOnchain.Helpers
   ( hashVerificationKey
+  , intervalFiniteClosedOpen
   , mkStandingBidTokenValue
   , serialise
   ) where
@@ -10,7 +11,15 @@ import Data.ByteArray (convert)
 import Data.ByteString (ByteString)
 import PlutusLedgerApi.V1 (CurrencySymbol, Value)
 import PlutusLedgerApi.V1.Value qualified as Value (singleton)
-import PlutusLedgerApi.V2 (BuiltinByteString, PubKeyHash (PubKeyHash), toBuiltin)
+import PlutusLedgerApi.V2
+  ( BuiltinByteString
+  , Extended (Finite)
+  , Interval (Interval)
+  , LowerBound (LowerBound)
+  , PubKeyHash (PubKeyHash)
+  , UpperBound (UpperBound)
+  , toBuiltin
+  )
 import PlutusTx (ToData, toBuiltinData)
 import PlutusTx.Builtins (serialiseData)
 
@@ -28,6 +37,10 @@ hashVerificationKey vkey =
         . convert
         $ hash @PublicKey @Blake2b_224 vkey
 
+intervalFiniteClosedOpen :: a -> a -> Interval a
+intervalFiniteClosedOpen a b =
+  Interval (LowerBound (Finite a) True) (UpperBound (Finite b) False)
+
 mkStandingBidTokenValue :: CurrencySymbol -> Value
 mkStandingBidTokenValue cs = Value.singleton cs "STANDING_BID" 1
 

test/Spec/HydraAuctionOnchain/QuickCheck/Gen.hs

@@ -45,7 +45,6 @@ import Test.QuickCheck
   , chooseInt
   , chooseInteger
   , liftArbitrary
-  , suchThat
   , vector
   )
 
@@ -62,6 +61,9 @@ genKeyPair =
     let (skey, _) = withDRG (drgNewTest seed) generateSecretKey
     in KeyPair skey $ toPublic skey
 
+genIntegerGreaterThan :: Integer -> Gen Integer
+genIntegerGreaterThan a = arbitrary @(Positive Integer) <&> \(Positive b) -> a + b
+
 genTxInfoTemplate :: Gen TxInfo
 genTxInfoTemplate = do
   txInfoFeeAda <- arbitrary @Integer
@@ -82,15 +84,29 @@ genTxInfoTemplate = do
       , txInfoId
       }
 
-genValidBidTerms :: CurrencySymbol -> AuctionTerms -> KeyPair -> KeyPair -> Gen BidTerms
-genValidBidTerms auctionCs auctionTerms sellerKeys bidderKeys = do
+genValidBidTerms
+  :: CurrencySymbol
+  -> AuctionTerms
+  -> KeyPair
+  -> KeyPair
+  -> Maybe Integer
+  -> Gen BidTerms
+genValidBidTerms auctionCs auctionTerms sellerKeys bidderKeys mOldBidPrice = do
   let (bi'BidderVk, bi'BidderPkh) = hashVerificationKey $ vkey bidderKeys
   let bt'Bidder = BidderInfo {..}
-  bt'BidPrice <- arbitrary @Integer `suchThat` (\x -> x > at'StartingBid auctionTerms)
+  bt'BidPrice <- genBidPrice
   let bt'SellerSignature = sellerSignature bi'BidderVk
   let bt'BidderSignature = bidderSignature bt'BidPrice bi'BidderPkh
   pure BidTerms {..}
   where
+    genBidPrice :: Gen Integer
+    genBidPrice =
+      case mOldBidPrice of
+        Just oldBidPrice ->
+          genIntegerGreaterThan $ oldBidPrice + at'MinBidIncrement auctionTerms
+        Nothing ->
+          genIntegerGreaterThan $ at'StartingBid auctionTerms
+
     sellerSignature :: BuiltinByteString -> BuiltinByteString
     sellerSignature bidderVkey =
       signUsingKeyPair sellerKeys $
@@ -110,7 +126,7 @@ genValidBidState
 genValidBidState auctionCs auctionTerms sellerKeys bidderKeys =
   StandingBidState
     <$> liftArbitrary
-      (genValidBidTerms auctionCs auctionTerms sellerKeys bidderKeys)
+      (genValidBidTerms auctionCs auctionTerms sellerKeys bidderKeys Nothing)
 
 genValidNewBidState
   :: StandingBidState
@@ -120,15 +136,14 @@ genValidNewBidState
   -> KeyPair
   -> Gen StandingBidState
 genValidNewBidState oldBidState auctionCs auctionTerms sellerKeys bidderKeys =
-  case oldBidState of
-    StandingBidState Nothing ->
-      genValidBidState auctionCs auctionTerms sellerKeys bidderKeys
-    StandingBidState (Just oldBidTerms) -> do
-      newBidPrice <- arbitrary @Integer `suchThat` (\x -> x >= at'MinBidIncrement auctionTerms)
-      pure . StandingBidState . Just $
-        oldBidTerms
-          { bt'BidPrice = newBidPrice
-          }
+  StandingBidState . Just
+    <$> genValidBidTerms auctionCs auctionTerms sellerKeys bidderKeys oldBidPrice
+  where
+    oldBidPrice :: Maybe Integer
+    oldBidPrice =
+      case oldBidState of
+        StandingBidState Nothing -> Nothing
+        StandingBidState (Just oldBidTerms) -> Just $ bt'BidPrice oldBidTerms
 
 genValidAuctionTerms :: PublicKey -> Gen AuctionTerms
 genValidAuctionTerms vkey = do
@@ -145,10 +160,10 @@ genValidAuctionTerms vkey = do
   let at'Cleanup = at'PurchaseDeadline + penaltyPeriod
 
   let minAuctionFeePerDelegate = 2_000_000
-  at'AuctionFeePerDelegate <- arbitrary @Integer `suchThat` (\x -> x > minAuctionFeePerDelegate)
+  at'AuctionFeePerDelegate <- genIntegerGreaterThan minAuctionFeePerDelegate
 
   let minStartingBid = at'AuctionFeePerDelegate * fromIntegral (length at'Delegates)
-  at'StartingBid <- arbitrary @Integer `suchThat` (\x -> x > minStartingBid)
+  at'StartingBid <- genIntegerGreaterThan minStartingBid
 
   Positive at'MinBidIncrement <- arbitrary @(Positive Integer)
   NonNegative at'MinDepositAmount <- arbitrary @(NonNegative Integer)

test/Spec/HydraAuctionOnchain/Types/AuctionTerms.hs

@@ -1,16 +1,19 @@
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Spec.HydraAuctionOnchain.Types.AuctionTerms
   ( AuctionTerms (..)
+  , biddingPeriod
   ) where
 
 import HydraAuctionOnchain.Types.AuctionTerms (PAuctionTerms)
 import Plutarch.DataRepr (DerivePConstantViaData (DerivePConstantViaData))
 import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
-import PlutusLedgerApi.V2 (BuiltinByteString, POSIXTime, PubKeyHash, Value)
+import PlutusLedgerApi.V2 (BuiltinByteString, POSIXTime, POSIXTimeRange, PubKeyHash, Value)
 import PlutusTx (makeIsDataIndexed)
+import Spec.HydraAuctionOnchain.Helpers (intervalFiniteClosedOpen)
 
 data AuctionTerms = AuctionTerms
   { at'AuctionLot :: Value
@@ -37,3 +40,10 @@ deriving via
 
 instance PUnsafeLiftDecl PAuctionTerms where
   type PLifted PAuctionTerms = AuctionTerms
+
+--------------------------------------------------------------------------------
+-- Auction Lifecycle
+--------------------------------------------------------------------------------
+
+biddingPeriod :: AuctionTerms -> POSIXTimeRange
+biddingPeriod AuctionTerms {..} = intervalFiniteClosedOpen at'BiddingStart at'BiddingEnd

test/Spec/HydraAuctionOnchain/Validators/StandingBid.hs

@@ -40,7 +40,7 @@ import Spec.HydraAuctionOnchain.QuickCheck.Gen
   , genValidNewBidState
   , vkey
   )
-import Spec.HydraAuctionOnchain.Types.AuctionTerms (AuctionTerms)
+import Spec.HydraAuctionOnchain.Types.AuctionTerms (AuctionTerms, biddingPeriod)
 import Spec.HydraAuctionOnchain.Types.Redeemers (StandingBidRedeemer (NewBidRedeemer))
 import Spec.HydraAuctionOnchain.Types.StandingBidState (StandingBidState)
 import Test.QuickCheck (Arbitrary (arbitrary), Property)
@@ -57,10 +57,14 @@ spec =
         ]
     ]
 
-prop_newBid_validInput_succeeds :: TestContext -> Property
+--------------------------------------------------------------------------------
+-- NewBid
+--------------------------------------------------------------------------------
+
+prop_newBid_validInput_succeeds :: NewBidTestContext -> Property
 prop_newBid_validInput_succeeds testContext = shouldSucceed $ testNewBid testContext
 
-data TestContext = TestContext
+data NewBidTestContext = NewBidTestContext
   { auctionCs :: CurrencySymbol
   , auctionTerms :: AuctionTerms
   , oldBidState :: StandingBidState
@@ -71,7 +75,7 @@ data TestContext = TestContext
   }
   deriving stock (Show, Eq)
 
-instance Arbitrary TestContext where
+instance Arbitrary NewBidTestContext where
   arbitrary = do
     GenCurrencySymbol auctionCs <- arbitrary @(GenCurrencySymbol 'WithoutAdaSymbol)
     (sellerKeys, bidderKeys) <- (,) <$> genKeyPair <*> genKeyPair
@@ -81,10 +85,10 @@ instance Arbitrary TestContext where
     txInfoTemplate <- genTxInfoTemplate
     standingBidInputOref <- arbitrary @TxOutRef
     scriptAddress <- flip Address Nothing . ScriptCredential <$> arbitrary @ScriptHash
-    pure TestContext {..}
+    pure NewBidTestContext {..}
 
-testNewBid :: TestContext -> Script
-testNewBid TestContext {..} =
+testNewBid :: NewBidTestContext -> Script
+testNewBid NewBidTestContext {..} =
   let
     standingBidTokenValue :: Value
     standingBidTokenValue = mkStandingBidTokenValue auctionCs
@@ -124,6 +128,7 @@ testNewBid TestContext {..} =
             txInfoTemplate
               { txInfoInputs = singleton standingBidInput
               , txInfoOutputs = singleton standingBidOutput
+              , txInfoValidRange = biddingPeriod auctionTerms
               , txInfoRedeemers = AMap.singleton scriptPurpose redeemer
               }
         , scriptContextPurpose = scriptPurpose