Skip to content

Commit f7c59e5

Browse files
errfromerrfrom
committed
feat!: wip: verify cose signatures
1 parent a8bd93f commit f7c59e5

File tree

12 files changed

+281
-91
lines changed

12 files changed

+281
-91
lines changed

‎compiled/auction_escrow_validator.plutus‎

Lines changed: 2 additions & 2 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

‎compiled/standing_bid_validator.plutus‎

Lines changed: 2 additions & 2 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

‎hydra-auction-onchain.cabal‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -105,6 +105,9 @@ library
105105
HydraAuctionOnchain.Errors.AuctionEscrow
106106
HydraAuctionOnchain.Errors.StandingBid
107107
HydraAuctionOnchain.Helpers
108+
HydraAuctionOnchain.Lib.Address
109+
HydraAuctionOnchain.Lib.Cose
110+
HydraAuctionOnchain.Lib.Serialization
108111
HydraAuctionOnchain.Scripts
109112
HydraAuctionOnchain.Types.AuctionEscrowState
110113
HydraAuctionOnchain.Types.AuctionInfo

‎src/HydraAuctionOnchain/Errors/AuctionEscrow.hs‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -7,7 +7,8 @@ import HydraAuctionOnchain.Types.Error (ErrorCodePrefix (errorCodePrefix))
77

88
data PAuctionEscrowError (s :: S)
99
= -- Common errors
10-
AuctionEscrow'Error'MissingAuctionEscrowInput
10+
AuctionEscrow'Error'InvalidSellerAddress
11+
| AuctionEscrow'Error'MissingAuctionEscrowInput
1112
| AuctionEscrow'Error'TooManyOwnScriptInputs
1213
| AuctionEscrow'Error'OwnInputMissingToken
1314
| -- StartBidding errors
@@ -33,6 +34,7 @@ data PAuctionEscrowError (s :: S)
3334
| AuctionEscrow'BidderBuys'Error'StandingBidInputMissingToken
3435
| AuctionEscrow'BidderBuys'Error'FailedToDecodeStandingBidState
3536
| AuctionEscrow'BidderBuys'Error'EmptyStandingBid
37+
| AuctionEscrow'BidderBuys'Error'InvalidBidderAddress
3638
| AuctionEscrow'BidderBuys'Error'BidTermsInvalid
3739
| AuctionEscrow'BidderBuys'Error'AuctionLotNotPaidToBidder
3840
| AuctionEscrow'BidderBuys'Error'NoBidderConsent

‎src/HydraAuctionOnchain/Helpers.hs‎

Lines changed: 17 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -14,7 +14,7 @@ module HydraAuctionOnchain.Helpers
1414
, ponlyOneInputFromAddress
1515
, pserialise
1616
, putxoAddress
17-
, pvaluePaidTo
17+
, pvaluePaidToAddr
1818
, pvaluePaidToScript
1919
) where
2020

@@ -180,31 +180,29 @@ putxoAddress = phoistAcyclic $
180180
plam $ \utxo ->
181181
pfield @"address" #$ pfield @"resolved" # utxo
182182

183-
pvaluePaidToGeneric
184-
:: Term
185-
s
186-
( PTxInfo
187-
:--> a
188-
:--> (PAddress :--> a :--> PBool)
189-
:--> PValue 'Sorted 'Positive
190-
)
191-
pvaluePaidToGeneric = phoistAcyclic $
192-
plam $ \txInfo x p ->
183+
pvaluePaidToAddr :: Term s (PTxInfo :--> PAddress :--> PValue 'Sorted 'Positive)
184+
pvaluePaidToAddr =
185+
plam $ \txInfo addr ->
193186
pfoldl
194187
# plam
195188
( \accValue utxo -> P.do
196189
utxoFields <- pletFields @["address", "value"] utxo
197-
pif (p # utxoFields.address # x) (accValue <> utxoFields.value) accValue
190+
pif (utxoFields.address #== addr) (accValue <> utxoFields.value) accValue
198191
)
199192
# mempty
200193
# (pfromData $ pfield @"outputs" # txInfo)
201194

202-
pvaluePaidTo :: Term s (PTxInfo :--> PPubKeyHash :--> PValue 'Sorted 'Positive)
203-
pvaluePaidTo = phoistAcyclic $
204-
plam $ \txInfo pkh ->
205-
pvaluePaidToGeneric # txInfo # pkh # paddressHasPubKeyHash
206-
207195
pvaluePaidToScript :: Term s (PTxInfo :--> PScriptHash :--> PValue 'Sorted 'Positive)
208-
pvaluePaidToScript = phoistAcyclic $
196+
pvaluePaidToScript =
209197
plam $ \txInfo sh ->
210-
pvaluePaidToGeneric # txInfo # sh # paddressHasScriptHash
198+
pfoldl
199+
# plam
200+
( \accValue utxo -> P.do
201+
utxoFields <- pletFields @["address", "value"] utxo
202+
pif
203+
(paddressHasScriptHash # utxoFields.address # sh)
204+
(accValue <> utxoFields.value)
205+
accValue
206+
)
207+
# mempty
208+
# (pfromData $ pfield @"outputs" # txInfo)

‎src/HydraAuctionOnchain/Lib/Address.hs‎

Lines changed: 23 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,23 @@
1+
module HydraAuctionOnchain.Lib.Address
2+
( paddrPaymentKeyHash
3+
, paddrPaymentKeyHashUnsafe
4+
) where
5+
6+
import Plutarch.Api.V1 (PCredential (PPubKeyCredential, PScriptCredential))
7+
import Plutarch.Api.V2 (PAddress, PPubKeyHash)
8+
import Plutarch.Extra.Maybe (pjust, pnothing)
9+
10+
paddrPaymentKeyHash :: Term s (PAddress :--> PMaybe PPubKeyHash)
11+
paddrPaymentKeyHash = phoistAcyclic $
12+
plam $ \addr ->
13+
pmatch (pfield @"credential" # addr) $ \case
14+
PPubKeyCredential rec -> pjust #$ pfield @"_0" # rec
15+
PScriptCredential _ -> pnothing
16+
17+
paddrPaymentKeyHashUnsafe :: Term s (PAddress :--> PPubKeyHash)
18+
paddrPaymentKeyHashUnsafe = phoistAcyclic $
19+
plam $ \addr ->
20+
pmatch (pfield @"credential" # addr) $ \case
21+
PPubKeyCredential rec -> pfield @"_0" # rec
22+
PScriptCredential _ ->
23+
ptraceError "paddrPaymentKeyHashUnsafe: failed to get payment pkh"

‎src/HydraAuctionOnchain/Lib/Cose.hs‎

Lines changed: 24 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,24 @@
1+
module HydraAuctionOnchain.Lib.Cose
2+
( pmkSigStructure
3+
) where
4+
5+
import HydraAuctionOnchain.Lib.Serialization (pserializeAddress)
6+
import Plutarch.Api.V2 (PAddress)
7+
import Plutarch.Extra.Maybe (pjust, pnothing)
8+
9+
pmkSigStructure :: Term s (PAddress :--> PByteString :--> PByteString :--> PMaybe PByteString)
10+
pmkSigStructure = phoistAcyclic $
11+
plam $ \addr payload payloadLength -> P.do
12+
pmatch (pserializeAddress # addr) $ \case
13+
PNothing -> pnothing
14+
PJust addrBytes ->
15+
pjust
16+
# mconcat
17+
[ phexByteStr "846a5369676e61747572653158"
18+
, phexByteStr "46" -- FIXME
19+
, phexByteStr "A201276761646472657373"
20+
, addrBytes
21+
, phexByteStr "4058"
22+
, payloadLength
23+
, payload
24+
]

‎src/HydraAuctionOnchain/Lib/Serialization.hs‎

Lines changed: 83 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,83 @@
1+
module HydraAuctionOnchain.Lib.Serialization
2+
( pserializeAddress
3+
) where
4+
5+
import Plutarch.Api.V1 (PCredential (PPubKeyCredential, PScriptCredential))
6+
import Plutarch.Api.V2
7+
( PAddress
8+
, PMaybeData (PDJust, PDNothing)
9+
, PPubKeyHash
10+
, PStakingCredential (PStakingHash, PStakingPtr)
11+
)
12+
import Plutarch.Extra.Maybe (pjust, pnothing)
13+
import Plutarch.Monadic qualified as P
14+
15+
data PAddressConfiguration (s :: S)
16+
= PAddressConfig'PaymentKeyHash'StakeKeyHash (Term s PPubKeyHash) (Term s PPubKeyHash)
17+
| PAddressConfig'PaymentKeyHash (Term s PPubKeyHash)
18+
deriving stock (Generic)
19+
deriving anyclass (PlutusType, PShow, PEq)
20+
21+
instance DerivePlutusType PAddressConfiguration where
22+
type DPTStrat _ = PlutusTypeScott
23+
24+
pserializeAddress :: Term s (PAddress :--> PMaybe PByteString)
25+
pserializeAddress = phoistAcyclic $
26+
plam $ \addr ->
27+
pmatch (pmkAddrConfig # addr) $ \case
28+
PNothing -> pnothing
29+
PJust addrConfig ->
30+
pjust
31+
# mconcat
32+
[ phexByteStr "58" -- byte string (one-byte uint8_t for n, and then n bytes follow)
33+
, paddrConfigAddrSize # addrConfig
34+
, paddrConfigAddrHeaderForTestnet # addrConfig
35+
, paddrConfigAddrBody # addrConfig
36+
]
37+
38+
pmkAddrConfig :: Term s (PAddress :--> PMaybe PAddressConfiguration)
39+
pmkAddrConfig = phoistAcyclic $
40+
plam $ \addr -> P.do
41+
creds <- pletFields @["credential", "stakingCredential"] addr
42+
pmatch creds.credential $ \case
43+
PScriptCredential _ -> pnothing
44+
PPubKeyCredential rec -> P.do
45+
let pkh = pfield @"_0" # rec
46+
pmatch creds.stakingCredential $ \case
47+
PDNothing _ -> pjust # pcon (PAddressConfig'PaymentKeyHash pkh)
48+
PDJust rec ->
49+
pmatch (pfield @"_0" # rec) $ \case
50+
PStakingHash rec ->
51+
pmatch (pfield @"_0" # rec) $ \case
52+
PScriptCredential _ -> pnothing
53+
PPubKeyCredential rec -> P.do
54+
let skh = pfield @"_0" # rec
55+
pjust # pcon (PAddressConfig'PaymentKeyHash'StakeKeyHash pkh skh)
56+
PStakingPtr _ -> pnothing
57+
58+
paddrConfigAddrSize :: Term s (PAddressConfiguration :--> PByteString)
59+
paddrConfigAddrSize = phoistAcyclic $
60+
plam $ \addrConfig ->
61+
pmatch addrConfig $ \case
62+
PAddressConfig'PaymentKeyHash'StakeKeyHash _ _ ->
63+
phexByteStr "39" -- 57 = 1 (header) + 28 (pkh) + 28 (skh)
64+
PAddressConfig'PaymentKeyHash _ ->
65+
phexByteStr "1D" -- 29 = 1 (header) + 28 (pkh)
66+
67+
paddrConfigAddrHeaderForTestnet :: Term s (PAddressConfiguration :--> PByteString)
68+
paddrConfigAddrHeaderForTestnet = phoistAcyclic $
69+
plam $ \addrConfig ->
70+
pmatch addrConfig $ \case
71+
PAddressConfig'PaymentKeyHash'StakeKeyHash _ _ ->
72+
phexByteStr "00" -- 0b0000_0000
73+
PAddressConfig'PaymentKeyHash _ ->
74+
phexByteStr "60" -- 0b0110_0000
75+
76+
paddrConfigAddrBody :: Term s (PAddressConfiguration :--> PByteString)
77+
paddrConfigAddrBody = phoistAcyclic $
78+
plam $ \addrConfig ->
79+
pmatch addrConfig $ \case
80+
PAddressConfig'PaymentKeyHash'StakeKeyHash pkh skh ->
81+
pto pkh <> pto skh
82+
PAddressConfig'PaymentKeyHash pkh ->
83+
pto pkh

‎src/HydraAuctionOnchain/Types/AuctionTerms.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@ import HydraAuctionOnchain.Helpers (pintervalFiniteClosedOpen)
1111
import Plutarch.Api.V2
1212
( AmountGuarantees (Positive)
1313
, KeyGuarantees (Sorted)
14+
, PAddress
1415
, PPOSIXTime
1516
, PPOSIXTimeRange
1617
, PPubKeyHash
@@ -27,7 +28,7 @@ newtype PAuctionTerms (s :: S)
2728
s
2829
( PDataRecord
2930
'[ "auctionLot" ':= PValue 'Sorted 'Positive
30-
, "sellerPkh" ':= PPubKeyHash
31+
, "sellerAddress" ':= PAddress
3132
, "sellerVk" ':= PByteString
3233
, "delegates" ':= PBuiltinList (PAsData PPubKeyHash)
3334
, "biddingStart" ':= PPOSIXTime

‎src/HydraAuctionOnchain/Types/BidTerms.hs‎

Lines changed: 41 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -1,16 +1,22 @@
1+
{-# LANGUAGE PackageImports #-}
2+
13
module HydraAuctionOnchain.Types.BidTerms
24
( PBidTerms (PBidTerms)
35
, psellerPayout
46
, pvalidateBidTerms
57
) where
68

79
import HydraAuctionOnchain.Helpers (pserialise)
10+
import HydraAuctionOnchain.Lib.Address (paddrPaymentKeyHashUnsafe)
11+
import HydraAuctionOnchain.Lib.Cose (pmkSigStructure)
812
import HydraAuctionOnchain.Types.AuctionTerms (PAuctionTerms, ptotalAuctionFees)
913
import HydraAuctionOnchain.Types.BidderInfo (PBidderInfo)
1014
import Plutarch.Api.V2 (PCurrencySymbol, PPubKeyHash)
1115
import Plutarch.Crypto (pverifyEd25519Signature)
1216
import Plutarch.DataRepr (PDataFields)
17+
import Plutarch.Maybe (pfromJust)
1318
import Plutarch.Monadic qualified as P
19+
import "liqwid-plutarch-extra" Plutarch.Extra.List (preplicate)
1420

1521
data PBidTerms (s :: S)
1622
= PBidTerms
@@ -46,34 +52,52 @@ psellerPayout = phoistAcyclic $
4652
pvalidateBidTerms :: Term s (PCurrencySymbol :--> PAuctionTerms :--> PBidTerms :--> PBool)
4753
pvalidateBidTerms = phoistAcyclic $
4854
plam $ \auctionCs auctionTerms bidTerms -> P.do
55+
sellerAddr <- plet $ pfield @"sellerAddress" # auctionTerms
4956
bidTermsFields <-
5057
pletFields
5158
@["btBidder", "btPrice", "btBidderSignature", "btSellerSignature"]
5259
bidTerms
53-
bidderInfo <- pletFields @["biBidderPkh", "biBidderVk"] bidTermsFields.btBidder
60+
bidderInfo <- pletFields @["biBidderAddress", "biBidderVk"] bidTermsFields.btBidder
5461

5562
let sellerSignature = bidTermsFields.btSellerSignature
5663
sellerVk <- plet $ pfield @"sellerVk" # auctionTerms
57-
sellerSignatureMsg <-
64+
sellerSigMsg <-
5865
plet $
5966
sellerSignatureMessage
6067
# auctionCs
6168
# bidderInfo.biBidderVk
6269

70+
sellerSigStruct <-
71+
plet $ pfromJust #$ pmkSigStructure # sellerAddr # sellerSigMsg # sellerSigMsgLengthHex
72+
6373
let
6474
bidderSignature = bidTermsFields.btBidderSignature
6575
bidderVk = bidderInfo.biBidderVk
66-
bidderSignatureMsg <-
76+
bidderAddr = bidderInfo.biBidderAddress
77+
bidderSigMsg <-
6778
plet $
6879
bidderSignatureMessage
6980
# auctionCs
7081
# bidTermsFields.btPrice
71-
# bidderInfo.biBidderPkh
82+
# (paddrPaymentKeyHashUnsafe # bidderAddr)
83+
84+
bidderSigStruct <-
85+
plet $ pfromJust #$ pmkSigStructure # bidderAddr # bidderSigMsg # bidderSigMsgLengthHex
7286

7387
-- The seller authorized the bidder to participate in the auction.
74-
(pverifyEd25519Signature # sellerVk # sellerSignatureMsg # sellerSignature)
88+
(pverifyEd25519Signature # sellerVk # sellerSigStruct # sellerSignature)
7589
-- The bidder authorized the bid to be submitted in the auction.
76-
#&& (pverifyEd25519Signature # bidderVk # bidderSignatureMsg # bidderSignature)
90+
#&& (pverifyEd25519Signature # bidderVk # bidderSigStruct # bidderSignature)
91+
92+
bidderSigMsgLengthHex :: Term s PByteString
93+
bidderSigMsgLengthHex =
94+
-- 69 = 2 (cbor) + 28 (cs) + 2 (cbor) + 28 (pkh) + 9 (lovelace)
95+
phoistAcyclic $ phexByteStr "45"
96+
97+
sellerSigMsgLengthHex :: Term s PByteString
98+
sellerSigMsgLengthHex =
99+
-- 64 = 2 (cbor) + 28 (cs) + 2 (cbor) + 32 (vk)
100+
phoistAcyclic $ phexByteStr "40"
77101

78102
bidderSignatureMessage
79103
:: Term
@@ -85,9 +109,19 @@ bidderSignatureMessage
85109
)
86110
bidderSignatureMessage = phoistAcyclic $
87111
plam $ \auctionCs bidPrice bidderPkh ->
88-
(pserialise # auctionCs) <> (pserialise # bidderPkh) <> (pserialise # bidPrice)
112+
padMessage # 69 #$ (pserialise # auctionCs)
113+
<> (pserialise # bidderPkh)
114+
<> (pserialise # bidPrice)
89115

90116
sellerSignatureMessage :: Term s (PCurrencySymbol :--> PByteString :--> PByteString)
91117
sellerSignatureMessage = phoistAcyclic $
92118
plam $ \auctionCs bidderVk ->
93119
(pserialise # auctionCs) <> (pserialise # bidderVk)
120+
121+
padMessage :: Term s (PInteger :--> PByteString :--> PByteString)
122+
padMessage = phoistAcyclic $
123+
plam $ \targetSize message -> P.do
124+
padSize <- plet $ targetSize - (plengthBS # message)
125+
let nul = phexByteStr "00"
126+
let padding = pfoldl # plam (<>) # mempty #$ preplicate @PBuiltinList # padSize # nul
127+
pif (padSize #<= 0) message (padding <> message)

0 commit comments

Comments
 (0)