Skip to content

Commit c0dc4bc

Browse files
errfromerrfrom
committed
feat(standing_bid): implement NewBid sub-validator
1 parent ec8dada commit c0dc4bc

File tree

6 files changed

+281
-23
lines changed

6 files changed

+281
-23
lines changed

‎src/HydraAuctionOnchain/Helpers.hs‎

Lines changed: 58 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,14 +1,40 @@
11
{-# LANGUAGE PackageImports #-}
22

33
module HydraAuctionOnchain.Helpers
4-
( pfindUnique
4+
( pdecodeInlineDatum
5+
, pfindUnique
56
, pfindUniqueOutputWithAddress
7+
, pintervalFiniteClosedOpen
8+
, pserialise
69
, putxoAddress
710
) where
811

9-
import Plutarch.Api.V2 (PAddress, PTxInInfo, PTxInfo, PTxOut)
12+
import Plutarch.Api.V2
13+
( PAddress
14+
, PExtended (PFinite)
15+
, PInterval (PInterval)
16+
, PLowerBound (PLowerBound)
17+
, POutputDatum (POutputDatum)
18+
, PTxInInfo
19+
, PTxInfo
20+
, PTxOut
21+
, PUpperBound (PUpperBound)
22+
)
23+
import Plutarch.Builtin (pforgetData, pserialiseData)
24+
import Plutarch.Extra.Maybe (pjust, pnothing)
25+
import Plutarch.Extra.ScriptContext (pfromPDatum)
26+
import Plutarch.Monadic qualified as P
1027
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfromSingleton)
1128

29+
pdecodeInlineDatum :: PTryFrom PData a => Term s (PTxOut :--> PMaybe a)
30+
pdecodeInlineDatum = phoistAcyclic $
31+
plam $ \txOut -> P.do
32+
datum <- plet $ pfield @"datum" # txOut
33+
pmatch datum $ \case
34+
POutputDatum inlineDatum ->
35+
pjust #$ pfromPDatum #$ pfield @"outputDatum" # inlineDatum
36+
_ -> pnothing
37+
1238
pfindUnique :: PIsListLike l a => Term s ((a :--> PBool) :--> l a :--> PMaybe a)
1339
pfindUnique = phoistAcyclic $
1440
plam $ \predicate list ->
@@ -22,6 +48,36 @@ pfindUniqueOutputWithAddress = phoistAcyclic $
2248
#$ pfield @"outputs"
2349
# txInfo
2450

51+
pintervalFiniteClosedOpen :: PIsData a => Term s (a :--> a :--> PInterval a)
52+
pintervalFiniteClosedOpen = phoistAcyclic $
53+
plam $ \a b ->
54+
pcon $
55+
PInterval $
56+
pdcons @"from"
57+
# ( pdata $
58+
pcon $
59+
PLowerBound $
60+
pdcons @"_0"
61+
# (pdata $ pcon $ PFinite $ pdcons @"_0" # pdata a # pdnil)
62+
#$ pdcons @"_1"
63+
# pconstantData True
64+
# pdnil
65+
)
66+
#$ pdcons @"to"
67+
# ( pdata $
68+
pcon $
69+
PUpperBound $
70+
pdcons @"_0"
71+
# (pdata $ pcon $ PFinite $ pdcons @"_0" # pdata b # pdnil)
72+
#$ pdcons @"_1"
73+
# pconstantData False
74+
# pdnil
75+
)
76+
# pdnil
77+
78+
pserialise :: PIsData a => Term s (a :--> PByteString)
79+
pserialise = phoistAcyclic $ plam $ \x -> pserialiseData #$ pforgetData $ pdata x
80+
2581
putxoAddress :: Term s (PTxInInfo :--> PAddress)
2682
putxoAddress = phoistAcyclic $
2783
plam $ \utxo ->

‎src/HydraAuctionOnchain/Types/AuctionTerms.hs‎

Lines changed: 14 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,15 +1,19 @@
11
module HydraAuctionOnchain.Types.AuctionTerms
22
( PAuctionTerms (PAuctionTerms)
3+
, pbiddingPeriod
34
) where
45

6+
import HydraAuctionOnchain.Helpers (pintervalFiniteClosedOpen)
57
import Plutarch.Api.V2
68
( AmountGuarantees (Positive)
79
, KeyGuarantees (Sorted)
810
, PPOSIXTime
11+
, PPOSIXTimeRange
912
, PPubKeyHash
1013
, PValue
1114
)
1215
import Plutarch.DataRepr (PDataFields)
16+
import Plutarch.Monadic qualified as P
1317
import Ply.Plutarch (PlyArgOf)
1418

1519
newtype PAuctionTerms (s :: S)
@@ -41,3 +45,13 @@ instance DerivePlutusType PAuctionTerms where
4145
data AuctionTerms
4246

4347
type instance PlyArgOf PAuctionTerms = AuctionTerms
48+
49+
--------------------------------------------------------------------------------
50+
-- Auction Lifecycle
51+
--------------------------------------------------------------------------------
52+
53+
pbiddingPeriod :: Term s (PAuctionTerms :--> PPOSIXTimeRange)
54+
pbiddingPeriod = phoistAcyclic $
55+
plam $ \auctionTerms -> P.do
56+
auctionTermsFields <- pletFields @["biddingStart", "biddingEnd"] auctionTerms
57+
pintervalFiniteClosedOpen # auctionTermsFields.biddingStart # auctionTermsFields.biddingEnd

‎src/HydraAuctionOnchain/Types/BidTerms.hs‎

Lines changed: 57 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,15 @@
11
module HydraAuctionOnchain.Types.BidTerms
22
( PBidTerms (PBidTerms)
3+
, pvalidateBidTerms
34
) where
45

6+
import HydraAuctionOnchain.Helpers (pserialise)
7+
import HydraAuctionOnchain.Types.AuctionTerms (PAuctionTerms)
58
import HydraAuctionOnchain.Types.BidderInfo (PBidderInfo)
9+
import Plutarch.Api.V2 (PCurrencySymbol, PPubKeyHash)
10+
import Plutarch.Crypto (pverifyEd25519Signature)
611
import Plutarch.DataRepr (PDataFields)
12+
import Plutarch.Monadic qualified as P
713

814
data PBidTerms (s :: S)
915
= PBidTerms
@@ -22,3 +28,54 @@ data PBidTerms (s :: S)
2228

2329
instance DerivePlutusType PBidTerms where
2430
type DPTStrat _ = PlutusTypeData
31+
32+
instance PTryFrom PData PBidTerms
33+
34+
pvalidateBidTerms :: Term s (PCurrencySymbol :--> PAuctionTerms :--> PBidTerms :--> PBool)
35+
pvalidateBidTerms = phoistAcyclic $
36+
plam $ \auctionCs auctionTerms bidTerms -> P.do
37+
bidTermsFields <-
38+
pletFields
39+
@["btBidder", "btPrice", "btBidderSignature", "btSellerSignature"]
40+
bidTerms
41+
bidderInfo <- pletFields @["biBidderPkh", "biBidderVk"] bidTermsFields.btBidder
42+
43+
let sellerSignature = bidTermsFields.btSellerSignature
44+
sellerVk <- plet $ pfield @"sellerVk" # auctionTerms
45+
sellerSignatureMsg <-
46+
plet $
47+
sellerSignatureMessage
48+
# auctionCs
49+
# bidderInfo.biBidderVk
50+
51+
let
52+
bidderSignature = bidTermsFields.btBidderSignature
53+
bidderVk = bidderInfo.biBidderVk
54+
bidderSignatureMsg <-
55+
plet $
56+
bidderSignatureMessage
57+
# auctionCs
58+
# bidTermsFields.btPrice
59+
# bidderInfo.biBidderPkh
60+
61+
-- The seller authorized the bidder to participate in the auction.
62+
(pverifyEd25519Signature # sellerVk # sellerSignatureMsg # sellerSignature)
63+
-- The bidder authorized the bid to be submitted in the auction.
64+
#&& (pverifyEd25519Signature # bidderVk # bidderSignatureMsg # bidderSignature)
65+
66+
bidderSignatureMessage
67+
:: Term
68+
s
69+
( PCurrencySymbol
70+
:--> PInteger
71+
:--> PPubKeyHash
72+
:--> PByteString
73+
)
74+
bidderSignatureMessage = phoistAcyclic $
75+
plam $ \auctionCs bidPrice bidderPkh ->
76+
(pserialise # auctionCs) <> (pserialise # bidPrice) <> (pserialise # bidderPkh)
77+
78+
sellerSignatureMessage :: Term s (PCurrencySymbol :--> PByteString :--> PByteString)
79+
sellerSignatureMessage = phoistAcyclic $
80+
plam $ \auctionCs bidderVk ->
81+
(pserialise # auctionCs) <> (pserialise # bidderVk)

‎src/HydraAuctionOnchain/Types/BidderInfo.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -20,3 +20,5 @@ data PBidderInfo (s :: S)
2020

2121
instance DerivePlutusType PBidderInfo where
2222
type DPTStrat _ = PlutusTypeData
23+
24+
instance PTryFrom PData PBidderInfo

‎src/HydraAuctionOnchain/Types/StandingBidState.hs‎

Lines changed: 54 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,13 +1,65 @@
11
module HydraAuctionOnchain.Types.StandingBidState
22
( PStandingBidState (PStandingBidState)
3+
, pvalidateNewBid
34
) where
45

5-
import HydraAuctionOnchain.Types.BidTerms (PBidTerms)
6-
import Plutarch.Api.V2 (PMaybeData)
6+
import HydraAuctionOnchain.Types.AuctionTerms (PAuctionTerms)
7+
import HydraAuctionOnchain.Types.BidTerms (PBidTerms, pvalidateBidTerms)
8+
import Plutarch.Api.V2 (PCurrencySymbol, PMaybeData)
9+
import Plutarch.Extra.Maybe (pmaybeData)
10+
import Plutarch.Monadic qualified as P
711

812
newtype PStandingBidState (s :: S) = PStandingBidState (Term s (PMaybeData PBidTerms))
913
deriving stock (Generic)
1014
deriving anyclass (PlutusType, PIsData, PShow, PEq)
1115

1216
instance DerivePlutusType PStandingBidState where
1317
type DPTStrat _ = PlutusTypeNewtype
18+
19+
instance PTryFrom PData PStandingBidState
20+
21+
pvalidateNewBid
22+
:: Term
23+
s
24+
( PCurrencySymbol
25+
:--> PAuctionTerms
26+
:--> PStandingBidState
27+
:--> PStandingBidState
28+
:--> PBool
29+
)
30+
pvalidateNewBid = phoistAcyclic $
31+
plam $ \auctionCs auctionTerms oldBidState newBidState ->
32+
pmaybeData
33+
# pcon PFalse -- The new bid state should not be empty.
34+
# plam
35+
( \newTerms ->
36+
(pvalidateBidTerms # auctionCs # auctionTerms # newTerms)
37+
#&& (pvalidateCompareBids # auctionTerms # oldBidState # newTerms)
38+
)
39+
# pto newBidState
40+
41+
pvalidateCompareBids :: Term s (PAuctionTerms :--> PStandingBidState :--> PBidTerms :--> PBool)
42+
pvalidateCompareBids = phoistAcyclic $
43+
plam $ \auctionTerms oldBidState newTerms ->
44+
pmaybeData
45+
# (pvalidateStartingBid # auctionTerms # newTerms)
46+
# plam (\oldTerms -> pvalidateBidIncrement # auctionTerms # oldTerms # newTerms)
47+
# pto oldBidState
48+
49+
-- The first bid's price is no smaller than the auction's starting price.
50+
pvalidateStartingBid :: Term s (PAuctionTerms :--> PBidTerms :--> PBool)
51+
pvalidateStartingBid = phoistAcyclic $
52+
plam $ \auctionTerms newTerms -> P.do
53+
startingBid <- plet $ pfromData $ pfield @"startingBid" # auctionTerms
54+
bidPrice <- plet $ pfromData $ pfield @"btPrice" # newTerms
55+
startingBid #<= bidPrice
56+
57+
-- The difference between the old and new bid price is no smaller than
58+
-- the auction's minimum bid increment.
59+
pvalidateBidIncrement :: Term s (PAuctionTerms :--> PBidTerms :--> PBidTerms :--> PBool)
60+
pvalidateBidIncrement = phoistAcyclic $
61+
plam $ \auctionTerms oldTerms newTerms -> P.do
62+
oldBidPrice <- plet $ pfromData $ pfield @"btPrice" # oldTerms
63+
newBidPrice <- plet $ pfromData $ pfield @"btPrice" # newTerms
64+
minBidIncrement <- plet $ pfromData $ pfield @"minBidIncrement" # auctionTerms
65+
oldBidPrice + minBidIncrement #<= newBidPrice

0 commit comments

Comments
 (0)