witnessing stakes in reference inputs
This commit is contained in:
Hongrui Fang
方泓睿
parent
02dd95aceb
commit
57082eb106
5 changed files with 340 additions and 257 deletions
|
|
@ -9,8 +9,7 @@ Proposal scripts encoding effects that operate on the system.
|
|||
-}
|
||||
module Agora.Proposal (
|
||||
-- * Haskell-land
|
||||
|
||||
-- Proposal (..),
|
||||
ProposalEffectMetadata (..),
|
||||
ProposalEffectGroup,
|
||||
ProposalDatum (..),
|
||||
ProposalRedeemer (..),
|
||||
|
|
@ -22,6 +21,7 @@ module Agora.Proposal (
|
|||
emptyVotesFor,
|
||||
|
||||
-- * Plutarch-land
|
||||
PProposalEffectMetadata (..),
|
||||
PProposalEffectGroup,
|
||||
PProposalDatum (..),
|
||||
PProposalRedeemer (..),
|
||||
|
|
|
|||
|
|
@ -39,32 +39,41 @@ import Agora.Stake (
|
|||
pisVoter,
|
||||
)
|
||||
import Agora.Utils (
|
||||
plistEqualsBy,
|
||||
pltAsData,
|
||||
)
|
||||
import Plutarch.Api.V1 (PCredential)
|
||||
import Plutarch.Api.V1.AssocMap (plookup)
|
||||
import Plutarch.Api.V2 (
|
||||
PDatumHash,
|
||||
PMintingPolicy,
|
||||
PScriptContext (PScriptContext),
|
||||
PScriptPurpose (PMinting, PSpending),
|
||||
PTxInInfo,
|
||||
PTxInfo (PTxInfo),
|
||||
PTxOut,
|
||||
PValidator,
|
||||
)
|
||||
import Plutarch.Extra.AssetClass (passetClass, passetClassValueOf)
|
||||
import Plutarch.Extra.Category (PCategory (pidentity))
|
||||
import Plutarch.Extra.Comonad (pextract)
|
||||
import Plutarch.Extra.Field (pletAll, pletAllC)
|
||||
import Plutarch.Extra.List (pfirstJust, pisUniq', pmapMaybe, pmergeBy, pmsortBy)
|
||||
import Plutarch.Extra.Functor (pfmap)
|
||||
import Plutarch.Extra.List (pfirstJust, pisUniq', pmergeBy, pmsort)
|
||||
import Plutarch.Extra.Map (pupdate)
|
||||
import Plutarch.Extra.Maybe (passertPJust, pfromJust, pisJust, pjust, pnothing)
|
||||
import Plutarch.Extra.Maybe (
|
||||
passertPJust,
|
||||
pfromJust,
|
||||
pfromMaybe,
|
||||
pisJust,
|
||||
pjust,
|
||||
pnothing,
|
||||
)
|
||||
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
|
||||
import Plutarch.Extra.ScriptContext (
|
||||
pfindTxInByTxOutRef,
|
||||
pfromDatumHash,
|
||||
pfromOutputDatum,
|
||||
pisTokenSpent,
|
||||
ptryFindDatum,
|
||||
ptryFromOutputDatum,
|
||||
)
|
||||
import Plutarch.Extra.TermCont (
|
||||
pguardC,
|
||||
|
|
@ -125,6 +134,33 @@ proposalPolicy (AssetClass (govCs, govTn)) =
|
|||
|
||||
pure $ popaque (pconstant ())
|
||||
|
||||
data PWitneseMultipleStakeContext (s :: S) = PWitneseMultipleStakeContext
|
||||
{ totalAmount :: Term s PInteger
|
||||
, orderedOwners :: Term s (PList PCredential)
|
||||
}
|
||||
deriving stock (Generic)
|
||||
deriving anyclass
|
||||
( PlutusType
|
||||
)
|
||||
|
||||
instance DerivePlutusType PWitneseMultipleStakeContext where
|
||||
type DPTStrat _ = PlutusTypeScott
|
||||
|
||||
data PSpendSingleStakeContext (s :: S) = PSpendSingleStakeContext
|
||||
{ inputStake :: Term s PStakeDatum
|
||||
, outputStake :: Term s PStakeDatum
|
||||
}
|
||||
deriving stock (Generic)
|
||||
deriving anyclass
|
||||
( PlutusType
|
||||
)
|
||||
|
||||
instance DerivePlutusType PSpendSingleStakeContext where
|
||||
type DPTStrat _ = PlutusTypeScott
|
||||
|
||||
pemptyWitneseMultipleStakeContext :: forall (s :: S). Term s PWitneseMultipleStakeContext
|
||||
pemptyWitneseMultipleStakeContext = pcon $ PWitneseMultipleStakeContext 0 pnil
|
||||
|
||||
{- | The validator for Proposals.
|
||||
|
||||
The documentation for various of the redeemers lives at 'Agora.Proposal.ProposalRedeemer'.
|
||||
|
|
@ -167,7 +203,8 @@ proposalValidator as maximumCosigners =
|
|||
PTxInfo txInfo' <- pmatchC txInfo
|
||||
txInfoF <-
|
||||
pletFieldsC
|
||||
@'[ "inputs"
|
||||
@'[ "referenceInputs"
|
||||
, "inputs"
|
||||
, "outputs"
|
||||
, "mint"
|
||||
, "datums"
|
||||
|
|
@ -256,6 +293,8 @@ proposalValidator as maximumCosigners =
|
|||
|
||||
onlyStatusChanged <-
|
||||
pletC $
|
||||
-- Only the status of proposals is updated.
|
||||
|
||||
-- Only the status of proposals is updated.
|
||||
proposalOut
|
||||
#== mkRecordConstr
|
||||
|
|
@ -274,141 +313,130 @@ proposalValidator as maximumCosigners =
|
|||
|
||||
-- Find the stake inputs/outputs by SST.
|
||||
|
||||
let AssetClass (stakeSym, stakeTn) = stakeSTAssetClass as
|
||||
stakeSTAssetClass <-
|
||||
pletC $ passetClass # pconstant stakeSym # pconstant stakeTn
|
||||
|
||||
filterStakeDatumHash :: Term _ (PTxOut :--> PMaybe (PAsData PDatumHash)) <-
|
||||
getStakeDatum :: Term _ (PTxOut :--> PMaybe PStakeDatum) <-
|
||||
pletC $
|
||||
plam $ \txOut -> unTermCont $ do
|
||||
txOutF <- pletFieldsC @'["value", "datum"] txOut
|
||||
pure $
|
||||
pif
|
||||
(passetClassValueOf # txOutF.value # stakeSTAssetClass #== 1)
|
||||
( let datumHash = pfromDatumHash # txOutF.datum
|
||||
in pcon $ PJust $ pdata datumHash
|
||||
)
|
||||
(pcon PNothing)
|
||||
plam $
|
||||
flip (pletFields @'["value", "datum"]) $ \txOutF ->
|
||||
let AssetClass (stakeSym, _) = stakeSTAssetClass as
|
||||
|
||||
stakeInputDatumHashes <-
|
||||
pletC $
|
||||
pmapMaybe @PBuiltinList
|
||||
# plam ((filterStakeDatumHash #) . (pfield @"resolved" #))
|
||||
# txInfoF.inputs
|
||||
isStakeUTxO =
|
||||
psymbolValueOf
|
||||
# pconstant stakeSym
|
||||
# txOutF.value
|
||||
#== 1
|
||||
|
||||
stakeOutputDatumHashes <-
|
||||
pletC $
|
||||
pmapMaybe @PBuiltinList
|
||||
# filterStakeDatumHash
|
||||
# txInfoF.outputs
|
||||
stake =
|
||||
pfromData $
|
||||
pfromJust
|
||||
-- Use inline datum to avoid extra map lookup.
|
||||
#$ ptryFromOutputDatum @(PAsData PStakeDatum)
|
||||
# txOutF.datum
|
||||
# txInfoF.datums
|
||||
in pif isStakeUTxO (pjust # stake) pnothing
|
||||
|
||||
stakeInputNum <- pletC $ plength # stakeInputDatumHashes
|
||||
|
||||
pguardC "Every stake input should have a correspoding output" $
|
||||
stakeInputNum #== plength # stakeOutputDatumHashes
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
withMultipleStakes' ::
|
||||
witnessStakes' ::
|
||||
Term
|
||||
_
|
||||
( ( PInteger
|
||||
:--> PBuiltinList (PAsData PCredential)
|
||||
:--> PUnit
|
||||
)
|
||||
:--> PUnit
|
||||
s
|
||||
( (PWitneseMultipleStakeContext :--> PUnit) :--> PUnit
|
||||
) <-
|
||||
pletC $
|
||||
plam $ \validationLogic -> unTermCont $ do
|
||||
-- The following code ensures that all the stake datums are not
|
||||
-- changed.
|
||||
--
|
||||
-- TODO: This is quite inefficient (O(nlogn)) but for now we don't
|
||||
-- have a nice way to check this. In plutus v2 we'll have map of
|
||||
-- (Script -> Redeemer) in ScriptContext, which should be the
|
||||
-- straight up solution.
|
||||
let sortDatumHashes = phoistAcyclic $ pmsortBy # pltAsData
|
||||
let updateCtx = plam $ \ctx' stake -> unTermCont $ do
|
||||
ctxF <- pmatchC ctx'
|
||||
|
||||
sortedStakeInputDatumHashes =
|
||||
sortDatumHashes # stakeInputDatumHashes
|
||||
stakeF <-
|
||||
pletFieldsC @'["stakedAmount", "owner"] $
|
||||
pto stake
|
||||
|
||||
sortedStakeOutputDatumHashes =
|
||||
sortDatumHashes # stakeOutputDatumHashes
|
||||
pure $
|
||||
pcon $
|
||||
PWitneseMultipleStakeContext
|
||||
{ totalAmount =
|
||||
ctxF.totalAmount
|
||||
+ punsafeCoerce
|
||||
(pfromData stakeF.stakedAmount)
|
||||
, orderedOwners =
|
||||
pcons # stakeF.owner
|
||||
# ctxF.orderedOwners
|
||||
}
|
||||
|
||||
pguardC "All stake datum are unchanged" $
|
||||
plistEquals
|
||||
# sortedStakeInputDatumHashes
|
||||
# sortedStakeOutputDatumHashes
|
||||
f :: Term _ (_ :--> PTxInInfo :--> _)
|
||||
f = plam $ \ctx' ((pfield @"resolved" #) -> txOut) ->
|
||||
pfromMaybe # ctx'
|
||||
#$ (pfmap # (updateCtx # ctx') #$ getStakeDatum # txOut)
|
||||
|
||||
PPair totalStakedAmount stakeOwners <-
|
||||
pmatchC $
|
||||
pfoldl
|
||||
# plam
|
||||
( \l dh -> unTermCont $ do
|
||||
let stake =
|
||||
pfromData $
|
||||
pfromJust
|
||||
#$ ptryFindDatum @(PAsData PStakeDatum)
|
||||
# pfromData dh
|
||||
# txInfoF.datums
|
||||
sortOwners = plam $
|
||||
flip pmatch $ \ctxF ->
|
||||
pcon $
|
||||
PWitneseMultipleStakeContext
|
||||
{ totalAmount = ctxF.totalAmount
|
||||
, orderedOwners = pmsort # ctxF.orderedOwners
|
||||
}
|
||||
|
||||
stakeF <- pletFieldsC @'["stakedAmount", "owner"] $ pto stake
|
||||
ctx =
|
||||
sortOwners
|
||||
#$ pfoldl
|
||||
# f
|
||||
# pemptyWitneseMultipleStakeContext
|
||||
# txInfoF.referenceInputs
|
||||
in plam (# ctx)
|
||||
|
||||
PPair amount owners <- pmatchC l
|
||||
let witnessStakes ::
|
||||
( PWitneseMultipleStakeContext _ ->
|
||||
TermCont _ ()
|
||||
) ->
|
||||
Term _ POpaque
|
||||
witnessStakes c = popaque $
|
||||
witnessStakes' #$ plam $ \sctxF ->
|
||||
unTermCont $ pmatchC sctxF >>= c >> pure (pconstant ())
|
||||
|
||||
let newAmount = amount + punsafeCoerce (pfromData stakeF.stakedAmount)
|
||||
updatedOwners = pcons # stakeF.owner # owners
|
||||
|
||||
pure $ pcon $ PPair newAmount updatedOwners
|
||||
)
|
||||
# pcon (PPair (0 :: Term _ PInteger) (pnil @PBuiltinList))
|
||||
# stakeInputDatumHashes
|
||||
|
||||
sortedStakeOwners <- pletC $ pmsortBy # pltAsData # stakeOwners
|
||||
|
||||
pure $ validationLogic # totalStakedAmount # sortedStakeOwners
|
||||
|
||||
withSingleStake' ::
|
||||
spendSingleStake' ::
|
||||
Term
|
||||
_
|
||||
( ( PStakeDatum :--> PStakeDatum :--> PBool :--> PUnit
|
||||
)
|
||||
:--> PUnit
|
||||
) <- pletC $
|
||||
plam $ \validationLogic -> unTermCont $ do
|
||||
pguardC "Can only deal with one stake" $
|
||||
stakeInputNum #== 1
|
||||
s
|
||||
((PSpendSingleStakeContext :--> PUnit) :--> PUnit) <-
|
||||
pletC $
|
||||
let singleInput ::
|
||||
Term
|
||||
_
|
||||
( PMaybe PStakeDatum
|
||||
:--> PTxInInfo
|
||||
:--> PMaybe PStakeDatum
|
||||
)
|
||||
singleInput = plam $ \l ((pfield @"resolved" #) -> txOut) ->
|
||||
unTermCont $ do
|
||||
lF <- pmatchC l
|
||||
t <- pletC $ getStakeDatum # txOut
|
||||
tF <- pmatchC l
|
||||
|
||||
stakeInputHash <- pletC $ pfromData $ phead # stakeInputDatumHashes
|
||||
stakeOutputHash <- pletC $ pfromData $ phead # stakeOutputDatumHashes
|
||||
pure $ case (lF, tF) of
|
||||
(PJust _, PJust _) ->
|
||||
ptraceError "Can only deal with one stake"
|
||||
(PNothing, _) -> t
|
||||
(_, PNothing) -> l
|
||||
|
||||
stakeIn :: Term _ PStakeDatum <-
|
||||
pletC $ pfromData $ pfromJust #$ ptryFindDatum # stakeInputHash # txInfoF.datums
|
||||
stakeInput =
|
||||
passertPJust # "Stake input not found"
|
||||
#$ pfoldl # singleInput # pnothing # txInfoF.inputs
|
||||
|
||||
stakeOut :: Term _ PStakeDatum <-
|
||||
pletC $ pfromData $ pfromJust #$ ptryFindDatum # stakeOutputHash # txInfoF.datums
|
||||
stakeOutput =
|
||||
pfromJust
|
||||
#$ pfirstJust # getStakeDatum # txInfoF.outputs
|
||||
|
||||
stakeUnchanged <- pletC $ stakeInputHash #== stakeOutputHash
|
||||
ctx = pcon $ PSpendSingleStakeContext stakeInput stakeOutput
|
||||
in plam (# ctx)
|
||||
|
||||
pure $ validationLogic # stakeIn # stakeOut # stakeUnchanged
|
||||
|
||||
let withMultipleStakes val =
|
||||
withMultipleStakes'
|
||||
#$ plam
|
||||
$ \totalStakedAmount sortedStakeOwner ->
|
||||
unTermCont $
|
||||
val totalStakedAmount sortedStakeOwner
|
||||
|
||||
withSingleStake val =
|
||||
withSingleStake' #$ plam $ \stakeIn stakeOut stakeUnchange -> unTermCont $ do
|
||||
stakeInF <- pletAllC $ pto stakeIn
|
||||
|
||||
val stakeInF stakeOut stakeUnchange
|
||||
let spendSingleStake ::
|
||||
( PSpendSingleStakeContext _ ->
|
||||
TermCont _ ()
|
||||
) ->
|
||||
Term _ POpaque
|
||||
spendSingleStake c = popaque $
|
||||
spendSingleStake' #$ plam $ \sctx ->
|
||||
unTermCont $ pmatchC sctx >>= c >> pure (pconstant ())
|
||||
|
||||
pure $
|
||||
popaque $
|
||||
pmatch proposalRedeemer $ \case
|
||||
PCosign r -> withMultipleStakes $ \_ sortedStakeOwners -> do
|
||||
PCosign r -> witnessStakes $ \sctxF -> do
|
||||
pguardC "Should be in draft state" $
|
||||
currentStatus #== pconstant Draft
|
||||
|
||||
|
|
@ -430,7 +458,10 @@ proposalValidator as maximumCosigners =
|
|||
pisUniq' # updatedSigs
|
||||
|
||||
pguardC "All new cosigners are witnessed by their Stake datums" $
|
||||
plistEquals # sortedStakeOwners # newSigs
|
||||
plistEqualsBy
|
||||
# plam (\x (pfromData -> y) -> x #== y)
|
||||
# sctxF.orderedOwners
|
||||
# newSigs
|
||||
|
||||
let expectedDatum =
|
||||
mkRecordConstr
|
||||
|
|
@ -448,11 +479,11 @@ proposalValidator as maximumCosigners =
|
|||
pguardC "Signatures are correctly added to cosignature list" $
|
||||
proposalOut #== expectedDatum
|
||||
|
||||
pure $ pconstant ()
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
PVote r -> withSingleStake $ \stakeInF stakeOut _ -> do
|
||||
PVote r -> spendSingleStake $ \sctxF -> do
|
||||
stakeInF <- pletAllC $ pto sctxF.inputStake
|
||||
|
||||
pguardC "Input proposal must be in VotingReady state" $
|
||||
currentStatus #== pconstant VotingReady
|
||||
|
||||
|
|
@ -471,7 +502,7 @@ proposalValidator as maximumCosigners =
|
|||
|
||||
-- Ensure that no lock with the current proposal id has been put on the stake.
|
||||
pguardC "Same stake shouldn't vote on the same proposal twice" $
|
||||
pnot #$ pisVoter #$ pgetStakeRole # proposalF.proposalId # pfromData stakeInF.lockedBy
|
||||
pnot #$ pisVoter #$ pgetStakeRole # proposalF.proposalId # stakeInF.lockedBy
|
||||
|
||||
let -- The amount of new votes should be the 'stakedAmount'.
|
||||
-- Update the vote counter of the proposal, and leave other stuff as is.
|
||||
|
|
@ -525,13 +556,13 @@ proposalValidator as maximumCosigners =
|
|||
.& #lockedBy .= pdata expectedProposalLocks
|
||||
)
|
||||
|
||||
pguardC "Output stake should be locked by the proposal" $ expectedStakeOut #== stakeOut
|
||||
|
||||
pure $ pconstant ()
|
||||
pguardC "Output stake should be locked by the proposal" $ expectedStakeOut #== sctxF.outputStake
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
PUnlock _ -> withSingleStake $ \stakeInF stakeOut _ -> do
|
||||
PUnlock _ -> spendSingleStake $ \sctxF -> do
|
||||
stakeInF <- pletAllC $ pto sctxF.inputStake
|
||||
|
||||
stakeRole <- pletC $ pgetStakeRole # proposalF.proposalId # stakeInF.lockedBy
|
||||
|
||||
pguardC "Stake input should be relevant" $
|
||||
|
|
@ -592,7 +623,7 @@ proposalValidator as maximumCosigners =
|
|||
$ ptraceIfFalse "Proposal unchanged" proposalUnchanged
|
||||
|
||||
-- At last, we ensure that all locks belong to this proposal will be removed.
|
||||
stakeOutputLocks <- pletC $ pfield @"lockedBy" # pto stakeOut
|
||||
stakeOutputLocks <- pletC $ pfield @"lockedBy" # pto sctxF.outputStake
|
||||
|
||||
let templateStakeOut =
|
||||
mkRecordConstr
|
||||
|
|
@ -604,102 +635,99 @@ proposalValidator as maximumCosigners =
|
|||
)
|
||||
|
||||
pguardC "Only locks updated in the output stake" $
|
||||
templateStakeOut #== stakeOut
|
||||
templateStakeOut #== sctxF.outputStake
|
||||
|
||||
pguardC "All relevant locks removed from the stake" $
|
||||
validateOutputLocks # stakeOutputLocks
|
||||
|
||||
pure $ pconstant ()
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
PAdvanceProposal _ -> unTermCont $ do
|
||||
currentTime' <- pletC $ pfromJust # currentTime
|
||||
|
||||
let inDraftPeriod = isDraftPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime'
|
||||
inVotingPeriod = isVotingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime'
|
||||
inExecutionPeriod = isExecutionPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime'
|
||||
|
||||
inLockedPeriod <- pletC $ isLockingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime'
|
||||
|
||||
pguardC "Only status changes in the output proposal" onlyStatusChanged
|
||||
let gstSymbol = pconstant $ governorSTSymbol as
|
||||
gstMoved <-
|
||||
pletC $
|
||||
pany
|
||||
# plam
|
||||
( \( (pfield @"value" #)
|
||||
. (pfield @"resolved" #) ->
|
||||
value
|
||||
) ->
|
||||
psymbolValueOf # gstSymbol # value #== 1
|
||||
)
|
||||
# pfromData txInfoF.inputs
|
||||
let toFailedState = unTermCont $ do
|
||||
-- -> 'Finished'
|
||||
pguardC "Proposal should fail: not on time" $
|
||||
proposalOutStatus #== pconstant Finished
|
||||
|
||||
pguardC "GST not moved" $ pnot # gstMoved
|
||||
|
||||
pure $ pconstant ()
|
||||
pure $
|
||||
pmatch currentStatus $ \case
|
||||
PDraft ->
|
||||
withMultipleStakes $ \totalStakedAmount sortedStakeOwners ->
|
||||
pmatchC inDraftPeriod >>= \case
|
||||
witnessStakes $ \sctxF -> do
|
||||
let notTooLate = inDraftPeriod
|
||||
|
||||
pmatchC notTooLate >>= \case
|
||||
PTrue -> do
|
||||
pguardC "More cosigns than minimum amount" $
|
||||
punsafeCoerce (pfromData thresholdsF.vote) #< totalStakedAmount
|
||||
punsafeCoerce (pfromData thresholdsF.vote) #< sctxF.totalAmount
|
||||
|
||||
pguardC "All new cosigners are witnessed by their Stake datums" $
|
||||
plistEquals # sortedStakeOwners # proposalF.cosigners
|
||||
plistEqualsBy
|
||||
# plam (\x (pfromData -> y) -> x #== y)
|
||||
# sctxF.orderedOwners
|
||||
# proposalF.cosigners
|
||||
|
||||
-- 'Draft' -> 'VotingReady'
|
||||
pguardC "Proposal status set to VotingReady" $
|
||||
proposalOutStatus #== pconstant VotingReady
|
||||
|
||||
pure $ pconstant ()
|
||||
PFalse -> do
|
||||
pguardC "Advance to failed state" $ proposalOutStatus #== pconstant Finished
|
||||
|
||||
pure $ pconstant ()
|
||||
-- Too late: failed proposal, status set to 'Finished'.
|
||||
PFalse ->
|
||||
pguardC "Proposal should fail: not on time" $
|
||||
proposalOutStatus #== pconstant Finished
|
||||
PVotingReady -> unTermCont $ do
|
||||
let notTooLate = inLockedPeriod
|
||||
notTooEarly = pnot # inVotingPeriod
|
||||
|
||||
pguardC "Cannot advance ahead of time" notTooEarly
|
||||
-- FIXME: This should be checked by Stake, as opposed to here.
|
||||
pguardC "No stakes must be present" $ stakeInputNum #== 0
|
||||
pure $
|
||||
pif
|
||||
notTooLate
|
||||
( unTermCont $ do
|
||||
-- 'VotingReady' -> 'Locked'
|
||||
pguardC "Proposal status set to Locked" $
|
||||
proposalOutStatus #== pconstant Locked
|
||||
|
||||
pguardC "Winner outcome not found" $
|
||||
pisJust #$ pwinner' # proposalF.votes
|
||||
#$ punsafeCoerce
|
||||
$ pfromData thresholdsF.execute
|
||||
pmatchC notTooLate >>= \case
|
||||
PTrue -> do
|
||||
-- 'VotingReady' -> 'Locked'
|
||||
pguardC "Proposal status set to Locked" $
|
||||
proposalOutStatus #== pconstant Locked
|
||||
|
||||
pure $ pconstant ()
|
||||
)
|
||||
-- Too late: failed proposal, status set to 'Finished'.
|
||||
toFailedState
|
||||
pguardC "Winner outcome not found" $
|
||||
pisJust #$ pwinner' # proposalF.votes
|
||||
#$ punsafeCoerce
|
||||
$ pfromData thresholdsF.execute
|
||||
-- Too late: failed proposal, status set to 'Finished'.
|
||||
PFalse ->
|
||||
pguardC "Proposal should fail: not on time" $
|
||||
proposalOutStatus #== pconstant Finished
|
||||
|
||||
pure $ popaque $ pconstant ()
|
||||
PLocked -> unTermCont $ do
|
||||
let notTooLate = inExecutionPeriod
|
||||
notTooEarly = pnot # inLockedPeriod
|
||||
|
||||
pguardC "Not too early" notTooEarly
|
||||
pguardC "No stakes must be present" $ stakeInputNum #== 0
|
||||
pure $
|
||||
|
||||
pguardC "Proposal status set to Finished" $
|
||||
proposalOutStatus #== pconstant Finished
|
||||
|
||||
let gstSymbol = pconstant $ governorSTSymbol as
|
||||
gstMoved =
|
||||
pany
|
||||
# plam
|
||||
( \( (pfield @"value" #)
|
||||
. (pfield @"resolved" #) ->
|
||||
value
|
||||
) ->
|
||||
psymbolValueOf # gstSymbol # value #== 1
|
||||
)
|
||||
# pfromData txInfoF.inputs
|
||||
|
||||
pguardC "GST not moved if too late, moved otherwise" $
|
||||
pif
|
||||
notTooLate
|
||||
( unTermCont $ do
|
||||
-- 'Locked' -> 'Finished'
|
||||
pguardC "Proposal status set to Finished" $
|
||||
proposalOutStatus #== pconstant Finished
|
||||
-- Not too late: GST should moved
|
||||
pidentity
|
||||
-- Not too late: GST should not moved
|
||||
pnot
|
||||
# gstMoved
|
||||
|
||||
pguardC "GST moved" gstMoved
|
||||
|
||||
pure $ pconstant ()
|
||||
)
|
||||
toFailedState
|
||||
pure $ popaque $ pconstant ()
|
||||
PFinished -> ptraceError "Finished proposals cannot be advanced"
|
||||
|
|
|
|||
|
|
@ -143,9 +143,6 @@ data StakeRedeemer
|
|||
-- always allowed to have votes retracted and won't affect the Proposal datum,
|
||||
-- allowing 'Stake's to be unlocked.
|
||||
RetractVotes
|
||||
| -- | The owner can consume stake if nothing is changed about it.
|
||||
-- If the proposal token moves, this is equivalent to the owner consuming it.
|
||||
WitnessStake
|
||||
| -- | The owner can delegate the stake to another user, allowing the
|
||||
-- delegate to vote on prooposals with the stake.
|
||||
DelegateTo Credential
|
||||
|
|
@ -164,9 +161,8 @@ PlutusTx.makeIsDataIndexed
|
|||
, ('Destroy, 1)
|
||||
, ('PermitVote, 2)
|
||||
, ('RetractVotes, 3)
|
||||
, ('WitnessStake, 4)
|
||||
, ('DelegateTo, 5)
|
||||
, ('ClearDelegate, 6)
|
||||
, ('DelegateTo, 4)
|
||||
, ('ClearDelegate, 5)
|
||||
]
|
||||
|
||||
{- | Haskell-level datum for Stake scripts.
|
||||
|
|
@ -264,7 +260,6 @@ data PStakeRedeemer (s :: S)
|
|||
PDestroy (Term s (PDataRecord '[]))
|
||||
| PPermitVote (Term s (PDataRecord '[]))
|
||||
| PRetractVotes (Term s (PDataRecord '[]))
|
||||
| PWitnessStake (Term s (PDataRecord '[]))
|
||||
| PDelegateTo (Term s (PDataRecord '["pkh" ':= PCredential]))
|
||||
| PClearDelegate (Term s (PDataRecord '[]))
|
||||
deriving stock
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@ Plutus Scripts for Stakes.
|
|||
module Agora.Stake.Scripts (stakePolicy, stakeValidator) where
|
||||
|
||||
import Agora.Credential (authorizationContext, pauthorizedBy)
|
||||
import Agora.Proposal (PProposalRedeemer (PUnlock, PVote))
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Scripts (AgoraScripts, proposalSTAssetClass, stakeSTSymbol)
|
||||
import Agora.Stake (
|
||||
|
|
@ -15,22 +16,22 @@ import Agora.Stake (
|
|||
PStakeRedeemer (..),
|
||||
pstakeLocked,
|
||||
)
|
||||
import Data.Function (on)
|
||||
import Data.Tagged (Tagged, untag)
|
||||
import Plutarch.Api.V1 (
|
||||
PCredential (PPubKeyCredential, PScriptCredential),
|
||||
PTokenName,
|
||||
PValue,
|
||||
)
|
||||
import Plutarch.Api.V1.AssocMap (plookup)
|
||||
import Plutarch.Api.V2 (
|
||||
AmountGuarantees (Positive),
|
||||
KeyGuarantees (Sorted),
|
||||
PDatumHash,
|
||||
PMaybeData,
|
||||
PMintingPolicy,
|
||||
PScriptPurpose (PMinting, PSpending),
|
||||
PTxInInfo,
|
||||
PTxInfo,
|
||||
PTxOut,
|
||||
PTxOutRef,
|
||||
PValidator,
|
||||
)
|
||||
import Plutarch.Extra.AssetClass (
|
||||
|
|
@ -38,23 +39,40 @@ import Plutarch.Extra.AssetClass (
|
|||
passetClassValueOf,
|
||||
pvalueOf,
|
||||
)
|
||||
import Plutarch.Extra.Bind (PBind ((#>>=)))
|
||||
import Plutarch.Extra.Field (pletAllC)
|
||||
import Plutarch.Extra.List (pmapMaybe, pmsortBy)
|
||||
import Plutarch.Extra.Maybe (passertPJust, pdjust, pdnothing, pmaybeData)
|
||||
import Plutarch.Extra.Functor (PFunctor (pfmap))
|
||||
import Plutarch.Extra.List (pfirstJust)
|
||||
import Plutarch.Extra.Maybe (
|
||||
passertPJust,
|
||||
pdjust,
|
||||
pdnothing,
|
||||
pjust,
|
||||
pmaybeData,
|
||||
pnothing,
|
||||
)
|
||||
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
|
||||
import Plutarch.Extra.ScriptContext (
|
||||
pfindTxInByTxOutRef,
|
||||
pfromDatumHash,
|
||||
pfromOutputDatum,
|
||||
pvalueSpent,
|
||||
)
|
||||
import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC)
|
||||
import Plutarch.Extra.TermCont (
|
||||
pguardC,
|
||||
pletC,
|
||||
pletFieldsC,
|
||||
pmatchC,
|
||||
ptryFromC,
|
||||
)
|
||||
import Plutarch.Extra.Value (
|
||||
pgeqByClass',
|
||||
pgeqBySymbol,
|
||||
psymbolValueOf,
|
||||
)
|
||||
import Plutarch.Numeric.Additive (AdditiveMonoid (zero), AdditiveSemigroup ((+)))
|
||||
import Plutarch.Numeric.Additive (
|
||||
AdditiveMonoid (zero),
|
||||
AdditiveSemigroup ((+)),
|
||||
)
|
||||
import Plutarch.SafeMoney (
|
||||
pdiscreteValue',
|
||||
pvalueDiscrete',
|
||||
|
|
@ -264,6 +282,7 @@ stakeValidator as gtClassRef =
|
|||
, "outputs"
|
||||
, "signatories"
|
||||
, "datums"
|
||||
, "redeemers"
|
||||
]
|
||||
txInfo
|
||||
|
||||
|
|
@ -321,9 +340,33 @@ stakeValidator as gtClassRef =
|
|||
_ -> unTermCont $ do
|
||||
let AssetClass (propCs, propTn) = proposalSTAssetClass as
|
||||
proposalSTClass = passetClass # pconstant propCs # pconstant propTn
|
||||
spentProposalST = passetClassValueOf # valueSpent # proposalSTClass
|
||||
|
||||
proposalTokenMoved <- pletC $ 1 #<= spentProposalST
|
||||
proposalRedeemer <-
|
||||
pletC $
|
||||
let convertRedeemer = plam $ \(pto -> dt) ->
|
||||
ptryFrom @PProposalRedeemer dt fst
|
||||
|
||||
findRedeemer = plam $ \ref ->
|
||||
plookup
|
||||
# pcon
|
||||
( PSpending $
|
||||
pdcons @_0
|
||||
# pdata ref
|
||||
# pdnil
|
||||
)
|
||||
# txInfoF.redeemers
|
||||
|
||||
f :: Term _ (PTxInInfo :--> PMaybe PTxOutRef)
|
||||
f = plam $ \inInfo ->
|
||||
let value = pfield @"value" #$ pfield @"resolved" # inInfo
|
||||
ref = pfield @"outRef" # inInfo
|
||||
in pif
|
||||
(passetClassValueOf # value # proposalSTClass #== 1)
|
||||
(pjust # ref)
|
||||
pnothing
|
||||
|
||||
proposalRef = pfirstJust # f # txInfoF.inputs
|
||||
in pfmap # convertRedeemer #$ proposalRef #>>= findRedeemer
|
||||
|
||||
-- Filter out own outputs using own address and ST.
|
||||
ownOutputs <-
|
||||
|
|
@ -339,52 +382,6 @@ stakeValidator as gtClassRef =
|
|||
)
|
||||
# pfromData txInfoF.outputs
|
||||
|
||||
let witnessStake = unTermCont $ do
|
||||
pguardC "Either owner signs the transaction or proposal token moved" $
|
||||
ownerSignsTransaction #|| proposalTokenMoved
|
||||
|
||||
-- FIXME: remove this once we have reference input.
|
||||
--
|
||||
-- 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 there's an output stake with the exact same value and datum hash as the stake being
|
||||
-- validated , 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
|
||||
|
||||
sortTxOuts :: Term _ (PBuiltinList PTxOut :--> PBuiltinList PTxOut)
|
||||
sortTxOuts = phoistAcyclic $ plam (pmsortBy # plam ((#<) `on` (getDatumHash #)) #)
|
||||
where
|
||||
getDatumHash :: Term _ (PTxOut :--> PDatumHash)
|
||||
getDatumHash = phoistAcyclic $ plam ((pfromDatumHash #) . (pfield @"datum" #))
|
||||
|
||||
sortedOwnInputs = sortTxOuts # ownInputs
|
||||
sortedOwnOutputs = sortTxOuts # ownOutputs
|
||||
|
||||
pguardC "Every stake inputs has a corresponding unchanged output" $
|
||||
plistEquals # sortedOwnInputs # sortedOwnOutputs
|
||||
|
||||
pure $ popaque $ pconstant ()
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
withSingleStake' ::
|
||||
|
|
@ -479,7 +476,17 @@ stakeValidator as gtClassRef =
|
|||
|
||||
-- This puts trust into the Proposal. The Proposal must necessarily check
|
||||
-- that this is not abused.
|
||||
pguardC "Proposal ST spent" proposalTokenMoved
|
||||
|
||||
pguardC "Proposal ST spent" $
|
||||
pmatch proposalRedeemer $ \case
|
||||
PJust redeemer -> pmatch redeemer $ \case
|
||||
PUnlock _ -> pconstant True
|
||||
_ ->
|
||||
ptrace "Expected PUnlock, but got other" $
|
||||
pconstant False
|
||||
PNothing ->
|
||||
ptrace "Proposal redeemer not found" $
|
||||
pconstant False
|
||||
|
||||
pguardC "A UTXO must exist with the correct output" $
|
||||
let valueCorrect = ctx.ownOutputValueUnchanged
|
||||
|
|
@ -503,7 +510,16 @@ stakeValidator as gtClassRef =
|
|||
-- This puts trust into the Proposal. The Proposal must necessarily check
|
||||
-- that this is not abused.
|
||||
pguardC "Proposal ST spent or minted" $
|
||||
proposalTokenMoved #|| proposalTokenMinted
|
||||
pmatch
|
||||
proposalRedeemer
|
||||
( \case
|
||||
PJust proposalRedeemer' ->
|
||||
pmatch proposalRedeemer' $ \case
|
||||
PVote _ -> pconstant True
|
||||
_ -> ptrace "Expected PVote" $ pconstant False
|
||||
_ -> proposalTokenMinted
|
||||
)
|
||||
|
||||
pguardC "A UTXO must exist with the correct output" $
|
||||
let correctOutputDatum = ctx.onlyLocksUpdated
|
||||
valueCorrect = ctx.ownOutputValueUnchanged
|
||||
|
|
@ -579,7 +595,4 @@ stakeValidator as gtClassRef =
|
|||
|
||||
------------------------------------------------------------------
|
||||
|
||||
PWitnessStake _ -> witnessStake
|
||||
------------------------------------------------------------------
|
||||
|
||||
_ -> ptraceError "unreachable"
|
||||
|
|
|
|||
|
|
@ -18,10 +18,15 @@ module Agora.Utils (
|
|||
pvalidatorHashToTokenName,
|
||||
pscriptHashToTokenName,
|
||||
scriptHashToTokenName,
|
||||
plistEqualsBy,
|
||||
pstringIntercalate,
|
||||
punwords,
|
||||
) where
|
||||
|
||||
import Plutarch.Api.V1 (PTokenName, PValidatorHash)
|
||||
import Plutarch.Api.V2 (PScriptHash)
|
||||
import Plutarch.Extra.TermCont (pmatchC)
|
||||
import Plutarch.List (puncons)
|
||||
import Plutarch.Unsafe (punsafeCoerce)
|
||||
import PlutusLedgerApi.V2 (
|
||||
Address (Address),
|
||||
|
|
@ -128,3 +133,45 @@ newtype CompiledMintingPolicy (redeemer :: Type) = CompiledMintingPolicy
|
|||
newtype CompiledEffect (datum :: Type) = CompiledEffect
|
||||
{ getCompiledEffect :: Validator
|
||||
}
|
||||
|
||||
-- | @since 1.0.0
|
||||
plistEqualsBy ::
|
||||
forall
|
||||
(list1 :: PType -> PType)
|
||||
(list2 :: PType -> PType)
|
||||
(a :: PType)
|
||||
(b :: PType)
|
||||
(s :: S).
|
||||
(PIsListLike list1 a, PIsListLike list2 b) =>
|
||||
Term s ((a :--> b :--> PBool) :--> list1 a :--> (list2 b :--> PBool))
|
||||
plistEqualsBy = phoistAcyclic $ pfix # go
|
||||
where
|
||||
go = plam $ \self eq l1 l2 -> unTermCont $ do
|
||||
l1' <- pmatchC $ puncons # l1
|
||||
l2' <- pmatchC $ puncons # l2
|
||||
|
||||
case (l1', l2') of
|
||||
(PJust l1'', PJust l2'') -> do
|
||||
(PPair h1 t1) <- pmatchC l1''
|
||||
(PPair h2 t2) <- pmatchC l2''
|
||||
|
||||
pure $ eq # h1 # h2 #&& self # eq # t1 # t2
|
||||
(PNothing, PNothing) -> pure $ pconstant True
|
||||
_ -> pure $ pconstant False
|
||||
|
||||
-- | @since 1.0.0
|
||||
pstringIntercalate ::
|
||||
forall (s :: S).
|
||||
Term s PString ->
|
||||
[Term s PString] ->
|
||||
Term s PString
|
||||
pstringIntercalate _ [x] = x
|
||||
pstringIntercalate i (x : xs) = x <> i <> pstringIntercalate i xs
|
||||
pstringIntercalate _ _ = ""
|
||||
|
||||
-- | @since 1.0.0
|
||||
punwords ::
|
||||
forall (s :: S).
|
||||
[Term s PString] ->
|
||||
Term s PString
|
||||
punwords = pstringIntercalate " "
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue