allow spending more than one stakes in one tx
This commit is contained in:
Hongrui Fang
parent
8e91a7ef2d
commit
1bc60a48e5
6 changed files with 397 additions and 325 deletions
|
|
@ -25,15 +25,21 @@ import Agora.Stake (
|
|||
PNoProposal,
|
||||
PWithProposalRedeemer
|
||||
),
|
||||
PSigContext (
|
||||
PSigContext (PSigContext),
|
||||
PSignedBy (
|
||||
PSignedByDelegate,
|
||||
PSignedByOwner,
|
||||
PUnknownSig
|
||||
),
|
||||
PStakeDatum,
|
||||
PStakeInputContext (PStakeInput),
|
||||
PStakeOutputContext (PStakeBurnt, PStakeOutput),
|
||||
PStakeRedeemer (PClearDelegate, PDelegateTo, PDepositWithdraw, PDestroy, PPermitVote, PRetractVotes),
|
||||
PStakeRedeemer (
|
||||
PClearDelegate,
|
||||
PDelegateTo,
|
||||
PDepositWithdraw,
|
||||
PDestroy,
|
||||
PPermitVote,
|
||||
PRetractVotes
|
||||
),
|
||||
PStakeRedeemerContext (
|
||||
PDepositWithdrawDelta,
|
||||
PNoMetadata,
|
||||
|
|
@ -57,15 +63,19 @@ import Agora.Stake.Redeemers (
|
|||
)
|
||||
import Data.Tagged (Tagged (Tagged))
|
||||
import Plutarch.Api.V1 (
|
||||
KeyGuarantees (Sorted),
|
||||
PCredential (PPubKeyCredential, PScriptCredential),
|
||||
PTokenName,
|
||||
)
|
||||
import Plutarch.Api.V1.AssocMap (plookup)
|
||||
import Plutarch.Api.V1.Value (PValue)
|
||||
import Plutarch.Api.V2 (
|
||||
AmountGuarantees,
|
||||
PMintingPolicy,
|
||||
PScriptPurpose (PMinting, PSpending),
|
||||
PTxInInfo,
|
||||
PTxInfo,
|
||||
PTxOut,
|
||||
PTxOutRef,
|
||||
PValidator,
|
||||
)
|
||||
|
|
@ -75,8 +85,9 @@ import Plutarch.Extra.AssetClass (
|
|||
pvalueOf,
|
||||
)
|
||||
import Plutarch.Extra.Bind (PBind ((#>>=)))
|
||||
import Plutarch.Extra.Field (pletAllC)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust)
|
||||
import Plutarch.Extra.Category (PSemigroupoid ((#>>>)))
|
||||
import Plutarch.Extra.Functor (PFunctor (pfmap))
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust, pmapMaybe)
|
||||
import Plutarch.Extra.Maybe (
|
||||
passertPJust,
|
||||
pjust,
|
||||
|
|
@ -100,6 +111,7 @@ import Plutarch.Extra.Value (
|
|||
psymbolValueOf,
|
||||
)
|
||||
import Plutarch.SafeMoney (
|
||||
pvalueDiscrete,
|
||||
pvalueDiscrete',
|
||||
)
|
||||
import Plutarch.Unsafe (punsafeCoerce)
|
||||
|
|
@ -235,8 +247,14 @@ mkStakeValidator
|
|||
impl
|
||||
as
|
||||
(Tagged (AssetClass (gtSym, gtTn))) =
|
||||
plam $ \datum redeemer ctx -> unTermCont $ do
|
||||
gtAssetClass <- pletC $ passetClass # pconstant gtSym # pconstant gtTn
|
||||
plam $ \_datum redeemer ctx -> unTermCont $ do
|
||||
let sstValueOf ::
|
||||
( forall (ag :: AmountGuarantees) (s :: S).
|
||||
Term s (PValue 'Sorted ag :--> PInteger)
|
||||
)
|
||||
sstValueOf =
|
||||
phoistAcyclic $
|
||||
psymbolValueOf # pconstant (stakeSTSymbol as)
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -257,118 +275,138 @@ mkStakeValidator
|
|||
|
||||
--------------------------------------------------------------------------
|
||||
|
||||
-- Assemble the stake input context.
|
||||
|
||||
stakeInputDatum <- pfromData . fst <$> ptryFromC datum
|
||||
stakeInputDatumF <- pletAllC $ pto stakeInputDatum
|
||||
|
||||
PSpending stakeInputRef <- pmatchC $ pfromData ctxF.purpose
|
||||
|
||||
-- The UTxO we are validating, which is also the input stake.
|
||||
stakeInput <-
|
||||
pletC $
|
||||
pfield @"resolved"
|
||||
#$ passertPJust # "Malformed script context: own input not found"
|
||||
#$ pfindTxInByTxOutRef
|
||||
# (pfield @"_0" # stakeInputRef)
|
||||
# txInfoF.inputs
|
||||
let validatedInput =
|
||||
pfield @"resolved"
|
||||
#$ passertPJust
|
||||
# "Malformed script context: validated input not found"
|
||||
#$ pfindTxInByTxOutRef
|
||||
# (pfield @"_0" # stakeInputRef)
|
||||
# txInfoF.inputs
|
||||
|
||||
stakeInputF <- pletFieldsC @'["address", "value"] stakeInput
|
||||
|
||||
stakeInputContext <-
|
||||
pletC $
|
||||
pcon $
|
||||
PStakeInput
|
||||
stakeInputDatum
|
||||
stakeInputF.value
|
||||
stakeValidatorAddress = pfield @"address" # validatedInput
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
|
||||
-- Assemble the signature context.
|
||||
getStakeDatum :: Term _ (PTxOut :--> PMaybe PStakeDatum) <-
|
||||
pletC $
|
||||
plam $ \txOut -> unTermCont $ do
|
||||
txOutF <- pletFieldsC @'["value", "datum", "address"] txOut
|
||||
|
||||
signedBy <- pletC $ pauthorizedBy # authorizationContext txInfoF
|
||||
let isStakeUTxO =
|
||||
foldl1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "Carries SST" $
|
||||
sstValueOf # txOutF.value #== 1
|
||||
, ptraceIfFalse "Owned by stake validator" $
|
||||
txOutF.address #== stakeValidatorAddress
|
||||
]
|
||||
|
||||
let ownerSignsTransaction = signedBy # stakeInputDatumF.owner
|
||||
datum =
|
||||
ptrace "Resolve stake datum" $
|
||||
pfromData $
|
||||
pfromOutputDatum @(PAsData PStakeDatum)
|
||||
# txOutF.datum
|
||||
# txInfoF.datums
|
||||
|
||||
pure $ pif isStakeUTxO (pjust # datum) pnothing
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
|
||||
stakeInputDatums <-
|
||||
pletC $
|
||||
pmapMaybe
|
||||
# ((pfield @"resolved") #>>> getStakeDatum)
|
||||
# pfromData txInfoF.inputs
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
|
||||
firstStakeInputDatumF <-
|
||||
pletFieldsC @'["owner", "delegatedTo"] $
|
||||
phead # stakeInputDatums
|
||||
|
||||
restOfStakeInputDatums <- pletC $ ptail # stakeInputDatums
|
||||
|
||||
pguardC "All input stakes have the same owner or delegate" $
|
||||
let allHaveSameOwner =
|
||||
pall
|
||||
# ( (pfield @"owner")
|
||||
#>>> plam (#== firstStakeInputDatumF.owner)
|
||||
)
|
||||
# restOfStakeInputDatums
|
||||
allHaveSameDelegate =
|
||||
pall
|
||||
# ( (pfield @"delegatedTo")
|
||||
#>>> plam (#== firstStakeInputDatumF.delegatedTo)
|
||||
)
|
||||
# restOfStakeInputDatums
|
||||
in allHaveSameOwner #|| allHaveSameDelegate
|
||||
|
||||
authorizedBy <- pletC $ pauthorizedBy # authorizationContext txInfoF
|
||||
|
||||
let ownerSignsTransaction = authorizedBy # firstStakeInputDatumF.owner
|
||||
|
||||
delegateSignsTransaction =
|
||||
pmaybeData
|
||||
# pconstant False
|
||||
# plam ((signedBy #) . pfromData)
|
||||
# pfromData stakeInputDatumF.delegatedTo
|
||||
# plam ((authorizedBy #) . pfromData)
|
||||
# pfromData firstStakeInputDatumF.delegatedTo
|
||||
|
||||
signedBy =
|
||||
pif
|
||||
ownerSignsTransaction
|
||||
(pcon PSignedByOwner)
|
||||
$ pif
|
||||
delegateSignsTransaction
|
||||
(pcon PSignedByDelegate)
|
||||
$ pcon PUnknownSig
|
||||
|
||||
sigContext <-
|
||||
pletC $
|
||||
pif ownerSignsTransaction (pcon PSignedByOwner) $
|
||||
pif delegateSignsTransaction (pcon PSignedByDelegate) $
|
||||
pcon PUnknownSig
|
||||
pcon $
|
||||
PSigContext
|
||||
firstStakeInputDatumF.owner
|
||||
firstStakeInputDatumF.delegatedTo
|
||||
signedBy
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
|
||||
stCurrencySymbol <- pletC $ pconstant $ stakeSTSymbol as
|
||||
mintedST <- pletC $ psymbolValueOf # stCurrencySymbol # txInfoF.mint
|
||||
valueSpent <- pletC $ pvalueSpent # txInfoF.inputs
|
||||
spentST <- pletC $ psymbolValueOf # stCurrencySymbol #$ valueSpent
|
||||
let gtAssetClass = passetClass # pconstant gtSym # pconstant gtTn
|
||||
|
||||
-- The stake validator can only handle one stake in one transaction.
|
||||
|
||||
pguardC "ST at inputs must be 1" $
|
||||
spentST #== 1
|
||||
|
||||
let oneStakeBurnt =
|
||||
ptraceIfFalse "Exactly one stake st burnt" $
|
||||
mintedST #== (-1)
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
|
||||
-- Assemble the stake output context.
|
||||
|
||||
let -- Look for the output stake.
|
||||
stakeOutput =
|
||||
pfindJust
|
||||
# plam
|
||||
( \output -> unTermCont $ do
|
||||
outputF <-
|
||||
pletFieldsC @'["address", "value", "datum"]
|
||||
output
|
||||
|
||||
let isStakeOutput =
|
||||
-- The stake should be owned by the stake validator.
|
||||
outputF.address #== stakeInputF.address
|
||||
#&&
|
||||
-- The stake UTxO carries the state thread token.
|
||||
psymbolValueOf
|
||||
# stCurrencySymbol
|
||||
# outputF.value #== 1
|
||||
|
||||
stakeOutputDatum =
|
||||
pfromOutputDatum
|
||||
# outputF.datum
|
||||
# txInfoF.datums
|
||||
|
||||
context =
|
||||
pcon $
|
||||
PStakeOutput
|
||||
(pfromData stakeOutputDatum)
|
||||
outputF.value
|
||||
|
||||
pure $
|
||||
pif
|
||||
isStakeOutput
|
||||
(pjust # context)
|
||||
pnothing
|
||||
)
|
||||
# pfromData txInfoF.outputs
|
||||
|
||||
stakeOutputContext <-
|
||||
stakeOutputDatums <-
|
||||
pletC $
|
||||
pmatch stakeOutput $ \case
|
||||
-- Stake output found.
|
||||
PJust stakeOutput' -> stakeOutput'
|
||||
-- Stake output not found, meaning the input stake should be burnt.
|
||||
PNothing -> unTermCont $ do
|
||||
pguardC "One stake should be burnt" oneStakeBurnt
|
||||
pmapMaybe
|
||||
# plam
|
||||
( \output ->
|
||||
let validateGT = plam $ \stakeDatum ->
|
||||
let expected = pfield @"stakedAmount" # stakeDatum
|
||||
actual =
|
||||
pvalueDiscrete
|
||||
# gtAssetClass
|
||||
# (pfield @"value" # output)
|
||||
in pif
|
||||
(expected #== actual)
|
||||
stakeDatum
|
||||
(ptraceError "Unmatched GT value")
|
||||
in pfmap
|
||||
# validateGT
|
||||
# (getStakeDatum # output)
|
||||
)
|
||||
# pfromData txInfoF.outputs
|
||||
|
||||
pure $ pcon PStakeBurnt
|
||||
--------------------------------------------------------------------------
|
||||
|
||||
mintedST <- pletC $ sstValueOf # txInfoF.mint
|
||||
|
||||
pguardC "No new SST minted" $
|
||||
foldl1
|
||||
(#||)
|
||||
[ ptraceIfFalse "All stakes burnt" $
|
||||
mintedST #< 0 #&& pnull # stakeOutputDatums
|
||||
, ptraceIfFalse "Nothing burnt" $
|
||||
mintedST #== 0
|
||||
]
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -427,12 +465,11 @@ mkStakeValidator
|
|||
plam $ \redeemerContext ->
|
||||
pcon $
|
||||
PStakeRedeemerHandlerContext
|
||||
stakeInputContext
|
||||
stakeOutputContext
|
||||
stakeInputDatums
|
||||
stakeOutputDatums
|
||||
redeemerContext
|
||||
sigContext
|
||||
proposalContext
|
||||
gtAssetClass
|
||||
txInfo
|
||||
|
||||
noMetadataContext <-
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue