From 57082eb10665e6e7ce11dfa813f15188da101441 Mon Sep 17 00:00:00 2001 From: Hongrui Fang Date: Tue, 30 Aug 2022 22:22:58 +0800 Subject: [PATCH] witnessing stakes in reference inputs --- agora/Agora/Proposal.hs | 4 +- agora/Agora/Proposal/Scripts.hs | 402 +++++++++++++++++--------------- agora/Agora/Stake.hs | 9 +- agora/Agora/Stake/Scripts.hs | 135 ++++++----- agora/Agora/Utils.hs | 47 ++++ 5 files changed, 340 insertions(+), 257 deletions(-) diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index 18d1483..7674f7c 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -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 (..), diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs index 01c23d7..19d6893 100644 --- a/agora/Agora/Proposal/Scripts.hs +++ b/agora/Agora/Proposal/Scripts.hs @@ -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" diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index cb600ff..efd6f37 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -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 diff --git a/agora/Agora/Stake/Scripts.hs b/agora/Agora/Stake/Scripts.hs index e253243..3ca8146 100644 --- a/agora/Agora/Stake/Scripts.hs +++ b/agora/Agora/Stake/Scripts.hs @@ -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" diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index 459fa69..043508f 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -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 " "