Skip to content

Commit 2e7ff00

Browse files
errfromerrfrom
committed
test(standing_bid): add positive test
1 parent 784a696 commit 2e7ff00

File tree

7 files changed

+315
-80
lines changed

7 files changed

+315
-80
lines changed

‎hydra-auction-onchain.cabal‎

Lines changed: 6 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -154,8 +154,10 @@ test-suite hydra-auction-onchain-test
154154
hs-source-dirs: test
155155
main-is: Spec.hs
156156
other-modules:
157-
Spec.HydraAuctionOnchain.Gen
157+
Spec.HydraAuctionOnchain.Expectations
158158
Spec.HydraAuctionOnchain.Helpers
159+
Spec.HydraAuctionOnchain.QuickCheck.Gen
160+
Spec.HydraAuctionOnchain.QuickCheck.Modifiers
159161
Spec.HydraAuctionOnchain.Types.AuctionTerms
160162
Spec.HydraAuctionOnchain.Types.BidderInfo
161163
Spec.HydraAuctionOnchain.Types.BidTerms
@@ -164,7 +166,10 @@ test-suite hydra-auction-onchain-test
164166
Spec.HydraAuctionOnchain.Validators.StandingBid
165167

166168
build-depends:
169+
, bytestring
170+
, cryptonite
167171
, hydra-auction-onchain
172+
, memory
168173
, plutarch
169174
, plutarch-quickcheck
170175
, plutus-ledger-api

‎test/Spec/HydraAuctionOnchain/Expectations.hs‎

Lines changed: 40 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,40 @@
1+
module Spec.HydraAuctionOnchain.Expectations
2+
( shouldFail
3+
, shouldSucceed
4+
) where
5+
6+
import Data.Text.Lazy qualified as TL (unpack)
7+
import Plutarch (Script)
8+
import Plutarch.Evaluate (evalScript)
9+
import Test.Tasty.QuickCheck (Property, counterexample, property)
10+
import Text.Pretty.Simple (pShow)
11+
12+
shouldFail :: Script -> Property
13+
shouldFail script =
14+
case result of
15+
Left _ -> property True
16+
Right _ ->
17+
counterexample "Expected failure, but succeeded instead."
18+
. counterexample (showLogs logs)
19+
. property
20+
$ False
21+
where
22+
(result, _exUnits, logs) = evalScript script
23+
24+
shouldSucceed :: Script -> Property
25+
shouldSucceed script =
26+
case result of
27+
Left err ->
28+
counterexample "Expected success, but failed instead."
29+
. counterexample ("Error: " <> show err)
30+
. counterexample (showLogs logs)
31+
. property
32+
$ False
33+
Right _ -> property True
34+
where
35+
(result, _exUnits, logs) = evalScript script
36+
37+
showLogs :: Show a => [a] -> String
38+
showLogs = \case
39+
[] -> "No logs found. Did you forget to compile with tracing on?"
40+
logs -> TL.unpack $ pShow logs

‎test/Spec/HydraAuctionOnchain/Gen.hs‎

Lines changed: 0 additions & 30 deletions
This file was deleted.

‎test/Spec/HydraAuctionOnchain/Helpers.hs‎

Lines changed: 29 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -1,40 +1,36 @@
11
module Spec.HydraAuctionOnchain.Helpers
2-
( shouldFail
3-
, shouldSucceed
2+
( hashVerificationKey
3+
, mkStandingBidTokenValue
4+
, serialise
45
) where
56

6-
import Data.Text.Lazy qualified as TL (unpack)
7-
import Plutarch (Script)
8-
import Plutarch.Evaluate (evalScript)
9-
import Test.Tasty.QuickCheck (Property, counterexample, property)
10-
import Text.Pretty.Simple (pShow)
7+
import Crypto.Hash (Blake2b_224, hash)
8+
import Crypto.PubKey.Ed25519 (PublicKey)
9+
import Data.ByteArray (convert)
10+
import Data.ByteString (ByteString)
11+
import PlutusLedgerApi.V1 (CurrencySymbol, Value)
12+
import PlutusLedgerApi.V1.Value qualified as Value (singleton)
13+
import PlutusLedgerApi.V2 (BuiltinByteString, PubKeyHash (PubKeyHash), toBuiltin)
14+
import PlutusTx (ToData, toBuiltinData)
15+
import PlutusTx.Builtins (serialiseData)
1116

12-
shouldFail :: Script -> Property
13-
shouldFail script =
14-
case result of
15-
Left _ -> property True
16-
Right _ ->
17-
counterexample "Expected failure, but succeeded instead."
18-
. counterexample (showLogs logs)
19-
. property
20-
$ False
17+
hashVerificationKey :: PublicKey -> (BuiltinByteString, PubKeyHash)
18+
hashVerificationKey vkey =
19+
(vkeyBytes, pubKeyHash)
2120
where
22-
(result, _exUnits, logs) = evalScript script
21+
vkeyBytes :: BuiltinByteString
22+
vkeyBytes = toBuiltin @ByteString $ convert vkey
2323

24-
shouldSucceed :: Script -> Property
25-
shouldSucceed script =
26-
case result of
27-
Left err ->
28-
counterexample "Expected success, but failed instead."
29-
. counterexample ("Error: " <> show err)
30-
. counterexample (showLogs logs)
31-
. property
32-
$ False
33-
Right _ -> property True
34-
where
35-
(result, _exUnits, logs) = evalScript script
24+
pubKeyHash :: PubKeyHash
25+
pubKeyHash =
26+
PubKeyHash
27+
. toBuiltin @ByteString
28+
. convert
29+
$ hash @PublicKey @Blake2b_224 vkey
30+
31+
mkStandingBidTokenValue :: CurrencySymbol -> Value
32+
mkStandingBidTokenValue cs = Value.singleton cs "STANDING_BID" 1
3633

37-
showLogs :: Show a => [a] -> String
38-
showLogs = \case
39-
[] -> "No logs found. Did you forget to compile with tracing on?"
40-
logs -> TL.unpack $ pShow logs
34+
{-# INLINEABLE serialise #-}
35+
serialise :: ToData a => a -> BuiltinByteString
36+
serialise = serialiseData . toBuiltinData

‎test/Spec/HydraAuctionOnchain/QuickCheck/Gen.hs‎

Lines changed: 155 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,155 @@
1+
{-# LANGUAGE RecordWildCards #-}
2+
3+
module Spec.HydraAuctionOnchain.QuickCheck.Gen
4+
( KeyPair (..)
5+
, genKeyPair
6+
, genTxInfoTemplate
7+
, genValidAuctionTerms
8+
, genValidBidState
9+
, genValidNewBidState
10+
) where
11+
12+
import Control.Monad (liftM3)
13+
import Crypto.PubKey.Ed25519 (PublicKey, SecretKey, generateSecretKey, sign, toPublic)
14+
import Crypto.Random (drgNewTest, withDRG)
15+
import Data.ByteArray (ByteArrayAccess, convert)
16+
import Data.ByteString (ByteString)
17+
import Data.Functor ((<&>))
18+
import Plutarch.Test.QuickCheck.Instances ()
19+
import PlutusLedgerApi.V1.Interval qualified as Interval (always)
20+
import PlutusLedgerApi.V1.Value qualified as Value (singleton)
21+
import PlutusLedgerApi.V2
22+
( BuiltinByteString
23+
, CurrencySymbol
24+
, POSIXTime (POSIXTime)
25+
, PubKeyHash
26+
, TxId
27+
, TxInfo (..)
28+
, adaSymbol
29+
, adaToken
30+
, toBuiltin
31+
)
32+
import PlutusTx.AssocMap qualified as AMap (empty)
33+
import Spec.HydraAuctionOnchain.Helpers (hashVerificationKey, serialise)
34+
import Spec.HydraAuctionOnchain.QuickCheck.Modifiers (GenNonAdaValue (GenNonAdaValue))
35+
import Spec.HydraAuctionOnchain.Types.AuctionTerms (AuctionTerms (..))
36+
import Spec.HydraAuctionOnchain.Types.BidTerms (BidTerms (..))
37+
import Spec.HydraAuctionOnchain.Types.BidderInfo (BidderInfo (..))
38+
import Spec.HydraAuctionOnchain.Types.StandingBidState (StandingBidState (StandingBidState))
39+
import Test.QuickCheck
40+
( Arbitrary (arbitrary)
41+
, Gen
42+
, NonNegative (NonNegative)
43+
, Positive (Positive)
44+
, arbitraryBoundedRandom
45+
, chooseInt
46+
, chooseInteger
47+
, liftArbitrary
48+
, suchThat
49+
, vector
50+
)
51+
52+
data KeyPair = KeyPair {skey :: SecretKey, vkey :: PublicKey}
53+
deriving stock (Show, Eq)
54+
55+
signUsingKeyPair :: ByteArrayAccess ba => KeyPair -> ba -> BuiltinByteString
56+
signUsingKeyPair KeyPair {skey, vkey} message =
57+
toBuiltin @ByteString $ convert $ sign skey vkey message
58+
59+
genKeyPair :: Gen KeyPair
60+
genKeyPair =
61+
arbitraryBoundedRandom <&> \seed ->
62+
let (skey, _) = withDRG (drgNewTest seed) generateSecretKey
63+
in KeyPair skey $ toPublic skey
64+
65+
genTxInfoTemplate :: Gen TxInfo
66+
genTxInfoTemplate = do
67+
txInfoFeeAda <- arbitrary @Integer
68+
txInfoId <- arbitrary @TxId
69+
pure $
70+
TxInfo
71+
{ txInfoInputs = mempty
72+
, txInfoReferenceInputs = mempty
73+
, txInfoOutputs = mempty
74+
, txInfoFee = Value.singleton adaSymbol adaToken txInfoFeeAda
75+
, txInfoMint = mempty
76+
, txInfoDCert = mempty
77+
, txInfoWdrl = AMap.empty
78+
, txInfoValidRange = Interval.always
79+
, txInfoSignatories = mempty
80+
, txInfoRedeemers = AMap.empty
81+
, txInfoData = AMap.empty
82+
, txInfoId
83+
}
84+
85+
genValidBidTerms :: CurrencySymbol -> AuctionTerms -> KeyPair -> KeyPair -> Gen BidTerms
86+
genValidBidTerms auctionCs auctionTerms sellerKeys bidderKeys = do
87+
let (bi'BidderVk, bi'BidderPkh) = hashVerificationKey $ vkey bidderKeys
88+
let bt'Bidder = BidderInfo {..}
89+
bt'BidPrice <- arbitrary @Integer `suchThat` (\x -> x > at'StartingBid auctionTerms)
90+
let bt'SellerSignature = sellerSignature bi'BidderVk
91+
let bt'BidderSignature = bidderSignature bt'BidPrice bi'BidderPkh
92+
pure BidTerms {..}
93+
where
94+
sellerSignature :: BuiltinByteString -> BuiltinByteString
95+
sellerSignature bidderVkey =
96+
signUsingKeyPair sellerKeys $
97+
(serialise auctionCs <> serialise bidderVkey)
98+
99+
bidderSignature :: Integer -> PubKeyHash -> BuiltinByteString
100+
bidderSignature bidPrice bidderPkh =
101+
signUsingKeyPair bidderKeys $
102+
(serialise auctionCs <> serialise bidderPkh <> serialise bidPrice)
103+
104+
genValidBidState
105+
:: CurrencySymbol
106+
-> AuctionTerms
107+
-> KeyPair
108+
-> KeyPair
109+
-> Gen StandingBidState
110+
genValidBidState auctionCs auctionTerms sellerKeys bidderKeys =
111+
StandingBidState
112+
<$> liftArbitrary
113+
(genValidBidTerms auctionCs auctionTerms sellerKeys bidderKeys)
114+
115+
genValidNewBidState
116+
:: StandingBidState
117+
-> CurrencySymbol
118+
-> AuctionTerms
119+
-> KeyPair
120+
-> KeyPair
121+
-> Gen StandingBidState
122+
genValidNewBidState oldBidState auctionCs auctionTerms sellerKeys bidderKeys =
123+
case oldBidState of
124+
StandingBidState Nothing ->
125+
genValidBidState auctionCs auctionTerms sellerKeys bidderKeys
126+
StandingBidState (Just oldBidTerms) -> do
127+
newBidPrice <- arbitrary @Integer `suchThat` (\x -> x >= at'MinBidIncrement auctionTerms)
128+
pure . StandingBidState . Just $
129+
oldBidTerms
130+
{ bt'BidPrice = newBidPrice
131+
}
132+
133+
genValidAuctionTerms :: PublicKey -> Gen AuctionTerms
134+
genValidAuctionTerms vkey = do
135+
GenNonAdaValue @Positive at'AuctionLot <- arbitrary
136+
let (at'SellerVk, at'SellerPkh) = hashVerificationKey vkey
137+
at'Delegates <- vector @PubKeyHash =<< chooseInt (0, 10)
138+
139+
let chooseInterval = POSIXTime <$> chooseInteger (1, 604_800_000) -- up to 1 week in msec
140+
(biddingPeriod, purchasePeriod, penaltyPeriod) <-
141+
liftM3 (,,) chooseInterval chooseInterval chooseInterval
142+
at'BiddingStart <- arbitrary @POSIXTime
143+
let at'BiddingEnd = at'BiddingStart + biddingPeriod
144+
let at'PurchaseDeadline = at'BiddingEnd + purchasePeriod
145+
let at'Cleanup = at'PurchaseDeadline + penaltyPeriod
146+
147+
let minAuctionFeePerDelegate = 2_000_000
148+
at'AuctionFeePerDelegate <- arbitrary @Integer `suchThat` (\x -> x > minAuctionFeePerDelegate)
149+
150+
let minStartingBid = at'AuctionFeePerDelegate * fromIntegral (length at'Delegates)
151+
at'StartingBid <- arbitrary @Integer `suchThat` (\x -> x > minStartingBid)
152+
153+
Positive at'MinBidIncrement <- arbitrary @(Positive Integer)
154+
NonNegative at'MinDepositAmount <- arbitrary @(NonNegative Integer)
155+
pure AuctionTerms {..}

‎test/Spec/HydraAuctionOnchain/QuickCheck/Modifiers.hs‎

Lines changed: 27 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,27 @@
1+
{-# LANGUAGE QuantifiedConstraints #-}
2+
{-# LANGUAGE UndecidableInstances #-}
3+
4+
module Spec.HydraAuctionOnchain.QuickCheck.Modifiers
5+
( GenNonAdaValue (GenNonAdaValue)
6+
) where
7+
8+
import Data.Coerce (Coercible)
9+
import Data.Functor.Identity (Identity (Identity))
10+
import Plutarch.Test.QuickCheck.Modifiers (GenValue (GenValue))
11+
import PlutusLedgerApi.V1.Value qualified as Value (getValue)
12+
import PlutusLedgerApi.V2 (Value (Value), adaSymbol)
13+
import PlutusTx.AssocMap qualified as AMap (delete)
14+
import Test.QuickCheck (Arbitrary (arbitrary))
15+
16+
newtype GenNonAdaValue (mod :: Type -> Type) = GenNonAdaValue Value
17+
deriving stock (Show, Eq)
18+
19+
instance
20+
( Arbitrary (mod Integer)
21+
, forall (a :: Type). Coercible (mod a) a
22+
)
23+
=> Arbitrary (GenNonAdaValue mod)
24+
where
25+
arbitrary = do
26+
GenValue valueWithAda <- arbitrary @(GenValue Identity mod)
27+
pure $ GenNonAdaValue $ Value $ AMap.delete adaSymbol $ Value.getValue valueWithAda

0 commit comments

Comments
 (0)