WitnessStake: accept multiple stakes at input

This commit is contained in:
Hongrui Fang 2022-07-05 07:53:56 +08:00
parent ae0e78976a
commit d433ab17d6
No known key found for this signature in database
GPG key ID: 1C4711FFF64C0254
2 changed files with 243 additions and 177 deletions

View file

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

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/effect validator should pass,106082031,292993,3609
Agora/Stake/policy/stakeCreation,50939580,148729,2387
Agora/Stake/validator/stakeDepositWithdraw deposit,181581435,493259,4413
Agora/Stake/validator/stakeDepositWithdraw withdraw,181581435,493259,4401
Agora/Stake/validator/stakeDepositWithdraw deposit,180222751,492217,5003
Agora/Stake/validator/stakeDepositWithdraw withdraw,180222751,492217,4991
Agora/Proposal/policy/proposalCreation,23140177,69194,1515
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/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/VotingReady -> Locked,247748475,699343,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