From 4411dba71704c12b0d3a43aa06ca25f1ec127184 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Mon, 25 Apr 2022 22:32:26 +0200 Subject: [PATCH] move Proposal impl. to `Agora.Proposal.Scripts` to avoid cyclic deps --- agora.cabal | 1 + agora/Agora/Effect/NoOp.hs | 1 - agora/Agora/Effect/TreasuryWithdrawal.hs | 8 +- agora/Agora/Proposal.hs | 200 +------------------- agora/Agora/Proposal/Scripts.hs | 227 +++++++++++++++++++++++ agora/Agora/Utils.hs | 13 ++ 6 files changed, 253 insertions(+), 197 deletions(-) create mode 100644 agora/Agora/Proposal/Scripts.hs diff --git a/agora.cabal b/agora.cabal index 1740981..1948966 100644 --- a/agora.cabal +++ b/agora.cabal @@ -129,6 +129,7 @@ library Agora.Governor Agora.MultiSig Agora.Proposal + Agora.Proposal.Scripts Agora.Proposal.Time Agora.Record Agora.SafeMoney diff --git a/agora/Agora/Effect/NoOp.hs b/agora/Agora/Effect/NoOp.hs index 90782e9..ccdae74 100644 --- a/agora/Agora/Effect/NoOp.hs +++ b/agora/Agora/Effect/NoOp.hs @@ -10,7 +10,6 @@ module Agora.Effect.NoOp (noOpValidator, PNoOp) where import Control.Applicative (Const) import Agora.Effect (makeEffect) -import Plutarch (popaque) import Plutarch.Api.V1 (PValidator) import Plutarch.TryFrom (PTryFrom (..)) import Plutus.V1.Ledger.Value (CurrencySymbol) diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index 209877f..312efbf 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -19,7 +19,6 @@ import Generics.SOP (Generic, I (I)) import Agora.Effect (makeEffect) import Agora.Utils (findTxOutByTxOutRef, paddValue, passert) -import Plutarch (popaque) import Plutarch.Api.V1 ( PCredential (..), PTuple, @@ -34,7 +33,7 @@ import Plutarch.DataRepr ( PDataFields, PIsDataReprInstances (..), ) -import Plutarch.Lift (PUnsafeLiftDecl (..)) +import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..)) import Plutarch.Monadic qualified as P import Plutarch.TryFrom (PTryFrom (..)) import Plutus.V1.Ledger.Credential (Credential) @@ -69,10 +68,11 @@ newtype PTreasuryWithdrawalDatum (s :: S) instance PUnsafeLiftDecl PTreasuryWithdrawalDatum where type PLifted PTreasuryWithdrawalDatum = TreasuryWithdrawalDatum + deriving via (DerivePConstantViaData TreasuryWithdrawalDatum PTreasuryWithdrawalDatum) instance - (PConstant TreasuryWithdrawalDatum) + (PConstantDecl TreasuryWithdrawalDatum) instance PTryFrom PData PTreasuryWithdrawalDatum where type PTryFromExcess PData PTreasuryWithdrawalDatum = Const () @@ -99,7 +99,7 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ \_cs (datum' :: Term _ PTreasuryWithdrawalDatum) txOutRef' txInfo' -> P.do datum <- pletFields @'["receivers", "treasuries"] datum' txInfo <- pletFields @'["outputs", "inputs"] txInfo' - PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef' # pfromData txInfo' + PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef' # pfromData txInfo.inputs effInput <- pletFields @'["address", "value"] $ txOut outputValues <- plet $ diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index e6cdce0..6c26a3f 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -26,11 +26,6 @@ module Agora.Proposal ( PProposalVotes (..), PProposalId (..), PResultTag (..), - - -- * Scripts - proposalValidator, - proposalPolicy, - proposalDatumValid, ) where import GHC.Generics qualified as GHC @@ -38,47 +33,26 @@ import Generics.SOP (Generic, I (I)) import Plutarch.Api.V1 ( PDatumHash, PMap, - PMintingPolicy, PPubKeyHash, - PScriptContext (PScriptContext), - PScriptPurpose (PMinting, PSpending), - PTxInfo (PTxInfo), - PValidator, PValidatorHash, - mintingPolicySymbol, - mkMintingPolicy, ) -import Plutarch.DataRepr ( - DerivePConstantViaData (..), - PDataFields, - PIsDataReprInstances (PIsDataReprInstances), - ) -import Plutus.V1.Ledger.Api (DatumHash, PubKeyHash, ValidatorHash) import PlutusTx qualified import PlutusTx.AssocMap qualified as AssocMap -------------------------------------------------------------------------------- -import Agora.Record (mkRecordConstr, (.&), (.=)) import Agora.SafeMoney (GTTag) -import Agora.Utils ( - anyOutput, - findTxOutByTxOutRef, - passert, - pnotNull, - psymbolValueOf, - ptokenSpent, - ptxSignedBy, - pvalueSpent, - ) import Control.Arrow (first) -import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf) -import Plutarch.Builtin (PBuiltinMap) -import Plutarch.Lift (DerivePConstantViaNewtype (..), PConstantDecl, PUnsafeLiftDecl (..)) -import Plutarch.Monadic qualified as P +import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields, PIsDataReprInstances (..)) +import Plutarch.Lift ( + DerivePConstantViaNewtype (..), + PConstantDecl, + PUnsafeLiftDecl (..), + ) import Plutarch.SafeMoney (PDiscrete, Tagged) import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom')) import Plutarch.Unsafe (punsafeCoerce) -import Plutus.V1.Ledger.Value (AssetClass (AssetClass)) +import Plutus.V1.Ledger.Api (DatumHash, PubKeyHash, ValidatorHash) +import Plutus.V1.Ledger.Value (AssetClass) -------------------------------------------------------------------------------- -- Haskell-land @@ -395,161 +369,3 @@ data PProposalRedeemer (s :: S) instance PUnsafeLiftDecl PProposalRedeemer where type PLifted PProposalRedeemer = ProposalRedeemer deriving via (DerivePConstantViaData ProposalRedeemer PProposalRedeemer) instance (PConstantDecl ProposalRedeemer) - --------------------------------------------------------------------------------- - -{- | Policy for Proposals. - This needs to perform two checks: - - Governor is happy with mint. - - Exactly 1 token is minted. - - NOTE: The governor needs to check that the datum is correct - and sent to the right address. --} -proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy -proposalPolicy proposal = - plam $ \_redeemer ctx' -> P.do - PScriptContext ctx' <- pmatch ctx' - ctx <- pletFields @'["txInfo", "purpose"] ctx' - PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo - txInfo <- pletFields @'["inputs", "mint"] txInfo' - PMinting _ownSymbol <- pmatch $ pfromData ctx.purpose - - let inputs = txInfo.inputs - mintedValue = pfromData txInfo.mint - AssetClass (govCs, govTn) = proposal.governorSTAssetClass - - PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose - let mintedProposalST = passetClassValueOf # mintedValue # (passetClass # (pfield @"_0" # ownSymbol') # pconstant "") - - passert "Governance state-thread token must move" $ - ptokenSpent - # (passetClass # pconstant govCs # pconstant govTn) - # inputs - - passert "Minted exactly one proposal ST" $ - mintedProposalST #== 1 - - popaque (pconstant ()) - --- | Validator for Proposals. -proposalValidator :: Proposal -> ClosedTerm PValidator -proposalValidator proposal = - plam $ \datum redeemer ctx' -> P.do - PScriptContext ctx' <- pmatch ctx' - ctx <- pletFields @'["txInfo", "purpose"] ctx' - txInfo <- plet $ pfromData ctx.txInfo - PTxInfo txInfo' <- pmatch txInfo - txInfoF <- pletFields @'["inputs", "mint"] txInfo' - PSpending ((pfield @"_0" #) -> txOutRef) <- pmatch $ pfromData ctx.purpose - - PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs - txOutF <- pletFields @'["address", "value"] $ txOut - - let proposalDatum :: Term _ PProposalDatum - proposalDatum = pfromData $ punsafeCoerce datum - proposalRedeemer :: Term _ PProposalRedeemer - proposalRedeemer = pfromData $ punsafeCoerce redeemer - - proposalF <- - pletFields - @'[ "proposalId" - , "effects" - , "status" - , "cosigners" - , "thresholds" - , "votes" - ] - proposalDatum - - ownAddress <- plet $ txOutF.address - - stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (proposalPolicy proposal) - valueSpent <- plet $ pvalueSpent # txInfoF.inputs - spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ valueSpent - let AssetClass (stakeSym, stakeTn) = proposal.stakeSTAssetClass - spentStakeST <- plet $ passetClassValueOf # valueSpent # (passetClass # pconstant stakeSym # pconstant stakeTn) - - pmatch proposalRedeemer $ \case - PVote _r -> P.do - passert "ST at inputs must be 1" $ - spentST #== 1 - - popaque (pconstant ()) - -------------------------------------------------------------------------- - PCosign r -> P.do - newSigs <- plet $ pfield @"newCosigners" # r - - passert "ST at inputs must be 1" $ - spentST #== 1 - - passert "Signed by all new cosigners" $ - pall # plam (\sig -> ptxSignedBy # ctx.txInfo # sig) # newSigs - - passert "As many new cosigners as Stake datums" $ - spentStakeST #== plength # newSigs - - passert "Signatures are correctly added to cosignature list" $ - anyOutput @PProposalDatum # ctx.txInfo - #$ plam - $ \newValue address newProposalDatum -> P.do - -- This is a little sad. Can we do better by - -- building a new ProposalDatum and then comparing? - let correctDatum = - pdata newProposalDatum - #== pdata - ( mkRecordConstr - PProposalDatum - ( #proposalId .= proposalF.proposalId - .& #effects .= proposalF.effects - .& #status .= proposalF.status - .& #cosigners .= pdata (pconcat # newSigs # proposalF.cosigners) - .& #thresholds .= proposalF.thresholds - .& #votes .= proposalF.votes - ) - ) - - foldr1 - (#&&) - [ pcon PTrue - , ptraceIfFalse "Datum must be correct" correctDatum - , ptraceIfFalse "Value should be correct" $ pdata txOutF.value #== pdata newValue - , ptraceIfFalse "Must be sent to Proposal's address" $ ownAddress #== pdata address - ] - - popaque (pconstant ()) - -------------------------------------------------------------------------- - PUnlock _r -> P.do - passert "ST at inputs must be 1" $ - spentST #== 1 - - popaque (pconstant ()) - -------------------------------------------------------------------------- - PAdvanceProposal _r -> P.do - passert "ST at inputs must be 1" $ - spentST #== 1 - - popaque (pconstant ()) - -{- | Check for various invariants a proposal must uphold. - This can be used to check both upopn creation and - upon any following state transitions in the proposal. --} -proposalDatumValid :: Term s (PProposalDatum :--> PBool) -proposalDatumValid = - phoistAcyclic $ - plam $ \datum' -> P.do - datum <- pletFields @'["effects", "cosigners"] $ datum' - - let effects :: Term _ (PBuiltinMap PResultTag (PBuiltinMap PValidatorHash PDatumHash)) - effects = punsafeCoerce datum.effects - - atLeastOneNegativeResult :: Term _ PBool - atLeastOneNegativeResult = - pany # plam (\pair -> pnull #$ pfromData $ psndBuiltin # pair) # effects - - foldr1 - (#&&) - [ ptraceIfFalse "Proposal has at least one ResultTag has no effects" atLeastOneNegativeResult - , ptraceIfFalse "Proposal has at least one cosigner" $ pnotNull # pfromData datum.cosigners - ] diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs new file mode 100644 index 0000000..ce21cea --- /dev/null +++ b/agora/Agora/Proposal/Scripts.hs @@ -0,0 +1,227 @@ +module Agora.Proposal.Scripts ( + proposalValidator, + proposalPolicy, + proposalDatumValid, +) where + +import Agora.Proposal +import Agora.Record (mkRecordConstr, (.&), (.=)) +import Agora.Stake (PStakeDatum) +import Agora.Utils ( + anyOutput, + findTxOutByTxOutRef, + passert, + pfindDatum', + pnotNull, + psymbolValueOf, + ptokenSpent, + ptxSignedBy, + pvalueSpent, + ) +import Plutarch.Api.V1 ( + PDatumHash, + PMaybeData (PDJust, PDNothing), + PMintingPolicy, + PPubKeyHash, + PScriptContext (PScriptContext), + PScriptPurpose (PMinting, PSpending), + PTxInInfo (PTxInInfo), + PTxInfo (PTxInfo), + PTxOut (PTxOut), + PValidator, + PValidatorHash, + mintingPolicySymbol, + mkMintingPolicy, + ) +import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf) +import Plutarch.Builtin (PBuiltinMap) +import Plutarch.Monadic qualified as P +import Plutarch.Unsafe (punsafeCoerce) +import Plutus.V1.Ledger.Value (AssetClass (AssetClass)) + +{- | Policy for Proposals. + This needs to perform two checks: + - Governor is happy with mint. + - Exactly 1 token is minted. + + NOTE: The governor needs to check that the datum is correct + and sent to the right address. +-} +proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy +proposalPolicy proposal = + plam $ \_redeemer ctx' -> P.do + PScriptContext ctx' <- pmatch ctx' + ctx <- pletFields @'["txInfo", "purpose"] ctx' + PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo + txInfo <- pletFields @'["inputs", "mint"] txInfo' + PMinting _ownSymbol <- pmatch $ pfromData ctx.purpose + + let inputs = txInfo.inputs + mintedValue = pfromData txInfo.mint + AssetClass (govCs, govTn) = proposal.governorSTAssetClass + + PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose + let mintedProposalST = passetClassValueOf # mintedValue # (passetClass # (pfield @"_0" # ownSymbol') # pconstant "") + + passert "Governance state-thread token must move" $ + ptokenSpent + # (passetClass # pconstant govCs # pconstant govTn) + # inputs + + passert "Minted exactly one proposal ST" $ + mintedProposalST #== 1 + + popaque (pconstant ()) + +-- | Validator for Proposals. +proposalValidator :: Proposal -> ClosedTerm PValidator +proposalValidator proposal = + plam $ \datum redeemer ctx' -> P.do + PScriptContext ctx' <- pmatch ctx' + ctx <- pletFields @'["txInfo", "purpose"] ctx' + txInfo <- plet $ pfromData ctx.txInfo + PTxInfo txInfo' <- pmatch txInfo + txInfoF <- pletFields @'["inputs", "mint"] txInfo' + PSpending ((pfield @"_0" #) -> txOutRef) <- pmatch $ pfromData ctx.purpose + + PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs + txOutF <- pletFields @'["address", "value"] $ txOut + + let proposalDatum :: Term _ PProposalDatum + proposalDatum = pfromData $ punsafeCoerce datum + proposalRedeemer :: Term _ PProposalRedeemer + proposalRedeemer = pfromData $ punsafeCoerce redeemer + + proposalF <- + pletFields + @'[ "proposalId" + , "effects" + , "status" + , "cosigners" + , "thresholds" + , "votes" + ] + proposalDatum + + ownAddress <- plet $ txOutF.address + + stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (proposalPolicy proposal) + valueSpent <- plet $ pvalueSpent # txInfoF.inputs + spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ valueSpent + let AssetClass (stakeSym, stakeTn) = proposal.stakeSTAssetClass + stakeSTAssetClass <- plet $ passetClass # pconstant stakeSym # pconstant stakeTn + spentStakeST <- plet $ passetClassValueOf # valueSpent # stakeSTAssetClass + + pmatch proposalRedeemer $ \case + PVote _r -> P.do + passert "ST at inputs must be 1" $ + spentST #== 1 + + popaque (pconstant ()) + -------------------------------------------------------------------------- + PCosign r -> P.do + newSigs <- plet $ pfield @"newCosigners" # r + + passert "ST at inputs must be 1" $ + spentST #== 1 + + passert "Signed by all new cosigners" $ + pall # plam (\sig -> ptxSignedBy # ctx.txInfo # sig) # newSigs + + passert "As many new cosigners as Stake datums" $ + spentStakeST #== plength # newSigs + + let stakeDatumOwnedBy :: Term _ (PPubKeyHash :--> PStakeDatum :--> PBool) + stakeDatumOwnedBy = + phoistAcyclic $ + plam $ \pk stakeDatum -> P.do + stakeDatumF <- pletFields @'["owner"] $ pto stakeDatum + stakeDatumF.owner #== pdata pk + + -- Does the input have a `Stake` owned by a particular PK? + let isInputStakeOwnedBy :: Term _ (PAsData PPubKeyHash :--> PAsData PTxInInfo :--> PBool) + isInputStakeOwnedBy = + plam $ \ss txInInfo' -> P.do + PTxInInfo ((pfield @"resolved" #) -> txOut) <- pmatch $ pfromData txInInfo' + PTxOut txOut' <- pmatch txOut + txOutF <- pletFields @'["value", "datumHash"] txOut' + outStakeST <- plet $ passetClassValueOf # txOutF.value # stakeSTAssetClass + pmatch txOutF.datumHash $ \case + PDNothing _ -> pcon PFalse + PDJust ((pfield @"_0" #) -> datumHash) -> + pif + (outStakeST #== 1) + -- TODO: use 'ptryFindDatum' instead in the future + ( pmatch (pfindDatum' # datumHash # txInfo) $ \case + PNothing -> pcon PFalse + PJust v -> stakeDatumOwnedBy # pfromData ss # pfromData v + ) + (pcon PFalse) + + passert "All new cosigners are witnessed by their Stake datums" $ + pall + # plam (\sig -> pany # (isInputStakeOwnedBy # sig) # txInfoF.inputs) + # newSigs + + passert "Signatures are correctly added to cosignature list" $ + anyOutput @PProposalDatum # ctx.txInfo + #$ plam + $ \newValue address newProposalDatum -> P.do + let correctDatum = + pdata newProposalDatum + #== pdata + ( mkRecordConstr + PProposalDatum + ( #proposalId .= proposalF.proposalId + .& #effects .= proposalF.effects + .& #status .= proposalF.status + .& #cosigners .= pdata (pconcat # newSigs # proposalF.cosigners) + .& #thresholds .= proposalF.thresholds + .& #votes .= proposalF.votes + ) + ) + + foldr1 + (#&&) + [ pcon PTrue + , ptraceIfFalse "Datum must be correct" correctDatum + , ptraceIfFalse "Value should be correct" $ pdata txOutF.value #== pdata newValue + , ptraceIfFalse "Must be sent to Proposal's address" $ ownAddress #== pdata address + ] + + popaque (pconstant ()) + -------------------------------------------------------------------------- + PUnlock _r -> P.do + passert "ST at inputs must be 1" $ + spentST #== 1 + + popaque (pconstant ()) + -------------------------------------------------------------------------- + PAdvanceProposal _r -> P.do + passert "ST at inputs must be 1" $ + spentST #== 1 + + popaque (pconstant ()) + +{- | Check for various invariants a proposal must uphold. + This can be used to check both upopn creation and + upon any following state transitions in the proposal. +-} +proposalDatumValid :: Term s (PProposalDatum :--> PBool) +proposalDatumValid = + phoistAcyclic $ + plam $ \datum' -> P.do + datum <- pletFields @'["effects", "cosigners"] $ datum' + + let effects :: Term _ (PBuiltinMap PResultTag (PBuiltinMap PValidatorHash PDatumHash)) + effects = punsafeCoerce datum.effects + + atLeastOneNegativeResult :: Term _ PBool + atLeastOneNegativeResult = + pany # plam (\pair -> pnull #$ pfromData $ psndBuiltin # pair) # effects + + foldr1 + (#&&) + [ ptraceIfFalse "Proposal has at least one ResultTag has no effects" atLeastOneNegativeResult + , ptraceIfFalse "Proposal has at least one cosigner" $ pnotNull # pfromData datum.cosigners + ] diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index bd0449d..7a2ee01 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -11,6 +11,7 @@ module Agora.Utils ( pfind', pfindDatum, pfindDatum', + ptryFindDatum, pvalueSpent, ptxSignedBy, paddValue, @@ -67,6 +68,7 @@ import Plutarch.Api.V1.Value (PValue (PValue)) import Plutarch.Builtin (ppairDataBuiltin) import Plutarch.Internal (punsafeCoerce) import Plutarch.Monadic qualified as P +import Plutarch.TryFrom (PTryFrom, ptryFrom) -------------------------------------------------------------------------------- -- Validator-level utility functions @@ -82,6 +84,17 @@ pfindDatum = phoistAcyclic $ PTxInfo txInfo' <- pmatch txInfo'' plookupTuple # datumHash #$ pfield @"datums" # txInfo' +-- | Find a datum with the given hash, and `ptryFrom` it. +ptryFindDatum :: PTryFrom PData a => Term s (PDatumHash :--> PTxInfo :--> PMaybe a) +ptryFindDatum = phoistAcyclic $ + plam $ \datumHash txInfo'' -> P.do + PTxInfo txInfo' <- pmatch txInfo'' + pmatch (plookupTuple # datumHash #$ pfield @"datums" # txInfo') $ \case + PNothing -> pcon PNothing + PJust datum -> P.do + (datum', _) <- ptryFrom $ pto datum + pcon (PJust datum') + {- | Find a datum with the given hash. NOTE: this is unsafe in the sense that, if the data layout is wrong, this is UB. -}