Sulkta-OSS/agora
3
0
Fork 0
Code Issues 1 Pull requests Projects Releases Packages Wiki Activity Actions

WitnessStake: accept multiple stakes at input

Browse source
This commit is contained in:
Hongrui Fang 2022-07-05 07:53:56 +08:00
parent bf4dd91342
commit 894bba2874
2 changed files with 243 additions and 177 deletions
Download patch file Download diff file Expand all files Collapse all files

412
agora/Agora/Stake/Scripts.hs
View file

@ -8,7 +8,18 @@ Plutus Scripts for Stakes.
module Agora.Stake.Scripts (stakePolicy, stakeValidator) where module Agora.Stake.Scripts (stakePolicy, stakeValidator) where
import Agora.SafeMoney (GTTag) import Agora.SafeMoney (GTTag)
import Agora.Stake import Agora.Stake (
PStakeDatum (PStakeDatum),
PStakeRedeemer (
PDepositWithdraw,
PDestroy,
PPermitVote,
PRetractVotes
),
Stake (gtClassRef, proposalSTClass),
StakeRedeemer (WitnessStake),
stakeLocked,
)
import Agora.Utils ( import Agora.Utils (
mustBePJust, mustBePJust,
mustFindDatum', mustFindDatum',
@ -18,18 +29,22 @@ import Data.Tagged (Tagged (..), untag)
import Plutarch.Api.V1 ( import Plutarch.Api.V1 (
AmountGuarantees (Positive), AmountGuarantees (Positive),
PCredential (PPubKeyCredential, PScriptCredential), PCredential (PPubKeyCredential, PScriptCredential),
PDatumHash,
PMintingPolicy, PMintingPolicy,
PScriptPurpose (PMinting, PSpending), PScriptPurpose (PMinting, PSpending),
PTokenName, PTokenName,
PTxInfo, PTxInfo,
PTxOut,
PValidator, PValidator,
PValue, PValue,
mintingPolicySymbol, mintingPolicySymbol,
mkMintingPolicy, mkMintingPolicy,
) )
import Plutarch.Api.V1.AssetClass (passetClass, passetClassValueOf, pvalueOf) import Plutarch.Api.V1.AssetClass (passetClass, passetClassValueOf, pvalueOf)
import Plutarch.Api.V1.ScriptContext (pfindTxInByTxOutRef, pisTokenSpent, ptxSignedBy, pvalueSpent) import Plutarch.Api.V1.ScriptContext (pfindTxInByTxOutRef, ptxSignedBy, pvalueSpent)
import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (pgeqByClass', pgeqBySymbol, psymbolValueOf) import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (pgeqByClass', pgeqBySymbol, psymbolValueOf)
import Plutarch.Extra.List (pmapMaybe, pmsortBy)
import Plutarch.Extra.Maybe (pfromDJust)
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=)) import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC) import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC)
import Plutarch.Internal (punsafeCoerce) import Plutarch.Internal (punsafeCoerce)
@ -208,7 +223,15 @@ stakeValidator stake =
plam $ \datum redeemer ctx' -> unTermCont $ do plam $ \datum redeemer ctx' -> unTermCont $ do
ctx <- pletFieldsC @'["txInfo", "purpose"] ctx' ctx <- pletFieldsC @'["txInfo", "purpose"] ctx'
txInfo <- pletC $ pfromData ctx.txInfo txInfo <- pletC $ pfromData ctx.txInfo
txInfoF <- pletFieldsC @'["mint", "inputs", "outputs", "signatories", "datums"] txInfo txInfoF <-
pletFieldsC
@'[ "mint"
, "inputs"
, "outputs"
, "signatories"
, "datums"
]
txInfo
(pfromData -> stakeRedeemer, _) <- ptryFromC redeemer (pfromData -> stakeRedeemer, _) <- ptryFromC redeemer
@ -219,23 +242,25 @@ stakeValidator stake =
PSpending txOutRef <- pmatchC $ pfromData ctx.purpose PSpending txOutRef <- pmatchC $ pfromData ctx.purpose
PJust txInInfo <- pmatchC $ pfindTxInByTxOutRef # (pfield @"_0" # txOutRef) # txInfoF.inputs PJust ((pfield @"resolved" #) -> resolved) <-
ownAddress <- pletC $ pfield @"address" #$ pfield @"resolved" # txInInfo pmatchC $
let continuingValue :: Term _ (PValue _ _) pfindTxInByTxOutRef
continuingValue = pfield @"value" #$ pfield @"resolved" # txInInfo # (pfield @"_0" # txOutRef)
# txInfoF.inputs
resolvedF <- pletFieldsC @'["address", "value", "datumHash"] resolved
-- Whether the owner signs this transaction or not. -- Whether the owner signs this transaction or not.
ownerSignsTransaction <- pletC $ ptxSignedBy # txInfoF.signatories # stakeDatum.owner ownerSignsTransaction <- pletC $ ptxSignedBy # txInfoF.signatories # stakeDatum.owner
stCurrencySymbol <- pletC $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake.gtClassRef) stCurrencySymbol <-
pletC $
pconstant $
mintingPolicySymbol $
mkMintingPolicy (stakePolicy stake.gtClassRef)
mintedST <- pletC $ psymbolValueOf # stCurrencySymbol # txInfoF.mint mintedST <- pletC $ psymbolValueOf # stCurrencySymbol # txInfoF.mint
valueSpent <- pletC $ pvalueSpent # txInfoF.inputs valueSpent <- pletC $ pvalueSpent # txInfoF.inputs
spentST <- pletC $ psymbolValueOf # stCurrencySymbol #$ valueSpent spentST <- pletC $ psymbolValueOf # stCurrencySymbol #$ valueSpent
let AssetClass (propCs, propTn) = stake.proposalSTClass
proposalSTClass = passetClass # pconstant propCs # pconstant propTn
spentProposalST <- pletC $ passetClassValueOf # valueSpent # proposalSTClass
-- Is the stake currently locked? -- Is the stake currently locked?
stakeIsLocked <- pletC $ stakeLocked # stakeDatum' stakeIsLocked <- pletC $ stakeLocked # stakeDatum'
@ -253,196 +278,237 @@ stakeValidator stake =
pguardC "Owner signs this transaction" ownerSignsTransaction pguardC "Owner signs this transaction" ownerSignsTransaction
pure $ popaque (pconstant ()) pure $ popaque (pconstant ())
-------------------------------------------------------------------------- ------------------------------------------------------------------------
-- Handle redeemers that require own stake output. -- Handle redeemers that require own stake output.
_ -> unTermCont $ do _ -> unTermCont $ do
-- Filter out own output with own address and PST. let AssetClass (propCs, propTn) = stake.proposalSTClass
ownOutput <- proposalSTClass = passetClass # pconstant propCs # pconstant propTn
spentProposalST = passetClassValueOf # valueSpent # proposalSTClass
proposalTokenMoved <- pletC $ spentProposalST #== 1
-- Filter out own outputs using own address and ST.
ownOutputs <-
pletC $ pletC $
mustBePJust # "Own output should be present" #$ pfind pfilter
# plam # plam
( \input -> unTermCont $ do ( \output -> unTermCont $ do
inputF <- pletFieldsC @'["address", "value"] input outputF <- pletFieldsC @'["address", "value"] output
pure $ pure $
inputF.address #== ownAddress outputF.address #== resolvedF.address
#&& psymbolValueOf # stCurrencySymbol # inputF.value #== 1 #&& psymbolValueOf # stCurrencySymbol # outputF.value #== 1
) )
# pfromData txInfoF.outputs # pfromData txInfoF.outputs
stakeOut <- let witnessStake = unTermCont $ do
pletC $ pguardC "Either owner signs the transaction or propsoal token moved" $
mustFindDatum' @PStakeDatum ownerSignsTransaction #|| proposalTokenMoved
# (pfield @"datumHash" # ownOutput)
# txInfoF.datums
ownOutputValue <- -- FIXME: refactor this with reference input, once it's supported by plutarch.
pletC $ --
pfield @"value" # ownOutput -- Our goal here is to allow multiple input stakes, and also ensure that every the input stakes has a
-- corresponding output stake, which carries the same value and the same datum as the input stake.
ownOutputValueUnchanged <- --
pletC $ -- Validation strategy I have tried/considered so far:
pdata continuingValue #== pdata ownOutputValue -- 1. Check that the number of input stakes equals to the number of output stakes, and verify
-- that every input stake has an output stake with the exact same value and datum hash.
stakeOutUnchanged <- -- However this approach has a fatal vulnerability: let's say we have two totally identical stakes,
pletC $ -- a malicious user can comsume these two stakes and remove GTs from one of them.
pdata stakeOut #== pdata stakeDatum' -- 2. Perform the same checks as the last approch does, while also checking that every output stake is
-- valid(stakedAmount == actual value). However this requires that all the output stake datum are
pure $ -- included in the transaction, and we have to find and go through them one by one to access the
pmatch stakeRedeemer $ \case -- 'stakedAmount' fields, meaning that computationally this approach is *very* expensive.
PRetractVotes l -> unTermCont $ do -- 3. The one implemented below. Find all the continuous input/output, sort them by 'datumHash', and
pguardC -- ensure that the two sorted lists are equal.
"Owner signs this transaction" let ownInputs =
ownerSignsTransaction pmapMaybe
# plam
pguardC "ST at inputs must be 1" $ ( \input -> plet (pfield @"resolved" # input) $ \resolvedInput ->
spentST #== 1 let value = pfield @"value" # resolvedInput
in pif
-- This puts trust into the Proposal. The Proposal must necessarily check (psymbolValueOf # stCurrencySymbol # value #== 1)
-- that this is not abused. (pcon $ PJust resolvedInput)
pguardC "Proposal ST spent" $ (pcon PNothing)
spentProposalST #== 1
pguardC "A UTXO must exist with the correct output" $
let expectedLocks = pfield @"locks" # l
expectedDatum =
mkRecordConstr
PStakeDatum
( #stakedAmount .= stakeDatum.stakedAmount
.& #owner .= stakeDatum.owner
.& #lockedBy .= expectedLocks
) )
# pfromData txInfoF.inputs
valueCorrect = ownOutputValueUnchanged sortTxOuts :: Term _ (PBuiltinList (PAsData PTxOut) :--> PBuiltinList (PAsData PTxOut))
outputDatumCorrect = stakeOut #== expectedDatum sortTxOuts =
in foldl1 plam
(#&&) ( pmsortBy
[ ptraceIfFalse "valueCorrect" valueCorrect # plam
, ptraceIfFalse "datumCorrect" outputDatumCorrect ( \((getDatumHash #) -> dhX)
] ((getDatumHash #) -> dhY) -> dhX #< dhY
)
#
)
where
getDatumHash :: Term _ (PAsData PTxOut :--> PDatumHash)
getDatumHash = phoistAcyclic $ plam ((pfromDJust #) . pfromData . (pfield @"datumHash" #))
pure $ popaque (pconstant ()) sortedOwnInputs = sortTxOuts # ownInputs
-------------------------------------------------------------------------- sortedOwnOutputs = sortTxOuts # ownOutputs
PPermitVote l -> unTermCont $ do
pguardC
"Owner signs this transaction"
ownerSignsTransaction
-- This puts trust into the Proposal. The Proposal must necessarily check pguardC "Every stake inputs has a corresponding unchanged output" $
-- that this is not abused. plistEquals # sortedOwnInputs # sortedOwnOutputs
pguardC "Proposal ST spent" $
spentProposalST #== 1
-- Update the stake datum, but only the 'lockedBy' field. pure $ popaque $ pconstant ()
let -- We actually don't know whether the given lock is valid or not. ----------------------------------------------------------------------
-- This is checked in the proposal validator.
newLock = pfield @"lock" # l
-- Prepend the new lock to the existing locks.
expectedLocks = pcons # newLock # stakeDatum.lockedBy
expectedDatum <- let onlyAcceptOneStake = unTermCont $ do
pguardC "ST at inputs must be 1" $
spentST #== 1
ownOutput <- pletC $ pfromData $ phead # ownOutputs
stakeOut <-
pletC $ pletC $
mkRecordConstr mustFindDatum' @PStakeDatum
PStakeDatum # (pfield @"datumHash" # ownOutput)
( #stakedAmount .= stakeDatum.stakedAmount # txInfoF.datums
.& #owner .= stakeDatum.owner
.& #lockedBy .= pdata expectedLocks
)
pguardC "A UTXO must exist with the correct output" $ ownOutputValue <-
let correctOutputDatum = stakeOut #== expectedDatum pletC $
valueCorrect = ownOutputValueUnchanged pfield @"value" # ownOutput
in foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" correctOutputDatum
]
pure $ popaque (pconstant ()) ownOutputValueUnchanged <-
-------------------------------------------------------------------------- pletC $
PWitnessStake _ -> unTermCont $ do pdata resolvedF.value #== pdata ownOutputValue
pguardC "ST at inputs must be 1" $
spentST #== 1
let AssetClass (propCs, propTn) = stake.proposalSTClass pure $
propAssetClass = passetClass # pconstant propCs # pconstant propTn pmatch stakeRedeemer $ \case
proposalTokenMoved = PRetractVotes l -> unTermCont $ do
pisTokenSpent pguardC
# propAssetClass "Owner signs this transaction"
# txInfoF.inputs ownerSignsTransaction
-- In order for cosignature to be witnessed, it must be possible for a -- This puts trust into the Proposal. The Proposal must necessarily check
-- proposal to allow this transaction to happen. This puts trust into the Proposal. -- that this is not abused.
-- The Proposal must necessarily check that this is not abused. pguardC "Proposal ST spent" proposalTokenMoved
pguardC
"Owner signs this transaction OR proposal token is spent"
(ownerSignsTransaction #|| proposalTokenMoved)
pguardC "A UTXO must exist with the correct output" $ pguardC "A UTXO must exist with the correct output" $
let correctOutputDatum = stakeOutUnchanged let expectedLocks = pfield @"locks" # l
valueCorrect = ownOutputValueUnchanged
in foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "correctOutputDatum" correctOutputDatum
]
pure $ popaque (pconstant ())
--------------------------------------------------------------------------
PDepositWithdraw r -> unTermCont $ do
pguardC "ST at inputs must be 1" $
spentST #== 1
pguardC "Stake unlocked" $
pnot #$ stakeIsLocked
pguardC
"Owner signs this transaction"
ownerSignsTransaction
pguardC "A UTXO must exist with the correct output" $
unTermCont $ do
let oldStakedAmount = pfromData $ stakeDatum.stakedAmount
delta = pfromData $ pfield @"delta" # r
newStakedAmount <- pletC $ oldStakedAmount + delta expectedDatum =
mkRecordConstr
PStakeDatum
( #stakedAmount .= stakeDatum.stakedAmount
.& #owner .= stakeDatum.owner
.& #lockedBy .= expectedLocks
)
pguardC "New staked amount shoudl be greater than or equal to 0" $ valueCorrect = ownOutputValueUnchanged
zero #<= newStakedAmount outputDatumCorrect = stakeOut #== expectedDatum
in foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" outputDatumCorrect
]
let expectedDatum = pure $ popaque (pconstant ())
------------------------------------------------------------
PPermitVote l -> unTermCont $ do
pguardC
"Owner signs this transaction"
ownerSignsTransaction
-- This puts trust into the Proposal. The Proposal must necessarily check
-- that this is not abused.
pguardC "Proposal ST spent" proposalTokenMoved
-- Update the stake datum, but only the 'lockedBy' field.
let -- We actually don't know whether the given lock is valid or not.
-- This is checked in the proposal validator.
newLock = pfield @"lock" # l
-- Prepend the new lock to the existing locks.
expectedLocks = pcons # newLock # stakeDatum.lockedBy
expectedDatum <-
pletC $
mkRecordConstr mkRecordConstr
PStakeDatum PStakeDatum
( #stakedAmount .= pdata newStakedAmount ( #stakedAmount .= stakeDatum.stakedAmount
.& #owner .= stakeDatum.owner .& #owner .= stakeDatum.owner
.& #lockedBy .= stakeDatum.lockedBy .& #lockedBy .= pdata expectedLocks
) )
datumCorrect = stakeOut #== expectedDatum
let valueDelta :: Term _ (PValue _ 'Positive) pguardC "A UTXO must exist with the correct output" $
valueDelta = pdiscreteValue' stake.gtClassRef # delta let correctOutputDatum = stakeOut #== expectedDatum
valueCorrect = ownOutputValueUnchanged
in foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" correctOutputDatum
]
expectedValue = pure $ popaque (pconstant ())
continuingValue <> valueDelta
valueCorrect = ------------------------------------------------------------
foldr1
(#&&) PDepositWithdraw r -> unTermCont $ do
[ pgeqByClass' (AssetClass ("", "")) pguardC "Stake unlocked" $
# ownOutputValue pnot #$ stakeIsLocked
# expectedValue pguardC
, pgeqByClass' (untag stake.gtClassRef) "Owner signs this transaction"
# ownOutputValue ownerSignsTransaction
# expectedValue pguardC "A UTXO must exist with the correct output" $
, pgeqBySymbol unTermCont $ do
# stCurrencySymbol let oldStakedAmount = pfromData $ stakeDatum.stakedAmount
# ownOutputValue delta = pfromData $ pfield @"delta" # r
# expectedValue
] newStakedAmount <- pletC $ oldStakedAmount + delta
--
pure $ pguardC "New staked amount shoudl be greater than or equal to 0" $
foldl1 zero #<= newStakedAmount
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect let expectedDatum =
, ptraceIfFalse "datumCorrect" datumCorrect mkRecordConstr
] PStakeDatum
-- ( #stakedAmount .= pdata newStakedAmount
pure $ popaque (pconstant ()) .& #owner .= stakeDatum.owner
_ -> popaque (pconstant ()) .& #lockedBy .= stakeDatum.lockedBy
)
datumCorrect = stakeOut #== expectedDatum
let valueDelta :: Term _ (PValue _ 'Positive)
valueDelta = pdiscreteValue' stake.gtClassRef # delta
expectedValue =
resolvedF.value <> valueDelta
valueCorrect =
foldr1
(#&&)
[ pgeqByClass' (AssetClass ("", ""))
# ownOutputValue
# expectedValue
, pgeqByClass' (untag stake.gtClassRef)
# ownOutputValue
# expectedValue
, pgeqBySymbol
# stCurrencySymbol
# ownOutputValue
# expectedValue
]
--
pure $
foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" datumCorrect
]
--
pure $ popaque (pconstant ())
_ -> popaque (pconstant ())
pure $
pif
(pdata stakeRedeemer #== pconstantData WitnessStake)
witnessStake
onlyAcceptOneStake

8
bench.csv
View file

@ -5,13 +5,13 @@ Agora/Effects/Treasury Withdrawal Effect/effect/Mixed Assets,456007605,1104500,3
Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/governor validator should pass,87839169,243032,8561 Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/governor validator should pass,87839169,243032,8561
Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/effect validator should pass,106082031,292993,3609 Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/effect validator should pass,106082031,292993,3609
Agora/Stake/policy/stakeCreation,50939580,148729,2387 Agora/Stake/policy/stakeCreation,50939580,148729,2387
Agora/Stake/validator/stakeDepositWithdraw deposit,181581435,493259,4413 Agora/Stake/validator/stakeDepositWithdraw deposit,180222751,492217,5003
Agora/Stake/validator/stakeDepositWithdraw withdraw,181581435,493259,4401 Agora/Stake/validator/stakeDepositWithdraw withdraw,180222751,492217,4991
Agora/Proposal/policy/proposalCreation,23140177,69194,1515 Agora/Proposal/policy/proposalCreation,23140177,69194,1515
Agora/Proposal/validator/cosignature/proposal,240482868,674626,8525 Agora/Proposal/validator/cosignature/proposal,240482868,674626,8525
Agora/Proposal/validator/cosignature/stake,125315872,312659,4942 Agora/Proposal/validator/cosignature/stake,136781411,336612,5528
Agora/Proposal/validator/voting/proposal,243946100,678901,8443 Agora/Proposal/validator/voting/proposal,243946100,678901,8443
Agora/Proposal/validator/voting/stake,120122971,320497,4899 Agora/Proposal/validator/voting/stake,128972262,348186,5489
Agora/Proposal/validator/advancing/successfully advance to next state/Draft -> VotringReady,219342631,620576,8350 Agora/Proposal/validator/advancing/successfully advance to next state/Draft -> VotringReady,219342631,620576,8350
Agora/Proposal/validator/advancing/successfully advance to next state/VotingReady -> Locked,247748475,699343,8359 Agora/Proposal/validator/advancing/successfully advance to next state/VotingReady -> Locked,247748475,699343,8359
Agora/Proposal/validator/advancing/successfully advance to next state/Locked -> Finished,236509366,666512,8359 Agora/Proposal/validator/advancing/successfully advance to next state/Locked -> Finished,236509366,666512,8359

1 name cpu mem size
5 Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/governor validator should pass 87839169 243032 8561
6 Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/effect validator should pass 106082031 292993 3609
7 Agora/Stake/policy/stakeCreation 50939580 148729 2387
8 Agora/Stake/validator/stakeDepositWithdraw deposit 181581435 180222751 493259 492217 4413 5003
9 Agora/Stake/validator/stakeDepositWithdraw withdraw 181581435 180222751 493259 492217 4401 4991
10 Agora/Proposal/policy/proposalCreation 23140177 69194 1515
11 Agora/Proposal/validator/cosignature/proposal 240482868 674626 8525
12 Agora/Proposal/validator/cosignature/stake 125315872 136781411 312659 336612 4942 5528
13 Agora/Proposal/validator/voting/proposal 243946100 678901 8443
14 Agora/Proposal/validator/voting/stake 120122971 128972262 320497 348186 4899 5489
15 Agora/Proposal/validator/advancing/successfully advance to next state/Draft -> VotringReady 219342631 620576 8350
16 Agora/Proposal/validator/advancing/successfully advance to next state/VotingReady -> Locked 247748475 699343 8359
17 Agora/Proposal/validator/advancing/successfully advance to next state/Locked -> Finished 236509366 666512 8359