From 801c9067e3492b09a32b17ece5418fc5fd2e993c Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Tue, 12 Apr 2022 14:25:30 +0200 Subject: [PATCH 01/28] add `proposalDatumValid` --- agora/Agora/Proposal.hs | 41 +++++++++++++++++++++++++++++++++++++++-- hie.yaml | 6 ------ 2 files changed, 39 insertions(+), 8 deletions(-) diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index 7125da0..4b1062c 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} {- | Module : Agora.Proposal @@ -28,6 +29,7 @@ module Agora.Proposal ( -- * Scripts proposalValidator, proposalPolicy, + proposalDatumValid, ) where import GHC.Generics qualified as GHC @@ -52,9 +54,14 @@ import PlutusTx.AssocMap qualified as AssocMap -------------------------------------------------------------------------------- import Agora.SafeMoney (GTTag) +import Agora.Utils (pnotNull) import Plutarch (popaque) +import Plutarch.Builtin (PBuiltinMap) import Plutarch.Lift (DerivePConstantViaNewtype (..), PUnsafeLiftDecl (..)) +import Plutarch.Monadic qualified as P import Plutarch.SafeMoney (PDiscrete, Tagged) +import Plutarch.Unsafe (punsafeCoerce) +import Plutus.V1.Ledger.Value (AssetClass) -------------------------------------------------------------------------------- -- Haskell-land @@ -169,6 +176,9 @@ newtype ProposalId = ProposalId {proposalTag :: Integer} -- | Parameters that identify the Proposal validator script. data Proposal = Proposal + { governorSTAssetClass :: AssetClass + } + deriving stock (Show, Eq) -------------------------------------------------------------------------------- -- Plutarch-land @@ -251,7 +261,7 @@ newtype PProposalDatum (s :: S) = PProposalDatum ( PDataRecord '[ "effects" ':= PMap PResultTag (PMap PValidatorHash PDatumHash) , "status" ':= PProposalStatus - , "cosigners" ':= PBuiltinList PPubKeyHash + , "cosigners" ':= PBuiltinList (PAsData PPubKeyHash) , "thresholds" ':= PProposalThresholds , "votes" ':= PProposalVotes ] @@ -269,7 +279,11 @@ deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PCo -------------------------------------------------------------------------------- --- | Policy for Proposals. +{- | Policy for Proposals. + This needs to perform two checks: + - Governor is happy with mint. + - Datum is valid +-} proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy proposalPolicy _ = plam $ \_redeemer _ctx' -> P.do @@ -280,3 +294,26 @@ proposalValidator :: Proposal -> ClosedTerm PValidator proposalValidator _ = plam $ \_datum _redeemer _ctx' -> P.do 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/hie.yaml b/hie.yaml index 6020af6..04cd243 100644 --- a/hie.yaml +++ b/hie.yaml @@ -1,8 +1,2 @@ cradle: cabal: - - path: "./agora" - component: "lib:agora" - - path: "./agora-bench" - component: "benchmark:agora-bench" - - path: "./agora-test" - component: "test:agora-test" From 27263486650641828edec1b128e773b962ebec71 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Wed, 13 Apr 2022 16:39:08 +0200 Subject: [PATCH 02/28] refactor out ptokenSpent --- agora/Agora/AuthorityToken.hs | 31 +++++++++-------------- agora/Agora/Proposal.hs | 46 +++++++++++++++++++++++++++++------ agora/Agora/Utils.hs | 37 +++++++++++++++------------- 3 files changed, 70 insertions(+), 44 deletions(-) diff --git a/agora/Agora/AuthorityToken.hs b/agora/Agora/AuthorityToken.hs index 8239242..cd04507 100644 --- a/agora/Agora/AuthorityToken.hs +++ b/agora/Agora/AuthorityToken.hs @@ -18,16 +18,14 @@ import Plutarch.Api.V1 ( PCurrencySymbol (..), PScriptContext (..), PScriptPurpose (..), - PTxInInfo (..), PTxInfo (..), PTxOut (..), ) import Plutarch.Api.V1.AssocMap (PMap (PMap)) import Plutarch.Api.V1.Value (PValue (PValue)) import Plutarch.Builtin (pforgetData) -import Plutarch.List (pfoldr') import Plutarch.Monadic qualified as P -import Plutus.V1.Ledger.Value (AssetClass) +import Plutus.V1.Ledger.Value (AssetClass (AssetClass)) import Prelude @@ -36,11 +34,11 @@ import Prelude import Agora.Utils ( allOutputs, passert, - passetClassValueOf, - passetClassValueOf', plookup, psymbolValueOf, + ptokenSpent, ) +import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf) -------------------------------------------------------------------------------- @@ -132,26 +130,19 @@ authorityTokenPolicy params = PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo txInfo <- pletFields @'["inputs", "mint"] txInfo' let inputs = txInfo.inputs - let authorityTokenInputs = - pfoldr' @PBuiltinList - ( \txInInfo' acc -> P.do - PTxInInfo txInInfo <- pmatch (pfromData txInInfo') - PTxOut txOut' <- pmatch $ pfromData $ pfield @"resolved" # txInInfo - txOut <- pletFields @'["value"] txOut' - let txOutValue = pfromData txOut.value - passetClassValueOf' params.authority # txOutValue + acc - ) - # 0 - # inputs - let mintedValue = pfromData txInfo.mint - let tokenMoved = 0 #< authorityTokenInputs + mintedValue = pfromData txInfo.mint + AssetClass (govCs, govTn) = params.authority + govAc = passetClass # pconstant govCs # pconstant govTn + govTokenSpent = ptokenSpent # govAc # inputs + PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose + let ownSymbol = pfromData $ pfield @"_0" # ownSymbol' - let mintedATs = passetClassValueOf # ownSymbol # pconstant "" # mintedValue + mintedATs = passetClassValueOf # mintedValue # (passetClass # ownSymbol # pconstant "") pif (0 #< mintedATs) ( P.do - passert "Parent token did not move in minting GATs" tokenMoved + passert "Parent token did not move in minting GATs" govTokenSpent passert "All outputs only emit valid GATs" $ allOutputs @PUnit # pfromData ctx.txInfo #$ plam $ \txOut _value _address _datum -> authorityTokensValidIn diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index 4b1062c..eea1c0c 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -1,5 +1,4 @@ {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} {- | Module : Agora.Proposal @@ -39,6 +38,9 @@ import Plutarch.Api.V1 ( PMap, PMintingPolicy, PPubKeyHash, + PScriptContext (PScriptContext), + PScriptPurpose (PMinting, PSpending), + PTxInfo (PTxInfo), PValidator, PValidatorHash, ) @@ -54,14 +56,15 @@ import PlutusTx.AssocMap qualified as AssocMap -------------------------------------------------------------------------------- import Agora.SafeMoney (GTTag) -import Agora.Utils (pnotNull) +import Agora.Utils (passert, pnotNull, ptokenSpent) import Plutarch (popaque) +import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf) import Plutarch.Builtin (PBuiltinMap) import Plutarch.Lift (DerivePConstantViaNewtype (..), PUnsafeLiftDecl (..)) import Plutarch.Monadic qualified as P import Plutarch.SafeMoney (PDiscrete, Tagged) import Plutarch.Unsafe (punsafeCoerce) -import Plutus.V1.Ledger.Value (AssetClass) +import Plutus.V1.Ledger.Value (AssetClass (AssetClass)) -------------------------------------------------------------------------------- -- Haskell-land @@ -282,17 +285,46 @@ deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PCo {- | Policy for Proposals. This needs to perform two checks: - Governor is happy with mint. - - Datum is valid + - 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 _ = - plam $ \_redeemer _ctx' -> P.do +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 _ = - plam $ \_datum _redeemer _ctx' -> P.do + plam $ \_datum _redeemer ctx' -> P.do + PScriptContext ctx' <- pmatch ctx' + ctx <- pletFields @'["txInfo", "purpose"] ctx' + PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo + _txInfo <- pletFields @'["inputs", "mint"] txInfo' + PSpending _txOutRef <- pmatch $ pfromData ctx.purpose popaque (pconstant ()) {- | Check for various invariants a proposal must uphold. diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index 48e5af3..58c350a 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -17,8 +17,6 @@ module Agora.Utils ( plookup, pfromMaybe, psymbolValueOf, - passetClassValueOf, - passetClassValueOf', pgeqByClass, pgeqBySymbol, pgeqByClass', @@ -27,6 +25,7 @@ module Agora.Utils ( pfindMap, pnotNull, pisJust, + ptokenSpent, -- * Functions which should (probably) not be upstreamed anyOutput, @@ -63,6 +62,7 @@ import Plutarch.Api.V1 ( PValue, ) import Plutarch.Api.V1.AssocMap (PMap (PMap)) +import Plutarch.Api.V1.Extra (PAssetClass, passetClassValueOf, pvalueOf) import Plutarch.Api.V1.Value (PValue (PValue)) import Plutarch.Builtin (ppairDataBuiltin) import Plutarch.Internal (punsafeCoerce) @@ -183,30 +183,17 @@ psymbolValueOf = PMap m <- pmatch (pfromData m') pfoldr # plam (\x v -> pfromData (psndBuiltin # x) + v) # 0 # m --- | Extract amount from PValue belonging to a Plutarch-level asset class. -passetClassValueOf :: - Term s (PCurrencySymbol :--> PTokenName :--> PValue :--> PInteger) -passetClassValueOf = - phoistAcyclic $ - plam $ \sym token value'' -> P.do - PValue value' <- pmatch value'' - PMap value <- pmatch value' - m' <- pexpectJust 0 (plookup # pdata sym # value) - PMap m <- pmatch (pfromData m') - v <- pexpectJust 0 (plookup # pdata token # m) - pfromData v - -- | Extract amount from PValue belonging to a Haskell-level AssetClass. passetClassValueOf' :: AssetClass -> Term s (PValue :--> PInteger) passetClassValueOf' (AssetClass (sym, token)) = - passetClassValueOf # pconstant sym # pconstant token + phoistAcyclic $ plam $ \value -> pvalueOf # value # pconstant sym # pconstant token -- | Return '>=' on two values comparing by only a particular AssetClass. pgeqByClass :: Term s (PCurrencySymbol :--> PTokenName :--> PValue :--> PValue :--> PBool) pgeqByClass = phoistAcyclic $ plam $ \cs tn a b -> - passetClassValueOf # cs # tn # b #<= passetClassValueOf # cs # tn # a + pvalueOf # b # cs # tn #<= pvalueOf # a # cs # tn -- | Return '>=' on two values comparing by only a particular CurrencySymbol. pgeqBySymbol :: Term s (PCurrencySymbol :--> PValue :--> PValue :--> PBool) @@ -421,3 +408,19 @@ findTxOutDatum = phoistAcyclic $ case datumHash' of PDJust ((pfield @"_0" #) -> datumHash) -> pfindDatum # datumHash # info _ -> pcon PNothing + +-- | Check if a particular asset class has been spent in the input list. +ptokenSpent :: forall {s :: S}. Term s (PAssetClass :--> PBuiltinList (PAsData PTxInInfo) :--> PBool) +ptokenSpent = + plam $ \tokenClass inputs -> + 0 + #< pfoldr @PBuiltinList + # ( plam $ \txInInfo' acc -> P.do + PTxInInfo txInInfo <- pmatch (pfromData txInInfo') + PTxOut txOut' <- pmatch $ pfromData $ pfield @"resolved" # txInInfo + txOut <- pletFields @'["value"] txOut' + let txOutValue = pfromData txOut.value + acc + passetClassValueOf # txOutValue # tokenClass + ) + # 0 + # inputs From 8f8416593f7ff960699af3e62d5b3d1543d493b4 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Fri, 15 Apr 2022 22:03:18 +0200 Subject: [PATCH 03/28] add `ProposalRedeemer`, bump plutarch-safemoney PR revision --- agora-test/Spec/Sample/Stake.hs | 3 +- agora/Agora/Proposal.hs | 102 ++++++++++++++++++++++++++++++-- agora/Agora/Stake.hs | 25 +++++--- flake.lock | 8 +-- flake.nix | 2 +- 5 files changed, 122 insertions(+), 18 deletions(-) diff --git a/agora-test/Spec/Sample/Stake.hs b/agora-test/Spec/Sample/Stake.hs index 08bd0e1..e62103e 100644 --- a/agora-test/Spec/Sample/Stake.hs +++ b/agora-test/Spec/Sample/Stake.hs @@ -177,8 +177,7 @@ stakeDepositWithdraw config = [ TxOut { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing , txOutValue = - st - <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount) + st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount) , txOutDatumHash = Just (toDatumHash stakeAfter) } ] diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index eea1c0c..d4b6c4d 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -57,12 +57,14 @@ import PlutusTx.AssocMap qualified as AssocMap import Agora.SafeMoney (GTTag) import Agora.Utils (passert, pnotNull, ptokenSpent) +import Control.Arrow (first) import Plutarch (popaque) import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf) import Plutarch.Builtin (PBuiltinMap) import Plutarch.Lift (DerivePConstantViaNewtype (..), PUnsafeLiftDecl (..)) import Plutarch.Monadic qualified as P import Plutarch.SafeMoney (PDiscrete, Tagged) +import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom')) import Plutarch.Unsafe (punsafeCoerce) import Plutus.V1.Ledger.Value (AssetClass (AssetClass)) @@ -102,26 +104,33 @@ data ProposalStatus -- This means that once the timing requirements align, -- proposal will be able to be voted on. VotingReady + | -- | The proposal has been voted on, and the votes have been locked + -- permanently. The proposal can now be executed. + Voted | -- | The proposal has finished. -- -- This can mean it's been voted on and completed, but it can also mean - -- the proposal failed due to time constraints or didn't + -- the proposal failed due to time constraints or didn't -- get to 'VotingReady' first. -- + -- At this stage, the 'votes' field of 'ProposalState' is frozen. + -- + -- See 'AdvanceProposal' for documentation on state transitions. + -- -- TODO: The owner of the proposal may choose to reclaim their proposal. Finished deriving stock (Eq, Show, GHC.Generic) -PlutusTx.makeIsDataIndexed ''ProposalStatus [('Draft, 0), ('VotingReady, 1), ('Finished, 2)] +PlutusTx.makeIsDataIndexed ''ProposalStatus [('Draft, 0), ('VotingReady, 1), ('Voted, 2), ('Finished, 3)] {- | The threshold values for various state transitions to happen. This data is stored centrally (in the 'Agora.Governor.Governor') and copied over to 'Proposal's when they are created. -} data ProposalThresholds = ProposalThresholds - { execute :: Tagged GTTag Integer + { countVoting :: Tagged GTTag Integer -- ^ How much GT minimum must a particular 'ResultTag' accumulate for it to pass. - , draft :: Tagged GTTag Integer + , create :: Tagged GTTag Integer -- ^ How much GT required to "create" a proposal. , vote :: Tagged GTTag Integer -- ^ How much GT required to allow voting to happen. @@ -168,6 +177,49 @@ data ProposalDatum = ProposalDatum PlutusTx.makeIsDataIndexed ''ProposalDatum [('ProposalDatum, 0)] +-- | Haskell-level redeemer for Proposal scripts. +data ProposalRedeemer + = -- | Cast one or more votes towards a particular 'ResultTag'. + Vote ResultTag + | -- | Add one or more public keys to the cosignature list. Must be signed by + -- those cosigning. + -- + -- This is particularly used in the 'Draft' 'ProposalStatus'. Where matching + -- 'Stake's can be called to advance the proposal, provided enough GT is shared + -- among them. + Cosign [PubKeyHash] + | -- | Allow unlocking one or more stakes with votes towards particular 'ResultTag'. + Unlock ResultTag + | -- | Advance the proposal, performing the required checks for whether that is legal. + -- + -- These are roughly the checks for each possible transition: + -- + -- @'Draft' -> 'VotingReady'@: + -- 1. The sum of all of the cosigner's GT is larger than the 'vote' field of 'ProposalThresholds'. + -- 2. The proposal hasn't been alive for longer than the review time. + -- + -- @'VotingReady' -> 'Voted'@: + -- 1. The sum of all votes is larger than 'countVoting'. + -- 2. The winning 'ResultTag' has more votes than all other 'ResultTag's. + -- 3. The proposal hasn't been alive for longer than the voting time. + -- + -- @'Voted' -> 'Finished'@: + -- Always valid provided the conditions for the transition are met. + -- + -- @* -> 'Finished'@: + -- If the proposal has run out of time for the current 'ProposalStatus', it will always be possible + -- to transition into 'Finished' state, because it has expired (and failed). + AdvanceProposal + deriving stock (Eq, Show, GHC.Generic) + +PlutusTx.makeIsDataIndexed + ''ProposalRedeemer + [ ('Vote, 0) + , ('Cosign, 1) + , ('Unlock, 2) + , ('AdvanceProposal, 3) + ] + {- | Identifies a Proposal, issued upon creation of a proposal. In practice, this number starts at zero, and increments by one for each proposal. The 100th proposal will be @'ProposalId' 99@. @@ -196,10 +248,30 @@ deriving via instance (PConstant ResultTag) +-- FIXME: This instance and the one below, for 'PProposalId', should be derived. +-- Soon this will be possible through 'DerivePNewtype'. +instance PTryFrom PData (PAsData PResultTag) where + type PTryFromExcess PData (PAsData PResultTag) = PTryFromExcess PData (PAsData PInteger) + ptryFrom' d k = + ptryFrom' @_ @(PAsData PInteger) d $ + -- JUSTIFICATION: + -- We are coercing from @PAsData underlying@ to @PAsData (PTagged tag underlying)@. + -- Since 'PTagged' is a simple newtype, their shape is the same. + k . first punsafeCoerce + -- | Plutarch-level version of 'PProposalId'. newtype PProposalId (s :: S) = PProposalId (Term s PInteger) deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalId PInteger) +instance PTryFrom PData (PAsData PProposalId) where + type PTryFromExcess PData (PAsData PProposalId) = PTryFromExcess PData (PAsData PInteger) + ptryFrom' d k = + ptryFrom' @_ @(PAsData PInteger) d $ + -- JUSTIFICATION: + -- We are coercing from @PAsData underlying@ to @PAsData (PTagged tag underlying)@. + -- Since 'PTagged' is a simple newtype, their shape is the same. + k . first punsafeCoerce + instance PUnsafeLiftDecl PProposalId where type PLifted PProposalId = ProposalId deriving via (DerivePConstantViaNewtype ProposalId PProposalId PInteger) @@ -280,6 +352,28 @@ newtype PProposalDatum (s :: S) = PProposalDatum instance PUnsafeLiftDecl PProposalDatum where type PLifted PProposalDatum = ProposalDatum deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PConstant ProposalDatum) +-- | Haskell-level redeemer for Proposal scripts. +data PProposalRedeemer (s :: S) + = PVote (Term s (PDataRecord '["resultTag" ':= PResultTag])) + | PCosign (Term s (PDataRecord '["newCosigners" ':= PBuiltinList (PAsData PPubKeyHash)])) + | PUnlock (Term s (PDataRecord '["resultTag" ':= PResultTag])) + | PAdvanceProposal (Term s (PDataRecord '[])) + deriving stock (GHC.Generic) + deriving anyclass (Generic) + deriving anyclass (PIsDataRepr) + deriving + (PlutusType, PIsData) + via PIsDataReprInstances PProposalRedeemer + +-- TODO: Waiting on PTryFrom for 'PPubKeyHash' +-- deriving via +-- PAsData (PIsDataReprInstances PProposalRedeemer) +-- instance +-- PTryFrom PData (PAsData PProposalRedeemer) + +instance PUnsafeLiftDecl PProposalRedeemer where type PLifted PProposalRedeemer = ProposalRedeemer +deriving via (DerivePConstantViaData ProposalRedeemer PProposalRedeemer) instance (PConstant ProposalRedeemer) + -------------------------------------------------------------------------------- {- | Policy for Proposals. diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index 8327d57..afaacb1 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -77,9 +77,10 @@ import Plutarch.Numeric import Plutarch.SafeMoney ( PDiscrete, Tagged (..), - pdiscreteValue, + pdiscreteValue', untag, ) +import Plutarch.TryFrom (PTryFrom, ptryFrom) -------------------------------------------------------------------------------- @@ -205,7 +206,7 @@ data PStakeRedeemer (s :: S) | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets. PDestroy (Term s (PDataRecord '[])) | PPermitVote (Term s (PDataRecord '["lock" ':= PProposalLock])) - | PRetractVotes (Term s (PDataRecord '["locks" ':= PBuiltinList PProposalLock])) + | PRetractVotes (Term s (PDataRecord '["locks" ':= PBuiltinList (PAsData PProposalLock)])) deriving stock (GHC.Generic) deriving anyclass (Generic) deriving anyclass (PIsDataRepr) @@ -213,6 +214,11 @@ data PStakeRedeemer (s :: S) (PlutusType, PIsData) via PIsDataReprInstances PStakeRedeemer +deriving via + PAsData (PIsDataReprInstances PStakeRedeemer) + instance + PTryFrom PData (PAsData PStakeRedeemer) + instance PUnsafeLiftDecl PStakeRedeemer where type PLifted PStakeRedeemer = StakeRedeemer deriving via (DerivePConstantViaData StakeRedeemer PStakeRedeemer) instance (PConstant StakeRedeemer) @@ -233,6 +239,11 @@ newtype PProposalLock (s :: S) = PProposalLock (PlutusType, PIsData, PDataFields) via (PIsDataReprInstances PProposalLock) +deriving via + PAsData (PIsDataReprInstances PProposalLock) + instance + PTryFrom PData (PAsData PProposalLock) + instance PUnsafeLiftDecl PProposalLock where type PLifted PProposalLock = ProposalLock deriving via (DerivePConstantViaData ProposalLock PProposalLock) instance (PConstant ProposalLock) @@ -312,7 +323,7 @@ stakePolicy stake = # 1 let expectedValue = paddValue - # (pdiscreteValue stake.gtClassRef # stakeDatum.stakedAmount) + # (pdiscreteValue' stake.gtClassRef # stakeDatum.stakedAmount) # stValue let ownerSignsTransaction = ptxSignedBy @@ -352,10 +363,10 @@ stakeValidator stake = txInfo' <- plet ctx.txInfo txInfo <- pletFields @'["mint", "inputs", "outputs"] txInfo' + (pfromData -> stakeRedeemer, _) <- ptryFrom redeemer + -- TODO: Use PTryFrom - let stakeRedeemer :: Term _ PStakeRedeemer - stakeRedeemer = pfromData $ punsafeCoerce redeemer - stakeDatum' :: Term _ PStakeDatum + let stakeDatum' :: Term _ PStakeDatum stakeDatum' = pfromData $ punsafeCoerce datum stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum' @@ -425,7 +436,7 @@ stakeValidator stake = -- do we need to check this, really? zero #<= pfromData newStakeDatum.stakedAmount ] - let expectedValue = paddValue # continuingValue # (pdiscreteValue stake.gtClassRef # delta) + let expectedValue = paddValue # continuingValue # (pdiscreteValue' stake.gtClassRef # delta) -- TODO: Same as above. This is quite inefficient now, as it does two lookups -- instead of a more efficient single pass, diff --git a/flake.lock b/flake.lock index 73e7d0d..0b23a54 100644 --- a/flake.lock +++ b/flake.lock @@ -1621,17 +1621,17 @@ "validity": "validity" }, "locked": { - "lastModified": 1648639396, - "narHash": "sha256-pAkEsIDXJckVYufVPUzD/4sq4/uE7iyV0IR2BuLhZjY=", + "lastModified": 1650025193, + "narHash": "sha256-SXfkWYse308SdnWO34cMVjKliDvyYYx++Y5uiuUmGXE=", "owner": "peter-mlabs", "repo": "plutarch", - "rev": "a7a410da209b9c14c834a41e07b1c197c2a4dcd6", + "rev": "18e787d420912ed765fc5653c3558f20ab5e638a", "type": "github" }, "original": { "owner": "peter-mlabs", "repo": "plutarch", - "rev": "a7a410da209b9c14c834a41e07b1c197c2a4dcd6", + "rev": "18e787d420912ed765fc5653c3558f20ab5e638a", "type": "github" } }, diff --git a/flake.nix b/flake.nix index 3b1756a..d51df25 100644 --- a/flake.nix +++ b/flake.nix @@ -9,7 +9,7 @@ # Rev is this PR https://github.com/peter-mlabs/plutarch/pull/5. inputs.plutarch.url = - "github:peter-mlabs/plutarch?rev=a7a410da209b9c14c834a41e07b1c197c2a4dcd6"; + "github:peter-mlabs/plutarch?rev=18e787d420912ed765fc5653c3558f20ab5e638a"; inputs.plutarch.inputs.nixpkgs.follows = "plutarch/haskell-nix/nixpkgs-unstable"; From faf326f9c30c4cbae73e2c97040de69ba159b9c4 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Fri, 15 Apr 2022 22:22:22 +0200 Subject: [PATCH 04/28] implement Agora.Record, implement Agora.Proposal.Time --- agora.cabal | 3 + agora/Agora/Proposal.hs | 11 +-- agora/Agora/Proposal/Time.hs | 160 +++++++++++++++++++++++++++++++++++ agora/Agora/Record.hs | 67 +++++++++++++++ 4 files changed, 236 insertions(+), 5 deletions(-) create mode 100644 agora/Agora/Proposal/Time.hs create mode 100644 agora/Agora/Record.hs diff --git a/agora.cabal b/agora.cabal index c1729d0..bd07338 100644 --- a/agora.cabal +++ b/agora.cabal @@ -78,6 +78,7 @@ common lang UndecidableInstances ViewPatterns OverloadedRecordDot + OverloadedLabels QualifiedDo default-language: Haskell2010 @@ -128,9 +129,11 @@ library Agora.Governor Agora.MultiSig Agora.Proposal + Agora.Proposal.Time Agora.SafeMoney Agora.Stake Agora.Treasury + Agora.Record other-modules: Agora.Utils diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index d4b6c4d..5399e95 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -105,8 +105,9 @@ data ProposalStatus -- proposal will be able to be voted on. VotingReady | -- | The proposal has been voted on, and the votes have been locked - -- permanently. The proposal can now be executed. - Voted + -- permanently. The proposal now goes into a locking time after the + -- normal voting time. After this, it's possible to execute the proposal. + Locked | -- | The proposal has finished. -- -- This can mean it's been voted on and completed, but it can also mean @@ -121,7 +122,7 @@ data ProposalStatus Finished deriving stock (Eq, Show, GHC.Generic) -PlutusTx.makeIsDataIndexed ''ProposalStatus [('Draft, 0), ('VotingReady, 1), ('Voted, 2), ('Finished, 3)] +PlutusTx.makeIsDataIndexed ''ProposalStatus [('Draft, 0), ('VotingReady, 1), ('Locked, 2), ('Finished, 3)] {- | The threshold values for various state transitions to happen. This data is stored centrally (in the 'Agora.Governor.Governor') and copied over @@ -198,12 +199,12 @@ data ProposalRedeemer -- 1. The sum of all of the cosigner's GT is larger than the 'vote' field of 'ProposalThresholds'. -- 2. The proposal hasn't been alive for longer than the review time. -- - -- @'VotingReady' -> 'Voted'@: + -- @'VotingReady' -> 'Locked'@: -- 1. The sum of all votes is larger than 'countVoting'. -- 2. The winning 'ResultTag' has more votes than all other 'ResultTag's. -- 3. The proposal hasn't been alive for longer than the voting time. -- - -- @'Voted' -> 'Finished'@: + -- @'Locked' -> 'Finished'@: -- Always valid provided the conditions for the transition are met. -- -- @* -> 'Finished'@: diff --git a/agora/Agora/Proposal/Time.hs b/agora/Agora/Proposal/Time.hs new file mode 100644 index 0000000..7245dd0 --- /dev/null +++ b/agora/Agora/Proposal/Time.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +{- | +Module : Agora.Proposal.Time +Maintainer : emi@haskell.fyi +Description: Time functions for proposal phases. + +Time functions for proposal phases. +-} +module Agora.Proposal.Time ( + -- * Haskell-land + ProposalTime (..), + ProposalTimingConfig (..), + ProposalStartingTime (..), + + -- * Plutarch-land + PProposalTime (..), + PProposalTimingConfig (..), + PProposalStartingTime (..), + + -- * Compute ranges given config and starting time. + proposalDraftRange, + + -- * Upstreamables + plowerBound, + pupperBound, + pstrictLowerBound, + pstrictUpperBound, +) where + +import Agora.Record (build, (.&), (.=)) +import GHC.Generics qualified as GHC +import Generics.SOP (Generic, I (I)) +import Plutarch.Api.V1 (PExtended (PFinite), PInterval (PInterval), PLowerBound (PLowerBound), PPOSIXTime, PPOSIXTimeRange, PUpperBound (PUpperBound)) +import Plutarch.DataRepr (PDataFields, PIsDataReprInstances (..)) +import Plutarch.Numeric (AdditiveSemigroup ((+))) +import Plutarch.Unsafe (punsafeCoerce) +import Plutus.V1.Ledger.Time (POSIXTime, POSIXTimeRange) +import PlutusTx qualified +import Prelude hiding ((+)) + +-------------------------------------------------------------------------------- + +-- | Represents the current time, as far as the proposal is concerned. +newtype ProposalTime = ProposalTime + { getProposalTime :: POSIXTimeRange + } + deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) + deriving stock (Eq, Show, GHC.Generic) + +-- | Represents the starting time of the proposal. +newtype ProposalStartingTime = ProposalStartingTime + { getProposalStartingTime :: POSIXTime + } + deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) + deriving stock (Eq, Show, GHC.Generic) + +-- | Configuration of proposal timings. +data ProposalTimingConfig = ProposalTimingConfig + { draftTime :: POSIXTime + -- ^ `D`: the length of the draft period. + , votingTime :: POSIXTime + -- ^ `V`: the length of the voting period. + , lockingTime :: POSIXTime + -- ^ `L`: the length of the locking period. + , executingTime :: POSIXTime + -- ^ `E`: the length of the execution period. + } + deriving stock (Eq, Show, GHC.Generic) + +PlutusTx.makeIsDataIndexed ''ProposalTimingConfig [('ProposalTimingConfig, 0)] + +-------------------------------------------------------------------------------- + +-- | Plutarch-level version of 'ProposalTime'. +newtype PProposalTime (s :: S) = PProposalTime (Term s PPOSIXTime) + deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalTime PPOSIXTime) + +-- | Plutarch-level version of 'ProposalStartingTime'. +newtype PProposalStartingTime (s :: S) = PProposalStartingTime (Term s PPOSIXTime) + deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalStartingTime PPOSIXTime) + +-- | Plutarch-level version of 'ProposalTimingConfig'. +newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig + { getProposalTimingConfig :: + Term + s + ( PDataRecord + '[ "draftTime" ':= PPOSIXTime + , "votingTime" ':= PPOSIXTime + , "lockingTime" ':= PPOSIXTime + , "executingTime" ':= PPOSIXTime + ] + ) + } + deriving stock (GHC.Generic) + deriving anyclass (Generic) + deriving anyclass (PIsDataRepr) + deriving + (PlutusType, PIsData, PDataFields) + via (PIsDataReprInstances PProposalTimingConfig) + +-------------------------------------------------------------------------------- + +-- -- Need to move these away from here +pstrictLowerBound :: PIsData a => Term s (a :--> PLowerBound a) +pstrictLowerBound = phoistAcyclic $ + plam $ \a -> + pcon + ( PLowerBound $ + build $ + #_0 .= pdata (pcon (PFinite $ build $ #_0 .= pdata a)) + .& #_1 .= pdata (pcon PFalse) + ) + +pstrictUpperBound :: PIsData a => Term s (a :--> PUpperBound a) +pstrictUpperBound = phoistAcyclic $ + plam $ \a -> + pcon + ( PUpperBound $ + build $ + #_0 .= pdata (pcon (PFinite $ build $ #_0 .= pdata a)) + .& #_1 .= pdata (pcon PFalse) + ) + +plowerBound :: PIsData a => Term s (a :--> PLowerBound a) +plowerBound = phoistAcyclic $ + plam $ \a -> + pcon + ( PLowerBound $ + build $ + #_0 .= pdata (pcon (PFinite $ build $ #_0 .= pdata a)) + .& #_1 .= pdata (pcon PTrue) + ) + +pupperBound :: PIsData a => Term s (a :--> PUpperBound a) +pupperBound = phoistAcyclic $ + plam $ \a -> + pcon + ( PUpperBound $ + build $ + #_0 .= pdata (pcon (PFinite $ build $ #_0 .= pdata a)) + .& #_1 .= pdata (pcon PTrue) + ) + +-- Move this to plutarch-extra. +instance AdditiveSemigroup (Term s PPOSIXTime) where + (punsafeCoerce @_ @_ @PInteger -> x) + (punsafeCoerce @_ @_ @PInteger -> y) = punsafeCoerce $ x + y + +-- | Compute the range of time during which cosigning is legal. +proposalDraftRange :: Term s (PPOSIXTime :--> PProposalTimingConfig :--> PPOSIXTimeRange) +proposalDraftRange = phoistAcyclic $ + plam $ \s config -> + pcon + ( PInterval $ + build $ + #from .= pdata (pstrictLowerBound # s) + .& #to .= pdata (pstrictUpperBound #$ s + pfield @"draftTime" # config) + ) diff --git a/agora/Agora/Record.hs b/agora/Agora/Record.hs new file mode 100644 index 0000000..3cd0723 --- /dev/null +++ b/agora/Agora/Record.hs @@ -0,0 +1,67 @@ +{- | +Module : Agora.Record +Maintainer : emi@haskell.fyi +Description: PDataRecord helper functions. + +PDataRecord helper functions. +-} +module Agora.Record (build, (.=), (.&)) where + +import Control.Category (Category (..)) +import Data.Coerce (coerce) +import GHC.OverloadedLabels (IsLabel (fromLabel)) +import GHC.TypeLits (Symbol) +import Plutarch.DataRepr (PDataRecord (PDCons)) +import Prelude hiding (id, (.)) + +-- | Like 'Data.Proxy.Proxy' but local to this module. +data FieldName (sym :: Symbol) = FieldName + +{- | The use of two different 'Symbol's here allows unification to happen, + ensuring 'FieldName' has a fully inferred 'Symbol'. + + For example, @'build' (#foo .= 'pconstantData' (42 :: 'Integer'))@ gets + the correct type. Namely, @'Term' s ('PDataRecord' '["foo" ':= 'PInteger'])@. +-} +instance forall (sym :: Symbol) (sym' :: Symbol). sym ~ sym' => IsLabel sym (FieldName sym') where + fromLabel = FieldName + +-- | Turn a builder into a fully built 'PDataRecord'. +build :: forall (s :: S) (r :: [PLabeledType]). RecordMorphism s '[] r -> Term s (PDataRecord r) +build f = coerce f pdnil + +-- | A morphism from one PDataRecord to another, representing some sort of consing of data. +newtype RecordMorphism (s :: S) (as :: [PLabeledType]) (bs :: [PLabeledType]) = RecordMorphism + { runRecordMorphism :: + Term s (PDataRecord as) -> + Term s (PDataRecord bs) + } + +instance Category (RecordMorphism s) where + id = RecordMorphism id + f . g = coerce $ f.runRecordMorphism . g.runRecordMorphism + +infix 7 .= + +-- | Cons a labeled type as a 'RecordMorphism'. +(.=) :: + forall (sym :: Symbol) (a :: PType) (as :: [PLabeledType]) (s :: S). + FieldName sym -> + Term s (PAsData a) -> + ( RecordMorphism s as ((sym ':= a) ': as) + ) +_ .= x = RecordMorphism $ pcon . PDCons x + +infixr 6 .& + +-- | Compose two morphisms between records. +(.&) :: + forall + (s :: S) + (a :: [PLabeledType]) + (b :: [PLabeledType]) + (c :: [PLabeledType]). + (RecordMorphism s b c) -> + (RecordMorphism s a b) -> + (RecordMorphism s a c) +(.&) = (.) From 12fc16390b091fee5bae608c1f1d02d1768eab7b Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Mon, 18 Apr 2022 13:52:01 +0200 Subject: [PATCH 05/28] add 'isDraftRange' checking function. --- agora/Agora/Proposal.hs | 32 ++++--- agora/Agora/Proposal/Time.hs | 158 +++++++++++++++++++++-------------- 2 files changed, 113 insertions(+), 77 deletions(-) diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index 5399e95..5252f0f 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -11,6 +11,7 @@ module Agora.Proposal ( -- * Haskell-land Proposal (..), ProposalDatum (..), + ProposalRedeemer (..), ProposalStatus (..), ProposalThresholds (..), ProposalVotes (..), @@ -19,6 +20,7 @@ module Agora.Proposal ( -- * Plutarch-land PProposalDatum (..), + PProposalRedeemer (..), PProposalStatus (..), PProposalThresholds (..), PProposalVotes (..), @@ -182,12 +184,12 @@ PlutusTx.makeIsDataIndexed ''ProposalDatum [('ProposalDatum, 0)] data ProposalRedeemer = -- | Cast one or more votes towards a particular 'ResultTag'. Vote ResultTag - | -- | Add one or more public keys to the cosignature list. Must be signed by - -- those cosigning. + | -- | Add one or more public keys to the cosignature list. + -- Must be signed by those cosigning. -- - -- This is particularly used in the 'Draft' 'ProposalStatus'. Where matching - -- 'Stake's can be called to advance the proposal, provided enough GT is shared - -- among them. + -- This is particularly used in the 'Draft' 'ProposalStatus', + -- where matching 'Stake's can be called to advance the proposal, + -- provided enough GT is shared among them. Cosign [PubKeyHash] | -- | Allow unlocking one or more stakes with votes towards particular 'ResultTag'. Unlock ResultTag @@ -195,19 +197,23 @@ data ProposalRedeemer -- -- These are roughly the checks for each possible transition: -- - -- @'Draft' -> 'VotingReady'@: + -- === @'Draft' -> 'VotingReady'@: + -- -- 1. The sum of all of the cosigner's GT is larger than the 'vote' field of 'ProposalThresholds'. -- 2. The proposal hasn't been alive for longer than the review time. -- - -- @'VotingReady' -> 'Locked'@: + -- === @'VotingReady' -> 'Locked'@: + -- -- 1. The sum of all votes is larger than 'countVoting'. -- 2. The winning 'ResultTag' has more votes than all other 'ResultTag's. -- 3. The proposal hasn't been alive for longer than the voting time. -- - -- @'Locked' -> 'Finished'@: + -- === @'Locked' -> 'Finished'@: + -- -- Always valid provided the conditions for the transition are met. -- - -- @* -> 'Finished'@: + -- === @* -> 'Finished'@: + -- -- If the proposal has run out of time for the current 'ProposalStatus', it will always be possible -- to transition into 'Finished' state, because it has expired (and failed). AdvanceProposal @@ -221,10 +227,10 @@ PlutusTx.makeIsDataIndexed , ('AdvanceProposal, 3) ] -{- | Identifies a Proposal, issued upon creation of a proposal. - In practice, this number starts at zero, and increments by one - for each proposal. The 100th proposal will be @'ProposalId' 99@. - This counter lives in the 'Governor', see 'nextProposalId'. +{- | Identifies a Proposal, issued upon creation of a proposal. In practice, + this number starts at zero, and increments by one for each proposal. + The 100th proposal will be @'ProposalId' 99@. This counter lives + in the 'Agora.Governor.Governor', see 'Agora.Governor.nextProposalId'. -} newtype ProposalId = ProposalId {proposalTag :: Integer} deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) diff --git a/agora/Agora/Proposal/Time.hs b/agora/Agora/Proposal/Time.hs index 7245dd0..952b8dd 100644 --- a/agora/Agora/Proposal/Time.hs +++ b/agora/Agora/Proposal/Time.hs @@ -20,35 +20,53 @@ module Agora.Proposal.Time ( PProposalStartingTime (..), -- * Compute ranges given config and starting time. - proposalDraftRange, - - -- * Upstreamables - plowerBound, - pupperBound, - pstrictLowerBound, - pstrictUpperBound, + currentProposalTime, + isDraftRange, ) where import Agora.Record (build, (.&), (.=)) import GHC.Generics qualified as GHC import Generics.SOP (Generic, I (I)) -import Plutarch.Api.V1 (PExtended (PFinite), PInterval (PInterval), PLowerBound (PLowerBound), PPOSIXTime, PPOSIXTimeRange, PUpperBound (PUpperBound)) +import Plutarch.Api.V1 (PExtended (PFinite), PInterval (PInterval), PLowerBound (PLowerBound), PMaybeData (PDJust, PDNothing), PPOSIXTime, PPOSIXTimeRange, PUpperBound (PUpperBound)) import Plutarch.DataRepr (PDataFields, PIsDataReprInstances (..)) +import Plutarch.Monadic qualified as P import Plutarch.Numeric (AdditiveSemigroup ((+))) import Plutarch.Unsafe (punsafeCoerce) -import Plutus.V1.Ledger.Time (POSIXTime, POSIXTimeRange) +import Plutus.V1.Ledger.Time (POSIXTime) import PlutusTx qualified import Prelude hiding ((+)) -------------------------------------------------------------------------------- --- | Represents the current time, as far as the proposal is concerned. -newtype ProposalTime = ProposalTime - { getProposalTime :: POSIXTimeRange +{- | == Establishing timing in Proposal interactions. + + In Plutus, it's impossible to determine time exactly. It's also impossible + to get a single point in time, yet often we need to check + various constraints on time. + + For the purposes of proposals, there's a single most important feature: + The ability to determine if we can perform an action. In order to correctly + determine if we are able to perform certain actions, we need to know what + time it roughly is, compared to when the proposal got created. + + 'ProposalTime' represents "the time according to the proposal". + Its representation is opaque, and doesn't matter. + + Various functions work simply on 'ProposalTime' and 'ProposalTimingConfig'. + In particular, 'currentProposalTime' is useful for extracting the time + from the 'Plutus.V1.Ledger.Api.txInfoValidRange' field + of 'Plutus.V1.Ledger.Api.TxInfo'. + + We avoid 'PPOSIXTimeRange' where we can in order to save on operations. +-} +data ProposalTime = ProposalTime + { lowerBound :: Maybe POSIXTime + , upperBound :: Maybe POSIXTime } - deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) deriving stock (Eq, Show, GHC.Generic) +PlutusTx.makeIsDataIndexed ''ProposalTime [('ProposalTime, 0)] + -- | Represents the starting time of the proposal. newtype ProposalStartingTime = ProposalStartingTime { getProposalStartingTime :: POSIXTime @@ -74,8 +92,22 @@ PlutusTx.makeIsDataIndexed ''ProposalTimingConfig [('ProposalTimingConfig, 0)] -------------------------------------------------------------------------------- -- | Plutarch-level version of 'ProposalTime'. -newtype PProposalTime (s :: S) = PProposalTime (Term s PPOSIXTime) - deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalTime PPOSIXTime) +newtype PProposalTime (s :: S) + = PProposalTime + ( Term + s + ( PDataRecord + '[ "lowerBound" ':= PMaybeData PPOSIXTime + , "upperBound" ':= PMaybeData PPOSIXTime + ] + ) + ) + deriving stock (GHC.Generic) + deriving anyclass (Generic) + deriving anyclass (PIsDataRepr) + deriving + (PlutusType, PIsData, PDataFields) + via (PIsDataReprInstances PProposalTime) -- | Plutarch-level version of 'ProposalStartingTime'. newtype PProposalStartingTime (s :: S) = PProposalStartingTime (Term s PPOSIXTime) @@ -103,58 +135,56 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig -------------------------------------------------------------------------------- --- -- Need to move these away from here -pstrictLowerBound :: PIsData a => Term s (a :--> PLowerBound a) -pstrictLowerBound = phoistAcyclic $ - plam $ \a -> - pcon - ( PLowerBound $ - build $ - #_0 .= pdata (pcon (PFinite $ build $ #_0 .= pdata a)) - .& #_1 .= pdata (pcon PFalse) - ) - -pstrictUpperBound :: PIsData a => Term s (a :--> PUpperBound a) -pstrictUpperBound = phoistAcyclic $ - plam $ \a -> - pcon - ( PUpperBound $ - build $ - #_0 .= pdata (pcon (PFinite $ build $ #_0 .= pdata a)) - .& #_1 .= pdata (pcon PFalse) - ) - -plowerBound :: PIsData a => Term s (a :--> PLowerBound a) -plowerBound = phoistAcyclic $ - plam $ \a -> - pcon - ( PLowerBound $ - build $ - #_0 .= pdata (pcon (PFinite $ build $ #_0 .= pdata a)) - .& #_1 .= pdata (pcon PTrue) - ) - -pupperBound :: PIsData a => Term s (a :--> PUpperBound a) -pupperBound = phoistAcyclic $ - plam $ \a -> - pcon - ( PUpperBound $ - build $ - #_0 .= pdata (pcon (PFinite $ build $ #_0 .= pdata a)) - .& #_1 .= pdata (pcon PTrue) - ) - --- Move this to plutarch-extra. +-- FIXME: Orphan instance, move this to plutarch-extra. instance AdditiveSemigroup (Term s PPOSIXTime) where (punsafeCoerce @_ @_ @PInteger -> x) + (punsafeCoerce @_ @_ @PInteger -> y) = punsafeCoerce $ x + y --- | Compute the range of time during which cosigning is legal. -proposalDraftRange :: Term s (PPOSIXTime :--> PProposalTimingConfig :--> PPOSIXTimeRange) -proposalDraftRange = phoistAcyclic $ - plam $ \s config -> +-- | Get the current proposal time, from the 'txInfoValidRange' field. +currentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PProposalTime) +currentProposalTime = phoistAcyclic $ + plam $ \iv -> P.do + PInterval iv' <- pmatch iv + ivf <- pletFields @'["from", "to"] iv' + PLowerBound lb <- pmatch ivf.from + PUpperBound ub <- pmatch ivf.to + lbf <- pletFields @'["_0", "_1"] lb + ubf <- pletFields @'["_0", "_1"] ub pcon - ( PInterval $ + ( PProposalTime $ build $ - #from .= pdata (pstrictLowerBound # s) - .& #to .= pdata (pstrictUpperBound #$ s + pfield @"draftTime" # config) + #lowerBound + .= pdata + ( pmatch lbf._0 $ + \case + PFinite d -> pcon (PDJust d) + _ -> pcon (PDNothing pdnil) + ) + .& #upperBound + .= pdata + ( pmatch ubf._0 $ \case + PFinite d -> pcon (PDJust d) + _ -> pcon (PDNothing pdnil) + ) ) + +-- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive. +proposalTimeWithin :: Term s (PPOSIXTime :--> PPOSIXTime :--> PProposalTime :--> PBool) +proposalTimeWithin = phoistAcyclic $ + plam $ \l h proposalTime' -> P.do + PProposalTime proposalTime <- pmatch proposalTime' + ptf <- pletFields @'["lowerBound", "upperBound"] proposalTime + foldr1 + (#&&) + [ pmatch ptf.lowerBound $ \case + PDJust lb -> l #<= pfromData (pfield @"_0" # lb) + _ -> pcon PFalse + , pmatch ptf.upperBound $ \case + PDJust lb -> pfromData (pfield @"_0" # lb) #<= h + _ -> pcon PFalse + ] + +-- | True if the 'PProposalTime' is in the draft period. +isDraftRange :: forall (s :: S). Term s (PProposalTimingConfig :--> PProposalStartingTime :--> PProposalTime :--> PBool) +isDraftRange = phoistAcyclic $ + plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) -> + proposalTimeWithin # s # (s + pfield @"draftTime" # config) From f79f85b2c0b6fb26221a0d1b3ef690ee9746b831 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Mon, 18 Apr 2022 16:26:34 +0200 Subject: [PATCH 06/28] add proposalCreation Sample test --- agora-test/Spec.hs | 4 + agora-test/Spec/Proposal.hs | 38 ++++++ agora-test/Spec/Sample/Proposal.hs | 198 +++++++++++++++++++++++++++++ agora-test/Spec/Stake.hs | 5 +- agora.cabal | 2 + agora/Agora/Governor.hs | 7 + agora/Agora/Proposal.hs | 25 ++-- 7 files changed, 267 insertions(+), 12 deletions(-) create mode 100644 agora-test/Spec/Proposal.hs create mode 100644 agora-test/Spec/Sample/Proposal.hs diff --git a/agora-test/Spec.hs b/agora-test/Spec.hs index 40a7b7f..22c5b49 100644 --- a/agora-test/Spec.hs +++ b/agora-test/Spec.hs @@ -11,6 +11,7 @@ import Test.Tasty (defaultMain, testGroup) import Spec.AuthorityToken qualified as AuthorityToken import Spec.Effect.TreasuryWithdrawal qualified as TreasuryWithdrawal import Spec.Model.MultiSig qualified as MultiSig +import Spec.Proposal qualified as Proposal import Spec.Stake qualified as Stake -- | The Agora test suite. @@ -28,6 +29,9 @@ main = , testGroup "Stake tests" Stake.tests + , testGroup + "Proposal tests" + Proposal.tests , testGroup "Multisig tests" [ testGroup diff --git a/agora-test/Spec/Proposal.hs b/agora-test/Spec/Proposal.hs new file mode 100644 index 0000000..4d3c4e3 --- /dev/null +++ b/agora-test/Spec/Proposal.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE QuasiQuotes #-} + +{- | +Module : Spec.Proposal +Maintainer : emi@haskell.fyi +Description: Tests for Proposal policy and validator + +Tests for Proposal policy and validator +-} +module Spec.Proposal (tests) where + +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- + +import Agora.Proposal (proposalPolicy) +import Spec.Sample.Proposal qualified as Proposal +import Spec.Util (policySucceedsWith) +import Test.Tasty (TestTree, testGroup) + +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- + +-- | Stake tests. +tests :: [TestTree] +tests = + [ testGroup + "policy" + [ policySucceedsWith + "stakeCreation" + (proposalPolicy Proposal.proposal) + () + Proposal.proposalCreation + ] + ] diff --git a/agora-test/Spec/Sample/Proposal.hs b/agora-test/Spec/Sample/Proposal.hs new file mode 100644 index 0000000..ba4a3bb --- /dev/null +++ b/agora-test/Spec/Sample/Proposal.hs @@ -0,0 +1,198 @@ +{- | +Module : Spec.Sample.Proposal +Maintainer : emi@haskell.fyi +Description: Sample based testing for Proposal utxos + +This module tests primarily the happy path for Proposal interactions +-} +module Spec.Sample.Proposal ( + proposal, + policy, + policySymbol, + validatorHashTN, + signer, + + -- * Script contexts + proposalCreation, +) where + +-------------------------------------------------------------------------------- +import Plutarch.Api.V1 ( + mintingPolicySymbol, + mkMintingPolicy, + mkValidator, + validatorHash, + ) +import Plutus.V1.Ledger.Api ( + Address (Address), + Credential (ScriptCredential), + CurrencySymbol, + Datum (Datum), + MintingPolicy (..), + PubKeyHash, + ScriptContext (..), + ScriptPurpose (..), + ToData (toBuiltinData), + TxInInfo (TxInInfo), + TxInfo (..), + TxOut (TxOut, txOutAddress, txOutDatumHash, txOutValue), + TxOutRef (TxOutRef), + ValidatorHash (ValidatorHash), + ) +import Plutus.V1.Ledger.Interval qualified as Interval +import Plutus.V1.Ledger.Scripts (Validator) +import Plutus.V1.Ledger.Value (AssetClass (AssetClass), TokenName (TokenName)) +import Plutus.V1.Ledger.Value qualified as Value + +-------------------------------------------------------------------------------- + +import Agora.Governor ( + Governor (Governor), + GovernorDatum (GovernorDatum, nextProposalId, proposalThresholds), + governorPolicy, + governorValidator, + ) +import Agora.Proposal +import Plutarch.SafeMoney +import PlutusTx.AssocMap qualified as AssocMap +import Spec.Util (datumPair, toDatumHash) + +-------------------------------------------------------------------------------- + +governor :: Governor +governor = Governor + +govPolicy :: MintingPolicy +govPolicy = mkMintingPolicy (governorPolicy governor) + +govValidator :: Validator +govValidator = mkValidator (governorValidator governor) + +govSymbol :: CurrencySymbol +govSymbol = mintingPolicySymbol govPolicy + +proposal :: Proposal +proposal = + Proposal + { governorSTAssetClass = + -- TODO: if we had a governor here + AssetClass + ( govSymbol + , "" + ) + } + +-- | 'Proposal' policy instance. +policy :: MintingPolicy +policy = mkMintingPolicy (proposalPolicy proposal) + +policySymbol :: CurrencySymbol +policySymbol = mintingPolicySymbol policy + +-- | A sample 'PubKeyHash'. +signer :: PubKeyHash +signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c" + +-- | 'Proposal' validator instance. +validator :: Validator +validator = mkValidator (proposalValidator proposal) + +-- | 'TokenName' that represents the hash of the 'Proposal' validator. +validatorHashTN :: TokenName +validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh + +propThresholds :: ProposalThresholds +propThresholds = + ProposalThresholds + { countVoting = Tagged 1000 + , create = Tagged 1 + , vote = Tagged 10 + } + +-- | This script context should be a valid transaction. +proposalCreation :: ScriptContext +proposalCreation = + let st = Value.singleton policySymbol "" 1 -- Proposal ST + proposalDatum :: Datum + proposalDatum = + Datum + ( toBuiltinData $ + ProposalDatum + { proposalId = ProposalId 0 + , effects = + AssocMap.fromList + [ (ResultTag 0, []) + , (ResultTag 1, []) + ] + , status = Draft + , cosigners = [signer] + , thresholds = propThresholds + , votes = ProposalVotes $ AssocMap.empty + } + ) + + govBefore :: Datum + govBefore = + Datum + ( toBuiltinData $ + GovernorDatum + { proposalThresholds = propThresholds + , nextProposalId = ProposalId 0 + } + ) + govAfter :: Datum + govAfter = + Datum + ( toBuiltinData $ + GovernorDatum + { proposalThresholds = propThresholds + , nextProposalId = ProposalId 1 + } + ) + in ScriptContext + { scriptContextTxInfo = + TxInfo + { txInfoInputs = + [ TxInInfo + (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) + TxOut + { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing + , txOutValue = Value.assetClassValue proposal.governorSTAssetClass 1 + , txOutDatumHash = Just (toDatumHash govBefore) + } + ] + , txInfoOutputs = + [ TxOut + { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing + , txOutValue = + mconcat + [ st + , Value.singleton "" "" 10_000_000 + ] + , txOutDatumHash = Just (toDatumHash proposalDatum) + } + , TxOut + { txOutAddress = Address (ScriptCredential $ validatorHash govValidator) Nothing + , txOutValue = + mconcat + [ Value.assetClassValue proposal.governorSTAssetClass 1 + , Value.singleton "" "" 10_000_000 + ] + , txOutDatumHash = Just (toDatumHash govAfter) + } + ] + , txInfoFee = Value.singleton "" "" 2 + , txInfoMint = st + , txInfoDCert = [] + , txInfoWdrl = [] + , txInfoValidRange = Interval.always + , txInfoSignatories = [signer] + , txInfoData = + [ datumPair proposalDatum + , datumPair govBefore + , datumPair govAfter + ] + , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" + } + , scriptContextPurpose = Minting policySymbol + } diff --git a/agora-test/Spec/Stake.hs b/agora-test/Spec/Stake.hs index 8f2538d..2513bab 100644 --- a/agora-test/Spec/Stake.hs +++ b/agora-test/Spec/Stake.hs @@ -49,7 +49,10 @@ tests = (stakePolicy Stake.stake) () Stake.stakeCreationUnsigned - , validatorSucceedsWith + ] + , testGroup + "validator" + [ validatorSucceedsWith "stakeDepositWithdraw deposit" (stakeValidator Stake.stake) (toDatum $ StakeDatum 100_000 signer []) diff --git a/agora.cabal b/agora.cabal index bd07338..df30ebb 100644 --- a/agora.cabal +++ b/agora.cabal @@ -162,6 +162,8 @@ test-suite agora-test Spec.Sample.Effect.TreasuryWithdrawal Spec.Sample.Stake Spec.Stake + Spec.Sample.Proposal + Spec.Proposal Spec.Util build-depends: agora diff --git a/agora/Agora/Governor.hs b/agora/Agora/Governor.hs index 8f12181..7a47865 100644 --- a/agora/Agora/Governor.hs +++ b/agora/Agora/Governor.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + {- | Module : Agora.Governor Maintainer : emi@haskell.fyi @@ -21,6 +23,7 @@ module Agora.Governor ( import Agora.Proposal (ProposalId, ProposalThresholds) import Plutarch (popaque) import Plutarch.Api.V1 (PMintingPolicy, PValidator) +import PlutusTx qualified -- | Datum for the Governor script. data GovernorDatum = GovernorDatum @@ -30,6 +33,8 @@ data GovernorDatum = GovernorDatum -- ^ What tag the next proposal will get upon creating. } +PlutusTx.makeIsDataIndexed ''GovernorDatum [('GovernorDatum, 0)] + {- | Redeemer for Governor script. The governor has two primary responsibilities: @@ -43,6 +48,8 @@ data GovernorRedeemer -- and allows minting GATs for each effect script. MintGATs +PlutusTx.makeIsDataIndexed ''GovernorRedeemer [('CreateProposal, 0), ('MintGATs, 1)] + -- | Parameters for creating Governor scripts. data Governor = Governor diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index 5252f0f..a32b283 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -73,6 +73,15 @@ import Plutus.V1.Ledger.Value (AssetClass (AssetClass)) -------------------------------------------------------------------------------- -- Haskell-land +{- | Identifies a Proposal, issued upon creation of a proposal. In practice, + this number starts at zero, and increments by one for each proposal. + The 100th proposal will be @'ProposalId' 99@. This counter lives + in the 'Agora.Governor.Governor', see 'Agora.Governor.nextProposalId'. +-} +newtype ProposalId = ProposalId {proposalTag :: Integer} + deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) + deriving stock (Eq, Show, GHC.Generic) + {- | Encodes a result. Typically, for a Yes/No proposal, we encode it like this: @ @@ -162,7 +171,9 @@ newtype ProposalVotes = ProposalVotes -- | Haskell-level datum for Proposal scripts. data ProposalDatum = ProposalDatum - { -- TODO: could we encode this more efficiently? + { proposalId :: ProposalId + -- ^ Identification of the proposal. + , -- TODO: could we encode this more efficiently? -- This is shaped this way for future proofing. -- See https://github.com/Liqwid-Labs/agora/issues/39 effects :: AssocMap.Map ResultTag [(ValidatorHash, DatumHash)] @@ -227,15 +238,6 @@ PlutusTx.makeIsDataIndexed , ('AdvanceProposal, 3) ] -{- | Identifies a Proposal, issued upon creation of a proposal. In practice, - this number starts at zero, and increments by one for each proposal. - The 100th proposal will be @'ProposalId' 99@. This counter lives - in the 'Agora.Governor.Governor', see 'Agora.Governor.nextProposalId'. --} -newtype ProposalId = ProposalId {proposalTag :: Integer} - deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) - deriving stock (Eq, Show, GHC.Generic) - -- | Parameters that identify the Proposal validator script. data Proposal = Proposal { governorSTAssetClass :: AssetClass @@ -341,7 +343,8 @@ newtype PProposalDatum (s :: S) = PProposalDatum Term s ( PDataRecord - '[ "effects" ':= PMap PResultTag (PMap PValidatorHash PDatumHash) + '[ "id" ':= PProposalId + , "effects" ':= PMap PResultTag (PMap PValidatorHash PDatumHash) , "status" ':= PProposalStatus , "cosigners" ':= PBuiltinList (PAsData PPubKeyHash) , "thresholds" ':= PProposalThresholds From eba9ce452e267c77607da9ff5e9696c4931c374d Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Tue, 19 Apr 2022 11:07:11 +0200 Subject: [PATCH 07/28] fix linter errors --- agora-test/Spec/Sample/Proposal.hs | 4 ++-- agora.cabal | 8 ++++---- agora/Agora/Proposal.hs | 2 +- agora/Agora/Record.hs | 6 +++--- agora/Agora/Utils.hs | 3 ++- 5 files changed, 12 insertions(+), 11 deletions(-) diff --git a/agora-test/Spec/Sample/Proposal.hs b/agora-test/Spec/Sample/Proposal.hs index ba4a3bb..9b464cb 100644 --- a/agora-test/Spec/Sample/Proposal.hs +++ b/agora-test/Spec/Sample/Proposal.hs @@ -127,7 +127,7 @@ proposalCreation = , status = Draft , cosigners = [signer] , thresholds = propThresholds - , votes = ProposalVotes $ AssocMap.empty + , votes = ProposalVotes AssocMap.empty } ) @@ -156,7 +156,7 @@ proposalCreation = [ TxInInfo (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) TxOut - { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing + { txOutAddress = Address (ScriptCredential $ validatorHash govValidator) Nothing , txOutValue = Value.assetClassValue proposal.governorSTAssetClass 1 , txOutDatumHash = Just (toDatumHash govBefore) } diff --git a/agora.cabal b/agora.cabal index df30ebb..6500ad6 100644 --- a/agora.cabal +++ b/agora.cabal @@ -60,6 +60,7 @@ common lang NamedFieldPuns NamedWildCards NumericUnderscores + OverloadedLabels OverloadedStrings PartialTypeSignatures PatternGuards @@ -78,7 +79,6 @@ common lang UndecidableInstances ViewPatterns OverloadedRecordDot - OverloadedLabels QualifiedDo default-language: Haskell2010 @@ -130,10 +130,10 @@ library Agora.MultiSig Agora.Proposal Agora.Proposal.Time + Agora.Record Agora.SafeMoney Agora.Stake Agora.Treasury - Agora.Record other-modules: Agora.Utils @@ -159,11 +159,11 @@ test-suite agora-test Spec.AuthorityToken Spec.Effect.TreasuryWithdrawal Spec.Model.MultiSig + Spec.Proposal Spec.Sample.Effect.TreasuryWithdrawal + Spec.Sample.Proposal Spec.Sample.Stake Spec.Stake - Spec.Sample.Proposal - Spec.Proposal Spec.Util build-depends: agora diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index a32b283..bd73e76 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -239,7 +239,7 @@ PlutusTx.makeIsDataIndexed ] -- | Parameters that identify the Proposal validator script. -data Proposal = Proposal +newtype Proposal = Proposal { governorSTAssetClass :: AssetClass } deriving stock (Show, Eq) diff --git a/agora/Agora/Record.hs b/agora/Agora/Record.hs index 3cd0723..a5dfe35 100644 --- a/agora/Agora/Record.hs +++ b/agora/Agora/Record.hs @@ -61,7 +61,7 @@ infixr 6 .& (a :: [PLabeledType]) (b :: [PLabeledType]) (c :: [PLabeledType]). - (RecordMorphism s b c) -> - (RecordMorphism s a b) -> - (RecordMorphism s a c) + RecordMorphism s b c -> + RecordMorphism s a b -> + RecordMorphism s a c (.&) = (.) diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index 58c350a..ed86334 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -415,7 +415,8 @@ ptokenSpent = plam $ \tokenClass inputs -> 0 #< pfoldr @PBuiltinList - # ( plam $ \txInInfo' acc -> P.do + # plam + ( \txInInfo' acc -> P.do PTxInInfo txInInfo <- pmatch (pfromData txInInfo') PTxOut txOut' <- pmatch $ pfromData $ pfield @"resolved" # txInInfo txOut <- pletFields @'["value"] txOut' From e77140e86333c4d473e6d68771853a7995dc408d Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Tue, 19 Apr 2022 14:16:31 +0200 Subject: [PATCH 08/28] stub redeemer matching --- agora/Agora/Proposal.hs | 42 +++++++++++++++++++++++++++++++++++++---- 1 file changed, 38 insertions(+), 4 deletions(-) diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index bd73e76..aaca9a1 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -45,6 +45,8 @@ import Plutarch.Api.V1 ( PTxInfo (PTxInfo), PValidator, PValidatorHash, + mintingPolicySymbol, + mkMintingPolicy, ) import Plutarch.DataRepr ( DerivePConstantViaData (..), @@ -58,7 +60,7 @@ import PlutusTx.AssocMap qualified as AssocMap -------------------------------------------------------------------------------- import Agora.SafeMoney (GTTag) -import Agora.Utils (passert, pnotNull, ptokenSpent) +import Agora.Utils (passert, pnotNull, psymbolValueOf, ptokenSpent, pvalueSpent) import Control.Arrow (first) import Plutarch (popaque) import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf) @@ -422,14 +424,46 @@ proposalPolicy proposal = -- | Validator for Proposals. proposalValidator :: Proposal -> ClosedTerm PValidator -proposalValidator _ = - plam $ \_datum _redeemer ctx' -> P.do +proposalValidator proposal = + plam $ \datum redeemer ctx' -> P.do PScriptContext ctx' <- pmatch ctx' ctx <- pletFields @'["txInfo", "purpose"] ctx' PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo _txInfo <- pletFields @'["inputs", "mint"] txInfo' PSpending _txOutRef <- pmatch $ pfromData ctx.purpose - popaque (pconstant ()) + + let _proposalDatum' :: Term _ PProposalDatum + _proposalDatum' = pfromData $ punsafeCoerce datum + proposalRedeemer :: Term _ PProposalRedeemer + proposalRedeemer = pfromData $ punsafeCoerce redeemer + + stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (proposalPolicy proposal) + spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # ctx.txInfo + + pmatch proposalRedeemer $ \case + PVote _r -> P.do + passert "ST at inputs must be 1" $ + spentST #== 1 + + popaque (pconstant ()) + -------------------------------------------------------------------------- + PCosign _r -> P.do + passert "ST at inputs must be 1" $ + spentST #== 1 + + 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 From 8f7f543438c7ee72a52731d2173a555380e4a7ec Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Tue, 19 Apr 2022 17:42:39 +0200 Subject: [PATCH 09/28] flake: bump plutarch-extra fork --- agora/Agora/Governor.hs | 1 - agora/Agora/MultiSig.hs | 3 +- agora/Agora/Proposal.hs | 17 ++-- agora/Agora/Stake.hs | 9 +- agora/Agora/Treasury.hs | 1 - agora/Agora/Utils.hs | 2 +- agora/PPrelude.hs | 5 +- flake.lock | 178 +++++++++++++++------------------------- flake.nix | 5 +- 9 files changed, 85 insertions(+), 136 deletions(-) diff --git a/agora/Agora/Governor.hs b/agora/Agora/Governor.hs index 7a47865..24f52ad 100644 --- a/agora/Agora/Governor.hs +++ b/agora/Agora/Governor.hs @@ -21,7 +21,6 @@ module Agora.Governor ( ) where import Agora.Proposal (ProposalId, ProposalThresholds) -import Plutarch (popaque) import Plutarch.Api.V1 (PMintingPolicy, PValidator) import PlutusTx qualified diff --git a/agora/Agora/MultiSig.hs b/agora/Agora/MultiSig.hs index 93cf3e6..a65d0f0 100644 --- a/agora/Agora/MultiSig.hs +++ b/agora/Agora/MultiSig.hs @@ -24,6 +24,7 @@ import Plutarch.DataRepr ( PIsDataReprInstances (PIsDataReprInstances), ) import Plutarch.Lift ( + PConstantDecl, PLifted, PUnsafeLiftDecl, ) @@ -73,7 +74,7 @@ newtype PMultiSig (s :: S) = PMultiSig via (PIsDataReprInstances PMultiSig) instance PUnsafeLiftDecl PMultiSig where type PLifted PMultiSig = MultiSig -deriving via (DerivePConstantViaData MultiSig PMultiSig) instance (PConstant MultiSig) +deriving via (DerivePConstantViaData MultiSig PMultiSig) instance (PConstantDecl MultiSig) -------------------------------------------------------------------------------- diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index aaca9a1..126b384 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -62,10 +62,9 @@ import PlutusTx.AssocMap qualified as AssocMap import Agora.SafeMoney (GTTag) import Agora.Utils (passert, pnotNull, psymbolValueOf, ptokenSpent, pvalueSpent) import Control.Arrow (first) -import Plutarch (popaque) import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf) import Plutarch.Builtin (PBuiltinMap) -import Plutarch.Lift (DerivePConstantViaNewtype (..), PUnsafeLiftDecl (..)) +import Plutarch.Lift (DerivePConstantViaNewtype (..), PConstantDecl, PUnsafeLiftDecl (..)) import Plutarch.Monadic qualified as P import Plutarch.SafeMoney (PDiscrete, Tagged) import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom')) @@ -257,7 +256,7 @@ instance PUnsafeLiftDecl PResultTag where type PLifted PResultTag = ResultTag deriving via (DerivePConstantViaNewtype ResultTag PResultTag PInteger) instance - (PConstant ResultTag) + (PConstantDecl ResultTag) -- FIXME: This instance and the one below, for 'PProposalId', should be derived. -- Soon this will be possible through 'DerivePNewtype'. @@ -287,7 +286,7 @@ instance PUnsafeLiftDecl PProposalId where type PLifted PProposalId = ProposalId deriving via (DerivePConstantViaNewtype ProposalId PProposalId PInteger) instance - (PConstant ProposalId) + (PConstantDecl ProposalId) -- | Plutarch-level version of 'ProposalStatus'. data PProposalStatus (s :: S) @@ -304,7 +303,7 @@ data PProposalStatus (s :: S) via PIsDataReprInstances PProposalStatus instance PUnsafeLiftDecl PProposalStatus where type PLifted PProposalStatus = ProposalStatus -deriving via (DerivePConstantViaData ProposalStatus PProposalStatus) instance (PConstant ProposalStatus) +deriving via (DerivePConstantViaData ProposalStatus PProposalStatus) instance (PConstantDecl ProposalStatus) -- | Plutarch-level version of 'ProposalThresholds'. newtype PProposalThresholds (s :: S) = PProposalThresholds @@ -326,7 +325,7 @@ newtype PProposalThresholds (s :: S) = PProposalThresholds via (PIsDataReprInstances PProposalThresholds) instance PUnsafeLiftDecl PProposalThresholds where type PLifted PProposalThresholds = ProposalThresholds -deriving via (DerivePConstantViaData ProposalThresholds PProposalThresholds) instance (PConstant ProposalThresholds) +deriving via (DerivePConstantViaData ProposalThresholds PProposalThresholds) instance (PConstantDecl ProposalThresholds) -- | Plutarch-level version of 'ProposalVotes'. newtype PProposalVotes (s :: S) @@ -337,7 +336,7 @@ instance PUnsafeLiftDecl PProposalVotes where type PLifted PProposalVotes = Prop deriving via (DerivePConstantViaNewtype ProposalVotes PProposalVotes (PMap PResultTag PInteger)) instance - (PConstant ProposalVotes) + (PConstantDecl ProposalVotes) -- | Plutarch-level version of 'ProposalDatum'. newtype PProposalDatum (s :: S) = PProposalDatum @@ -362,7 +361,7 @@ newtype PProposalDatum (s :: S) = PProposalDatum via (PIsDataReprInstances PProposalDatum) instance PUnsafeLiftDecl PProposalDatum where type PLifted PProposalDatum = ProposalDatum -deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PConstant ProposalDatum) +deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PConstantDecl ProposalDatum) -- | Haskell-level redeemer for Proposal scripts. data PProposalRedeemer (s :: S) @@ -384,7 +383,7 @@ data PProposalRedeemer (s :: S) -- PTryFrom PData (PAsData PProposalRedeemer) instance PUnsafeLiftDecl PProposalRedeemer where type PLifted PProposalRedeemer = ProposalRedeemer -deriving via (DerivePConstantViaData ProposalRedeemer PProposalRedeemer) instance (PConstant ProposalRedeemer) +deriving via (DerivePConstantViaData ProposalRedeemer PProposalRedeemer) instance (PConstantDecl ProposalRedeemer) -------------------------------------------------------------------------------- diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index afaacb1..9334d29 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -33,7 +33,6 @@ import PlutusTx qualified -------------------------------------------------------------------------------- -import Plutarch (popaque) import Plutarch.Api.V1 ( PCredential (PPubKeyCredential, PScriptCredential), PMintingPolicy, @@ -50,7 +49,7 @@ import Plutarch.DataRepr ( PIsDataReprInstances (PIsDataReprInstances), ) import Plutarch.Internal (punsafeCoerce) -import Plutarch.Lift (PUnsafeLiftDecl (..)) +import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..)) import Plutarch.Monadic qualified as P import Plutus.V1.Ledger.Value (AssetClass (AssetClass)) @@ -197,7 +196,7 @@ newtype PStakeDatum (s :: S) = PStakeDatum via (PIsDataReprInstances PStakeDatum) instance PUnsafeLiftDecl PStakeDatum where type PLifted PStakeDatum = StakeDatum -deriving via (DerivePConstantViaData StakeDatum PStakeDatum) instance (PConstant StakeDatum) +deriving via (DerivePConstantViaData StakeDatum PStakeDatum) instance (PConstantDecl StakeDatum) -- | Plutarch-level redeemer for Stake scripts. data PStakeRedeemer (s :: S) @@ -220,7 +219,7 @@ deriving via PTryFrom PData (PAsData PStakeRedeemer) instance PUnsafeLiftDecl PStakeRedeemer where type PLifted PStakeRedeemer = StakeRedeemer -deriving via (DerivePConstantViaData StakeRedeemer PStakeRedeemer) instance (PConstant StakeRedeemer) +deriving via (DerivePConstantViaData StakeRedeemer PStakeRedeemer) instance (PConstantDecl StakeRedeemer) newtype PProposalLock (s :: S) = PProposalLock { getProposalLock :: @@ -245,7 +244,7 @@ deriving via PTryFrom PData (PAsData PProposalLock) instance PUnsafeLiftDecl PProposalLock where type PLifted PProposalLock = ProposalLock -deriving via (DerivePConstantViaData ProposalLock PProposalLock) instance (PConstant ProposalLock) +deriving via (DerivePConstantViaData ProposalLock PProposalLock) instance (PConstantDecl ProposalLock) -------------------------------------------------------------------------------- {- What this Policy does diff --git a/agora/Agora/Treasury.hs b/agora/Agora/Treasury.hs index 3f48a1f..9cda2b1 100644 --- a/agora/Agora/Treasury.hs +++ b/agora/Agora/Treasury.hs @@ -23,7 +23,6 @@ import Plutus.V1.Ledger.Value (CurrencySymbol) import Agora.AuthorityToken (singleAuthorityTokenBurned) import Agora.Utils (passert) -import Plutarch (popaque) import Plutarch.Api.V1 (PValidator) import Plutarch.Unsafe (punsafeCoerce) diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index ed86334..8eeb07a 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -80,7 +80,7 @@ pfindDatum :: Term s (PDatumHash :--> PTxInfo :--> PMaybe PDatum) pfindDatum = phoistAcyclic $ plam $ \datumHash txInfo'' -> P.do PTxInfo txInfo' <- pmatch txInfo'' - plookupTuple # datumHash #$ pfield @"data" # txInfo' + plookupTuple # datumHash #$ pfield @"datums" # txInfo' {- | Find a datum with the given hash. NOTE: this is unsafe in the sense that, if the data layout is wrong, this is UB. diff --git a/agora/PPrelude.hs b/agora/PPrelude.hs index 3232cf9..5878ff4 100644 --- a/agora/PPrelude.hs +++ b/agora/PPrelude.hs @@ -11,8 +11,7 @@ module PPrelude ( module Plutarch, ) where --- NOTE: These are not exported by Plutarch.Prelude, for some reason. --- Maybe we can 'fix' this upstream? -import Plutarch (ClosedTerm, POpaque, compile) +-- 'compile' is not exported by Plutarch.Prelude. +import Plutarch (compile) import Plutarch.Prelude import Prelude diff --git a/flake.lock b/flake.lock index 0b23a54..00c46fe 100644 --- a/flake.lock +++ b/flake.lock @@ -117,23 +117,6 @@ "type": "github" } }, - "autodocodec": { - "flake": false, - "locked": { - "lastModified": 1644358110, - "narHash": "sha256-X1TNZlmO2qDFk3OL4Z1v/gzvd3ouoACAiMweutsYek4=", - "owner": "srid", - "repo": "autodocodec", - "rev": "42b42a7407f33c6c74fa4e8c84906aebfed28daf", - "type": "github" - }, - "original": { - "owner": "srid", - "ref": "ghc921", - "repo": "autodocodec", - "type": "github" - } - }, "cabal-32": { "flake": false, "locked": { @@ -463,21 +446,6 @@ "type": "github" } }, - "flake-compat-ci_3": { - "locked": { - "lastModified": 1641672839, - "narHash": "sha256-Bdwv+DKeEMlRNPDpZxSz0sSrqQBvdKO5fZ8LmvrgCOU=", - "owner": "hercules-ci", - "repo": "flake-compat-ci", - "rev": "e832114bc18376c0f3fa13c19bf5ff253cc6570a", - "type": "github" - }, - "original": { - "owner": "hercules-ci", - "repo": "flake-compat-ci", - "type": "github" - } - }, "flake-compat_2": { "flake": false, "locked": { @@ -495,22 +463,6 @@ } }, "flake-compat_3": { - "flake": false, - "locked": { - "lastModified": 1641205782, - "narHash": "sha256-4jY7RCWUoZ9cKD8co0/4tFARpWB+57+r1bLLvXNJliY=", - "owner": "edolstra", - "repo": "flake-compat", - "rev": "b7547d3eed6f32d06102ead8991ec52ab0a4f1a7", - "type": "github" - }, - "original": { - "owner": "edolstra", - "repo": "flake-compat", - "type": "github" - } - }, - "flake-compat_4": { "flake": false, "locked": { "lastModified": 1606424373, @@ -527,7 +479,7 @@ "type": "github" } }, - "flake-compat_5": { + "flake-compat_4": { "flake": false, "locked": { "lastModified": 1606424373, @@ -981,7 +933,7 @@ }, "hercules-ci-agent": { "inputs": { - "flake-compat": "flake-compat_5", + "flake-compat": "flake-compat_4", "nix-darwin": "nix-darwin", "nixos-20_09": "nixos-20_09", "nixos-unstable": "nixos-unstable", @@ -1004,7 +956,7 @@ }, "hercules-ci-effects": { "inputs": { - "flake-compat": "flake-compat_4", + "flake-compat": "flake-compat_3", "hercules-ci-agent": "hercules-ci-agent", "nixpkgs": "nixpkgs_3", "nixpkgs-nixops": "nixpkgs-nixops" @@ -1088,6 +1040,55 @@ "type": "github" } }, + "hspec": { + "flake": false, + "locked": { + "lastModified": 1649095108, + "narHash": "sha256-cPmt4hvmdh727VT6UAL8yFArmm4FAWeg3K5Qi3XtU4g=", + "owner": "srid", + "repo": "hspec", + "rev": "44f2a143e10c93df237af428457d0e4b74ae270a", + "type": "github" + }, + "original": { + "owner": "srid", + "ref": "askAncestors", + "repo": "hspec", + "type": "github" + } + }, + "hspec-golden": { + "flake": false, + "locked": { + "lastModified": 1648755064, + "narHash": "sha256-5a6BksZx00o2iL0Ei/L1Kkou2BsnsIagN+tTmqYyKfs=", + "owner": "stackbuilders", + "repo": "hspec-golden", + "rev": "4b0ad56b2de0254a7b1e0feda917656f78a5bcda", + "type": "github" + }, + "original": { + "owner": "stackbuilders", + "repo": "hspec-golden", + "type": "github" + } + }, + "hspec-hedgehog": { + "flake": false, + "locked": { + "lastModified": 1602603478, + "narHash": "sha256-XnS3zjQ7eh3iBOWq+Z/YcwrfWI55hV6k8LsZ8qm/qOc=", + "owner": "parsonsmatt", + "repo": "hspec-hedgehog", + "rev": "eb617d854542510f0129acdea4bf52e50b13042e", + "type": "github" + }, + "original": { + "owner": "parsonsmatt", + "repo": "hspec-hedgehog", + "type": "github" + } + }, "iohk-nix": { "flake": false, "locked": { @@ -1592,19 +1593,24 @@ "plutarch": { "inputs": { "Shrinker": "Shrinker", - "autodocodec": "autodocodec", "cardano-base": "cardano-base", "cardano-crypto": "cardano-crypto", "cardano-prelude": "cardano-prelude", "cryptonite": "cryptonite", - "flake-compat": "flake-compat_3", - "flake-compat-ci": "flake-compat-ci_3", + "emanote": [ + "plutarch", + "haskell-nix", + "nixpkgs-unstable" + ], "flat": "flat", "foundation": "foundation", "haskell-language-server": "haskell-language-server_2", "haskell-nix": "haskell-nix_4", "hercules-ci-effects": "hercules-ci-effects", "hs-memory": "hs-memory", + "hspec": "hspec", + "hspec-golden": "hspec-golden", + "hspec-hedgehog": "hspec-hedgehog", "iohk-nix": "iohk-nix_2", "nixpkgs": [ "plutarch", @@ -1614,24 +1620,21 @@ "nixpkgs-2111": "nixpkgs-2111_5", "plutus": "plutus_2", "protolude": "protolude", - "safe-coloured-text": "safe-coloured-text", "sized-functors": "sized-functors", - "sydtest": "sydtest", - "th-extras": "th-extras", - "validity": "validity" + "th-extras": "th-extras" }, "locked": { - "lastModified": 1650025193, - "narHash": "sha256-SXfkWYse308SdnWO34cMVjKliDvyYYx++Y5uiuUmGXE=", + "lastModified": 1650382454, + "narHash": "sha256-b31DK+E/0MtR45+Z+F5U1E8jjcewvZ42UmFLZlXDAYM=", "owner": "peter-mlabs", "repo": "plutarch", - "rev": "18e787d420912ed765fc5653c3558f20ab5e638a", + "rev": "6ef18aacd02050fc07398e399cff5e8734c1045e", "type": "github" }, "original": { "owner": "peter-mlabs", "repo": "plutarch", - "rev": "18e787d420912ed765fc5653c3558f20ab5e638a", + "rev": "6ef18aacd02050fc07398e399cff5e8734c1045e", "type": "github" } }, @@ -1771,23 +1774,6 @@ "plutarch": "plutarch" } }, - "safe-coloured-text": { - "flake": false, - "locked": { - "lastModified": 1644357337, - "narHash": "sha256-sXSKw8m6O9K/H2BBiYqO5e4sJIo+9UP+UvEukRn28d8=", - "owner": "srid", - "repo": "safe-coloured-text", - "rev": "034f3612525568b422e0c62b52417d77b7cf31c2", - "type": "github" - }, - "original": { - "owner": "srid", - "ref": "ghc921", - "repo": "safe-coloured-text", - "type": "github" - } - }, "sized-functors": { "flake": false, "locked": { @@ -1917,23 +1903,6 @@ "type": "github" } }, - "sydtest": { - "flake": false, - "locked": { - "lastModified": 1645114028, - "narHash": "sha256-P6ZwwfFeN8fpi3fziz9yERTn7BfxdE/j/OofUu+4GdA=", - "owner": "srid", - "repo": "sydtest", - "rev": "9c6c7678f7aabe22e075aab810a6a2e304591d24", - "type": "github" - }, - "original": { - "owner": "srid", - "ref": "ghc921", - "repo": "sydtest", - "type": "github" - } - }, "th-extras": { "flake": false, "locked": { @@ -1950,23 +1919,6 @@ "rev": "787ed752c1e5d41b5903b74e171ed087de38bffa", "type": "github" } - }, - "validity": { - "flake": false, - "locked": { - "lastModified": 1644358698, - "narHash": "sha256-dpMIu08qXMzy8Kilk/2VWpuwIsfqFtpg/3mkwt5pdjA=", - "owner": "srid", - "repo": "validity", - "rev": "f7982549b95d0ab727950dc876ca06b1862135ba", - "type": "github" - }, - "original": { - "owner": "srid", - "ref": "ghc921", - "repo": "validity", - "type": "github" - } } }, "root": "root", diff --git a/flake.nix b/flake.nix index d51df25..3da51ee 100644 --- a/flake.nix +++ b/flake.nix @@ -7,9 +7,10 @@ # see https://github.com/NixOS/nix/issues/6013 inputs.nixpkgs-2111 = { url = "github:NixOS/nixpkgs/nixpkgs-21.11-darwin"; }; - # Rev is this PR https://github.com/peter-mlabs/plutarch/pull/5. inputs.plutarch.url = - "github:peter-mlabs/plutarch?rev=18e787d420912ed765fc5653c3558f20ab5e638a"; + "github:peter-mlabs/plutarch?rev=6ef18aacd02050fc07398e399cff5e8734c1045e"; + inputs.plutarch.inputs.emanote.follows = + "plutarch/haskell-nix/nixpkgs-unstable"; inputs.plutarch.inputs.nixpkgs.follows = "plutarch/haskell-nix/nixpkgs-unstable"; From 7634460241c8a1c15448b570d5e5913446f06abd Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Tue, 19 Apr 2022 22:20:17 +0200 Subject: [PATCH 10/28] simplify some PTxInfo functions --- agora/Agora/Proposal.hs | 56 ++++++++++++++++++---- agora/Agora/Record.hs | 3 +- agora/Agora/Stake.hs | 27 ++++++----- agora/Agora/Utils.hs | 100 ++++++++++++++++++++-------------------- 4 files changed, 113 insertions(+), 73 deletions(-) diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index 126b384..693b3bc 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -60,7 +60,16 @@ import PlutusTx.AssocMap qualified as AssocMap -------------------------------------------------------------------------------- import Agora.SafeMoney (GTTag) -import Agora.Utils (passert, pnotNull, psymbolValueOf, ptokenSpent, pvalueSpent) +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) @@ -427,17 +436,25 @@ proposalValidator proposal = plam $ \datum redeemer ctx' -> P.do PScriptContext ctx' <- pmatch ctx' ctx <- pletFields @'["txInfo", "purpose"] ctx' - PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo - _txInfo <- pletFields @'["inputs", "mint"] txInfo' - PSpending _txOutRef <- pmatch $ pfromData ctx.purpose + txInfo <- plet $ pfromData ctx.txInfo + PTxInfo txInfo' <- pmatch $ txInfo + txInfoF <- pletFields @'["inputs", "mint"] txInfo' + PSpending ((pfield @"_0" #) -> txOutRef) <- pmatch $ pfromData ctx.purpose - let _proposalDatum' :: Term _ PProposalDatum - _proposalDatum' = pfromData $ punsafeCoerce datum + PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs + txOutF <- pletFields @'["address"] $ txOut + + let proposalDatum :: Term _ PProposalDatum + proposalDatum = pfromData $ punsafeCoerce datum proposalRedeemer :: Term _ PProposalRedeemer proposalRedeemer = pfromData $ punsafeCoerce redeemer + proposalF <- pletFields @'["cosigners"] proposalDatum + + ownAddress <- plet $ txOutF.address + stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (proposalPolicy proposal) - spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # ctx.txInfo + spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # txInfoF.inputs pmatch proposalRedeemer $ \case PVote _r -> P.do @@ -446,10 +463,33 @@ proposalValidator proposal = popaque (pconstant ()) -------------------------------------------------------------------------- - PCosign _r -> P.do + 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 "Signatures are correctly added to cosignature list" $ + anyOutput @PProposalDatum # ctx.txInfo + #$ plam + $ \_value address newProposalDatum -> P.do + newProposalF <- pletFields @'["cosigners"] newProposalDatum + + let correctDatum = + foldr1 + (#&&) + [ newProposalF.cosigners #== proposalF.cosigners + ] + + foldr1 + (#&&) + [ ptraceIfFalse "Datum must be correct" $ correctDatum + , ptraceIfFalse "Must be sent to Proposal's address" $ ownAddress #== pdata address + ] + popaque (pconstant ()) -------------------------------------------------------------------------- PUnlock _r -> P.do diff --git a/agora/Agora/Record.hs b/agora/Agora/Record.hs index a5dfe35..db293c7 100644 --- a/agora/Agora/Record.hs +++ b/agora/Agora/Record.hs @@ -48,8 +48,7 @@ infix 7 .= forall (sym :: Symbol) (a :: PType) (as :: [PLabeledType]) (s :: S). FieldName sym -> Term s (PAsData a) -> - ( RecordMorphism s as ((sym ':= a) ': as) - ) + RecordMorphism s as ((sym ':= a) ': as) _ .= x = RecordMorphism $ pcon . PDCons x infixr 6 .& diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index 9334d29..600af94 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -39,6 +39,7 @@ import Plutarch.Api.V1 ( PPubKeyHash, PScriptPurpose (PMinting, PSpending), PTokenName, + PTxInfo, PValidator, mintingPolicySymbol, mkMintingPolicy, @@ -266,13 +267,15 @@ stakePolicy :: Stake -> ClosedTerm PMintingPolicy stakePolicy stake = plam $ \_redeemer ctx' -> P.do ctx <- pletFields @'["txInfo", "purpose"] ctx' - txInfo' <- plet ctx.txInfo - txInfo <- pletFields @'["mint", "inputs", "outputs"] txInfo' + txInfo <- plet $ ctx.txInfo + let _a :: Term _ PTxInfo + _a = txInfo + txInfoF <- pletFields @'["mint", "inputs", "outputs"] txInfo PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose ownSymbol <- plet $ pfield @"_0" # ownSymbol' - spentST <- plet $ psymbolValueOf # ownSymbol #$ pvalueSpent # pfromData txInfo' - mintedST <- plet $ psymbolValueOf # ownSymbol # txInfo.mint + spentST <- plet $ psymbolValueOf # ownSymbol #$ pvalueSpent # txInfoF.inputs + mintedST <- plet $ psymbolValueOf # ownSymbol # txInfoF.mint let burning = P.do passert "ST at inputs must be 1" $ @@ -282,7 +285,7 @@ stakePolicy stake = mintedST #== -1 passert "An unlocked input existed containing an ST" $ - anyInput @PStakeDatum # pfromData txInfo' + anyInput @PStakeDatum # txInfo #$ plam $ \value _ stakeDatum' -> P.do let hasST = psymbolValueOf # ownSymbol # value #== 1 @@ -299,7 +302,7 @@ stakePolicy stake = mintedST #== 1 passert "A UTXO must exist with the correct output" $ - anyOutput @PStakeDatum # pfromData txInfo' + anyOutput @PStakeDatum # txInfo #$ plam $ \value address stakeDatum' -> P.do let cred = pfield @"credential" # address @@ -359,8 +362,8 @@ stakeValidator :: Stake -> ClosedTerm PValidator stakeValidator stake = plam $ \datum redeemer ctx' -> P.do ctx <- pletFields @'["txInfo", "purpose"] ctx' - txInfo' <- plet ctx.txInfo - txInfo <- pletFields @'["mint", "inputs", "outputs"] txInfo' + txInfo <- plet $ pfromData ctx.txInfo + txInfoF <- pletFields @'["mint", "inputs", "outputs"] txInfo (pfromData -> stakeRedeemer, _) <- ptryFrom redeemer @@ -371,7 +374,7 @@ stakeValidator stake = PSpending txOutRef <- pmatch $ pfromData ctx.purpose - PJust txInInfo <- pmatch $ pfindTxInByTxOutRef # (pfield @"_0" # txOutRef) # txInfo' + PJust txInInfo <- pmatch $ pfindTxInByTxOutRef # (pfield @"_0" # txOutRef) # txInfoF.inputs ownAddress <- plet $ pfield @"address" #$ pfield @"resolved" # txInInfo let continuingValue = pfield @"value" #$ pfield @"resolved" # txInInfo @@ -379,8 +382,8 @@ stakeValidator stake = ownerSignsTransaction <- plet $ ptxSignedBy # ctx.txInfo # stakeDatum.owner stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake) - mintedST <- plet $ psymbolValueOf # stCurrencySymbol # txInfo.mint - spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # txInfo' + mintedST <- plet $ psymbolValueOf # stCurrencySymbol # txInfoF.mint + spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # txInfoF.inputs -- Is the stake currently locked? stakeIsLocked <- plet $ stakeLocked # stakeDatum' @@ -420,7 +423,7 @@ stakeValidator stake = "Owner signs this transaction" ownerSignsTransaction passert "A UTXO must exist with the correct output" $ - anyOutput @PStakeDatum # txInfo' + anyOutput @PStakeDatum # txInfo #$ plam $ \value address newStakeDatum' -> P.do newStakeDatum <- pletFields @'["owner", "stakedAmount"] newStakeDatum' diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index 8eeb07a..ba9763c 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -249,46 +249,61 @@ paddValue = phoistAcyclic $ ) -- | Sum of all value at input. -pvalueSpent :: Term s (PTxInfo :--> PValue) +pvalueSpent :: Term s (PBuiltinList (PAsData PTxInInfo) :--> PValue) pvalueSpent = phoistAcyclic $ - plam $ \txInfo' -> - pmatch txInfo' $ \(PTxInfo txInfo) -> - pfoldr - # plam - ( \txInInfo' v -> - pmatch - (pfromData txInInfo') - $ \(PTxInInfo txInInfo) -> - paddValue - # pmatch - (pfield @"resolved" # txInInfo) - (\(PTxOut o) -> pfromData $ pfield @"value" # o) - # v - ) - # pconstant mempty - # (pfield @"inputs" # txInfo) + plam $ \inputs -> + pfoldr + # plam + ( \txInInfo' v -> + pmatch + (pfromData txInInfo') + $ \(PTxInInfo txInInfo) -> + paddValue + # pmatch + (pfield @"resolved" # txInInfo) + (\(PTxOut o) -> pfromData $ pfield @"value" # o) + # v + ) + # pconstant mempty + # inputs -- | Find the TxInInfo by a TxOutRef. -pfindTxInByTxOutRef :: Term s (PTxOutRef :--> PTxInfo :--> PMaybe PTxInInfo) +pfindTxInByTxOutRef :: Term s (PTxOutRef :--> PBuiltinList (PAsData PTxInInfo) :--> PMaybe PTxInInfo) pfindTxInByTxOutRef = phoistAcyclic $ - plam $ \txOutRef txInfo' -> - pmatch txInfo' $ \(PTxInfo txInfo) -> - pfindMap - # plam - ( \txInInfo' -> - plet (pfromData txInInfo') $ \r -> - pmatch r $ \(PTxInInfo txInInfo) -> - pif - (pdata txOutRef #== pfield @"outRef" # txInInfo) - (pcon (PJust r)) - (pcon PNothing) - ) - #$ (pfield @"inputs" # txInfo) + plam $ \txOutRef inputs -> + pfindMap + # plam + ( \txInInfo' -> + plet (pfromData txInInfo') $ \r -> + pmatch r $ \(PTxInInfo txInInfo) -> + pif + (pdata txOutRef #== pfield @"outRef" # txInInfo) + (pcon (PJust r)) + (pcon PNothing) + ) + #$ inputs -- | True if a list is not empty. pnotNull :: forall list a. PIsListLike list a => Term _ (list a :--> PBool) pnotNull = phoistAcyclic $ plam $ pelimList (\_ _ -> pcon PTrue) (pcon PFalse) +-- | Check if a particular asset class has been spent in the input list. +ptokenSpent :: forall {s :: S}. Term s (PAssetClass :--> PBuiltinList (PAsData PTxInInfo) :--> PBool) +ptokenSpent = + plam $ \tokenClass inputs -> + 0 + #< pfoldr @PBuiltinList + # plam + ( \txInInfo' acc -> P.do + PTxInInfo txInInfo <- pmatch (pfromData txInInfo') + PTxOut txOut' <- pmatch $ pfromData $ pfield @"resolved" # txInInfo + txOut <- pletFields @'["value"] txOut' + let txOutValue = pfromData txOut.value + acc + passetClassValueOf # txOutValue # tokenClass + ) + # 0 + # inputs + -------------------------------------------------------------------------------- {- Functions which should (probably) not be upstreamed All of these functions are quite inefficient. @@ -372,10 +387,10 @@ psingletonValue = phoistAcyclic $ in res -- | Finds the TxOut of an effect from TxInfo and TxOutRef -findTxOutByTxOutRef :: Term s (PTxOutRef :--> PTxInfo :--> PMaybe PTxOut) +findTxOutByTxOutRef :: Term s (PTxOutRef :--> PBuiltinList (PAsData PTxInInfo) :--> PMaybe PTxOut) findTxOutByTxOutRef = phoistAcyclic $ - plam $ \txOutRef txInfo -> - pmatch (pfindTxInByTxOutRef # txOutRef # txInfo) $ \case + plam $ \txOutRef inputs -> + pmatch (pfindTxInByTxOutRef # txOutRef # inputs) $ \case PJust ((pfield @"resolved" #) -> txOut) -> pcon $ PJust txOut PNothing -> pcon PNothing @@ -408,20 +423,3 @@ findTxOutDatum = phoistAcyclic $ case datumHash' of PDJust ((pfield @"_0" #) -> datumHash) -> pfindDatum # datumHash # info _ -> pcon PNothing - --- | Check if a particular asset class has been spent in the input list. -ptokenSpent :: forall {s :: S}. Term s (PAssetClass :--> PBuiltinList (PAsData PTxInInfo) :--> PBool) -ptokenSpent = - plam $ \tokenClass inputs -> - 0 - #< pfoldr @PBuiltinList - # plam - ( \txInInfo' acc -> P.do - PTxInInfo txInInfo <- pmatch (pfromData txInInfo') - PTxOut txOut' <- pmatch $ pfromData $ pfield @"resolved" # txInInfo - txOut <- pletFields @'["value"] txOut' - let txOutValue = pfromData txOut.value - acc + passetClassValueOf # txOutValue # tokenClass - ) - # 0 - # inputs From 18df6ead55fcd992267becaa13086a3f884e7829 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Tue, 19 Apr 2022 22:31:38 +0200 Subject: [PATCH 11/28] add checks to cosign --- agora-test/Spec/Proposal.hs | 42 ++++++++- agora-test/Spec/Sample/Proposal.hs | 138 ++++++++++++++++++++++++----- agora-test/Spec/Sample/Stake.hs | 3 +- agora-test/Spec/Stake.hs | 8 +- agora/Agora/Proposal.hs | 39 ++++++-- agora/Agora/Stake.hs | 49 ++++++++-- agora/Agora/Utils.hs | 6 +- 7 files changed, 241 insertions(+), 44 deletions(-) diff --git a/agora-test/Spec/Proposal.hs b/agora-test/Spec/Proposal.hs index 4d3c4e3..e59df7e 100644 --- a/agora-test/Spec/Proposal.hs +++ b/agora-test/Spec/Proposal.hs @@ -13,9 +13,26 @@ module Spec.Proposal (tests) where -------------------------------------------------------------------------------- -import Agora.Proposal (proposalPolicy) +import Agora.Proposal ( + ProposalDatum (ProposalDatum), + ProposalId (ProposalId), + ProposalRedeemer (Cosign), + ProposalStatus (Draft), + ProposalVotes (ProposalVotes), + ResultTag (ResultTag), + cosigners, + effects, + proposalId, + proposalPolicy, + proposalValidator, + status, + thresholds, + votes, + ) +import PlutusTx.AssocMap qualified as AssocMap +import Spec.Sample.Proposal (propThresholds, signer, signer2) import Spec.Sample.Proposal qualified as Proposal -import Spec.Util (policySucceedsWith) +import Spec.Util (policySucceedsWith, validatorSucceedsWith) import Test.Tasty (TestTree, testGroup) -------------------------------------------------------------------------------- @@ -35,4 +52,25 @@ tests = () Proposal.proposalCreation ] + , testGroup + "validator" + [ validatorSucceedsWith + "stakeCreation" + (proposalValidator Proposal.proposal) + ( ProposalDatum + { proposalId = ProposalId 0 + , effects = + AssocMap.fromList + [ (ResultTag 0, []) + , (ResultTag 1, []) + ] + , status = Draft + , cosigners = [signer] + , thresholds = propThresholds + , votes = ProposalVotes AssocMap.empty + } + ) + (Cosign [signer2]) + (Proposal.cosignProposal [signer2]) + ] ] diff --git a/agora-test/Spec/Sample/Proposal.hs b/agora-test/Spec/Sample/Proposal.hs index 9b464cb..cceb12e 100644 --- a/agora-test/Spec/Sample/Proposal.hs +++ b/agora-test/Spec/Sample/Proposal.hs @@ -7,13 +7,15 @@ This module tests primarily the happy path for Proposal interactions -} module Spec.Sample.Proposal ( proposal, - policy, - policySymbol, - validatorHashTN, + propPolicy, + propPolicySymbol, + propThresholds, signer, + signer2, -- * Script contexts proposalCreation, + cosignProposal, ) where -------------------------------------------------------------------------------- @@ -37,11 +39,9 @@ import Plutus.V1.Ledger.Api ( TxInfo (..), TxOut (TxOut, txOutAddress, txOutDatumHash, txOutValue), TxOutRef (TxOutRef), - ValidatorHash (ValidatorHash), ) import Plutus.V1.Ledger.Interval qualified as Interval -import Plutus.V1.Ledger.Scripts (Validator) -import Plutus.V1.Ledger.Value (AssetClass (AssetClass), TokenName (TokenName)) +import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash) import Plutus.V1.Ledger.Value qualified as Value -------------------------------------------------------------------------------- @@ -52,13 +52,35 @@ import Agora.Governor ( governorPolicy, governorValidator, ) -import Agora.Proposal +import Agora.Proposal ( + Proposal (..), + ProposalDatum (..), + ProposalId (..), + ProposalStatus (..), + ProposalThresholds (..), + ProposalVotes (..), + ResultTag (..), + proposalPolicy, + proposalValidator, + ) +import Agora.Stake (Stake (..), stakePolicy) import Plutarch.SafeMoney +import Plutus.V1.Ledger.Address (scriptHashAddress) import PlutusTx.AssocMap qualified as AssocMap import Spec.Util (datumPair, toDatumHash) -------------------------------------------------------------------------------- +stake :: Stake +stake = + Stake + { gtClassRef = Tagged $ Value.assetClass govSymbol "" + , proposalSTClass = Value.assetClass propPolicySymbol "" + } + +stakeSymbol :: CurrencySymbol +stakeSymbol = mintingPolicySymbol $ mkMintingPolicy $ stakePolicy stake.gtClassRef + governor :: Governor governor = Governor @@ -76,30 +98,35 @@ proposal = Proposal { governorSTAssetClass = -- TODO: if we had a governor here - AssetClass - ( govSymbol - , "" - ) + Value.assetClass govSymbol "" + , stakeSTAssetClass = + Value.assetClass stakeSymbol "" } -- | 'Proposal' policy instance. -policy :: MintingPolicy -policy = mkMintingPolicy (proposalPolicy proposal) +propPolicy :: MintingPolicy +propPolicy = mkMintingPolicy (proposalPolicy proposal) -policySymbol :: CurrencySymbol -policySymbol = mintingPolicySymbol policy +propPolicySymbol :: CurrencySymbol +propPolicySymbol = mintingPolicySymbol propPolicy -- | A sample 'PubKeyHash'. signer :: PubKeyHash signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c" --- | 'Proposal' validator instance. -validator :: Validator -validator = mkValidator (proposalValidator proposal) +-- | Another sample 'PubKeyHash'. +signer2 :: PubKeyHash +signer2 = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be74012141420192" --- | 'TokenName' that represents the hash of the 'Proposal' validator. -validatorHashTN :: TokenName -validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh +-- | 'Proposal' validator instance. +propValidator :: Validator +propValidator = mkValidator (proposalValidator proposal) + +propValidatorHash :: ValidatorHash +propValidatorHash = validatorHash propValidator + +propValidatorAddress :: Address +propValidatorAddress = scriptHashAddress propValidatorHash propThresholds :: ProposalThresholds propThresholds = @@ -112,7 +139,7 @@ propThresholds = -- | This script context should be a valid transaction. proposalCreation :: ScriptContext proposalCreation = - let st = Value.singleton policySymbol "" 1 -- Proposal ST + let st = Value.singleton propPolicySymbol "" 1 -- Proposal ST proposalDatum :: Datum proposalDatum = Datum @@ -163,7 +190,7 @@ proposalCreation = ] , txInfoOutputs = [ TxOut - { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing + { txOutAddress = Address (ScriptCredential $ validatorHash propValidator) Nothing , txOutValue = mconcat [ st @@ -194,5 +221,68 @@ proposalCreation = ] , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" } - , scriptContextPurpose = Minting policySymbol + , scriptContextPurpose = Minting propPolicySymbol + } + +-- | This script context should be a valid transaction. +cosignProposal :: [PubKeyHash] -> ScriptContext +cosignProposal newSigners = + let st = Value.singleton propPolicySymbol "" 1 -- Proposal ST + proposalBefore :: ProposalDatum + proposalBefore = + ProposalDatum + { proposalId = ProposalId 0 + , effects = + AssocMap.fromList + [ (ResultTag 0, []) + , (ResultTag 1, []) + ] + , status = Draft + , cosigners = [signer] + , thresholds = propThresholds + , votes = ProposalVotes AssocMap.empty + } + proposalAfter :: ProposalDatum + proposalAfter = proposalBefore {cosigners = newSigners <> proposalBefore.cosigners} + proposalRef = (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) + in ScriptContext + { scriptContextTxInfo = + TxInfo + { txInfoInputs = + [ TxInInfo + proposalRef + TxOut + { txOutAddress = propValidatorAddress + , txOutValue = + mconcat + [ st + , Value.singleton "" "" 10_000_000 + ] + , txOutDatumHash = Just (toDatumHash proposalBefore) + } + ] + , txInfoOutputs = + [ TxOut + { txOutAddress = Address (ScriptCredential $ validatorHash propValidator) Nothing + , txOutValue = + mconcat + [ st + , Value.singleton "" "" 10_000_000 + ] + , txOutDatumHash = Just (toDatumHash . Datum $ toBuiltinData proposalAfter) + } + ] + , txInfoFee = Value.singleton "" "" 2 + , txInfoMint = st + , txInfoDCert = [] + , txInfoWdrl = [] + , txInfoValidRange = Interval.always + , txInfoSignatories = newSigners + , txInfoData = + [ datumPair . Datum $ toBuiltinData proposalBefore + , datumPair . Datum $ toBuiltinData proposalAfter + ] + , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" + } + , scriptContextPurpose = Spending proposalRef } diff --git a/agora-test/Spec/Sample/Stake.hs b/agora-test/Spec/Sample/Stake.hs index e62103e..f100ab6 100644 --- a/agora-test/Spec/Sample/Stake.hs +++ b/agora-test/Spec/Sample/Stake.hs @@ -69,11 +69,12 @@ stake = , "LQ" ) ) + , proposalSTClass = AssetClass ("", "") } -- | 'Stake' policy instance. policy :: MintingPolicy -policy = mkMintingPolicy (stakePolicy stake) +policy = mkMintingPolicy (stakePolicy stake.gtClassRef) policySymbol :: CurrencySymbol policySymbol = mintingPolicySymbol policy diff --git a/agora-test/Spec/Stake.hs b/agora-test/Spec/Stake.hs index 2513bab..427f228 100644 --- a/agora-test/Spec/Stake.hs +++ b/agora-test/Spec/Stake.hs @@ -19,7 +19,7 @@ import Test.Tasty (TestTree, testGroup) -------------------------------------------------------------------------------- -import Agora.Stake (StakeDatum (StakeDatum), StakeRedeemer (DepositWithdraw), stakePolicy, stakeValidator) +import Agora.Stake (Stake (..), StakeDatum (StakeDatum), StakeRedeemer (DepositWithdraw), stakePolicy, stakeValidator) -------------------------------------------------------------------------------- @@ -36,17 +36,17 @@ tests = "policy" [ policySucceedsWith "stakeCreation" - (stakePolicy Stake.stake) + (stakePolicy Stake.stake.gtClassRef) () Stake.stakeCreation , policyFailsWith "stakeCreationWrongDatum" - (stakePolicy Stake.stake) + (stakePolicy Stake.stake.gtClassRef) () Stake.stakeCreationWrongDatum , policyFailsWith "stakeCreationUnsigned" - (stakePolicy Stake.stake) + (stakePolicy Stake.stake.gtClassRef) () Stake.stakeCreationUnsigned ] diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index 693b3bc..cc73294 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -249,8 +249,9 @@ PlutusTx.makeIsDataIndexed ] -- | Parameters that identify the Proposal validator script. -newtype Proposal = Proposal +data Proposal = Proposal { governorSTAssetClass :: AssetClass + , stakeSTAssetClass :: AssetClass } deriving stock (Show, Eq) @@ -442,14 +443,23 @@ proposalValidator proposal = PSpending ((pfield @"_0" #) -> txOutRef) <- pmatch $ pfromData ctx.purpose PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs - txOutF <- pletFields @'["address"] $ txOut + txOutF <- pletFields @'["address", "value"] $ txOut let proposalDatum :: Term _ PProposalDatum proposalDatum = pfromData $ punsafeCoerce datum proposalRedeemer :: Term _ PProposalRedeemer proposalRedeemer = pfromData $ punsafeCoerce redeemer - proposalF <- pletFields @'["cosigners"] proposalDatum + proposalF <- + pletFields + @'[ "id" + , "effects" + , "status" + , "cosigners" + , "thresholds" + , "votes" + ] + proposalDatum ownAddress <- plet $ txOutF.address @@ -475,18 +485,35 @@ proposalValidator proposal = passert "Signatures are correctly added to cosignature list" $ anyOutput @PProposalDatum # ctx.txInfo #$ plam - $ \_value address newProposalDatum -> P.do - newProposalF <- pletFields @'["cosigners"] newProposalDatum + $ \newValue address newProposalDatum -> P.do + newProposalF <- + pletFields + @'[ "id" + , "effects" + , "status" + , "cosigners" + , "thresholds" + , "votes" + ] + newProposalDatum + -- This is a little sad. Can we do better by + -- building a new ProposalDatum and then comparing? let correctDatum = foldr1 (#&&) - [ newProposalF.cosigners #== proposalF.cosigners + [ newProposalF.cosigners #== pconcat # newSigs # proposalF.cosigners + , newProposalF.id #== proposalF.id + , newProposalF.effects #== proposalF.effects + , newProposalF.status #== proposalF.status + , newProposalF.thresholds #== proposalF.thresholds + , newProposalF.votes #== proposalF.votes ] foldr1 (#&&) [ 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 ] diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index 600af94..98242c8 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -70,9 +70,11 @@ import Agora.Utils ( pnotNull, psingletonValue, psymbolValueOf, + ptokenSpent, ptxSignedBy, pvalueSpent, ) +import Plutarch.Api.V1.Extra (passetClass) import Plutarch.Numeric import Plutarch.SafeMoney ( PDiscrete, @@ -85,9 +87,10 @@ import Plutarch.TryFrom (PTryFrom, ptryFrom) -------------------------------------------------------------------------------- -- | Parameters for creating Stake scripts. -newtype Stake = Stake +data Stake = Stake { gtClassRef :: Tagged GTTag AssetClass -- ^ Used when inlining the AssetClass of a 'PDiscrete' in the script code. + , proposalSTClass :: AssetClass } {- | A lock placed on a Stake datum in order to prevent @@ -147,6 +150,9 @@ data StakeRedeemer -- always allowed to have votes retracted and won't affect the Proposal datum, -- allowing 'Stake's to be unlocked. RetractVotes [ProposalLock] + | -- | 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 deriving stock (Show, GHC.Generic) PlutusTx.makeIsDataIndexed @@ -155,6 +161,7 @@ PlutusTx.makeIsDataIndexed , ('Destroy, 1) , ('PermitVote, 2) , ('RetractVotes, 3) + , ('WitnessStake, 4) ] -- | Haskell-level datum for Stake scripts. @@ -207,6 +214,7 @@ data PStakeRedeemer (s :: S) PDestroy (Term s (PDataRecord '[])) | PPermitVote (Term s (PDataRecord '["lock" ':= PProposalLock])) | PRetractVotes (Term s (PDataRecord '["locks" ':= PBuiltinList (PAsData PProposalLock)])) + | PWitnessStake (Term s (PDataRecord '[])) deriving stock (GHC.Generic) deriving anyclass (Generic) deriving anyclass (PIsDataRepr) @@ -263,8 +271,8 @@ deriving via (DerivePConstantViaData ProposalLock PProposalLock) instance (PCons -------------------------------------------------------------------------------- -- | Policy for Stake state threads. -stakePolicy :: Stake -> ClosedTerm PMintingPolicy -stakePolicy stake = +stakePolicy :: Tagged GTTag AssetClass -> ClosedTerm PMintingPolicy +stakePolicy gtClassRef = plam $ \_redeemer ctx' -> P.do ctx <- pletFields @'["txInfo", "purpose"] ctx' txInfo <- plet $ ctx.txInfo @@ -325,7 +333,7 @@ stakePolicy stake = # 1 let expectedValue = paddValue - # (pdiscreteValue' stake.gtClassRef # stakeDatum.stakedAmount) + # (pdiscreteValue' gtClassRef # stakeDatum.stakedAmount) # stValue let ownerSignsTransaction = ptxSignedBy @@ -339,7 +347,7 @@ stakePolicy stake = foldr1 (#&&) [ pgeqByClass' (AssetClass ("", "")) # value # expectedValue - , pgeqByClass' (untag stake.gtClassRef) + , pgeqByClass' (untag gtClassRef) # value # expectedValue , pgeqByClass @@ -381,7 +389,7 @@ stakeValidator stake = -- Whether the owner signs this transaction or not. ownerSignsTransaction <- plet $ ptxSignedBy # ctx.txInfo # stakeDatum.owner - stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake) + stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake.gtClassRef) mintedST <- plet $ psymbolValueOf # stCurrencySymbol # txInfoF.mint spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # txInfoF.inputs @@ -414,6 +422,35 @@ stakeValidator stake = -- TODO: check proposal constraints popaque (pconstant ()) -------------------------------------------------------------------------- + PWitnessStake _ -> P.do + passert "ST at inputs must be 1" $ + spentST #== 1 + + let AssetClass (propCs, propTn) = stake.proposalSTClass + propAssetClass = passetClass # pconstant propCs # pconstant propTn + proposalTokenMoved = + ptokenSpent + # propAssetClass + # txInfoF.inputs + + passert + "Owner signs this transaction OR proposal token is spent" + (ownerSignsTransaction #|| proposalTokenMoved) + + passert "A UTXO must exist with the correct output" $ + anyOutput @PStakeDatum # txInfo + #$ plam + $ \value address newStakeDatum' -> P.do + let isScriptAddress = pdata address #== ownAddress + let correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum' + let valueCorrect = pdata continuingValue #== pdata value + foldr1 + (#&&) + [ ptraceIfFalse "isScriptAddress" isScriptAddress + , ptraceIfFalse "correctOutputDatum" correctOutputDatum + , ptraceIfFalse "valueCorrect" valueCorrect + ] + popaque (pconstant ()) PDepositWithdraw r -> P.do passert "ST at inputs must be 1" $ spentST #== 1 diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index ba9763c..bd0449d 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -287,7 +287,11 @@ pfindTxInByTxOutRef = phoistAcyclic $ pnotNull :: forall list a. PIsListLike list a => Term _ (list a :--> PBool) pnotNull = phoistAcyclic $ plam $ pelimList (\_ _ -> pcon PTrue) (pcon PFalse) --- | Check if a particular asset class has been spent in the input list. +{- | Check if a particular asset class has been spent in the input list. + + When using this as an authority check, you __MUST__ ensure the authority + knows how to ensure its end of the contract. +-} ptokenSpent :: forall {s :: S}. Term s (PAssetClass :--> PBuiltinList (PAsData PTxInInfo) :--> PBool) ptokenSpent = plam $ \tokenClass inputs -> From eb4dc2c6548c48fe1b7bd55b5e4f43acc000762b Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Wed, 20 Apr 2022 16:39:03 +0200 Subject: [PATCH 12/28] add shared Sample values module - add Proposal validator testing - add some Agora.Record improvements --- agora-test/Spec/Proposal.hs | 57 +++++--- agora-test/Spec/Sample/Proposal.hs | 218 +++++++++++------------------ agora-test/Spec/Sample/Shared.hs | 132 +++++++++++++++++ agora-test/Spec/Sample/Stake.hs | 59 ++------ agora-test/Spec/Util.hs | 9 +- agora.cabal | 1 + agora/Agora/AuthorityToken.hs | 1 + agora/Agora/Proposal.hs | 51 ++++--- agora/Agora/Proposal/Time.hs | 33 ++--- agora/Agora/Record.hs | 59 ++++++-- agora/Agora/Stake.hs | 17 ++- 11 files changed, 367 insertions(+), 270 deletions(-) create mode 100644 agora-test/Spec/Sample/Shared.hs diff --git a/agora-test/Spec/Proposal.hs b/agora-test/Spec/Proposal.hs index e59df7e..2827d5d 100644 --- a/agora-test/Spec/Proposal.hs +++ b/agora-test/Spec/Proposal.hs @@ -11,8 +11,6 @@ module Spec.Proposal (tests) where -------------------------------------------------------------------------------- --------------------------------------------------------------------------------- - import Agora.Proposal ( ProposalDatum (ProposalDatum), ProposalId (ProposalId), @@ -29,9 +27,13 @@ import Agora.Proposal ( thresholds, votes, ) +import Agora.Stake (StakeDatum (StakeDatum), StakeRedeemer (WitnessStake), stakeValidator) +import Plutarch.SafeMoney (Tagged (Tagged)) +import Plutus.V1.Ledger.Api (ScriptContext (..), ScriptPurpose (..)) import PlutusTx.AssocMap qualified as AssocMap -import Spec.Sample.Proposal (propThresholds, signer, signer2) import Spec.Sample.Proposal qualified as Proposal +import Spec.Sample.Shared (signer, signer2) +import Spec.Sample.Shared qualified as Shared import Spec.Util (policySucceedsWith, validatorSucceedsWith) import Test.Tasty (TestTree, testGroup) @@ -47,30 +49,39 @@ tests = [ testGroup "policy" [ policySucceedsWith - "stakeCreation" - (proposalPolicy Proposal.proposal) + "proposalCreation" + (proposalPolicy Shared.proposal) () Proposal.proposalCreation ] , testGroup "validator" - [ validatorSucceedsWith - "stakeCreation" - (proposalValidator Proposal.proposal) - ( ProposalDatum - { proposalId = ProposalId 0 - , effects = - AssocMap.fromList - [ (ResultTag 0, []) - , (ResultTag 1, []) - ] - , status = Draft - , cosigners = [signer] - , thresholds = propThresholds - , votes = ProposalVotes AssocMap.empty - } - ) - (Cosign [signer2]) - (Proposal.cosignProposal [signer2]) + [ testGroup + "cosignature" + [ validatorSucceedsWith + "proposal" + (proposalValidator Shared.proposal) + ( ProposalDatum + { proposalId = ProposalId 0 + , effects = + AssocMap.fromList + [ (ResultTag 0, []) + , (ResultTag 1, []) + ] + , status = Draft + , cosigners = [signer] + , thresholds = Shared.defaultProposalThresholds + , votes = ProposalVotes AssocMap.empty + } + ) + (Cosign [signer2]) + (ScriptContext (Proposal.cosignProposal [signer2]) (Spending Proposal.proposalRef)) + , validatorSucceedsWith + "stake" + (stakeValidator Shared.stake) + (StakeDatum (Tagged 50_000_000) signer2 []) + WitnessStake + (ScriptContext (Proposal.cosignProposal [signer2]) (Spending Proposal.stakeRef)) + ] ] ] diff --git a/agora-test/Spec/Sample/Proposal.hs b/agora-test/Spec/Sample/Proposal.hs index cceb12e..1b560f4 100644 --- a/agora-test/Spec/Sample/Proposal.hs +++ b/agora-test/Spec/Sample/Proposal.hs @@ -6,31 +6,21 @@ Description: Sample based testing for Proposal utxos This module tests primarily the happy path for Proposal interactions -} module Spec.Sample.Proposal ( - proposal, - propPolicy, - propPolicySymbol, - propThresholds, - signer, - signer2, - -- * Script contexts proposalCreation, cosignProposal, + proposalRef, + stakeRef, ) where -------------------------------------------------------------------------------- import Plutarch.Api.V1 ( - mintingPolicySymbol, - mkMintingPolicy, - mkValidator, validatorHash, ) import Plutus.V1.Ledger.Api ( Address (Address), Credential (ScriptCredential), - CurrencySymbol, Datum (Datum), - MintingPolicy (..), PubKeyHash, ScriptContext (..), ScriptPurpose (..), @@ -41,105 +31,33 @@ import Plutus.V1.Ledger.Api ( TxOutRef (TxOutRef), ) import Plutus.V1.Ledger.Interval qualified as Interval -import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash) import Plutus.V1.Ledger.Value qualified as Value -------------------------------------------------------------------------------- import Agora.Governor ( - Governor (Governor), GovernorDatum (GovernorDatum, nextProposalId, proposalThresholds), - governorPolicy, - governorValidator, ) import Agora.Proposal ( Proposal (..), ProposalDatum (..), ProposalId (..), ProposalStatus (..), - ProposalThresholds (..), ProposalVotes (..), ResultTag (..), - proposalPolicy, - proposalValidator, ) -import Agora.Stake (Stake (..), stakePolicy) -import Plutarch.SafeMoney -import Plutus.V1.Ledger.Address (scriptHashAddress) +import Agora.Stake (Stake (..), StakeDatum (StakeDatum)) +import Plutarch.SafeMoney (Tagged (Tagged), untag) import PlutusTx.AssocMap qualified as AssocMap +import Spec.Sample.Shared import Spec.Util (datumPair, toDatumHash) -------------------------------------------------------------------------------- -stake :: Stake -stake = - Stake - { gtClassRef = Tagged $ Value.assetClass govSymbol "" - , proposalSTClass = Value.assetClass propPolicySymbol "" - } - -stakeSymbol :: CurrencySymbol -stakeSymbol = mintingPolicySymbol $ mkMintingPolicy $ stakePolicy stake.gtClassRef - -governor :: Governor -governor = Governor - -govPolicy :: MintingPolicy -govPolicy = mkMintingPolicy (governorPolicy governor) - -govValidator :: Validator -govValidator = mkValidator (governorValidator governor) - -govSymbol :: CurrencySymbol -govSymbol = mintingPolicySymbol govPolicy - -proposal :: Proposal -proposal = - Proposal - { governorSTAssetClass = - -- TODO: if we had a governor here - Value.assetClass govSymbol "" - , stakeSTAssetClass = - Value.assetClass stakeSymbol "" - } - --- | 'Proposal' policy instance. -propPolicy :: MintingPolicy -propPolicy = mkMintingPolicy (proposalPolicy proposal) - -propPolicySymbol :: CurrencySymbol -propPolicySymbol = mintingPolicySymbol propPolicy - --- | A sample 'PubKeyHash'. -signer :: PubKeyHash -signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c" - --- | Another sample 'PubKeyHash'. -signer2 :: PubKeyHash -signer2 = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be74012141420192" - --- | 'Proposal' validator instance. -propValidator :: Validator -propValidator = mkValidator (proposalValidator proposal) - -propValidatorHash :: ValidatorHash -propValidatorHash = validatorHash propValidator - -propValidatorAddress :: Address -propValidatorAddress = scriptHashAddress propValidatorHash - -propThresholds :: ProposalThresholds -propThresholds = - ProposalThresholds - { countVoting = Tagged 1000 - , create = Tagged 1 - , vote = Tagged 10 - } - -- | This script context should be a valid transaction. proposalCreation :: ScriptContext proposalCreation = - let st = Value.singleton propPolicySymbol "" 1 -- Proposal ST + let st = Value.singleton proposalPolicySymbol "" 1 -- Proposal ST proposalDatum :: Datum proposalDatum = Datum @@ -153,7 +71,7 @@ proposalCreation = ] , status = Draft , cosigners = [signer] - , thresholds = propThresholds + , thresholds = defaultProposalThresholds , votes = ProposalVotes AssocMap.empty } ) @@ -163,7 +81,7 @@ proposalCreation = Datum ( toBuiltinData $ GovernorDatum - { proposalThresholds = propThresholds + { proposalThresholds = defaultProposalThresholds , nextProposalId = ProposalId 0 } ) @@ -172,7 +90,7 @@ proposalCreation = Datum ( toBuiltinData $ GovernorDatum - { proposalThresholds = propThresholds + { proposalThresholds = defaultProposalThresholds , nextProposalId = ProposalId 1 } ) @@ -190,7 +108,7 @@ proposalCreation = ] , txInfoOutputs = [ TxOut - { txOutAddress = Address (ScriptCredential $ validatorHash propValidator) Nothing + { txOutAddress = Address (ScriptCredential proposalValidatorHash) Nothing , txOutValue = mconcat [ st @@ -221,13 +139,19 @@ proposalCreation = ] , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" } - , scriptContextPurpose = Minting propPolicySymbol + , scriptContextPurpose = Minting proposalPolicySymbol } +proposalRef :: TxOutRef +proposalRef = TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1 + +stakeRef :: TxOutRef +stakeRef = TxOutRef "0ca36f3a357bc69579ab2531aecd1e7d3714d993c7820f40b864be15" 0 + -- | This script context should be a valid transaction. -cosignProposal :: [PubKeyHash] -> ScriptContext +cosignProposal :: [PubKeyHash] -> TxInfo cosignProposal newSigners = - let st = Value.singleton propPolicySymbol "" 1 -- Proposal ST + let st = Value.singleton proposalPolicySymbol "" 1 -- Proposal ST proposalBefore :: ProposalDatum proposalBefore = ProposalDatum @@ -239,50 +163,70 @@ cosignProposal newSigners = ] , status = Draft , cosigners = [signer] - , thresholds = propThresholds + , thresholds = defaultProposalThresholds , votes = ProposalVotes AssocMap.empty } + stakeDatum :: StakeDatum + stakeDatum = StakeDatum (Tagged 50_000_000) signer2 [] proposalAfter :: ProposalDatum proposalAfter = proposalBefore {cosigners = newSigners <> proposalBefore.cosigners} - proposalRef = (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) - in ScriptContext - { scriptContextTxInfo = - TxInfo - { txInfoInputs = - [ TxInInfo - proposalRef - TxOut - { txOutAddress = propValidatorAddress - , txOutValue = - mconcat - [ st - , Value.singleton "" "" 10_000_000 - ] - , txOutDatumHash = Just (toDatumHash proposalBefore) - } - ] - , txInfoOutputs = - [ TxOut - { txOutAddress = Address (ScriptCredential $ validatorHash propValidator) Nothing - , txOutValue = - mconcat - [ st - , Value.singleton "" "" 10_000_000 - ] - , txOutDatumHash = Just (toDatumHash . Datum $ toBuiltinData proposalAfter) - } - ] - , txInfoFee = Value.singleton "" "" 2 - , txInfoMint = st - , txInfoDCert = [] - , txInfoWdrl = [] - , txInfoValidRange = Interval.always - , txInfoSignatories = newSigners - , txInfoData = - [ datumPair . Datum $ toBuiltinData proposalBefore - , datumPair . Datum $ toBuiltinData proposalAfter - ] - , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" - } - , scriptContextPurpose = Spending proposalRef + in TxInfo + { txInfoInputs = + [ TxInInfo + proposalRef + TxOut + { txOutAddress = proposalValidatorAddress + , txOutValue = + mconcat + [ st + , Value.singleton "" "" 10_000_000 + ] + , txOutDatumHash = Just (toDatumHash proposalBefore) + } + , TxInInfo + stakeRef + TxOut + { txOutAddress = stakeAddress + , txOutValue = + mconcat + [ Value.singleton "" "" 10_000_000 + , Value.assetClassValue (untag stake.gtClassRef) 50_000_000 + , Value.singleton stakeSymbol "" 1 + ] + , txOutDatumHash = Just (toDatumHash stakeDatum) + } + ] + , txInfoOutputs = + [ TxOut + { txOutAddress = Address (ScriptCredential proposalValidatorHash) Nothing + , txOutValue = + mconcat + [ st + , Value.singleton "" "" 10_000_000 + ] + , txOutDatumHash = Just (toDatumHash . Datum $ toBuiltinData proposalAfter) + } + , TxOut + { txOutAddress = stakeAddress + , txOutValue = + mconcat + [ Value.singleton "" "" 10_000_000 + , Value.assetClassValue (untag stake.gtClassRef) 50_000_000 + , Value.singleton stakeSymbol "" 1 + ] + , txOutDatumHash = Just (toDatumHash stakeDatum) + } + ] + , txInfoFee = Value.singleton "" "" 2 + , txInfoMint = st + , txInfoDCert = [] + , txInfoWdrl = [] + , txInfoValidRange = Interval.always + , txInfoSignatories = newSigners + , txInfoData = + [ datumPair . Datum $ toBuiltinData proposalBefore + , datumPair . Datum $ toBuiltinData proposalAfter + , datumPair . Datum $ toBuiltinData stakeDatum + ] + , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" } diff --git a/agora-test/Spec/Sample/Shared.hs b/agora-test/Spec/Sample/Shared.hs new file mode 100644 index 0000000..1bb4636 --- /dev/null +++ b/agora-test/Spec/Sample/Shared.hs @@ -0,0 +1,132 @@ +{- | +Module : Spec.Sample.Shared +Maintainer : emi@haskell.fyi +Description: Shared useful values for creating Samples for testing. + +Shared useful values for creating Samples for testing. +-} +module Spec.Sample.Shared ( + -- * Misc + signer, + signer2, + + -- * Components + + -- ** Stake + stake, + stakeSymbol, + stakeValidatorHash, + stakeAddress, + + -- ** Governor + governor, + govPolicy, + govValidator, + govSymbol, + + -- ** Proposal + defaultProposalThresholds, + proposal, + proposalPolicySymbol, + proposalValidatorHash, + proposalValidatorAddress, +) where + +import Agora.Governor ( + Governor (Governor), + governorPolicy, + governorValidator, + ) +import Agora.Proposal ( + Proposal (..), + ProposalThresholds (..), + proposalPolicy, + proposalValidator, + ) +import Agora.Stake (Stake (..), stakePolicy, stakeValidator) +import Plutarch.Api.V1 ( + mintingPolicySymbol, + mkMintingPolicy, + mkValidator, + validatorHash, + ) +import Plutarch.SafeMoney +import Plutus.V1.Ledger.Address (scriptHashAddress) +import Plutus.V1.Ledger.Api ( + Address (Address), + Credential (ScriptCredential), + CurrencySymbol, + MintingPolicy (..), + PubKeyHash, + ) +import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash) +import Plutus.V1.Ledger.Value qualified as Value + +-------------------------------------------------------------------------------- + +stake :: Stake +stake = + Stake + { gtClassRef = + Tagged $ + Value.assetClass + "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" + "LQ" + , proposalSTClass = Value.assetClass proposalPolicySymbol "" + } + +stakeSymbol :: CurrencySymbol +stakeSymbol = mintingPolicySymbol $ mkMintingPolicy $ stakePolicy stake.gtClassRef + +stakeValidatorHash :: ValidatorHash +stakeValidatorHash = validatorHash $ mkValidator (stakeValidator stake) + +stakeAddress :: Address +stakeAddress = Address (ScriptCredential stakeValidatorHash) Nothing + +governor :: Governor +governor = Governor + +govPolicy :: MintingPolicy +govPolicy = mkMintingPolicy (governorPolicy governor) + +govValidator :: Validator +govValidator = mkValidator (governorValidator governor) + +govSymbol :: CurrencySymbol +govSymbol = mintingPolicySymbol govPolicy + +proposal :: Proposal +proposal = + Proposal + { governorSTAssetClass = + -- TODO: if we had a governor here + Value.assetClass govSymbol "" + , stakeSTAssetClass = + Value.assetClass stakeSymbol "" + } + +proposalPolicySymbol :: CurrencySymbol +proposalPolicySymbol = mintingPolicySymbol $ mkMintingPolicy (proposalPolicy proposal) + +-- | A sample 'PubKeyHash'. +signer :: PubKeyHash +signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c" + +-- | Another sample 'PubKeyHash'. +signer2 :: PubKeyHash +signer2 = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be74012141420192" + +proposalValidatorHash :: ValidatorHash +proposalValidatorHash = validatorHash (mkValidator $ proposalValidator proposal) + +proposalValidatorAddress :: Address +proposalValidatorAddress = scriptHashAddress proposalValidatorHash + +defaultProposalThresholds :: ProposalThresholds +defaultProposalThresholds = + ProposalThresholds + { countVoting = Tagged 1000 + , create = Tagged 1 + , vote = Tagged 10 + } diff --git a/agora-test/Spec/Sample/Stake.hs b/agora-test/Spec/Sample/Stake.hs index f100ab6..e893eed 100644 --- a/agora-test/Spec/Sample/Stake.hs +++ b/agora-test/Spec/Sample/Stake.hs @@ -7,8 +7,7 @@ This module tests primarily the happy path for Stake creation -} module Spec.Sample.Stake ( stake, - policy, - policySymbol, + stakeSymbol, validatorHashTN, signer, @@ -22,19 +21,14 @@ module Spec.Sample.Stake ( -------------------------------------------------------------------------------- import Plutarch.Api.V1 ( - mintingPolicySymbol, - mkMintingPolicy, mkValidator, validatorHash, ) import Plutus.V1.Ledger.Api ( Address (Address), Credential (ScriptCredential), - CurrencySymbol, Datum (Datum), DatumHash (DatumHash), - MintingPolicy (..), - PubKeyHash, ScriptContext (..), ScriptPurpose (..), ToData (toBuiltinData), @@ -45,8 +39,7 @@ import Plutus.V1.Ledger.Api ( ) import Plutus.V1.Ledger.Contexts (TxOut (TxOut), TxOutRef (TxOutRef)) import Plutus.V1.Ledger.Interval qualified as Interval -import Plutus.V1.Ledger.Scripts (Validator) -import Plutus.V1.Ledger.Value (AssetClass (AssetClass), TokenName (TokenName)) +import Plutus.V1.Ledger.Value (TokenName (TokenName)) import Plutus.V1.Ledger.Value qualified as Value -------------------------------------------------------------------------------- @@ -54,47 +47,19 @@ import Plutus.V1.Ledger.Value qualified as Value import Agora.SafeMoney (GTTag) import Agora.Stake import Plutarch.SafeMoney +import Spec.Sample.Shared import Spec.Util (datumPair, toDatumHash) -------------------------------------------------------------------------------- --- | 'Stake' parameters for 'LQ'. -stake :: Stake -stake = - Stake - { gtClassRef = - Tagged - ( AssetClass - ( "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" - , "LQ" - ) - ) - , proposalSTClass = AssetClass ("", "") - } - --- | 'Stake' policy instance. -policy :: MintingPolicy -policy = mkMintingPolicy (stakePolicy stake.gtClassRef) - -policySymbol :: CurrencySymbol -policySymbol = mintingPolicySymbol policy - --- | A sample 'PubKeyHash'. -signer :: PubKeyHash -signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c" - --- | 'Stake' validator instance. -validator :: Validator -validator = mkValidator (stakeValidator stake) - -- | 'TokenName' that represents the hash of the 'Stake' validator. validatorHashTN :: TokenName -validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh +validatorHashTN = let ValidatorHash vh = validatorHash (mkValidator $ stakeValidator stake) in TokenName vh -- | This script context should be a valid transaction. stakeCreation :: ScriptContext stakeCreation = - let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST + let st = Value.singleton stakeSymbol validatorHashTN 1 -- Stake ST datum :: Datum datum = Datum (toBuiltinData $ StakeDatum 424242424242 signer []) in ScriptContext @@ -103,7 +68,7 @@ stakeCreation = { txInfoInputs = [] , txInfoOutputs = [ TxOut - { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing + { txOutAddress = Address (ScriptCredential stakeValidatorHash) Nothing , txOutValue = st <> Value.singleton "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" "LQ" 424242424242 , txOutDatumHash = Just (DatumHash "") } @@ -117,7 +82,7 @@ stakeCreation = , txInfoData = [("", datum)] , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" } - , scriptContextPurpose = Minting policySymbol + , scriptContextPurpose = Minting stakeSymbol } -- | This ScriptContext should fail because the datum has too much GT. @@ -127,7 +92,7 @@ stakeCreationWrongDatum = datum = Datum (toBuiltinData $ StakeDatum 4242424242424242 signer []) -- Too much GT in ScriptContext { scriptContextTxInfo = stakeCreation.scriptContextTxInfo {txInfoData = [("", datum)]} - , scriptContextPurpose = Minting policySymbol + , scriptContextPurpose = Minting stakeSymbol } -- | This ScriptContext should fail because the datum has too much GT. @@ -138,7 +103,7 @@ stakeCreationUnsigned = stakeCreation.scriptContextTxInfo { txInfoSignatories = [] } - , scriptContextPurpose = Minting policySymbol + , scriptContextPurpose = Minting stakeSymbol } -------------------------------------------------------------------------------- @@ -154,7 +119,7 @@ data DepositWithdrawExample = DepositWithdrawExample -- | Create a ScriptContext that deposits or withdraws, given the config for it. stakeDepositWithdraw :: DepositWithdrawExample -> ScriptContext stakeDepositWithdraw config = - let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST + let st = Value.singleton stakeSymbol validatorHashTN 1 -- Stake ST stakeBefore :: StakeDatum stakeBefore = StakeDatum config.startAmount signer [] @@ -167,7 +132,7 @@ stakeDepositWithdraw config = [ TxInInfo (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) TxOut - { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing + { txOutAddress = Address (ScriptCredential stakeValidatorHash) Nothing , txOutValue = st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeBefore.stakedAmount) @@ -176,7 +141,7 @@ stakeDepositWithdraw config = ] , txInfoOutputs = [ TxOut - { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing + { txOutAddress = Address (ScriptCredential stakeValidatorHash) Nothing , txOutValue = st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount) , txOutDatumHash = Just (toDatumHash stakeAfter) diff --git a/agora-test/Spec/Util.hs b/agora-test/Spec/Util.hs index f36b3ba..c9c3ce4 100644 --- a/agora-test/Spec/Util.hs +++ b/agora-test/Spec/Util.hs @@ -90,6 +90,7 @@ policyFailsWith tag policy redeemer scriptContext = -- | Check that a validator script succeeds, given a name and arguments. validatorSucceedsWith :: ( PLift datum + , Show (PLifted datum) , PlutusTx.ToData (PLifted datum) , PLift redeemer , PlutusTx.ToData (PLifted redeemer) @@ -100,10 +101,10 @@ validatorSucceedsWith :: PLifted redeemer -> ScriptContext -> TestTree -validatorSucceedsWith tag policy datum redeemer scriptContext = +validatorSucceedsWith tag validator datum redeemer scriptContext = scriptSucceeds tag $ compile - ( policy + ( validator # pforgetData (pconstantData datum) # pforgetData (pconstantData redeemer) # pconstant scriptContext @@ -122,10 +123,10 @@ validatorFailsWith :: PLifted redeemer -> ScriptContext -> TestTree -validatorFailsWith tag policy datum redeemer scriptContext = +validatorFailsWith tag validator datum redeemer scriptContext = scriptFails tag $ compile - ( policy + ( validator # pforgetData (pconstantData datum) # pforgetData (pconstantData redeemer) # pconstant scriptContext diff --git a/agora.cabal b/agora.cabal index 6500ad6..1740981 100644 --- a/agora.cabal +++ b/agora.cabal @@ -162,6 +162,7 @@ test-suite agora-test Spec.Proposal Spec.Sample.Effect.TreasuryWithdrawal Spec.Sample.Proposal + Spec.Sample.Shared Spec.Sample.Stake Spec.Stake Spec.Util diff --git a/agora/Agora/AuthorityToken.hs b/agora/Agora/AuthorityToken.hs index cd04507..57baf46 100644 --- a/agora/Agora/AuthorityToken.hs +++ b/agora/Agora/AuthorityToken.hs @@ -18,6 +18,7 @@ import Plutarch.Api.V1 ( PCurrencySymbol (..), PScriptContext (..), PScriptPurpose (..), + PTxInInfo (PTxInInfo), PTxInfo (..), PTxOut (..), ) diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index cc73294..5fa862d 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -58,7 +58,7 @@ import PlutusTx qualified import PlutusTx.AssocMap qualified as AssocMap -------------------------------------------------------------------------------- - +import Agora.Record (mkRecordConstr, (.&), (.=)) import Agora.SafeMoney (GTTag) import Agora.Utils ( anyOutput, @@ -354,7 +354,7 @@ newtype PProposalDatum (s :: S) = PProposalDatum Term s ( PDataRecord - '[ "id" ':= PProposalId + '[ "proposalId" ':= PProposalId , "effects" ':= PMap PResultTag (PMap PValidatorHash PDatumHash) , "status" ':= PProposalStatus , "cosigners" ':= PBuiltinList (PAsData PPubKeyHash) @@ -438,7 +438,7 @@ proposalValidator proposal = PScriptContext ctx' <- pmatch ctx' ctx <- pletFields @'["txInfo", "purpose"] ctx' txInfo <- plet $ pfromData ctx.txInfo - PTxInfo txInfo' <- pmatch $ txInfo + PTxInfo txInfo' <- pmatch txInfo txInfoF <- pletFields @'["inputs", "mint"] txInfo' PSpending ((pfield @"_0" #) -> txOutRef) <- pmatch $ pfromData ctx.purpose @@ -452,7 +452,7 @@ proposalValidator proposal = proposalF <- pletFields - @'[ "id" + @'[ "proposalId" , "effects" , "status" , "cosigners" @@ -464,7 +464,10 @@ proposalValidator proposal = ownAddress <- plet $ txOutF.address stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (proposalPolicy proposal) - spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # txInfoF.inputs + 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 @@ -482,37 +485,33 @@ proposalValidator proposal = 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 - newProposalF <- - pletFields - @'[ "id" - , "effects" - , "status" - , "cosigners" - , "thresholds" - , "votes" - ] - newProposalDatum - -- This is a little sad. Can we do better by -- building a new ProposalDatum and then comparing? let correctDatum = - foldr1 - (#&&) - [ newProposalF.cosigners #== pconcat # newSigs # proposalF.cosigners - , newProposalF.id #== proposalF.id - , newProposalF.effects #== proposalF.effects - , newProposalF.status #== proposalF.status - , newProposalF.thresholds #== proposalF.thresholds - , newProposalF.votes #== proposalF.votes - ] + 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 (#&&) - [ ptraceIfFalse "Datum must be correct" $ correctDatum + [ 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 ] diff --git a/agora/Agora/Proposal/Time.hs b/agora/Agora/Proposal/Time.hs index 952b8dd..311c3fb 100644 --- a/agora/Agora/Proposal/Time.hs +++ b/agora/Agora/Proposal/Time.hs @@ -24,7 +24,7 @@ module Agora.Proposal.Time ( isDraftRange, ) where -import Agora.Record (build, (.&), (.=)) +import Agora.Record (mkRecordConstr, (.&), (.=)) import GHC.Generics qualified as GHC import Generics.SOP (Generic, I (I)) import Plutarch.Api.V1 (PExtended (PFinite), PInterval (PInterval), PLowerBound (PLowerBound), PMaybeData (PDJust, PDNothing), PPOSIXTime, PPOSIXTimeRange, PUpperBound (PUpperBound)) @@ -149,23 +149,20 @@ currentProposalTime = phoistAcyclic $ PUpperBound ub <- pmatch ivf.to lbf <- pletFields @'["_0", "_1"] lb ubf <- pletFields @'["_0", "_1"] ub - pcon - ( PProposalTime $ - build $ - #lowerBound - .= pdata - ( pmatch lbf._0 $ - \case - PFinite d -> pcon (PDJust d) - _ -> pcon (PDNothing pdnil) - ) - .& #upperBound - .= pdata - ( pmatch ubf._0 $ \case - PFinite d -> pcon (PDJust d) - _ -> pcon (PDNothing pdnil) - ) - ) + mkRecordConstr PProposalTime $ + #lowerBound + .= pdata + ( pmatch lbf._0 $ + \case + PFinite d -> pcon (PDJust d) + _ -> pcon (PDNothing pdnil) + ) + .& #upperBound + .= pdata + ( pmatch ubf._0 $ \case + PFinite d -> pcon (PDJust d) + _ -> pcon (PDNothing pdnil) + ) -- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive. proposalTimeWithin :: Term s (PPOSIXTime :--> PPOSIXTime :--> PProposalTime :--> PBool) diff --git a/agora/Agora/Record.hs b/agora/Agora/Record.hs index db293c7..5ad5691 100644 --- a/agora/Agora/Record.hs +++ b/agora/Agora/Record.hs @@ -3,9 +3,16 @@ Module : Agora.Record Maintainer : emi@haskell.fyi Description: PDataRecord helper functions. -PDataRecord helper functions. +'PDataRecord' helper functions. -} -module Agora.Record (build, (.=), (.&)) where +module Agora.Record ( + mkRecord, + mkRecordConstr, + (.=), + (.&), + RecordMorphism, + FieldName, +) where import Control.Category (Category (..)) import Data.Coerce (coerce) @@ -20,17 +27,47 @@ data FieldName (sym :: Symbol) = FieldName {- | The use of two different 'Symbol's here allows unification to happen, ensuring 'FieldName' has a fully inferred 'Symbol'. - For example, @'build' (#foo .= 'pconstantData' (42 :: 'Integer'))@ gets + For example, @'mkRecord' (#foo .= 'pconstantData' (42 :: 'Integer'))@ gets the correct type. Namely, @'Term' s ('PDataRecord' '["foo" ':= 'PInteger'])@. -} -instance forall (sym :: Symbol) (sym' :: Symbol). sym ~ sym' => IsLabel sym (FieldName sym') where +instance forall (sym :: Symbol) (sym' :: Symbol). sym ~ sym' => IsLabel sym (FieldName sym) where fromLabel = FieldName --- | Turn a builder into a fully built 'PDataRecord'. -build :: forall (s :: S) (r :: [PLabeledType]). RecordMorphism s '[] r -> Term s (PDataRecord r) -build f = coerce f pdnil +-- | Turn a constant 'RecordMorphism' into a fully built 'PDataRecord'. +mkRecord :: forall (r :: [PLabeledType]) (s :: S). RecordMorphism s '[] r -> Term s (PDataRecord r) +mkRecord f = f.runRecordMorphism pdnil --- | A morphism from one PDataRecord to another, representing some sort of consing of data. +{- | 'mkRecord' but for known data-types. + +This allows you to dynamically construct a record type constructor. + +=== Example: +@ +'mkRecordConstr' + 'Agora.Stake.PStakeDatum' + ( #stakedAmount '.=' 'pconstantData' ('Plutarch.SafeMoney.Tagged' @GTTag 42) + '.&' #owner '.=' 'pconstantData' "aabbcc" + '.&' #lockedBy '.=' 'pdata' pnil + ) +@ +Is the same as + +@ +'pconstant' ('Agora.Stake.StakeDatum' ('Plutarch.SafeMoney.Tagged' 42) "aabbcc" []) +@ +-} +mkRecordConstr :: + forall (r :: [PLabeledType]) (s :: S) (pt :: PType). + PlutusType pt => + -- | The constructor. This is just the Haskell-level constructor for the type. + -- For 'PMaybeData', this could be 'PDJust', or 'PNothing'. + (forall s'. Term s' (PDataRecord r) -> pt s') -> + -- | The morphism that builds the record. + RecordMorphism s '[] r -> + Term s pt +mkRecordConstr ctr = pcon . ctr . mkRecord + +-- | A morphism from one 'PDataRecord' to another, representing some sort of consing of data. newtype RecordMorphism (s :: S) (as :: [PLabeledType]) (bs :: [PLabeledType]) = RecordMorphism { runRecordMorphism :: Term s (PDataRecord as) -> @@ -46,14 +83,18 @@ infix 7 .= -- | Cons a labeled type as a 'RecordMorphism'. (.=) :: forall (sym :: Symbol) (a :: PType) (as :: [PLabeledType]) (s :: S). + -- | The field name. You can use @-XOverloadedLabels@ to enable the syntax: + -- @#hello ~ 'FieldName' "hello"@ FieldName sym -> + -- | The value at that field. This must be 'PAsData', because the underlying + -- type is @'Constr' 'Integer' ['Data']@. Term s (PAsData a) -> RecordMorphism s as ((sym ':= a) ': as) _ .= x = RecordMorphism $ pcon . PDCons x infixr 6 .& --- | Compose two morphisms between records. +-- | Compose two 'RecordMorphism's. (.&) :: forall (s :: S) diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index 98242c8..05a4d23 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -441,15 +441,20 @@ stakeValidator stake = anyOutput @PStakeDatum # txInfo #$ plam $ \value address newStakeDatum' -> P.do + PStakeDatum newStakeDatum <- pmatch newStakeDatum' + newStakeDatumF <- pletFields @'["stakedAmount"] newStakeDatum let isScriptAddress = pdata address #== ownAddress let correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum' let valueCorrect = pdata continuingValue #== pdata value - foldr1 - (#&&) - [ ptraceIfFalse "isScriptAddress" isScriptAddress - , ptraceIfFalse "correctOutputDatum" correctOutputDatum - , ptraceIfFalse "valueCorrect" valueCorrect - ] + pif + isScriptAddress + ( foldl1 + (#&&) + [ ptraceIfFalse "valueCorrect" valueCorrect + , ptraceIfFalse "correctOutputDatum" correctOutputDatum + ] + ) + (pcon PFalse) popaque (pconstant ()) PDepositWithdraw r -> P.do passert "ST at inputs must be 1" $ From 53629f53c3e5326080311efa8b533db4e1c7f265 Mon Sep 17 00:00:00 2001 From: Hongrui Fang Date: Thu, 21 Apr 2022 18:21:20 +0800 Subject: [PATCH 13/28] add missing plutarch level proposal status `PLocked` --- agora/Agora/Proposal.hs | 1 + agora/Agora/Stake.hs | 2 -- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index 5fa862d..e6cdce0 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -304,6 +304,7 @@ data PProposalStatus (s :: S) -- e.g. like Tilde used 'pmatchEnum'. PDraft (Term s (PDataRecord '[])) | PVotingReady (Term s (PDataRecord '[])) + | PLocked (Term s (PDataRecord '[])) | PFinished (Term s (PDataRecord '[])) deriving stock (GHC.Generic) deriving anyclass (Generic) diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index 05a4d23..f484f9d 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -441,8 +441,6 @@ stakeValidator stake = anyOutput @PStakeDatum # txInfo #$ plam $ \value address newStakeDatum' -> P.do - PStakeDatum newStakeDatum <- pmatch newStakeDatum' - newStakeDatumF <- pletFields @'["stakedAmount"] newStakeDatum let isScriptAddress = pdata address #== ownAddress let correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum' let valueCorrect = pdata continuingValue #== pdata value From 4411dba71704c12b0d3a43aa06ca25f1ec127184 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Mon, 25 Apr 2022 22:32:26 +0200 Subject: [PATCH 14/28] 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. -} From 189973f30fef0c18d373a2e5eb765f4b4ddbb1b9 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Tue, 26 Apr 2022 15:37:54 +0200 Subject: [PATCH 15/28] reduce 'PTxInfo' passing to functions --- agora/Agora/Effect/TreasuryWithdrawal.hs | 8 +- agora/Agora/Proposal.hs | 3 + agora/Agora/Proposal/Scripts.hs | 95 ++++++++++-------------- agora/Agora/Stake.hs | 75 +++++++++++++++++-- agora/Agora/Utils.hs | 56 ++++++-------- 5 files changed, 140 insertions(+), 97 deletions(-) diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index 312efbf..8693cdf 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -40,9 +40,12 @@ import Plutus.V1.Ledger.Credential (Credential) import Plutus.V1.Ledger.Value (CurrencySymbol, Value) import PlutusTx qualified +-- | Datum that encodes behavior of Treasury Withdrawal effect. data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum { receivers :: [(Credential, Value)] + -- ^ AssocMap for Value sent to each receiver from the treasury. , treasuries :: [Credential] + -- ^ What Credentials is spending from legal. } deriving stock (Show, GHC.Generic) deriving anyclass (Generic) @@ -77,7 +80,8 @@ deriving via instance PTryFrom PData PTreasuryWithdrawalDatum where type PTryFromExcess PData PTreasuryWithdrawalDatum = Const () ptryFrom' opq cont = - -- this will need to not use punsafeCoerce... + -- TODO: This should not use 'punsafeCoerce'. + -- Blocked by 'PCredential', and 'PTuple'. cont (punsafeCoerce opq, ()) {- | Withdraws given list of values to specific target addresses. @@ -90,7 +94,7 @@ instance PTryFrom PData PTreasuryWithdrawalDatum where Note: It should check... 1. Transaction outputs should contain all of what Datum specified - 2. Left over assests should be redirected back to Treasury + 2. Left over assets should be redirected back to Treasury It can be more flexiable over... - The number of outputs themselves -} diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index 6c26a3f..bf88bf8 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -128,6 +128,9 @@ data ProposalThresholds = ProposalThresholds -- ^ How much GT minimum must a particular 'ResultTag' accumulate for it to pass. , create :: Tagged GTTag Integer -- ^ How much GT required to "create" a proposal. + -- + -- It is recommended this be a high enough amount, in order to prevent DOS from bad + -- actors. , vote :: Tagged GTTag Integer -- ^ How much GT required to allow voting to happen. -- (i.e. to move into 'VotingReady') diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs index ce21cea..09ae5c4 100644 --- a/agora/Agora/Proposal/Scripts.hs +++ b/agora/Agora/Proposal/Scripts.hs @@ -4,14 +4,18 @@ module Agora.Proposal.Scripts ( proposalDatumValid, ) where -import Agora.Proposal +import Agora.Proposal ( + PProposalDatum (PProposalDatum), + PProposalRedeemer (..), + PResultTag, + Proposal (governorSTAssetClass, stakeSTAssetClass), + ) import Agora.Record (mkRecordConstr, (.&), (.=)) -import Agora.Stake (PStakeDatum) +import Agora.Stake (findStakeOwnedBy) import Agora.Utils ( anyOutput, findTxOutByTxOutRef, passert, - pfindDatum', pnotNull, psymbolValueOf, ptokenSpent, @@ -20,14 +24,10 @@ import Agora.Utils ( ) import Plutarch.Api.V1 ( PDatumHash, - PMaybeData (PDJust, PDNothing), PMintingPolicy, - PPubKeyHash, PScriptContext (PScriptContext), PScriptPurpose (PMinting, PSpending), - PTxInInfo (PTxInInfo), PTxInfo (PTxInfo), - PTxOut (PTxOut), PValidator, PValidatorHash, mintingPolicySymbol, @@ -47,20 +47,20 @@ import Plutus.V1.Ledger.Value (AssetClass (AssetClass)) NOTE: The governor needs to check that the datum is correct and sent to the right address. -} -proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy +proposalPolicy :: Agora.Proposal.Proposal -> ClosedTerm Plutarch.Api.V1.PMintingPolicy proposalPolicy proposal = plam $ \_redeemer ctx' -> P.do - PScriptContext ctx' <- pmatch ctx' + Plutarch.Api.V1.PScriptContext ctx' <- pmatch ctx' ctx <- pletFields @'["txInfo", "purpose"] ctx' - PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo + Plutarch.Api.V1.PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo txInfo <- pletFields @'["inputs", "mint"] txInfo' - PMinting _ownSymbol <- pmatch $ pfromData ctx.purpose + Plutarch.Api.V1.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 + Plutarch.Api.V1.PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose let mintedProposalST = passetClassValueOf # mintedValue # (passetClass # (pfield @"_0" # ownSymbol') # pconstant "") passert "Governance state-thread token must move" $ @@ -74,22 +74,22 @@ proposalPolicy proposal = popaque (pconstant ()) -- | Validator for Proposals. -proposalValidator :: Proposal -> ClosedTerm PValidator +proposalValidator :: Agora.Proposal.Proposal -> ClosedTerm Plutarch.Api.V1.PValidator proposalValidator proposal = plam $ \datum redeemer ctx' -> P.do - PScriptContext ctx' <- pmatch ctx' + Plutarch.Api.V1.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 + Plutarch.Api.V1.PTxInfo txInfo' <- pmatch txInfo + txInfoF <- pletFields @'["inputs", "mint", "datums", "signatories"] txInfo' + Plutarch.Api.V1.PSpending ((pfield @"_0" #) -> txOutRef) <- pmatch $ pfromData ctx.purpose PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs txOutF <- pletFields @'["address", "value"] $ txOut - let proposalDatum :: Term _ PProposalDatum + let proposalDatum :: Term _ Agora.Proposal.PProposalDatum proposalDatum = pfromData $ punsafeCoerce datum - proposalRedeemer :: Term _ PProposalRedeemer + proposalRedeemer :: Term _ Agora.Proposal.PProposalRedeemer proposalRedeemer = pfromData $ punsafeCoerce redeemer proposalF <- @@ -105,73 +105,53 @@ proposalValidator proposal = ownAddress <- plet $ txOutF.address - stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (proposalPolicy proposal) + stCurrencySymbol <- plet $ pconstant $ Plutarch.Api.V1.mintingPolicySymbol $ Plutarch.Api.V1.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 + signedBy <- plet $ ptxSignedBy # txInfoF.signatories + pmatch proposalRedeemer $ \case - PVote _r -> P.do + Agora.Proposal.PVote _r -> P.do passert "ST at inputs must be 1" $ spentST #== 1 popaque (pconstant ()) -------------------------------------------------------------------------- - PCosign r -> P.do + Agora.Proposal.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 + pall # signedBy # 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) + # plam + ( \sig -> + pmatch (findStakeOwnedBy # stakeSTAssetClass # pfromData sig # txInfoF.datums # txInfoF.inputs) $ \case + PNothing -> pcon PFalse + PJust _ -> pcon PTrue + ) # newSigs passert "Signatures are correctly added to cosignature list" $ - anyOutput @PProposalDatum # ctx.txInfo + anyOutput @Agora.Proposal.PProposalDatum # ctx.txInfo #$ plam $ \newValue address newProposalDatum -> P.do let correctDatum = pdata newProposalDatum #== pdata ( mkRecordConstr - PProposalDatum + Agora.Proposal.PProposalDatum ( #proposalId .= proposalF.proposalId .& #effects .= proposalF.effects .& #status .= proposalF.status @@ -191,13 +171,13 @@ proposalValidator proposal = popaque (pconstant ()) -------------------------------------------------------------------------- - PUnlock _r -> P.do + Agora.Proposal.PUnlock _r -> P.do passert "ST at inputs must be 1" $ spentST #== 1 popaque (pconstant ()) -------------------------------------------------------------------------- - PAdvanceProposal _r -> P.do + Agora.Proposal.PAdvanceProposal _r -> P.do passert "ST at inputs must be 1" $ spentST #== 1 @@ -207,13 +187,13 @@ proposalValidator proposal = This can be used to check both upopn creation and upon any following state transitions in the proposal. -} -proposalDatumValid :: Term s (PProposalDatum :--> PBool) +proposalDatumValid :: Term s (Agora.Proposal.PProposalDatum :--> PBool) proposalDatumValid = phoistAcyclic $ plam $ \datum' -> P.do datum <- pletFields @'["effects", "cosigners"] $ datum' - let effects :: Term _ (PBuiltinMap PResultTag (PBuiltinMap PValidatorHash PDatumHash)) + let effects :: Term _ (PBuiltinMap Agora.Proposal.PResultTag (PBuiltinMap Plutarch.Api.V1.PValidatorHash Plutarch.Api.V1.PDatumHash)) effects = punsafeCoerce datum.effects atLeastOneNegativeResult :: Term _ PBool @@ -224,4 +204,5 @@ proposalDatumValid = (#&&) [ ptraceIfFalse "Proposal has at least one ResultTag has no effects" atLeastOneNegativeResult , ptraceIfFalse "Proposal has at least one cosigner" $ pnotNull # pfromData datum.cosigners + , ptraceIfFalse "Proposal has at most five cosigners" $ plength # (pfromData datum.cosigners) #< 6 ] diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index f484f9d..d5d872f 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -18,6 +18,7 @@ module Agora.Stake ( stakePolicy, stakeValidator, stakeLocked, + findStakeOwnedBy, ) where -------------------------------------------------------------------------------- @@ -35,11 +36,17 @@ import PlutusTx qualified import Plutarch.Api.V1 ( PCredential (PPubKeyCredential, PScriptCredential), + PDatum, + PDatumHash, + PMaybeData (PDJust, PDNothing), PMintingPolicy, PPubKeyHash, PScriptPurpose (PMinting, PSpending), PTokenName, + PTuple, + PTxInInfo (PTxInInfo), PTxInfo, + PTxOut (PTxOut), PValidator, mintingPolicySymbol, mkMintingPolicy, @@ -63,6 +70,7 @@ import Agora.Utils ( anyOutput, paddValue, passert, + pfindDatum, pfindTxInByTxOutRef, pgeqByClass, pgeqByClass', @@ -74,7 +82,7 @@ import Agora.Utils ( ptxSignedBy, pvalueSpent, ) -import Plutarch.Api.V1.Extra (passetClass) +import Plutarch.Api.V1.Extra (PAssetClass, passetClass, passetClassValueOf) import Plutarch.Numeric import Plutarch.SafeMoney ( PDiscrete, @@ -278,7 +286,7 @@ stakePolicy gtClassRef = txInfo <- plet $ ctx.txInfo let _a :: Term _ PTxInfo _a = txInfo - txInfoF <- pletFields @'["mint", "inputs", "outputs"] txInfo + txInfoF <- pletFields @'["mint", "inputs", "outputs", "signatories"] txInfo PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose ownSymbol <- plet $ pfield @"_0" # ownSymbol' @@ -337,7 +345,7 @@ stakePolicy gtClassRef = # stValue let ownerSignsTransaction = ptxSignedBy - # ctx.txInfo + # txInfoF.signatories # stakeDatum.owner -- TODO: This is quite inefficient now, as it does two lookups @@ -371,7 +379,7 @@ stakeValidator stake = plam $ \datum redeemer ctx' -> P.do ctx <- pletFields @'["txInfo", "purpose"] ctx' txInfo <- plet $ pfromData ctx.txInfo - txInfoF <- pletFields @'["mint", "inputs", "outputs"] txInfo + txInfoF <- pletFields @'["mint", "inputs", "outputs", "signatories"] txInfo (pfromData -> stakeRedeemer, _) <- ptryFrom redeemer @@ -387,7 +395,7 @@ stakeValidator stake = let continuingValue = pfield @"value" #$ pfield @"resolved" # txInInfo -- Whether the owner signs this transaction or not. - ownerSignsTransaction <- plet $ ptxSignedBy # ctx.txInfo # stakeDatum.owner + ownerSignsTransaction <- plet $ ptxSignedBy # txInfoF.signatories # stakeDatum.owner stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake.gtClassRef) mintedST <- plet $ psymbolValueOf # stCurrencySymbol # txInfoF.mint @@ -514,3 +522,60 @@ stakeLocked = phoistAcyclic $ let locks :: Term _ (PBuiltinList (PAsData PProposalLock)) locks = pfield @"lockedBy" # stakeDatum in pnotNull # locks + +-- | Find a stake owned by a particular PK. +findStakeOwnedBy :: + Term + s + ( PAssetClass + :--> PPubKeyHash + :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) + :--> PBuiltinList (PAsData PTxInInfo) + :--> PMaybe PTxOut + ) +findStakeOwnedBy = phoistAcyclic $ + plam $ \ac pk datums inputs -> + pmatch (pfind # (isInputStakeOwnedBy # ac # pk # datums) # inputs) $ \case + PNothing -> pcon PNothing + PJust (pfromData -> v) -> P.do + let txOut = pfield @"resolved" # pto v + txOutF <- pletFields @'["datumHash"] $ txOut + pmatch txOutF.datumHash $ \case + PDNothing _ -> pcon PNothing + PDJust ((pfield @"_0" #) -> dh) -> + -- TODO: PTryFrom here + punsafeCoerce $ pfindDatum # dh # datums + +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? +isInputStakeOwnedBy :: + Term + _ + ( PAssetClass :--> PPubKeyHash + :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) + :--> PAsData PTxInInfo + :--> PBool + ) +isInputStakeOwnedBy = + plam $ \ac ss datums txInInfo' -> P.do + PTxInInfo ((pfield @"resolved" #) -> txOut) <- pmatch $ pfromData txInInfo' + PTxOut txOut' <- pmatch txOut + txOutF <- pletFields @'["value", "datumHash"] txOut' + outStakeST <- plet $ passetClassValueOf # txOutF.value # ac + pmatch txOutF.datumHash $ \case + PDNothing _ -> pcon PFalse + PDJust ((pfield @"_0" #) -> datumHash) -> + pif + (outStakeST #== 1) + -- TODO: use 'ptryFindDatum' instead in the future + ( pmatch (pfindDatum # datumHash # datums) $ \case + PNothing -> pcon PFalse + PJust v -> stakeDatumOwnedBy # ss # pfromData (punsafeCoerce v) + ) + (pcon PFalse) diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index 7a2ee01..e1b80e1 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -56,7 +56,7 @@ import Plutarch.Api.V1 ( PTokenName, PTuple, PTxInInfo (PTxInInfo), - PTxInfo (PTxInfo), + PTxInfo, PTxOut (PTxOut), PTxOutRef, PValidatorHash, @@ -78,35 +78,30 @@ passert :: Term s PString -> Term s PBool -> Term s k -> Term s k passert errorMessage check k = pif check k (ptraceError errorMessage) -- | Find a datum with the given hash. -pfindDatum :: Term s (PDatumHash :--> PTxInfo :--> PMaybe PDatum) +pfindDatum :: Term s (PDatumHash :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PMaybe PDatum) pfindDatum = phoistAcyclic $ - plam $ \datumHash txInfo'' -> P.do - PTxInfo txInfo' <- pmatch txInfo'' - plookupTuple # datumHash #$ pfield @"datums" # txInfo' + plam $ \datumHash datums -> plookupTuple # datumHash # datums -- | Find a datum with the given hash, and `ptryFrom` it. -ptryFindDatum :: PTryFrom PData a => Term s (PDatumHash :--> PTxInfo :--> PMaybe a) +ptryFindDatum :: PTryFrom PData a => Term s (PDatumHash :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PMaybe a) ptryFindDatum = phoistAcyclic $ - plam $ \datumHash txInfo'' -> P.do - PTxInfo txInfo' <- pmatch txInfo'' - pmatch (plookupTuple # datumHash #$ pfield @"datums" # txInfo') $ \case + plam $ \datumHash inputs -> P.do + pmatch (pfindDatum # datumHash # inputs) $ \case PNothing -> pcon PNothing PJust datum -> P.do - (datum', _) <- ptryFrom $ pto datum + (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. -} -pfindDatum' :: PIsData a => Term s (PDatumHash :--> PTxInfo :--> PMaybe (PAsData a)) +pfindDatum' :: PIsData a => Term s (PDatumHash :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PMaybe (PAsData a)) pfindDatum' = phoistAcyclic $ plam $ \dh x -> punsafeCoerce $ pfindDatum # dh # x -- | Check if a PubKeyHash signs this transaction. -ptxSignedBy :: Term s (PTxInfo :--> PAsData PPubKeyHash :--> PBool) +ptxSignedBy :: Term s (PBuiltinList (PAsData PPubKeyHash) :--> PAsData PPubKeyHash :--> PBool) ptxSignedBy = phoistAcyclic $ - plam $ \txInfo' pkh -> P.do - txInfo <- pletFields @'["signatories"] txInfo' - pelem @PBuiltinList # pkh # txInfo.signatories + plam $ \sigs sig -> pelem # sig # sigs -- | Get the first element that matches a predicate or return Nothing. pfind' :: @@ -334,14 +329,14 @@ anyOutput :: Term s (PTxInfo :--> (PValue :--> PAddress :--> datum :--> PBool) :--> PBool) anyOutput = phoistAcyclic $ plam $ \txInfo' predicate -> P.do - txInfo <- pletFields @'["outputs"] txInfo' + txInfo <- pletFields @'["outputs", "datums"] txInfo' pany # plam ( \txOut'' -> P.do PTxOut txOut' <- pmatch (pfromData txOut'') txOut <- pletFields @'["value", "datumHash", "address"] txOut' PDJust dh <- pmatch txOut.datumHash - pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo') $ \case + pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo.datums) $ \case PJust datum -> P.do predicate # txOut.value # txOut.address # pfromData datum PNothing -> pcon PFalse @@ -356,14 +351,14 @@ allOutputs :: Term s (PTxInfo :--> (PTxOut :--> PValue :--> PAddress :--> datum :--> PBool) :--> PBool) allOutputs = phoistAcyclic $ plam $ \txInfo' predicate -> P.do - txInfo <- pletFields @'["outputs"] txInfo' + txInfo <- pletFields @'["outputs", "datums"] txInfo' pall # plam ( \txOut'' -> P.do PTxOut txOut' <- pmatch (pfromData txOut'') txOut <- pletFields @'["value", "datumHash", "address"] txOut' PDJust dh <- pmatch txOut.datumHash - pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo') $ \case + pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo.datums) $ \case PJust datum -> P.do predicate # pfromData txOut'' # txOut.value # txOut.address # pfromData datum PNothing -> pcon PFalse @@ -378,7 +373,7 @@ anyInput :: Term s (PTxInfo :--> (PValue :--> PAddress :--> datum :--> PBool) :--> PBool) anyInput = phoistAcyclic $ plam $ \txInfo' predicate -> P.do - txInfo <- pletFields @'["inputs"] txInfo' + txInfo <- pletFields @'["inputs", "datums"] txInfo' pany # plam ( \txInInfo'' -> P.do @@ -387,7 +382,7 @@ anyInput = phoistAcyclic $ PTxOut txOut' <- pmatch (pfromData txOut'') txOut <- pletFields @'["value", "datumHash", "address"] txOut' PDJust dh <- pmatch txOut.datumHash - pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo') $ \case + pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo.datums) $ \case PJust datum -> P.do predicate # txOut.value # txOut.address # pfromData datum PNothing -> pcon PFalse @@ -420,23 +415,18 @@ scriptHashFromAddress = phoistAcyclic $ _ -> pcon PNothing -- | Find all TxOuts sent to an Address -findOutputsToAddress :: Term s (PTxInfo :--> PAddress :--> PBuiltinList (PAsData PTxOut)) +findOutputsToAddress :: Term s (PBuiltinList (PAsData PTxOut) :--> PAddress :--> PBuiltinList (PAsData PTxOut)) findOutputsToAddress = phoistAcyclic $ - plam $ \info address' -> P.do + plam $ \outputs address' -> P.do address <- plet $ pdata address' - let outputs = pfromData $ pfield @"outputs" # info - filteredOutputs = - pfilter - # plam - (\(pfromData -> txOut) -> pfield @"address" # txOut #== address) - # outputs - filteredOutputs + pfilter # plam (\(pfromData -> txOut) -> pfield @"address" # txOut #== address) + # outputs -- | Find the data corresponding to a TxOut, if there is one -findTxOutDatum :: Term s (PTxInfo :--> PTxOut :--> PMaybe PDatum) +findTxOutDatum :: Term s (PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PTxOut :--> PMaybe PDatum) findTxOutDatum = phoistAcyclic $ - plam $ \info out -> P.do + plam $ \datums out -> P.do datumHash' <- pmatch $ pfromData $ pfield @"datumHash" # out case datumHash' of - PDJust ((pfield @"_0" #) -> datumHash) -> pfindDatum # datumHash # info + PDJust ((pfield @"_0" #) -> datumHash) -> pfindDatum # datumHash # datums _ -> pcon PNothing From f2a9749d95b60d55c59d14f9e22cb15f42b53239 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Tue, 26 Apr 2022 17:34:00 +0200 Subject: [PATCH 16/28] remove `TreasuryDatum`, `PTryFrom` for `PTreasuryRedeemer` --- agora/Agora/Treasury.hs | 93 ++++++++++++++++++++--------------------- 1 file changed, 46 insertions(+), 47 deletions(-) diff --git a/agora/Agora/Treasury.hs b/agora/Agora/Treasury.hs index 9cda2b1..db9172f 100644 --- a/agora/Agora/Treasury.hs +++ b/agora/Agora/Treasury.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + {- | Module: Agora.Treasury Maintainer: jack@mlabs.city @@ -8,23 +10,58 @@ treasury. -} module Agora.Treasury (module Agora.Treasury) where +import Agora.AuthorityToken (singleAuthorityTokenBurned) +import Agora.Utils (passert) import GHC.Generics qualified as GHC import Generics.SOP +import Plutarch.Api.V1 (PValidator) import Plutarch.Api.V1.Contexts (PScriptPurpose (PMinting)) -import Plutarch.Api.V1.Value (PCurrencySymbol, PValue) +import Plutarch.Api.V1.Value (PValue) import Plutarch.DataRepr ( - PDataFields, + DerivePConstantViaData (..), PIsDataReprInstances (PIsDataReprInstances), ) +import Plutarch.Lift (PConstantDecl (..), PLifted (..), PUnsafeLiftDecl) import Plutarch.Monadic qualified as P +import Plutarch.TryFrom (PTryFrom, ptryFrom) import Plutus.V1.Ledger.Value (CurrencySymbol) +import PlutusTx qualified -------------------------------------------------------------------------------- -import Agora.AuthorityToken (singleAuthorityTokenBurned) -import Agora.Utils (passert) -import Plutarch.Api.V1 (PValidator) -import Plutarch.Unsafe (punsafeCoerce) +data TreasuryRedeemer + = SpendTreasuryGAT + deriving stock (Eq, Show, GHC.Generic) + +PlutusTx.makeIsDataIndexed + ''TreasuryRedeemer + [ ('SpendTreasuryGAT, 0) + ] + +-------------------------------------------------------------------------------- + +{- | Plutarch level type representing valid redeemers of the + treasury. +-} +newtype PTreasuryRedeemer (s :: S) + = -- | Alters treasury parameters, subject to the burning of a + -- governance authority token. + PSpendTreasuryGAT (Term s (PDataRecord '[])) + deriving stock (GHC.Generic) + deriving anyclass (Generic, PIsDataRepr) + deriving + (PlutusType, PIsData) + via PIsDataReprInstances PTreasuryRedeemer + +deriving via + PAsData (PIsDataReprInstances PTreasuryRedeemer) + instance + PTryFrom PData (PAsData PTreasuryRedeemer) + +instance PUnsafeLiftDecl PTreasuryRedeemer where type PLifted PTreasuryRedeemer = TreasuryRedeemer +deriving via (DerivePConstantViaData TreasuryRedeemer PTreasuryRedeemer) instance (PConstantDecl TreasuryRedeemer) + +-------------------------------------------------------------------------------- {- | Validator ensuring that transactions consuming the treasury do so in a valid manner. @@ -32,12 +69,8 @@ import Plutarch.Unsafe (punsafeCoerce) treasuryValidator :: CurrencySymbol -> ClosedTerm PValidator -treasuryValidator gatCs' = plam $ \datum redeemer ctx' -> P.do - -- TODO: Use PTryFrom - let treasuryRedeemer :: Term _ (PAsData PTreasuryRedeemer) - treasuryRedeemer = punsafeCoerce redeemer - _treasuryDatum' :: Term _ (PAsData PTreasuryDatum) - _treasuryDatum' = punsafeCoerce datum +treasuryValidator gatCs' = plam $ \_datum redeemer ctx' -> P.do + (treasuryRedeemer, _) <- ptryFrom redeemer -- plet required fields from script context. ctx <- pletFields @["txInfo", "purpose"] ctx' @@ -46,7 +79,7 @@ treasuryValidator gatCs' = plam $ \datum redeemer ctx' -> P.do PMinting _ <- pmatch ctx.purpose -- Ensure redeemer type is valid. - PAlterTreasuryParams _ <- pmatch $ pfromData treasuryRedeemer + PSpendTreasuryGAT _ <- pmatch $ pfromData treasuryRedeemer -- Get the minted value from txInfo. txInfo' <- plet ctx.txInfo @@ -59,37 +92,3 @@ treasuryValidator gatCs' = plam $ \datum redeemer ctx' -> P.do passert "A single authority token has been burned" $ singleAuthorityTokenBurned gatCs txInfo' mint popaque $ pconstant () - -{- | Plutarch level type representing datum of the treasury. - Contains: - - - @stateThread@ representing the asset class of the - treasury's state thread token. --} -newtype PTreasuryDatum (s :: S) - = PTreasuryDatum - ( Term - s - ( PDataRecord - '[ "stateThread" ':= PCurrencySymbol - ] - ) - ) - deriving stock (GHC.Generic) - deriving anyclass (Generic, PIsDataRepr) - deriving - (PlutusType, PIsData, PDataFields) - via PIsDataReprInstances PTreasuryDatum - -{- | Plutarch level type representing valid redeemers of the - treasury. --} -newtype PTreasuryRedeemer (s :: S) - = -- | Alters treasury parameters, subject to the burning of a - -- governance authority token. - PAlterTreasuryParams (Term s (PDataRecord '[])) - deriving stock (GHC.Generic) - deriving anyclass (Generic, PIsDataRepr) - deriving - (PlutusType, PIsData) - via PIsDataReprInstances PTreasuryRedeemer From 438ed872e3524c6b9843778c4e16596c4fef5c20 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Tue, 26 Apr 2022 19:26:26 +0200 Subject: [PATCH 17/28] move Stake to Scripts, fix tests --- agora-test/Spec/Effect/TreasuryWithdrawal.hs | 13 +- agora-test/Spec/Proposal.hs | 13 +- agora-test/Spec/Sample/Shared.hs | 5 +- agora-test/Spec/Sample/Stake.hs | 1 + agora-test/Spec/Stake.hs | 3 +- agora-test/Spec/Util.hs | 1 - agora.cabal | 1 + agora/Agora/Proposal/Scripts.hs | 7 + agora/Agora/Stake.hs | 296 +----------------- agora/Agora/Stake/Scripts.hs | 297 +++++++++++++++++++ agora/Agora/Utils.hs | 6 +- 11 files changed, 341 insertions(+), 302 deletions(-) create mode 100644 agora/Agora/Stake/Scripts.hs diff --git a/agora-test/Spec/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Effect/TreasuryWithdrawal.hs index db0aed6..27310d9 100644 --- a/agora-test/Spec/Effect/TreasuryWithdrawal.hs +++ b/agora-test/Spec/Effect/TreasuryWithdrawal.hs @@ -7,6 +7,11 @@ This module tests the Treasury Withdrawal Effect. -} module Spec.Effect.TreasuryWithdrawal (tests) where +import Agora.Effect.TreasuryWithdrawal ( + TreasuryWithdrawalDatum (TreasuryWithdrawalDatum), + treasuryWithdrawalValidator, + ) +import Plutus.V1.Ledger.Value qualified as Value import Spec.Sample.Effect.TreasuryWithdrawal ( buildReceiversOutputFromDatum, buildScriptContext, @@ -20,15 +25,7 @@ import Spec.Sample.Effect.TreasuryWithdrawal ( treasuries, users, ) - -import Agora.Effect.TreasuryWithdrawal ( - TreasuryWithdrawalDatum (TreasuryWithdrawalDatum), - treasuryWithdrawalValidator, - ) - -import Plutus.V1.Ledger.Value qualified as Value import Spec.Util (effectFailsWith, effectSucceedsWith) - import Test.Tasty (TestTree, testGroup) tests :: [TestTree] diff --git a/agora-test/Spec/Proposal.hs b/agora-test/Spec/Proposal.hs index 2827d5d..b80d144 100644 --- a/agora-test/Spec/Proposal.hs +++ b/agora-test/Spec/Proposal.hs @@ -21,13 +21,16 @@ import Agora.Proposal ( cosigners, effects, proposalId, - proposalPolicy, - proposalValidator, status, thresholds, votes, ) -import Agora.Stake (StakeDatum (StakeDatum), StakeRedeemer (WitnessStake), stakeValidator) +import Agora.Proposal.Scripts ( + proposalPolicy, + proposalValidator, + ) +import Agora.Stake (StakeDatum (StakeDatum), StakeRedeemer (WitnessStake)) +import Agora.Stake.Scripts (stakeValidator) import Plutarch.SafeMoney (Tagged (Tagged)) import Plutus.V1.Ledger.Api (ScriptContext (..), ScriptPurpose (..)) import PlutusTx.AssocMap qualified as AssocMap @@ -39,10 +42,6 @@ import Test.Tasty (TestTree, testGroup) -------------------------------------------------------------------------------- --------------------------------------------------------------------------------- - --------------------------------------------------------------------------------- - -- | Stake tests. tests :: [TestTree] tests = diff --git a/agora-test/Spec/Sample/Shared.hs b/agora-test/Spec/Sample/Shared.hs index 1bb4636..37b1afc 100644 --- a/agora-test/Spec/Sample/Shared.hs +++ b/agora-test/Spec/Sample/Shared.hs @@ -40,10 +40,13 @@ import Agora.Governor ( import Agora.Proposal ( Proposal (..), ProposalThresholds (..), + ) +import Agora.Proposal.Scripts ( proposalPolicy, proposalValidator, ) -import Agora.Stake (Stake (..), stakePolicy, stakeValidator) +import Agora.Stake (Stake (..)) +import Agora.Stake.Scripts (stakePolicy, stakeValidator) import Plutarch.Api.V1 ( mintingPolicySymbol, mkMintingPolicy, diff --git a/agora-test/Spec/Sample/Stake.hs b/agora-test/Spec/Sample/Stake.hs index e893eed..07af063 100644 --- a/agora-test/Spec/Sample/Stake.hs +++ b/agora-test/Spec/Sample/Stake.hs @@ -46,6 +46,7 @@ import Plutus.V1.Ledger.Value qualified as Value import Agora.SafeMoney (GTTag) import Agora.Stake +import Agora.Stake.Scripts (stakeValidator) import Plutarch.SafeMoney import Spec.Sample.Shared import Spec.Util (datumPair, toDatumHash) diff --git a/agora-test/Spec/Stake.hs b/agora-test/Spec/Stake.hs index 427f228..6824b80 100644 --- a/agora-test/Spec/Stake.hs +++ b/agora-test/Spec/Stake.hs @@ -19,7 +19,8 @@ import Test.Tasty (TestTree, testGroup) -------------------------------------------------------------------------------- -import Agora.Stake (Stake (..), StakeDatum (StakeDatum), StakeRedeemer (DepositWithdraw), stakePolicy, stakeValidator) +import Agora.Stake (Stake (..), StakeDatum (StakeDatum), StakeRedeemer (DepositWithdraw)) +import Agora.Stake.Scripts (stakePolicy, stakeValidator) -------------------------------------------------------------------------------- diff --git a/agora-test/Spec/Util.hs b/agora-test/Spec/Util.hs index c9c3ce4..365ad50 100644 --- a/agora-test/Spec/Util.hs +++ b/agora-test/Spec/Util.hs @@ -90,7 +90,6 @@ policyFailsWith tag policy redeemer scriptContext = -- | Check that a validator script succeeds, given a name and arguments. validatorSucceedsWith :: ( PLift datum - , Show (PLifted datum) , PlutusTx.ToData (PLifted datum) , PLift redeemer , PlutusTx.ToData (PLifted redeemer) diff --git a/agora.cabal b/agora.cabal index 1948966..b55630b 100644 --- a/agora.cabal +++ b/agora.cabal @@ -134,6 +134,7 @@ library Agora.Record Agora.SafeMoney Agora.Stake + Agora.Stake.Scripts Agora.Treasury other-modules: diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs index 09ae5c4..417f577 100644 --- a/agora/Agora/Proposal/Scripts.hs +++ b/agora/Agora/Proposal/Scripts.hs @@ -1,3 +1,10 @@ +{- | +Module : Agora.Proposal.Scripts +Maintainer : emi@haskell.fyi +Description: Plutus Scripts for Proposals. + +Plutus Scripts for Proposals. +-} module Agora.Proposal.Scripts ( proposalValidator, proposalPolicy, diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index d5d872f..efdc91b 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -8,15 +8,18 @@ Description: Vote-lockable stake UTXOs holding GT. Vote-lockable stake UTXOs holding GT. -} module Agora.Stake ( - PStakeDatum (..), - PStakeRedeemer (..), + -- * Haskell-land StakeDatum (..), StakeRedeemer (..), - ProposalLock (..), - PProposalLock (..), Stake (..), - stakePolicy, - stakeValidator, + ProposalLock (..), + + -- * Plutarch-land + PStakeDatum (..), + PStakeRedeemer (..), + PProposalLock (..), + + -- * Utility functions stakeLocked, findStakeOwnedBy, ) where @@ -35,21 +38,13 @@ import PlutusTx qualified -------------------------------------------------------------------------------- import Plutarch.Api.V1 ( - PCredential (PPubKeyCredential, PScriptCredential), PDatum, PDatumHash, PMaybeData (PDJust, PDNothing), - PMintingPolicy, PPubKeyHash, - PScriptPurpose (PMinting, PSpending), - PTokenName, PTuple, PTxInInfo (PTxInInfo), - PTxInfo, PTxOut (PTxOut), - PValidator, - mintingPolicySymbol, - mkMintingPolicy, ) import Plutarch.DataRepr ( DerivePConstantViaData (..), @@ -59,38 +54,23 @@ import Plutarch.DataRepr ( import Plutarch.Internal (punsafeCoerce) import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..)) import Plutarch.Monadic qualified as P -import Plutus.V1.Ledger.Value (AssetClass (AssetClass)) +import Plutus.V1.Ledger.Value (AssetClass) -------------------------------------------------------------------------------- import Agora.Proposal (PProposalId, PResultTag, ProposalId (..), ResultTag (..)) import Agora.SafeMoney (GTTag) import Agora.Utils ( - anyInput, - anyOutput, - paddValue, - passert, pfindDatum, - pfindTxInByTxOutRef, - pgeqByClass, - pgeqByClass', - pgeqBySymbol, pnotNull, - psingletonValue, - psymbolValueOf, - ptokenSpent, - ptxSignedBy, - pvalueSpent, ) -import Plutarch.Api.V1.Extra (PAssetClass, passetClass, passetClassValueOf) -import Plutarch.Numeric +import Plutarch.Api.V1.Extra (PAssetClass, passetClassValueOf) +import Plutarch.Numeric () import Plutarch.SafeMoney ( PDiscrete, Tagged (..), - pdiscreteValue', - untag, ) -import Plutarch.TryFrom (PTryFrom, ptryFrom) +import Plutarch.TryFrom (PTryFrom) -------------------------------------------------------------------------------- @@ -263,256 +243,6 @@ deriving via instance PUnsafeLiftDecl PProposalLock where type PLifted PProposalLock = ProposalLock deriving via (DerivePConstantViaData ProposalLock PProposalLock) instance (PConstantDecl ProposalLock) --------------------------------------------------------------------------------- -{- What this Policy does - - For minting: - Check that exactly one state thread is minted - Check that an output exists with a state thread and a valid datum - Check that no state thread is an input - assert TokenName == ValidatorHash of the script that we pay to - - For burning: - Check that exactly one state thread is burned - Check that datum at state thread is valid and not locked --} --------------------------------------------------------------------------------- - --- | Policy for Stake state threads. -stakePolicy :: Tagged GTTag AssetClass -> ClosedTerm PMintingPolicy -stakePolicy gtClassRef = - plam $ \_redeemer ctx' -> P.do - ctx <- pletFields @'["txInfo", "purpose"] ctx' - txInfo <- plet $ ctx.txInfo - let _a :: Term _ PTxInfo - _a = txInfo - txInfoF <- pletFields @'["mint", "inputs", "outputs", "signatories"] txInfo - - PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose - ownSymbol <- plet $ pfield @"_0" # ownSymbol' - spentST <- plet $ psymbolValueOf # ownSymbol #$ pvalueSpent # txInfoF.inputs - mintedST <- plet $ psymbolValueOf # ownSymbol # txInfoF.mint - - let burning = P.do - passert "ST at inputs must be 1" $ - spentST #== 1 - - passert "ST burned" $ - mintedST #== -1 - - passert "An unlocked input existed containing an ST" $ - anyInput @PStakeDatum # txInfo - #$ plam - $ \value _ stakeDatum' -> P.do - let hasST = psymbolValueOf # ownSymbol # value #== 1 - let unlocked = pnot # (stakeLocked # stakeDatum') - hasST #&& unlocked - - popaque (pconstant ()) - - let minting = P.do - passert "ST at inputs must be 0" $ - spentST #== 0 - - passert "Minted ST must be exactly 1" $ - mintedST #== 1 - - passert "A UTXO must exist with the correct output" $ - anyOutput @PStakeDatum # txInfo - #$ plam - $ \value address stakeDatum' -> P.do - let cred = pfield @"credential" # address - pmatch cred $ \case - -- Should pay to a script address - PPubKeyCredential _ -> pcon PFalse - PScriptCredential validatorHash' -> P.do - validatorHash <- pletFields @'["_0"] validatorHash' - stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum' - - -- TODO: figure out why this is required :/ (specifically, why `validatorHash._0` is `PData`) - tn <- plet (pfromData (punsafeCoerce validatorHash._0 :: Term _ (PAsData PTokenName))) - - let stValue = - psingletonValue - # ownSymbol - -- This coerce is safe because the structure - -- of PValidatorHash is the same as PTokenName. - # tn - # 1 - let expectedValue = - paddValue - # (pdiscreteValue' gtClassRef # stakeDatum.stakedAmount) - # stValue - let ownerSignsTransaction = - ptxSignedBy - # txInfoF.signatories - # stakeDatum.owner - - -- TODO: This is quite inefficient now, as it does two lookups - -- instead of a more efficient single pass, - -- but it doesn't really matter for this. At least it's correct. - let valueCorrect = - foldr1 - (#&&) - [ pgeqByClass' (AssetClass ("", "")) # value # expectedValue - , pgeqByClass' (untag gtClassRef) - # value - # expectedValue - , pgeqByClass - # ownSymbol - # tn - # value - # expectedValue - ] - - ownerSignsTransaction - #&& valueCorrect - popaque (pconstant ()) - - pif (0 #< mintedST) minting burning - --------------------------------------------------------------------------------- - --- | Validator intended for Stake UTXOs to live in. -stakeValidator :: Stake -> ClosedTerm PValidator -stakeValidator stake = - plam $ \datum redeemer ctx' -> P.do - ctx <- pletFields @'["txInfo", "purpose"] ctx' - txInfo <- plet $ pfromData ctx.txInfo - txInfoF <- pletFields @'["mint", "inputs", "outputs", "signatories"] txInfo - - (pfromData -> stakeRedeemer, _) <- ptryFrom redeemer - - -- TODO: Use PTryFrom - let stakeDatum' :: Term _ PStakeDatum - stakeDatum' = pfromData $ punsafeCoerce datum - stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum' - - PSpending txOutRef <- pmatch $ pfromData ctx.purpose - - PJust txInInfo <- pmatch $ pfindTxInByTxOutRef # (pfield @"_0" # txOutRef) # txInfoF.inputs - ownAddress <- plet $ pfield @"address" #$ pfield @"resolved" # txInInfo - let continuingValue = pfield @"value" #$ pfield @"resolved" # txInInfo - - -- Whether the owner signs this transaction or not. - ownerSignsTransaction <- plet $ ptxSignedBy # txInfoF.signatories # stakeDatum.owner - - stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake.gtClassRef) - mintedST <- plet $ psymbolValueOf # stCurrencySymbol # txInfoF.mint - spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # txInfoF.inputs - - -- Is the stake currently locked? - stakeIsLocked <- plet $ stakeLocked # stakeDatum' - - pmatch stakeRedeemer $ \case - PDestroy _ -> P.do - passert "ST at inputs must be 1" $ - spentST #== 1 - passert "Should burn ST" $ - mintedST #== -1 - passert "Stake unlocked" $ pnot # stakeIsLocked - passert - "Owner signs this transaction" - ownerSignsTransaction - popaque (pconstant ()) - -------------------------------------------------------------------------- - PRetractVotes _ -> P.do - passert - "Owner signs this transaction" - ownerSignsTransaction - -- TODO: check proposal constraints - popaque (pconstant ()) - -------------------------------------------------------------------------- - PPermitVote _ -> P.do - passert - "Owner signs this transaction" - ownerSignsTransaction - -- TODO: check proposal constraints - popaque (pconstant ()) - -------------------------------------------------------------------------- - PWitnessStake _ -> P.do - passert "ST at inputs must be 1" $ - spentST #== 1 - - let AssetClass (propCs, propTn) = stake.proposalSTClass - propAssetClass = passetClass # pconstant propCs # pconstant propTn - proposalTokenMoved = - ptokenSpent - # propAssetClass - # txInfoF.inputs - - passert - "Owner signs this transaction OR proposal token is spent" - (ownerSignsTransaction #|| proposalTokenMoved) - - passert "A UTXO must exist with the correct output" $ - anyOutput @PStakeDatum # txInfo - #$ plam - $ \value address newStakeDatum' -> P.do - let isScriptAddress = pdata address #== ownAddress - let correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum' - let valueCorrect = pdata continuingValue #== pdata value - pif - isScriptAddress - ( foldl1 - (#&&) - [ ptraceIfFalse "valueCorrect" valueCorrect - , ptraceIfFalse "correctOutputDatum" correctOutputDatum - ] - ) - (pcon PFalse) - popaque (pconstant ()) - PDepositWithdraw r -> P.do - passert "ST at inputs must be 1" $ - spentST #== 1 - passert "Stake unlocked" $ - pnot #$ stakeIsLocked - passert - "Owner signs this transaction" - ownerSignsTransaction - passert "A UTXO must exist with the correct output" $ - anyOutput @PStakeDatum # txInfo - #$ plam - $ \value address newStakeDatum' -> P.do - newStakeDatum <- pletFields @'["owner", "stakedAmount"] newStakeDatum' - delta <- plet $ pfield @"delta" # r - let isScriptAddress = pdata address #== ownAddress - let correctOutputDatum = - foldr1 - (#&&) - [ stakeDatum.owner #== newStakeDatum.owner - , (stakeDatum.stakedAmount + delta) #== newStakeDatum.stakedAmount - , -- We can't magically conjure GT anyway (no input to spend!) - -- do we need to check this, really? - zero #<= pfromData newStakeDatum.stakedAmount - ] - let expectedValue = paddValue # continuingValue # (pdiscreteValue' stake.gtClassRef # delta) - - -- TODO: Same as above. This is quite inefficient now, as it does two lookups - -- instead of a more efficient single pass, - -- but it doesn't really matter for this. At least it's correct. - let valueCorrect = - foldr1 - (#&&) - [ pgeqByClass' (AssetClass ("", "")) # value # expectedValue - , pgeqByClass' (untag stake.gtClassRef) - # value - # expectedValue - , pgeqBySymbol - # stCurrencySymbol - # value - # expectedValue - ] - - foldr1 - (#&&) - [ ptraceIfFalse "isScriptAddress" isScriptAddress - , ptraceIfFalse "correctOutputDatum" correctOutputDatum - , ptraceIfFalse "valueCorrect" valueCorrect - ] - - popaque (pconstant ()) - -------------------------------------------------------------------------------- -- | Check whether a Stake is locked. If it is locked, various actions are unavailable. diff --git a/agora/Agora/Stake/Scripts.hs b/agora/Agora/Stake/Scripts.hs new file mode 100644 index 0000000..f07ace3 --- /dev/null +++ b/agora/Agora/Stake/Scripts.hs @@ -0,0 +1,297 @@ +{- | +Module : Agora.Stake.Scripts +Maintainer : emi@haskell.fyi +Description: Plutus Scripts for Stakes. + +Plutus Scripts for Stakes. +-} +module Agora.Stake.Scripts (stakePolicy, stakeValidator) where + +import Agora.SafeMoney (GTTag) +import Agora.Stake +import Agora.Utils ( + anyInput, + anyOutput, + paddValue, + passert, + pfindTxInByTxOutRef, + pgeqByClass, + pgeqByClass', + pgeqBySymbol, + psingletonValue, + psymbolValueOf, + ptokenSpent, + ptxSignedBy, + pvalueSpent, + validatorHashToTokenName, + ) +import Plutarch.Api.V1 ( + PCredential (PPubKeyCredential, PScriptCredential), + PMintingPolicy, + PScriptPurpose (PMinting, PSpending), + PTokenName, + PTxInfo, + PValidator, + mintingPolicySymbol, + mkMintingPolicy, + ) +import Plutarch.Api.V1.Extra (passetClass) +import Plutarch.Internal (punsafeCoerce) +import Plutarch.Monadic qualified as P +import Plutarch.Numeric +import Plutarch.SafeMoney ( + Tagged (..), + pdiscreteValue', + untag, + ) +import Plutarch.TryFrom (ptryFrom) +import Plutus.V1.Ledger.Value (AssetClass (AssetClass)) +import Prelude hiding (Num (..)) + +{- | Policy for Stake state threads. + + == What this Policy does + + === For minting: + + - Check that exactly one state thread is minted + - Check that an output exists with a state thread and a valid datum + - Check that no state thread is an input + - assert @'TokenName' == 'ValidatorHash'@ of the script that we pay to + + === For burning: + + - Check that exactly one state thread is burned + - Check that datum at state thread is valid and not locked +-} +stakePolicy :: Tagged GTTag AssetClass -> ClosedTerm PMintingPolicy +stakePolicy gtClassRef = + plam $ \_redeemer ctx' -> P.do + ctx <- pletFields @'["txInfo", "purpose"] ctx' + txInfo <- plet $ ctx.txInfo + let _a :: Term _ PTxInfo + _a = txInfo + txInfoF <- pletFields @'["mint", "inputs", "outputs", "signatories"] txInfo + + PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose + ownSymbol <- plet $ pfield @"_0" # ownSymbol' + spentST <- plet $ psymbolValueOf # ownSymbol #$ pvalueSpent # txInfoF.inputs + mintedST <- plet $ psymbolValueOf # ownSymbol # txInfoF.mint + + let burning = P.do + passert "ST at inputs must be 1" $ + spentST #== 1 + + passert "ST burned" $ + mintedST #== -1 + + passert "An unlocked input existed containing an ST" $ + anyInput @PStakeDatum # txInfo + #$ plam + $ \value _ stakeDatum' -> P.do + let hasST = psymbolValueOf # ownSymbol # value #== 1 + let unlocked = pnot # (stakeLocked # stakeDatum') + hasST #&& unlocked + + popaque (pconstant ()) + + let minting = P.do + passert "ST at inputs must be 0" $ + spentST #== 0 + + passert "Minted ST must be exactly 1" $ + mintedST #== 1 + + passert "A UTXO must exist with the correct output" $ + anyOutput @PStakeDatum # txInfo + #$ plam + $ \value address stakeDatum' -> P.do + let cred = pfield @"credential" # address + pmatch cred $ \case + -- Should pay to a script address + PPubKeyCredential _ -> pcon PFalse + PScriptCredential validatorHash -> P.do + stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum' + + tn :: Term _ PTokenName <- plet (validatorHashToTokenName $ pfromData $ pfield @"_0" # validatorHash) + + let stValue = + psingletonValue + # ownSymbol + -- This coerce is safe because the structure + -- of PValidatorHash is the same as PTokenName. + # tn + # 1 + let expectedValue = + paddValue + # (pdiscreteValue' gtClassRef # stakeDatum.stakedAmount) + # stValue + let ownerSignsTransaction = + ptxSignedBy + # txInfoF.signatories + # stakeDatum.owner + + -- TODO: This is quite inefficient now, as it does two lookups + -- instead of a more efficient single pass, + -- but it doesn't really matter for this. At least it's correct. + let valueCorrect = + foldr1 + (#&&) + [ pgeqByClass' (AssetClass ("", "")) # value # expectedValue + , pgeqByClass' (untag gtClassRef) + # value + # expectedValue + , pgeqByClass + # ownSymbol + # tn + # value + # expectedValue + ] + + ownerSignsTransaction + #&& valueCorrect + popaque (pconstant ()) + + pif (0 #< mintedST) minting burning + +-------------------------------------------------------------------------------- + +-- | Validator intended for Stake UTXOs to live in. +stakeValidator :: Stake -> ClosedTerm PValidator +stakeValidator stake = + plam $ \datum redeemer ctx' -> P.do + ctx <- pletFields @'["txInfo", "purpose"] ctx' + txInfo <- plet $ pfromData ctx.txInfo + txInfoF <- pletFields @'["mint", "inputs", "outputs", "signatories"] txInfo + + (pfromData -> stakeRedeemer, _) <- ptryFrom redeemer + + -- TODO: Use PTryFrom + let stakeDatum' :: Term _ PStakeDatum + stakeDatum' = pfromData $ punsafeCoerce datum + stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum' + + PSpending txOutRef <- pmatch $ pfromData ctx.purpose + + PJust txInInfo <- pmatch $ pfindTxInByTxOutRef # (pfield @"_0" # txOutRef) # txInfoF.inputs + ownAddress <- plet $ pfield @"address" #$ pfield @"resolved" # txInInfo + let continuingValue = pfield @"value" #$ pfield @"resolved" # txInInfo + + -- Whether the owner signs this transaction or not. + ownerSignsTransaction <- plet $ ptxSignedBy # txInfoF.signatories # stakeDatum.owner + + stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake.gtClassRef) + mintedST <- plet $ psymbolValueOf # stCurrencySymbol # txInfoF.mint + spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # txInfoF.inputs + + -- Is the stake currently locked? + stakeIsLocked <- plet $ stakeLocked # stakeDatum' + + pmatch stakeRedeemer $ \case + PDestroy _ -> P.do + passert "ST at inputs must be 1" $ + spentST #== 1 + passert "Should burn ST" $ + mintedST #== -1 + passert "Stake unlocked" $ pnot # stakeIsLocked + passert + "Owner signs this transaction" + ownerSignsTransaction + popaque (pconstant ()) + -------------------------------------------------------------------------- + PRetractVotes _ -> P.do + passert + "Owner signs this transaction" + ownerSignsTransaction + -- TODO: check proposal constraints + popaque (pconstant ()) + -------------------------------------------------------------------------- + PPermitVote _ -> P.do + passert + "Owner signs this transaction" + ownerSignsTransaction + -- TODO: check proposal constraints + popaque (pconstant ()) + -------------------------------------------------------------------------- + PWitnessStake _ -> P.do + passert "ST at inputs must be 1" $ + spentST #== 1 + + let AssetClass (propCs, propTn) = stake.proposalSTClass + propAssetClass = passetClass # pconstant propCs # pconstant propTn + proposalTokenMoved = + ptokenSpent + # propAssetClass + # txInfoF.inputs + + passert + "Owner signs this transaction OR proposal token is spent" + (ownerSignsTransaction #|| proposalTokenMoved) + + passert "A UTXO must exist with the correct output" $ + anyOutput @PStakeDatum # txInfo + #$ plam + $ \value address newStakeDatum' -> P.do + let isScriptAddress = pdata address #== ownAddress + let correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum' + let valueCorrect = pdata continuingValue #== pdata value + pif + isScriptAddress + ( foldl1 + (#&&) + [ ptraceIfFalse "valueCorrect" valueCorrect + , ptraceIfFalse "correctOutputDatum" correctOutputDatum + ] + ) + (pcon PFalse) + popaque (pconstant ()) + PDepositWithdraw r -> P.do + passert "ST at inputs must be 1" $ + spentST #== 1 + passert "Stake unlocked" $ + pnot #$ stakeIsLocked + passert + "Owner signs this transaction" + ownerSignsTransaction + passert "A UTXO must exist with the correct output" $ + anyOutput @PStakeDatum # txInfo + #$ plam + $ \value address newStakeDatum' -> P.do + newStakeDatum <- pletFields @'["owner", "stakedAmount"] newStakeDatum' + delta <- plet $ pfield @"delta" # r + let isScriptAddress = pdata address #== ownAddress + let correctOutputDatum = + foldr1 + (#&&) + [ stakeDatum.owner #== newStakeDatum.owner + , (stakeDatum.stakedAmount + delta) #== newStakeDatum.stakedAmount + , -- We can't magically conjure GT anyway (no input to spend!) + -- do we need to check this, really? + zero #<= pfromData newStakeDatum.stakedAmount + ] + let expectedValue = paddValue # continuingValue # (pdiscreteValue' stake.gtClassRef # delta) + + -- TODO: Same as above. This is quite inefficient now, as it does two lookups + -- instead of a more efficient single pass, + -- but it doesn't really matter for this. At least it's correct. + let valueCorrect = + foldr1 + (#&&) + [ pgeqByClass' (AssetClass ("", "")) # value # expectedValue + , pgeqByClass' (untag stake.gtClassRef) + # value + # expectedValue + , pgeqBySymbol + # stCurrencySymbol + # value + # expectedValue + ] + + foldr1 + (#&&) + [ ptraceIfFalse "isScriptAddress" isScriptAddress + , ptraceIfFalse "correctOutputDatum" correctOutputDatum + , ptraceIfFalse "valueCorrect" valueCorrect + ] + + popaque (pconstant ()) diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index e1b80e1..f60c853 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -36,6 +36,7 @@ module Agora.Utils ( scriptHashFromAddress, findOutputsToAddress, findTxOutDatum, + validatorHashToTokenName, ) where -------------------------------------------------------------------------------- @@ -53,7 +54,7 @@ import Plutarch.Api.V1 ( PMap, PMaybeData (PDJust), PPubKeyHash, - PTokenName, + PTokenName (PTokenName), PTuple, PTxInInfo (PTxInInfo), PTxInfo, @@ -430,3 +431,6 @@ findTxOutDatum = phoistAcyclic $ case datumHash' of PDJust ((pfield @"_0" #) -> datumHash) -> pfindDatum # datumHash # datums _ -> pcon PNothing + +validatorHashToTokenName :: forall (s :: S). Term s PValidatorHash -> Term s PTokenName +validatorHashToTokenName vh = pcon (PTokenName (pto vh)) From 8cbdbeb2fe195874dc7185bfc7773fe3a009ba29 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Tue, 26 Apr 2022 21:07:02 +0200 Subject: [PATCH 18/28] fix haddock errors --- agora/Agora/Effect/NoOp.hs | 1 + agora/Agora/Effect/TreasuryWithdrawal.hs | 10 ++++++++-- agora/Agora/Proposal.hs | 6 +++--- agora/Agora/Proposal/Time.hs | 25 +++++++++++++++++------- agora/Agora/Record.hs | 5 +++-- agora/Agora/Stake.hs | 7 ++++--- agora/Agora/Stake/Scripts.hs | 13 ++++++------ agora/Agora/Treasury.hs | 4 +++- 8 files changed, 47 insertions(+), 24 deletions(-) diff --git a/agora/Agora/Effect/NoOp.hs b/agora/Agora/Effect/NoOp.hs index ccdae74..82069b9 100644 --- a/agora/Agora/Effect/NoOp.hs +++ b/agora/Agora/Effect/NoOp.hs @@ -14,6 +14,7 @@ import Plutarch.Api.V1 (PValidator) import Plutarch.TryFrom (PTryFrom (..)) import Plutus.V1.Ledger.Value (CurrencySymbol) +-- | Dummy datum for NoOp effect. newtype PNoOp (s :: S) = PNoOp (Term s PUnit) deriving (PlutusType, PIsData) via (DerivePNewtype PNoOp PUnit) diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index 8693cdf..e9957a4 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -40,7 +40,12 @@ import Plutus.V1.Ledger.Credential (Credential) import Plutus.V1.Ledger.Value (CurrencySymbol, Value) import PlutusTx qualified --- | Datum that encodes behavior of Treasury Withdrawal effect. +{- | Datum that encodes behavior of Treasury Withdrawal effect. + +Note: This Datum acts like a "predefined redeemer". Which is to say that +it encodes the properties a redeemer would, but is locked in-place until +spend. +-} data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum { receivers :: [(Credential, Value)] -- ^ AssocMap for Value sent to each receiver from the treasury. @@ -51,8 +56,9 @@ data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum deriving anyclass (Generic) PlutusTx.makeLift ''TreasuryWithdrawalDatum -PlutusTx.unstableMakeIsData ''TreasuryWithdrawalDatum +PlutusTx.makeIsDataIndexed ''TreasuryWithdrawalDatum [('TreasuryWithdrawalDatum, 0)] +-- | Haskell-level version of 'TreasuryWithdrawalDatum'. newtype PTreasuryWithdrawalDatum (s :: S) = PTreasuryWithdrawalDatum ( Term diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index bf88bf8..05a9f91 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -109,7 +109,7 @@ data ProposalStatus -- the proposal failed due to time constraints or didn't -- get to 'VotingReady' first. -- - -- At this stage, the 'votes' field of 'ProposalState' is frozen. + -- At this stage, the 'votes' field of 'ProposalDatum' is frozen. -- -- See 'AdvanceProposal' for documentation on state transitions. -- @@ -186,7 +186,7 @@ data ProposalRedeemer -- Must be signed by those cosigning. -- -- This is particularly used in the 'Draft' 'ProposalStatus', - -- where matching 'Stake's can be called to advance the proposal, + -- where matching 'Agora.Stake.Stake's can be called to advance the proposal, -- provided enough GT is shared among them. Cosign [PubKeyHash] | -- | Allow unlocking one or more stakes with votes towards particular 'ResultTag'. @@ -351,7 +351,7 @@ newtype PProposalDatum (s :: S) = PProposalDatum instance PUnsafeLiftDecl PProposalDatum where type PLifted PProposalDatum = ProposalDatum deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PConstantDecl ProposalDatum) --- | Haskell-level redeemer for Proposal scripts. +-- | Plutarch-level version of 'ProposalRedeemer'. data PProposalRedeemer (s :: S) = PVote (Term s (PDataRecord '["resultTag" ':= PResultTag])) | PCosign (Term s (PDataRecord '["newCosigners" ':= PBuiltinList (PAsData PPubKeyHash)])) diff --git a/agora/Agora/Proposal/Time.hs b/agora/Agora/Proposal/Time.hs index 311c3fb..fd5063a 100644 --- a/agora/Agora/Proposal/Time.hs +++ b/agora/Agora/Proposal/Time.hs @@ -27,7 +27,15 @@ module Agora.Proposal.Time ( import Agora.Record (mkRecordConstr, (.&), (.=)) import GHC.Generics qualified as GHC import Generics.SOP (Generic, I (I)) -import Plutarch.Api.V1 (PExtended (PFinite), PInterval (PInterval), PLowerBound (PLowerBound), PMaybeData (PDJust, PDNothing), PPOSIXTime, PPOSIXTimeRange, PUpperBound (PUpperBound)) +import Plutarch.Api.V1 ( + PExtended (PFinite), + PInterval (PInterval), + PLowerBound (PLowerBound), + PMaybeData (PDJust, PDNothing), + PPOSIXTime, + PPOSIXTimeRange, + PUpperBound (PUpperBound), + ) import Plutarch.DataRepr (PDataFields, PIsDataReprInstances (..)) import Plutarch.Monadic qualified as P import Plutarch.Numeric (AdditiveSemigroup ((+))) @@ -74,16 +82,19 @@ newtype ProposalStartingTime = ProposalStartingTime deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) deriving stock (Eq, Show, GHC.Generic) --- | Configuration of proposal timings. +{- | Configuration of proposal timings. + + See: https://github.com/Liqwid-Labs/agora/blob/master/docs/tech-design/proposals.md#when-may-interactions-occur +-} data ProposalTimingConfig = ProposalTimingConfig { draftTime :: POSIXTime - -- ^ `D`: the length of the draft period. + -- ^ "D": the length of the draft period. , votingTime :: POSIXTime - -- ^ `V`: the length of the voting period. + -- ^ "V": the length of the voting period. , lockingTime :: POSIXTime - -- ^ `L`: the length of the locking period. + -- ^ "L": the length of the locking period. , executingTime :: POSIXTime - -- ^ `E`: the length of the execution period. + -- ^ "E": the length of the execution period. } deriving stock (Eq, Show, GHC.Generic) @@ -139,7 +150,7 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig instance AdditiveSemigroup (Term s PPOSIXTime) where (punsafeCoerce @_ @_ @PInteger -> x) + (punsafeCoerce @_ @_ @PInteger -> y) = punsafeCoerce $ x + y --- | Get the current proposal time, from the 'txInfoValidRange' field. +-- | Get the current proposal time, from the 'Plutus.V1.Ledger.Api.txInfoValidRange' field. currentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PProposalTime) currentProposalTime = phoistAcyclic $ plam $ \iv -> P.do diff --git a/agora/Agora/Record.hs b/agora/Agora/Record.hs index 5ad5691..30d7490 100644 --- a/agora/Agora/Record.hs +++ b/agora/Agora/Record.hs @@ -60,7 +60,8 @@ mkRecordConstr :: forall (r :: [PLabeledType]) (s :: S) (pt :: PType). PlutusType pt => -- | The constructor. This is just the Haskell-level constructor for the type. - -- For 'PMaybeData', this could be 'PDJust', or 'PNothing'. + -- For 'Plutarch.Api.V1.Maybe.PMaybeData', this would + -- be 'Plutarch.Api.V1.Maybe.PDJust', or 'Plutarch.Api.V1.Maybe.PNothing'. (forall s'. Term s' (PDataRecord r) -> pt s') -> -- | The morphism that builds the record. RecordMorphism s '[] r -> @@ -87,7 +88,7 @@ infix 7 .= -- @#hello ~ 'FieldName' "hello"@ FieldName sym -> -- | The value at that field. This must be 'PAsData', because the underlying - -- type is @'Constr' 'Integer' ['Data']@. + -- type is @'PlutusCore.Data.Constr' 'Integer' ['PlutusCore.Data.Data']@. Term s (PAsData a) -> RecordMorphism s as ((sym ':= a) ': as) _ .= x = RecordMorphism $ pcon . PDCons x diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index efdc91b..6788f91 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -127,14 +127,14 @@ data StakeRedeemer | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets. -- Stake must be unlocked. Destroy - | -- | Permit a Vote to be added onto a 'Proposal'. + | -- | Permit a Vote to be added onto a 'Agora.Proposal.Proposal'. -- This also adds a lock to the 'lockedBy' field. See 'ProposalLock'. -- This needs to be done in sync with casting a vote, otherwise -- it's possible for a lock to be permanently placed on the stake, -- and then the funds are lost. PermitVote ProposalLock | -- | Retract a vote, removing it from the 'lockedBy' field. See 'ProposalLock'. - -- This action checks for permission of the 'Proposal'. Finished proposals are + -- This action checks for permission of the 'Agora.Proposal.Proposal'. Finished proposals are -- always allowed to have votes retracted and won't affect the Proposal datum, -- allowing 'Stake's to be unlocked. RetractVotes [ProposalLock] @@ -156,7 +156,7 @@ PlutusTx.makeIsDataIndexed data StakeDatum = StakeDatum { stakedAmount :: Tagged GTTag Integer -- ^ Tracks the amount of governance token staked in the datum. - -- This also acts as the voting weight for 'Proposal's. + -- This also acts as the voting weight for 'Agora.Proposal.Proposal's. , owner :: PubKeyHash -- ^ The hash of the public key this stake belongs to. -- @@ -218,6 +218,7 @@ deriving via instance PUnsafeLiftDecl PStakeRedeemer where type PLifted PStakeRedeemer = StakeRedeemer deriving via (DerivePConstantViaData StakeRedeemer PStakeRedeemer) instance (PConstantDecl StakeRedeemer) +-- | Plutarch-level version of 'ProposalLock'. newtype PProposalLock (s :: S) = PProposalLock { getProposalLock :: Term diff --git a/agora/Agora/Stake/Scripts.hs b/agora/Agora/Stake/Scripts.hs index f07ace3..44cefac 100644 --- a/agora/Agora/Stake/Scripts.hs +++ b/agora/Agora/Stake/Scripts.hs @@ -54,15 +54,16 @@ import Prelude hiding (Num (..)) === For minting: - - Check that exactly one state thread is minted - - Check that an output exists with a state thread and a valid datum - - Check that no state thread is an input - - assert @'TokenName' == 'ValidatorHash'@ of the script that we pay to + - Check that exactly one state thread is minted. + - Check that an output exists with a state thread and a valid datum. + - Check that no state thread is an input. + - assert @'Plutus.V1.Ledger.Api.TokenName' == 'Plutus.V1.Ledger.Api.ValidatorHash'@ + of the script that we pay to. === For burning: - - Check that exactly one state thread is burned - - Check that datum at state thread is valid and not locked + - Check that exactly one state thread is burned. + - Check that datum at state thread is valid and not locked. -} stakePolicy :: Tagged GTTag AssetClass -> ClosedTerm PMintingPolicy stakePolicy gtClassRef = diff --git a/agora/Agora/Treasury.hs b/agora/Agora/Treasury.hs index db9172f..f3ff441 100644 --- a/agora/Agora/Treasury.hs +++ b/agora/Agora/Treasury.hs @@ -29,8 +29,10 @@ import PlutusTx qualified -------------------------------------------------------------------------------- +-- | Redeemer for Treasury actions. data TreasuryRedeemer - = SpendTreasuryGAT + = -- | Allow transaction to pass by delegating to GAT burn. + SpendTreasuryGAT deriving stock (Eq, Show, GHC.Generic) PlutusTx.makeIsDataIndexed From 34827aeca668db9aa9cb7cc897c011c307d15c18 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Tue, 26 Apr 2022 22:08:31 +0200 Subject: [PATCH 19/28] add missing range checks --- agora/Agora/Proposal.hs | 8 ++++---- agora/Agora/Proposal/Time.hs | 24 ++++++++++++++++++++++++ 2 files changed, 28 insertions(+), 4 deletions(-) diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index 05a9f91..8fcaa43 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -252,8 +252,8 @@ instance PTryFrom PData (PAsData PResultTag) where ptryFrom' d k = ptryFrom' @_ @(PAsData PInteger) d $ -- JUSTIFICATION: - -- We are coercing from @PAsData underlying@ to @PAsData (PTagged tag underlying)@. - -- Since 'PTagged' is a simple newtype, their shape is the same. + -- We are coercing from @PAsData PInteger@ to @PAsData PResultTag@. + -- Since 'PResultTag' is a simple newtype, their shape is the same. k . first punsafeCoerce -- | Plutarch-level version of 'PProposalId'. @@ -265,8 +265,8 @@ instance PTryFrom PData (PAsData PProposalId) where ptryFrom' d k = ptryFrom' @_ @(PAsData PInteger) d $ -- JUSTIFICATION: - -- We are coercing from @PAsData underlying@ to @PAsData (PTagged tag underlying)@. - -- Since 'PTagged' is a simple newtype, their shape is the same. + -- We are coercing from @PAsData PInteger@ to @PAsData PProposalId@. + -- Since 'PProposalId' is a simple newtype, their shape is the same. k . first punsafeCoerce instance PUnsafeLiftDecl PProposalId where type PLifted PProposalId = ProposalId diff --git a/agora/Agora/Proposal/Time.hs b/agora/Agora/Proposal/Time.hs index fd5063a..54e3d3d 100644 --- a/agora/Agora/Proposal/Time.hs +++ b/agora/Agora/Proposal/Time.hs @@ -22,6 +22,9 @@ module Agora.Proposal.Time ( -- * Compute ranges given config and starting time. currentProposalTime, isDraftRange, + isVotingRange, + isLockingRange, + isExecutionRange, ) where import Agora.Record (mkRecordConstr, (.&), (.=)) @@ -196,3 +199,24 @@ isDraftRange :: forall (s :: S). Term s (PProposalTimingConfig :--> PProposalSta isDraftRange = phoistAcyclic $ plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) -> proposalTimeWithin # s # (s + pfield @"draftTime" # config) + +-- | True if the 'PProposalTime' is in the voting period. +isVotingRange :: forall (s :: S). Term s (PProposalTimingConfig :--> PProposalStartingTime :--> PProposalTime :--> PBool) +isVotingRange = phoistAcyclic $ + plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) -> + pletFields @'["draftTime", "votingTime"] config $ \f -> + proposalTimeWithin # s # (s + f.draftTime + f.votingTime) + +-- | True if the 'PProposalTime' is in the locking period. +isLockingRange :: forall (s :: S). Term s (PProposalTimingConfig :--> PProposalStartingTime :--> PProposalTime :--> PBool) +isLockingRange = phoistAcyclic $ + plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) -> + pletFields @'["draftTime", "votingTime", "lockingTime"] config $ \f -> + proposalTimeWithin # s # (s + f.draftTime + f.votingTime + f.lockingTime) + +-- | True if the 'PProposalTime' is in the execution period. +isExecutionRange :: forall (s :: S). Term s (PProposalTimingConfig :--> PProposalStartingTime :--> PProposalTime :--> PBool) +isExecutionRange = phoistAcyclic $ + plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) -> + pletFields @'["draftTime", "votingTime", "lockingTime", "executingTime"] config $ \f -> + proposalTimeWithin # s # (s + f.draftTime + f.votingTime + f.lockingTime + f.executingTime) From 9dd5bed05ea4077a9399299246f6392cbf5a3ecd Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Wed, 27 Apr 2022 12:42:19 +0200 Subject: [PATCH 20/28] reduce use of unjustified `punsafeCoerce` --- agora/Agora/AuthorityToken.hs | 2 +- agora/Agora/Proposal.hs | 50 +++++++++++++++++++++++ agora/Agora/Proposal/Scripts.hs | 38 ++--------------- agora/Agora/Stake.hs | 20 +++++---- agora/Agora/Stake/Scripts.hs | 72 +++++++++++++++++++++++++++++---- agora/Agora/Utils.hs | 8 ++-- docs/tech-design/proposals.md | 9 ++++- 7 files changed, 143 insertions(+), 56 deletions(-) diff --git a/agora/Agora/AuthorityToken.hs b/agora/Agora/AuthorityToken.hs index 57baf46..241ad13 100644 --- a/agora/Agora/AuthorityToken.hs +++ b/agora/Agora/AuthorityToken.hs @@ -145,7 +145,7 @@ authorityTokenPolicy params = ( P.do passert "Parent token did not move in minting GATs" govTokenSpent passert "All outputs only emit valid GATs" $ - allOutputs @PUnit # pfromData ctx.txInfo #$ plam $ \txOut _value _address _datum -> + allOutputs @PData # pfromData ctx.txInfo #$ plam $ \txOut _value _address _datum -> authorityTokensValidIn # ownSymbol # txOut diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index 8fcaa43..a383b00 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -26,6 +26,9 @@ module Agora.Proposal ( PProposalVotes (..), PProposalId (..), PResultTag (..), + + -- * Plutarch helpers + proposalDatumValid, ) where import GHC.Generics qualified as GHC @@ -41,13 +44,17 @@ import PlutusTx.AssocMap qualified as AssocMap -------------------------------------------------------------------------------- import Agora.SafeMoney (GTTag) +import Agora.Utils (pnotNull) +import Control.Applicative (Const) import Control.Arrow (first) +import Plutarch.Builtin (PBuiltinMap) import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields, PIsDataReprInstances (..)) import Plutarch.Lift ( DerivePConstantViaNewtype (..), PConstantDecl, PUnsafeLiftDecl (..), ) +import Plutarch.Monadic qualified as P import Plutarch.SafeMoney (PDiscrete, Tagged) import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom')) import Plutarch.Unsafe (punsafeCoerce) @@ -348,6 +355,12 @@ newtype PProposalDatum (s :: S) = PProposalDatum (PlutusType, PIsData, PDataFields) via (PIsDataReprInstances PProposalDatum) +-- TODO: Derive this. +instance PTryFrom PData (PAsData PProposalDatum) where + type PTryFromExcess PData (PAsData PProposalDatum) = Const () + ptryFrom' d k = + k (punsafeCoerce d, ()) + instance PUnsafeLiftDecl PProposalDatum where type PLifted PProposalDatum = ProposalDatum deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PConstantDecl ProposalDatum) @@ -364,6 +377,12 @@ data PProposalRedeemer (s :: S) (PlutusType, PIsData) via PIsDataReprInstances PProposalRedeemer +-- See below. +instance PTryFrom PData (PAsData PProposalRedeemer) where + type PTryFromExcess PData (PAsData PProposalRedeemer) = Const () + ptryFrom' d k = + k (punsafeCoerce d, ()) + -- TODO: Waiting on PTryFrom for 'PPubKeyHash' -- deriving via -- PAsData (PIsDataReprInstances PProposalRedeemer) @@ -372,3 +391,34 @@ data PProposalRedeemer (s :: S) instance PUnsafeLiftDecl PProposalRedeemer where type PLifted PProposalRedeemer = ProposalRedeemer deriving via (DerivePConstantViaData ProposalRedeemer PProposalRedeemer) instance (PConstantDecl ProposalRedeemer) + +-------------------------------------------------------------------------------- + +{- | 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 (Agora.Proposal.PProposalDatum :--> PBool) +proposalDatumValid = + phoistAcyclic $ + plam $ \datum' -> P.do + datum <- pletFields @'["effects", "cosigners"] $ datum' + + let effects :: Term _ (PBuiltinMap Agora.Proposal.PResultTag (PBuiltinMap Plutarch.Api.V1.PValidatorHash Plutarch.Api.V1.PDatumHash)) + effects = + -- JUSTIFICATION: + -- @datum.effects : PMap PResultTag (PMap PValidatorHash PDatumHash)@ + -- @PMap PResultTag (PMap PValidatorHash PDatumHash)@ is equivalent to + -- @PBuiltinMap PResultTag (PBuiltinMap Plutarch.Api.V1.PValidatorHash Plutarch.Api.V1.PDatumHash)@ + 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 + , ptraceIfFalse "Proposal has at most five cosigners" $ plength # (pfromData datum.cosigners) #< 6 + ] diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs index 417f577..44612be 100644 --- a/agora/Agora/Proposal/Scripts.hs +++ b/agora/Agora/Proposal/Scripts.hs @@ -8,13 +8,11 @@ Plutus Scripts for Proposals. module Agora.Proposal.Scripts ( proposalValidator, proposalPolicy, - proposalDatumValid, ) where import Agora.Proposal ( PProposalDatum (PProposalDatum), PProposalRedeemer (..), - PResultTag, Proposal (governorSTAssetClass, stakeSTAssetClass), ) import Agora.Record (mkRecordConstr, (.&), (.=)) @@ -23,27 +21,23 @@ import Agora.Utils ( anyOutput, findTxOutByTxOutRef, passert, - pnotNull, psymbolValueOf, ptokenSpent, ptxSignedBy, pvalueSpent, ) import Plutarch.Api.V1 ( - PDatumHash, PMintingPolicy, PScriptContext (PScriptContext), PScriptPurpose (PMinting, PSpending), PTxInfo (PTxInfo), 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 Plutarch.TryFrom (ptryFrom) import Plutus.V1.Ledger.Value (AssetClass (AssetClass)) {- | Policy for Proposals. @@ -94,10 +88,8 @@ proposalValidator proposal = PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs txOutF <- pletFields @'["address", "value"] $ txOut - let proposalDatum :: Term _ Agora.Proposal.PProposalDatum - proposalDatum = pfromData $ punsafeCoerce datum - proposalRedeemer :: Term _ Agora.Proposal.PProposalRedeemer - proposalRedeemer = pfromData $ punsafeCoerce redeemer + (pfromData -> proposalDatum, _) <- ptryFrom @(PAsData PProposalDatum) datum + (pfromData -> proposalRedeemer, _) <- ptryFrom @(PAsData PProposalRedeemer) redeemer proposalF <- pletFields @@ -189,27 +181,3 @@ proposalValidator proposal = 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 (Agora.Proposal.PProposalDatum :--> PBool) -proposalDatumValid = - phoistAcyclic $ - plam $ \datum' -> P.do - datum <- pletFields @'["effects", "cosigners"] $ datum' - - let effects :: Term _ (PBuiltinMap Agora.Proposal.PResultTag (PBuiltinMap Plutarch.Api.V1.PValidatorHash Plutarch.Api.V1.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 - , ptraceIfFalse "Proposal has at most five cosigners" $ plength # (pfromData datum.cosigners) #< 6 - ] diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index 6788f91..b25a7ef 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -61,16 +61,17 @@ import Plutus.V1.Ledger.Value (AssetClass) import Agora.Proposal (PProposalId, PResultTag, ProposalId (..), ResultTag (..)) import Agora.SafeMoney (GTTag) import Agora.Utils ( - pfindDatum, pnotNull, + ptryFindDatum, ) +import Control.Applicative (Const) import Plutarch.Api.V1.Extra (PAssetClass, passetClassValueOf) import Plutarch.Numeric () import Plutarch.SafeMoney ( PDiscrete, Tagged (..), ) -import Plutarch.TryFrom (PTryFrom) +import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom')) -------------------------------------------------------------------------------- @@ -191,6 +192,11 @@ newtype PStakeDatum (s :: S) = PStakeDatum (PlutusType, PIsData, PDataFields) via (PIsDataReprInstances PStakeDatum) +instance PTryFrom PData (PAsData PStakeDatum) where + type PTryFromExcess PData (PAsData PStakeDatum) = Const () + ptryFrom' d k = + k (punsafeCoerce d, ()) + instance PUnsafeLiftDecl PStakeDatum where type PLifted PStakeDatum = StakeDatum deriving via (DerivePConstantViaData StakeDatum PStakeDatum) instance (PConstantDecl StakeDatum) @@ -262,7 +268,7 @@ findStakeOwnedBy :: :--> PPubKeyHash :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PBuiltinList (PAsData PTxInInfo) - :--> PMaybe PTxOut + :--> PMaybe (PAsData PStakeDatum) ) findStakeOwnedBy = phoistAcyclic $ plam $ \ac pk datums inputs -> @@ -273,9 +279,8 @@ findStakeOwnedBy = phoistAcyclic $ txOutF <- pletFields @'["datumHash"] $ txOut pmatch txOutF.datumHash $ \case PDNothing _ -> pcon PNothing - PDJust ((pfield @"_0" #) -> dh) -> - -- TODO: PTryFrom here - punsafeCoerce $ pfindDatum # dh # datums + PDJust ((pfield @"_0" #) -> dh) -> P.do + ptryFindDatum @(PAsData PStakeDatum) # dh # datums stakeDatumOwnedBy :: Term _ (PPubKeyHash :--> PStakeDatum :--> PBool) stakeDatumOwnedBy = @@ -304,8 +309,7 @@ isInputStakeOwnedBy = PDJust ((pfield @"_0" #) -> datumHash) -> pif (outStakeST #== 1) - -- TODO: use 'ptryFindDatum' instead in the future - ( pmatch (pfindDatum # datumHash # datums) $ \case + ( pmatch (ptryFindDatum @(PAsData PStakeDatum) # datumHash # datums) $ \case PNothing -> pcon PFalse PJust v -> stakeDatumOwnedBy # ss # pfromData (punsafeCoerce v) ) diff --git a/agora/Agora/Stake/Scripts.hs b/agora/Agora/Stake/Scripts.hs index 44cefac..2f80d66 100644 --- a/agora/Agora/Stake/Scripts.hs +++ b/agora/Agora/Stake/Scripts.hs @@ -35,7 +35,7 @@ import Plutarch.Api.V1 ( mintingPolicySymbol, mkMintingPolicy, ) -import Plutarch.Api.V1.Extra (passetClass) +import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf) import Plutarch.Internal (punsafeCoerce) import Plutarch.Monadic qualified as P import Plutarch.Numeric @@ -183,7 +183,12 @@ stakeValidator stake = stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake.gtClassRef) mintedST <- plet $ psymbolValueOf # stCurrencySymbol # txInfoF.mint - spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # txInfoF.inputs + valueSpent <- plet $ pvalueSpent # txInfoF.inputs + spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ valueSpent + + let AssetClass (propCs, propTn) = stake.proposalSTClass + proposalSTClass = passetClass # pconstant propCs # pconstant propTn + spentProposalST <- plet $ passetClassValueOf # valueSpent # proposalSTClass -- Is the stake currently locked? stakeIsLocked <- plet $ stakeLocked # stakeDatum' @@ -192,26 +197,76 @@ stakeValidator stake = PDestroy _ -> P.do passert "ST at inputs must be 1" $ spentST #== 1 + passert "Should burn ST" $ mintedST #== -1 + passert "Stake unlocked" $ pnot # stakeIsLocked - passert - "Owner signs this transaction" - ownerSignsTransaction + + passert "Owner signs this transaction" ownerSignsTransaction + popaque (pconstant ()) -------------------------------------------------------------------------- PRetractVotes _ -> P.do passert "Owner signs this transaction" ownerSignsTransaction - -- TODO: check proposal constraints + + passert "ST at inputs must be 1" $ + spentST #== 1 + + -- This puts trust into the Proposal. The Proposal must necessarily check + -- that this is not abused. + passert "Proposal ST spent" $ + spentProposalST #== 1 + + passert "A UTXO must exist with the correct output" $ + anyOutput @PStakeDatum # txInfo + #$ plam + $ \value address newStakeDatum' -> P.do + let isScriptAddress = pdata address #== ownAddress + let _correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum' + let valueCorrect = pdata continuingValue #== pdata value + pif + isScriptAddress + ( foldl1 + (#&&) + [ ptraceIfFalse "valueCorrect" valueCorrect + ] + ) + (pcon PFalse) + popaque (pconstant ()) -------------------------------------------------------------------------- PPermitVote _ -> P.do passert "Owner signs this transaction" ownerSignsTransaction - -- TODO: check proposal constraints + + passert "ST at inputs must be 1" $ + spentST #== 1 + + -- This puts trust into the Proposal. The Proposal must necessarily check + -- that this is not abused. + passert "Proposal ST spent" $ + spentProposalST #== 1 + + passert "A UTXO must exist with the correct output" $ + anyOutput @PStakeDatum # txInfo + #$ plam + $ \value address newStakeDatum' -> P.do + let isScriptAddress = pdata address #== ownAddress + let _correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum' + let valueCorrect = pdata continuingValue #== pdata value + pif + isScriptAddress + ( foldl1 + (#&&) + [ ptraceIfFalse "valueCorrect" valueCorrect + ] + ) + (pcon PFalse) + popaque (pconstant ()) -------------------------------------------------------------------------- PWitnessStake _ -> P.do @@ -225,6 +280,9 @@ stakeValidator stake = # propAssetClass # txInfoF.inputs + -- 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. passert "Owner signs this transaction OR proposal token is spent" (ownerSignsTransaction #|| proposalTokenMoved) diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index f60c853..0f60dde 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -84,7 +84,7 @@ pfindDatum = phoistAcyclic $ plam $ \datumHash datums -> plookupTuple # datumHash # datums -- | Find a datum with the given hash, and `ptryFrom` it. -ptryFindDatum :: PTryFrom PData a => Term s (PDatumHash :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PMaybe a) +ptryFindDatum :: forall (a :: PType) (s :: S). PTryFrom PData a => Term s (PDatumHash :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PMaybe a) ptryFindDatum = phoistAcyclic $ plam $ \datumHash inputs -> P.do pmatch (pfindDatum # datumHash # inputs) $ \case @@ -326,6 +326,7 @@ ptokenSpent = anyOutput :: forall (datum :: PType) s. ( PIsData datum + , PTryFrom PData (PAsData datum) ) => Term s (PTxInfo :--> (PValue :--> PAddress :--> datum :--> PBool) :--> PBool) anyOutput = phoistAcyclic $ @@ -337,7 +338,7 @@ anyOutput = phoistAcyclic $ PTxOut txOut' <- pmatch (pfromData txOut'') txOut <- pletFields @'["value", "datumHash", "address"] txOut' PDJust dh <- pmatch txOut.datumHash - pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo.datums) $ \case + pmatch (ptryFindDatum @(PAsData datum) # (pfield @"_0" # dh) # txInfo.datums) $ \case PJust datum -> P.do predicate # txOut.value # txOut.address # pfromData datum PNothing -> pcon PFalse @@ -348,6 +349,7 @@ anyOutput = phoistAcyclic $ allOutputs :: forall (datum :: PType) s. ( PIsData datum + , PTryFrom PData (PAsData datum) ) => Term s (PTxInfo :--> (PTxOut :--> PValue :--> PAddress :--> datum :--> PBool) :--> PBool) allOutputs = phoistAcyclic $ @@ -359,7 +361,7 @@ allOutputs = phoistAcyclic $ PTxOut txOut' <- pmatch (pfromData txOut'') txOut <- pletFields @'["value", "datumHash", "address"] txOut' PDJust dh <- pmatch txOut.datumHash - pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo.datums) $ \case + pmatch (ptryFindDatum @(PAsData datum) # (pfield @"_0" # dh) # txInfo.datums) $ \case PJust datum -> P.do predicate # pfromData txOut'' # txOut.value # txOut.address # pfromData datum PNothing -> pcon PFalse diff --git a/docs/tech-design/proposals.md b/docs/tech-design/proposals.md index a3a3fb1..6098795 100644 --- a/docs/tech-design/proposals.md +++ b/docs/tech-design/proposals.md @@ -4,7 +4,7 @@ This document gives an overview of the technical design of the proposals system | Specification | Implementation | Last revision | |:-----------:|:-----------:|:-------------:| -| WIP | WIP | v0.1 2022-04-11 | +| WIP | WIP | v0.1 2022-04-27 | --- @@ -35,7 +35,12 @@ Initiating a proposal requires the proposer to have more than a certain amount o ### Voting stages -The life-cycle of a proposal is neatly represented by a state machine, with the 'draft' phase being the initial state, and 'executed' and 'failed' being the terminating states. Please note that this state-machine representation is purely conceptual and should not be expected to reflect technical implementation. +The life-cycle of a proposal is neatly represented by a state machine, with the 'draft' phase being the initial state, and 'executed' and 'failed' being the terminating states. + +**Please note that this state-machine representation is purely conceptual and should not be expected to reflect technical implementation.** This is because some state transitions in the state machine representation don't need to happen in the actual implementation as a transaction. A key example is going from the "lock" phase to the "execution" phase. The only thing that needs to happen is that time goes by. So under the hood, they are represented the same in the Proposal's datum. + +> Emily 2022-04-27: This is quite confusing still, I feel. @Jack, could you try to reword this and make it more clear? + ![](../diagrams/ProposalStateMachine.svg) From 2865f2f093a6e10df38033d016de942e4030d260 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Wed, 27 Apr 2022 14:43:55 +0200 Subject: [PATCH 21/28] be more consistent in use of "period", "state", etc wrt. proposals - specify maximum cosigners requirement in spec. - remove silly qualified names in Proposal impl. --- agora-test/Spec/Sample/Shared.hs | 1 + agora/Agora/Proposal.hs | 18 +++++++++++------- agora/Agora/Proposal/Scripts.hs | 30 +++++++++++++++--------------- docs/tech-design/proposals.md | 24 ++++++++++++------------ 4 files changed, 39 insertions(+), 34 deletions(-) diff --git a/agora-test/Spec/Sample/Shared.hs b/agora-test/Spec/Sample/Shared.hs index 37b1afc..516435b 100644 --- a/agora-test/Spec/Sample/Shared.hs +++ b/agora-test/Spec/Sample/Shared.hs @@ -107,6 +107,7 @@ proposal = Value.assetClass govSymbol "" , stakeSTAssetClass = Value.assetClass stakeSymbol "" + , maximumCosigners = 6 } proposalPolicySymbol :: CurrencySymbol diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index a383b00..d7c6e35 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -84,8 +84,10 @@ newtype ResultTag = ResultTag {getResultTag :: Integer} deriving stock (Eq, Show, Ord) deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) -{- | The "status" of the proposal. This is only useful for state transitions, - as opposed to time-based "phases". +{- | The "status" of the proposal. This is only useful for state transitions that + need to happen as a result of a transaction as opposed to time-based "periods". + + See the note on wording & the state machine in the tech-design. If the proposal is 'VotingReady', for instance, that doesn't necessarily mean that voting is possible, as this also requires the timing to be right. @@ -220,7 +222,7 @@ data ProposalRedeemer -- === @* -> 'Finished'@: -- -- If the proposal has run out of time for the current 'ProposalStatus', it will always be possible - -- to transition into 'Finished' state, because it has expired (and failed). + -- to transition into 'Finished' status, because it has expired (and failed). AdvanceProposal deriving stock (Eq, Show, GHC.Generic) @@ -236,6 +238,8 @@ PlutusTx.makeIsDataIndexed data Proposal = Proposal { governorSTAssetClass :: AssetClass , stakeSTAssetClass :: AssetClass + , maximumCosigners :: Integer + -- ^ Arbitrary limit for maximum amount of cosigners on a proposal. } deriving stock (Show, Eq) @@ -395,11 +399,11 @@ deriving via (DerivePConstantViaData ProposalRedeemer PProposalRedeemer) instanc -------------------------------------------------------------------------------- {- | Check for various invariants a proposal must uphold. - This can be used to check both upopn creation and + This can be used to check both upon creation and upon any following state transitions in the proposal. -} -proposalDatumValid :: Term s (Agora.Proposal.PProposalDatum :--> PBool) -proposalDatumValid = +proposalDatumValid :: Proposal -> Term s (Agora.Proposal.PProposalDatum :--> PBool) +proposalDatumValid proposal = phoistAcyclic $ plam $ \datum' -> P.do datum <- pletFields @'["effects", "cosigners"] $ datum' @@ -420,5 +424,5 @@ proposalDatumValid = (#&&) [ ptraceIfFalse "Proposal has at least one ResultTag has no effects" atLeastOneNegativeResult , ptraceIfFalse "Proposal has at least one cosigner" $ pnotNull # pfromData datum.cosigners - , ptraceIfFalse "Proposal has at most five cosigners" $ plength # (pfromData datum.cosigners) #< 6 + , ptraceIfFalse "Proposal has at most five cosigners" $ plength # (pfromData datum.cosigners) #<= pconstant proposal.maximumCosigners ] diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs index 44612be..3535260 100644 --- a/agora/Agora/Proposal/Scripts.hs +++ b/agora/Agora/Proposal/Scripts.hs @@ -48,20 +48,20 @@ import Plutus.V1.Ledger.Value (AssetClass (AssetClass)) NOTE: The governor needs to check that the datum is correct and sent to the right address. -} -proposalPolicy :: Agora.Proposal.Proposal -> ClosedTerm Plutarch.Api.V1.PMintingPolicy +proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy proposalPolicy proposal = plam $ \_redeemer ctx' -> P.do - Plutarch.Api.V1.PScriptContext ctx' <- pmatch ctx' + PScriptContext ctx' <- pmatch ctx' ctx <- pletFields @'["txInfo", "purpose"] ctx' - Plutarch.Api.V1.PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo + PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo txInfo <- pletFields @'["inputs", "mint"] txInfo' - Plutarch.Api.V1.PMinting _ownSymbol <- pmatch $ pfromData ctx.purpose + PMinting _ownSymbol <- pmatch $ pfromData ctx.purpose let inputs = txInfo.inputs mintedValue = pfromData txInfo.mint AssetClass (govCs, govTn) = proposal.governorSTAssetClass - Plutarch.Api.V1.PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose + PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose let mintedProposalST = passetClassValueOf # mintedValue # (passetClass # (pfield @"_0" # ownSymbol') # pconstant "") passert "Governance state-thread token must move" $ @@ -75,15 +75,15 @@ proposalPolicy proposal = popaque (pconstant ()) -- | Validator for Proposals. -proposalValidator :: Agora.Proposal.Proposal -> ClosedTerm Plutarch.Api.V1.PValidator +proposalValidator :: Proposal -> ClosedTerm PValidator proposalValidator proposal = plam $ \datum redeemer ctx' -> P.do - Plutarch.Api.V1.PScriptContext ctx' <- pmatch ctx' + PScriptContext ctx' <- pmatch ctx' ctx <- pletFields @'["txInfo", "purpose"] ctx' txInfo <- plet $ pfromData ctx.txInfo - Plutarch.Api.V1.PTxInfo txInfo' <- pmatch txInfo + PTxInfo txInfo' <- pmatch txInfo txInfoF <- pletFields @'["inputs", "mint", "datums", "signatories"] txInfo' - Plutarch.Api.V1.PSpending ((pfield @"_0" #) -> txOutRef) <- pmatch $ pfromData ctx.purpose + PSpending ((pfield @"_0" #) -> txOutRef) <- pmatch $ pfromData ctx.purpose PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs txOutF <- pletFields @'["address", "value"] $ txOut @@ -114,13 +114,13 @@ proposalValidator proposal = signedBy <- plet $ ptxSignedBy # txInfoF.signatories pmatch proposalRedeemer $ \case - Agora.Proposal.PVote _r -> P.do + PVote _r -> P.do passert "ST at inputs must be 1" $ spentST #== 1 popaque (pconstant ()) -------------------------------------------------------------------------- - Agora.Proposal.PCosign r -> P.do + PCosign r -> P.do newSigs <- plet $ pfield @"newCosigners" # r passert "ST at inputs must be 1" $ @@ -143,14 +143,14 @@ proposalValidator proposal = # newSigs passert "Signatures are correctly added to cosignature list" $ - anyOutput @Agora.Proposal.PProposalDatum # ctx.txInfo + anyOutput @PProposalDatum # ctx.txInfo #$ plam $ \newValue address newProposalDatum -> P.do let correctDatum = pdata newProposalDatum #== pdata ( mkRecordConstr - Agora.Proposal.PProposalDatum + PProposalDatum ( #proposalId .= proposalF.proposalId .& #effects .= proposalF.effects .& #status .= proposalF.status @@ -170,13 +170,13 @@ proposalValidator proposal = popaque (pconstant ()) -------------------------------------------------------------------------- - Agora.Proposal.PUnlock _r -> P.do + PUnlock _r -> P.do passert "ST at inputs must be 1" $ spentST #== 1 popaque (pconstant ()) -------------------------------------------------------------------------- - Agora.Proposal.PAdvanceProposal _r -> P.do + PAdvanceProposal _r -> P.do passert "ST at inputs must be 1" $ spentST #== 1 diff --git a/docs/tech-design/proposals.md b/docs/tech-design/proposals.md index 6098795..2be2a23 100644 --- a/docs/tech-design/proposals.md +++ b/docs/tech-design/proposals.md @@ -35,9 +35,9 @@ Initiating a proposal requires the proposer to have more than a certain amount o ### Voting stages -The life-cycle of a proposal is neatly represented by a state machine, with the 'draft' phase being the initial state, and 'executed' and 'failed' being the terminating states. +The life-cycle of a proposal is neatly represented by a state machine, with the 'draft' state being the initial state, and 'executed' and 'failed' being the terminating states. -**Please note that this state-machine representation is purely conceptual and should not be expected to reflect technical implementation.** This is because some state transitions in the state machine representation don't need to happen in the actual implementation as a transaction. A key example is going from the "lock" phase to the "execution" phase. The only thing that needs to happen is that time goes by. So under the hood, they are represented the same in the Proposal's datum. +**Please note that this state-machine representation is purely conceptual and should not be expected to reflect technical implementation.** This is because some state transitions in the state machine representation don't need to happen in the actual implementation as a transaction. A key example is going from the "lock" phase to the "execution" phase. The only thing that needs to happen is that time goes by. So under the hood, they are represented the same in the Proposal's datum. Furthermore, in order to make our wording consistent, we use _"period"_ to mean a time-based, and _"status"_ to mean what is encoded in the datum. "State", then, refers to the more vague notion of what the state machine would look like. > Emily 2022-04-27: This is quite confusing still, I feel. @Jack, could you try to reword this and make it more clear? @@ -54,21 +54,21 @@ Consider the following 'stages' of a proposal: - `L`: the length of the locking period. - `E`: the length of the execution period. -| Action | Valid POSIXTimeRange | Valid _stored_ state(s) | -|-------------------------------------|-------------------------------------|-------------------------| -| Witness | \[S, ∞) | \* | -| Cosign | \[S, S + D) | Draft | -| AdvanceProposal | \[S, S + D) | Draft | -| Vote | \[S + D, S + D + V) | Voting | -| Unlock | \[S + D, ∞) | \* | -| CountVotes | \[S + D + V, S + D + V + L) | Voting | -| ExecuteProposal (if quorum reached) | \[S + D + V + L, S + D + V + L + E) | Voting | +| Action | Valid POSIXTimeRange | Valid _stored_ status(es) | +|-------------------------------------|-------------------------------------|---------------------------| +| Witness | \[S, ∞) | \* | +| Cosign | \[S, S + D) | Draft | +| AdvanceProposal | \[S, S + D) | Draft | +| Vote | \[S + D, S + D + V) | Voting | +| Unlock | \[S + D, ∞) | \* | +| CountVotes | \[S + D + V, S + D + V + L) | Voting | +| ExecuteProposal (if quorum reached) | \[S + D + V + L, S + D + V + L + E) | Voting | > Jack 2022-02-02: I will consider revising this table further at a later time. #### Draft phase -During the draft phase, a new UTXO at the proposal script has been created. At this stage, only votes in favor of co-signing the draft are counted. For the proposal to transition to the voting phase, a threshold of GT will have to be staked backing the proposal. This threshold will be determined on a per-system basis and could itself be a 'governable' parameter. It's important to note that cosignatures are not locking votes. Cosignatures are more like a delegated approval to a proposal. The sum of all cosignatures must tally to the threshold, and all cosigner stake datums must fit into a single transaction to witness their size. +During the draft phase, a new UTXO at the proposal script has been created. At this stage, only votes in favor of co-signing the draft are counted. For the proposal to transition to the voting phase, a threshold of GT will have to be staked backing the proposal. This threshold will be determined on a per-system basis and could itself be a 'governable' parameter. It's important to note that cosignatures are not locking votes. Cosignatures are more like a delegated approval to a proposal. The sum of all cosignatures must tally to the threshold, and all cosigner stake datums must fit into a single transaction to witness their size. A limit on the maximum amount of cosigners is placed in order to prevent a situation where the stake datums no longer fit in the transaction. The number doesn't matter and may be expressed in a parametrized way. #### Voting phase From 0ce867686074846c7bbef80e39e7a49f042ab519 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Wed, 27 Apr 2022 15:18:07 +0200 Subject: [PATCH 22/28] add effect and votes shape check on `proposalDatumValid` --- agora/Agora/Proposal.hs | 5 +++-- agora/Agora/Utils.hs | 13 +++++++++++++ 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index d7c6e35..fef4c71 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -44,7 +44,7 @@ import PlutusTx.AssocMap qualified as AssocMap -------------------------------------------------------------------------------- import Agora.SafeMoney (GTTag) -import Agora.Utils (pnotNull) +import Agora.Utils (pkeysEqual, pnotNull) import Control.Applicative (Const) import Control.Arrow (first) import Plutarch.Builtin (PBuiltinMap) @@ -406,7 +406,7 @@ proposalDatumValid :: Proposal -> Term s (Agora.Proposal.PProposalDatum :--> PBo proposalDatumValid proposal = phoistAcyclic $ plam $ \datum' -> P.do - datum <- pletFields @'["effects", "cosigners"] $ datum' + datum <- pletFields @'["effects", "cosigners", "votes"] $ datum' let effects :: Term _ (PBuiltinMap Agora.Proposal.PResultTag (PBuiltinMap Plutarch.Api.V1.PValidatorHash Plutarch.Api.V1.PDatumHash)) effects = @@ -425,4 +425,5 @@ proposalDatumValid proposal = [ ptraceIfFalse "Proposal has at least one ResultTag has no effects" atLeastOneNegativeResult , ptraceIfFalse "Proposal has at least one cosigner" $ pnotNull # pfromData datum.cosigners , ptraceIfFalse "Proposal has at most five cosigners" $ plength # (pfromData datum.cosigners) #<= pconstant proposal.maximumCosigners + , ptraceIfFalse "Proposal votes and effects are compatible with eachother" $ pkeysEqual # datum.effects # pto (pfromData datum.votes) ] diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index 0f60dde..0affea1 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -27,6 +27,7 @@ module Agora.Utils ( pnotNull, pisJust, ptokenSpent, + pkeysEqual, -- * Functions which should (probably) not be upstreamed anyOutput, @@ -68,6 +69,7 @@ import Plutarch.Api.V1.Extra (PAssetClass, passetClassValueOf, pvalueOf) import Plutarch.Api.V1.Value (PValue (PValue)) import Plutarch.Builtin (ppairDataBuiltin) import Plutarch.Internal (punsafeCoerce) +import Plutarch.Map.Extra (pkeys) import Plutarch.Monadic qualified as P import Plutarch.TryFrom (PTryFrom, ptryFrom) @@ -317,6 +319,17 @@ ptokenSpent = # 0 # inputs +{- | True if both maps have exactly the same keys. + Using @'#=='@ is not sufficient, because keys returned are not ordered. +-} +pkeysEqual :: forall (s :: S) k a b. Term s (PMap k a :--> PMap k b :--> PBool) +pkeysEqual = phoistAcyclic $ + plam $ \p q -> P.do + pks <- plet $ pkeys # p + qks <- plet $ pkeys # q + pall # plam (\pk -> pelem # pk # qks) # pks + #&& pall # plam (\qk -> pelem # qk # pks) # qks + -------------------------------------------------------------------------------- {- Functions which should (probably) not be upstreamed All of these functions are quite inefficient. From a313b2680a8625152446e9a78ec81ed2da193796 Mon Sep 17 00:00:00 2001 From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com> Date: Thu, 28 Apr 2022 09:27:03 +0100 Subject: [PATCH 23/28] add hasktags function to Makefile --- Makefile | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/Makefile b/Makefile index da13647..15de684 100644 --- a/Makefile +++ b/Makefile @@ -35,3 +35,7 @@ format_check: haddock: cabal haddock --haddock-html --haddock-hoogle --builddir=haddock + +tag: + hasktags -x agora agora-bench agora-test + From 45e52619896919223307e2054272f962dce55614 Mon Sep 17 00:00:00 2001 From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com> Date: Thu, 28 Apr 2022 09:28:58 +0100 Subject: [PATCH 24/28] Added doc to new Makefile function --- Makefile | 1 + 1 file changed, 1 insertion(+) diff --git a/Makefile b/Makefile index 15de684..6a3164c 100644 --- a/Makefile +++ b/Makefile @@ -10,6 +10,7 @@ usage: @echo " hoogle -- Start local hoogle" @echo " format -- Format the project" @echo " haddock -- Generate Haddock docs for project" + @echo " tag -- Generate CTAGS and ETAGS files for project" hoogle: pkill hoogle || true From 5ec74e86b80e98f50ef12fde4c99b5ee41049920 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Thu, 28 Apr 2022 16:18:07 +0200 Subject: [PATCH 25/28] apply suggestions --- agora-test/Spec/Sample/Proposal.hs | 14 ++-- agora-test/Spec/Sample/Shared.hs | 7 +- agora/Agora/Proposal.hs | 23 +++--- agora/Agora/Proposal/Scripts.hs | 110 ++++++++++++++++++++--------- agora/Agora/Proposal/Time.hs | 76 +++++++++++++++----- agora/Agora/Stake/Scripts.hs | 61 ++++++++++++++-- agora/Agora/Utils.hs | 40 ++++++++++- docs/tech-design/proposals.md | 41 +++++------ 8 files changed, 273 insertions(+), 99 deletions(-) diff --git a/agora-test/Spec/Sample/Proposal.hs b/agora-test/Spec/Sample/Proposal.hs index 1b560f4..7ca6514 100644 --- a/agora-test/Spec/Sample/Proposal.hs +++ b/agora-test/Spec/Sample/Proposal.hs @@ -45,6 +45,7 @@ import Agora.Proposal ( ProposalStatus (..), ProposalVotes (..), ResultTag (..), + emptyVotesFor, ) import Agora.Stake (Stake (..), StakeDatum (StakeDatum)) import Plutarch.SafeMoney (Tagged (Tagged), untag) @@ -58,21 +59,22 @@ import Spec.Util (datumPair, toDatumHash) proposalCreation :: ScriptContext proposalCreation = let st = Value.singleton proposalPolicySymbol "" 1 -- Proposal ST + effects = + AssocMap.fromList + [ (ResultTag 0, []) + , (ResultTag 1, []) + ] proposalDatum :: Datum proposalDatum = Datum ( toBuiltinData $ ProposalDatum { proposalId = ProposalId 0 - , effects = - AssocMap.fromList - [ (ResultTag 0, []) - , (ResultTag 1, []) - ] + , effects = effects , status = Draft , cosigners = [signer] , thresholds = defaultProposalThresholds - , votes = ProposalVotes AssocMap.empty + , votes = emptyVotesFor effects } ) diff --git a/agora-test/Spec/Sample/Shared.hs b/agora-test/Spec/Sample/Shared.hs index 516435b..56b136a 100644 --- a/agora-test/Spec/Sample/Shared.hs +++ b/agora-test/Spec/Sample/Shared.hs @@ -102,11 +102,8 @@ govSymbol = mintingPolicySymbol govPolicy proposal :: Proposal proposal = Proposal - { governorSTAssetClass = - -- TODO: if we had a governor here - Value.assetClass govSymbol "" - , stakeSTAssetClass = - Value.assetClass stakeSymbol "" + { governorSTAssetClass = Value.assetClass govSymbol "" + , stakeSTAssetClass = Value.assetClass stakeSymbol "" , maximumCosigners = 6 } diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index fef4c71..c5e0068 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -17,6 +17,7 @@ module Agora.Proposal ( ProposalVotes (..), ProposalId (..), ResultTag (..), + emptyVotesFor, -- * Plutarch-land PProposalDatum (..), @@ -67,7 +68,8 @@ import Plutus.V1.Ledger.Value (AssetClass) {- | Identifies a Proposal, issued upon creation of a proposal. In practice, this number starts at zero, and increments by one for each proposal. The 100th proposal will be @'ProposalId' 99@. This counter lives - in the 'Agora.Governor.Governor', see 'Agora.Governor.nextProposalId'. + in the 'Agora.Governor.Governor'. See 'Agora.Governor.nextProposalId', and + 'Agora.Governor.pgetNextProposalId'. -} newtype ProposalId = ProposalId {proposalTag :: Integer} deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) @@ -140,7 +142,7 @@ data ProposalThresholds = ProposalThresholds -- -- It is recommended this be a high enough amount, in order to prevent DOS from bad -- actors. - , vote :: Tagged GTTag Integer + , startVoting :: Tagged GTTag Integer -- ^ How much GT required to allow voting to happen. -- (i.e. to move into 'VotingReady') } @@ -165,6 +167,10 @@ newtype ProposalVotes = ProposalVotes deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) deriving stock (Eq, Show, GHC.Generic) +-- | Create a 'ProposalVotes' that has the same shape as the 'effects' field. +emptyVotesFor :: forall a. AssocMap.Map ResultTag a -> ProposalVotes +emptyVotesFor = ProposalVotes . AssocMap.mapWithKey (const . const 0) + -- | Haskell-level datum for Proposal scripts. data ProposalDatum = ProposalDatum { proposalId :: ProposalId @@ -206,18 +212,19 @@ data ProposalRedeemer -- -- === @'Draft' -> 'VotingReady'@: -- - -- 1. The sum of all of the cosigner's GT is larger than the 'vote' field of 'ProposalThresholds'. - -- 2. The proposal hasn't been alive for longer than the review time. + -- 1. The sum of all of the cosigner's GT is larger than the 'startVoting' field of 'ProposalThresholds'. + -- 2. The proposal's current time ensures 'isDraftPeriod'. -- -- === @'VotingReady' -> 'Locked'@: -- -- 1. The sum of all votes is larger than 'countVoting'. -- 2. The winning 'ResultTag' has more votes than all other 'ResultTag's. - -- 3. The proposal hasn't been alive for longer than the voting time. + -- 3. The proposal's current time ensures 'isVotingPeriod'. -- -- === @'Locked' -> 'Finished'@: -- - -- Always valid provided the conditions for the transition are met. + -- 1. The proposal's current time ensures 'isExecutionPeriod'. + -- 2. The transaction mints the GATs to the receiving effects. -- -- === @* -> 'Finished'@: -- @@ -424,6 +431,6 @@ proposalDatumValid proposal = (#&&) [ ptraceIfFalse "Proposal has at least one ResultTag has no effects" atLeastOneNegativeResult , ptraceIfFalse "Proposal has at least one cosigner" $ pnotNull # pfromData datum.cosigners - , ptraceIfFalse "Proposal has at most five cosigners" $ plength # (pfromData datum.cosigners) #<= pconstant proposal.maximumCosigners - , ptraceIfFalse "Proposal votes and effects are compatible with eachother" $ pkeysEqual # datum.effects # pto (pfromData datum.votes) + , ptraceIfFalse "Proposal has fewer cosigners than the limit" $ plength # (pfromData datum.cosigners) #<= pconstant proposal.maximumCosigners + , ptraceIfFalse "Proposal votes and effects are compatible with each other" $ pkeysEqual # datum.effects # pto (pfromData datum.votes) ] diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs index 3535260..1d06853 100644 --- a/agora/Agora/Proposal/Scripts.hs +++ b/agora/Agora/Proposal/Scripts.hs @@ -20,7 +20,9 @@ import Agora.Stake (findStakeOwnedBy) import Agora.Utils ( anyOutput, findTxOutByTxOutRef, + getMintingPolicySymbol, passert, + pisUniq, psymbolValueOf, ptokenSpent, ptxSignedBy, @@ -32,8 +34,6 @@ import Plutarch.Api.V1 ( PScriptPurpose (PMinting, PSpending), PTxInfo (PTxInfo), PValidator, - mintingPolicySymbol, - mkMintingPolicy, ) import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf) import Plutarch.Monadic qualified as P @@ -41,12 +41,22 @@ import Plutarch.TryFrom (ptryFrom) 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. + == What this policy does + + === For minting: + + - Governor is happy with mint. + + * The governor must do most of the checking for the validity of the + transaction. For example, the governor must check that the datum + is correct, and that the ST is correctly paid to the right validator. + + - Exactly 1 token is minted. + + === For burning: + + - This policy cannot be burned. -} proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy proposalPolicy proposal = @@ -62,7 +72,10 @@ proposalPolicy proposal = AssetClass (govCs, govTn) = proposal.governorSTAssetClass PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose - let mintedProposalST = passetClassValueOf # mintedValue # (passetClass # (pfield @"_0" # ownSymbol') # pconstant "") + let mintedProposalST = + passetClassValueOf + # mintedValue + # (passetClass # (pfield @"_0" # ownSymbol') # pconstant "") passert "Governance state-thread token must move" $ ptokenSpent @@ -74,7 +87,32 @@ proposalPolicy proposal = popaque (pconstant ()) --- | Validator for Proposals. +{- | The validator for Proposals. + +The documentation for various of the redeemers lives at 'Agora.Proposal.ProposalRedeemer'. + +== What this validator does + +=== Voting/unlocking + +When voting and unlocking, the proposal must witness a state transition +occuring in the relevant Stake. This transition must place a lock on +the stake that is tagged with the right 'Agora.Proposal.ResultTag', and 'Agora.Proposal.ProposalId'. + +=== Periods + +Most redeemers are time-sensitive. + +A list of all time-sensitive redeemers and their requirements: + +- 'Agora.Proposal.Vote' can only be used when both the status is in 'Agora.Proposal.VotingReady', + and 'Agora.Proposal.Time.isVotingPeriod' is true. +- 'Agora.Proposal.Cosign' can only be used when both the status is in 'Agora.Proposal.Draft', + and 'Agora.Proposal.Time.isDraftPeriod' is true. +- 'Agora.Proposal.AdvanceProposal' can only be used when the status can be advanced + (see 'Agora.Proposal.AdvanceProposal' docs). +- 'Agora.Proposal.Unlock' is always valid. +-} proposalValidator :: Proposal -> ClosedTerm PValidator proposalValidator proposal = plam $ \datum redeemer ctx' -> P.do @@ -88,8 +126,10 @@ proposalValidator proposal = PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs txOutF <- pletFields @'["address", "value"] $ txOut - (pfromData -> proposalDatum, _) <- ptryFrom @(PAsData PProposalDatum) datum - (pfromData -> proposalRedeemer, _) <- ptryFrom @(PAsData PProposalRedeemer) redeemer + (pfromData -> proposalDatum, _) <- + ptryFrom @(PAsData PProposalDatum) datum + (pfromData -> proposalRedeemer, _) <- + ptryFrom @(PAsData PProposalRedeemer) redeemer proposalF <- pletFields @@ -104,27 +144,30 @@ proposalValidator proposal = ownAddress <- plet $ txOutF.address - stCurrencySymbol <- plet $ pconstant $ Plutarch.Api.V1.mintingPolicySymbol $ Plutarch.Api.V1.mkMintingPolicy (proposalPolicy proposal) + let stCurrencySymbol = + pconstant $ getMintingPolicySymbol (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 + stakeSTAssetClass <- + plet $ passetClass # pconstant stakeSym # pconstant stakeTn + spentStakeST <- + plet $ passetClassValueOf # valueSpent # stakeSTAssetClass signedBy <- plet $ ptxSignedBy # txInfoF.signatories + passert "ST at inputs must be 1" $ + spentST #== 1 + 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 "Cosigners are unique" $ + pisUniq # newSigs passert "Signed by all new cosigners" $ pall # signedBy # newSigs @@ -136,9 +179,15 @@ proposalValidator proposal = pall # plam ( \sig -> - pmatch (findStakeOwnedBy # stakeSTAssetClass # pfromData sig # txInfoF.datums # txInfoF.inputs) $ \case - PNothing -> pcon PFalse - PJust _ -> pcon PTrue + pmatch + ( findStakeOwnedBy # stakeSTAssetClass + # pfromData sig + # txInfoF.datums + # txInfoF.inputs + ) + $ \case + PNothing -> pcon PFalse + PJust _ -> pcon PTrue ) # newSigs @@ -146,7 +195,8 @@ proposalValidator proposal = anyOutput @PProposalDatum # ctx.txInfo #$ plam $ \newValue address newProposalDatum -> P.do - let correctDatum = + let updatedSigs = pconcat # newSigs # proposalF.cosigners + correctDatum = pdata newProposalDatum #== pdata ( mkRecordConstr @@ -154,7 +204,7 @@ proposalValidator proposal = ( #proposalId .= proposalF.proposalId .& #effects .= proposalF.effects .& #status .= proposalF.status - .& #cosigners .= pdata (pconcat # newSigs # proposalF.cosigners) + .& #cosigners .= pdata updatedSigs .& #thresholds .= proposalF.thresholds .& #votes .= proposalF.votes ) @@ -164,20 +214,16 @@ proposalValidator proposal = (#&&) [ 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 + , 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 ()) diff --git a/agora/Agora/Proposal/Time.hs b/agora/Agora/Proposal/Time.hs index 54e3d3d..560bc73 100644 --- a/agora/Agora/Proposal/Time.hs +++ b/agora/Agora/Proposal/Time.hs @@ -19,12 +19,12 @@ module Agora.Proposal.Time ( PProposalTimingConfig (..), PProposalStartingTime (..), - -- * Compute ranges given config and starting time. + -- * Compute periods given config and starting time. currentProposalTime, - isDraftRange, - isVotingRange, - isLockingRange, - isExecutionRange, + isDraftPeriod, + isVotingPeriod, + isLockingPeriod, + isExecutionPeriod, ) where import Agora.Record (mkRecordConstr, (.&), (.=)) @@ -58,14 +58,14 @@ import Prelude hiding ((+)) For the purposes of proposals, there's a single most important feature: The ability to determine if we can perform an action. In order to correctly determine if we are able to perform certain actions, we need to know what - time it roughly is, compared to when the proposal got created. + time it roughly is, compared to when the proposal was created. 'ProposalTime' represents "the time according to the proposal". Its representation is opaque, and doesn't matter. Various functions work simply on 'ProposalTime' and 'ProposalTimingConfig'. In particular, 'currentProposalTime' is useful for extracting the time - from the 'Plutus.V1.Ledger.Api.txInfoValidRange' field + from the 'Plutus.V1.Ledger.Api.txInfoValidPeriod' field of 'Plutus.V1.Ledger.Api.TxInfo'. We avoid 'PPOSIXTimeRange' where we can in order to save on operations. @@ -153,7 +153,7 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig instance AdditiveSemigroup (Term s PPOSIXTime) where (punsafeCoerce @_ @_ @PInteger -> x) + (punsafeCoerce @_ @_ @PInteger -> y) = punsafeCoerce $ x + y --- | Get the current proposal time, from the 'Plutus.V1.Ledger.Api.txInfoValidRange' field. +-- | Get the current proposal time, from the 'Plutus.V1.Ledger.Api.txInfoValidPeriod' field. currentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PProposalTime) currentProposalTime = phoistAcyclic $ plam $ \iv -> P.do @@ -179,7 +179,14 @@ currentProposalTime = phoistAcyclic $ ) -- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive. -proposalTimeWithin :: Term s (PPOSIXTime :--> PPOSIXTime :--> PProposalTime :--> PBool) +proposalTimeWithin :: + Term + s + ( PPOSIXTime + :--> PPOSIXTime + :--> PProposalTime + :--> PBool + ) proposalTimeWithin = phoistAcyclic $ plam $ \l h proposalTime' -> P.do PProposalTime proposalTime <- pmatch proposalTime' @@ -195,28 +202,61 @@ proposalTimeWithin = phoistAcyclic $ ] -- | True if the 'PProposalTime' is in the draft period. -isDraftRange :: forall (s :: S). Term s (PProposalTimingConfig :--> PProposalStartingTime :--> PProposalTime :--> PBool) -isDraftRange = phoistAcyclic $ +isDraftPeriod :: + forall (s :: S). + Term + s + ( PProposalTimingConfig + :--> PProposalStartingTime + :--> PProposalTime + :--> PBool + ) +isDraftPeriod = phoistAcyclic $ plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) -> proposalTimeWithin # s # (s + pfield @"draftTime" # config) -- | True if the 'PProposalTime' is in the voting period. -isVotingRange :: forall (s :: S). Term s (PProposalTimingConfig :--> PProposalStartingTime :--> PProposalTime :--> PBool) -isVotingRange = phoistAcyclic $ +isVotingPeriod :: + forall (s :: S). + Term + s + ( PProposalTimingConfig + :--> PProposalStartingTime + :--> PProposalTime + :--> PBool + ) +isVotingPeriod = phoistAcyclic $ plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) -> pletFields @'["draftTime", "votingTime"] config $ \f -> proposalTimeWithin # s # (s + f.draftTime + f.votingTime) -- | True if the 'PProposalTime' is in the locking period. -isLockingRange :: forall (s :: S). Term s (PProposalTimingConfig :--> PProposalStartingTime :--> PProposalTime :--> PBool) -isLockingRange = phoistAcyclic $ +isLockingPeriod :: + forall (s :: S). + Term + s + ( PProposalTimingConfig + :--> PProposalStartingTime + :--> PProposalTime + :--> PBool + ) +isLockingPeriod = phoistAcyclic $ plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) -> pletFields @'["draftTime", "votingTime", "lockingTime"] config $ \f -> proposalTimeWithin # s # (s + f.draftTime + f.votingTime + f.lockingTime) -- | True if the 'PProposalTime' is in the execution period. -isExecutionRange :: forall (s :: S). Term s (PProposalTimingConfig :--> PProposalStartingTime :--> PProposalTime :--> PBool) -isExecutionRange = phoistAcyclic $ +isExecutionPeriod :: + forall (s :: S). + Term + s + ( PProposalTimingConfig + :--> PProposalStartingTime + :--> PProposalTime + :--> PBool + ) +isExecutionPeriod = phoistAcyclic $ plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) -> pletFields @'["draftTime", "votingTime", "lockingTime", "executingTime"] config $ \f -> - proposalTimeWithin # s # (s + f.draftTime + f.votingTime + f.lockingTime + f.executingTime) + proposalTimeWithin # s + # (s + f.draftTime + f.votingTime + f.lockingTime + f.executingTime) diff --git a/agora/Agora/Stake/Scripts.hs b/agora/Agora/Stake/Scripts.hs index 2f80d66..48483d3 100644 --- a/agora/Agora/Stake/Scripts.hs +++ b/agora/Agora/Stake/Scripts.hs @@ -65,7 +65,10 @@ import Prelude hiding (Num (..)) - Check that exactly one state thread is burned. - Check that datum at state thread is valid and not locked. -} -stakePolicy :: Tagged GTTag AssetClass -> ClosedTerm PMintingPolicy +stakePolicy :: + -- | The (governance) token that a Stake can store. + Tagged GTTag AssetClass -> + ClosedTerm PMintingPolicy stakePolicy gtClassRef = plam $ \_redeemer ctx' -> P.do ctx <- pletFields @'["txInfo", "purpose"] ctx' @@ -157,7 +160,59 @@ stakePolicy gtClassRef = -------------------------------------------------------------------------------- --- | Validator intended for Stake UTXOs to live in. +-- | Validator intended for Stake UTXOs to be locked by. +-- +-- +-- == What this Validator does: +-- +-- === 'DepositWithdraw' +-- +-- Deposit or withdraw some GT to the stake. +-- +-- - Tx must be signed by the owner. +-- - The 'stakedAmount' field must be updated. +-- - The stake must not be locked. +-- - The new UTXO must have the previous value plus the difference +-- as stated by the redeemer. +-- +-- === 'PermitVote' +-- +-- Allow a 'ProposalLock' to be put on the stake in order to vote +-- on a proposal. +-- +-- - A proposal token must be spent alongside the stake. +-- +-- * Its total votes must be correctly updated to include this stake's +-- contribution. +-- +-- - Tx must be signed by the owner. +-- +-- +-- === 'RetractVotes' +-- +-- Remove a 'ProposalLock' set when voting on a proposal. +-- +-- - A proposal token must be spent alongside the stake. +-- - Tx must be signed by the owner. +-- +-- +-- === 'Destroy' +-- +-- Destroy the stake in order to reclaim the min ADA. +-- +-- - The stake must not be locked. +-- - Tx must be signed by the owner. +-- +-- +-- === 'WitnessStake' +-- +-- Allow this Stake to be included in a transaction without making +-- any changes to it. In the future, +-- this could use [CIP-31](https://cips.cardano.org/cips/cip31/) instead. +-- +-- - Tx must be signed by the owner __or__ a proposal ST token must be spent +-- alongside the stake. +-- - The datum and value must remain unchanged. stakeValidator :: Stake -> ClosedTerm PValidator stakeValidator stake = plam $ \datum redeemer ctx' -> P.do @@ -243,8 +298,6 @@ stakeValidator stake = "Owner signs this transaction" ownerSignsTransaction - passert "ST at inputs must be 1" $ - spentST #== 1 -- This puts trust into the Proposal. The Proposal must necessarily check -- that this is not abused. diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index 0affea1..bb852c4 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -28,6 +28,8 @@ module Agora.Utils ( pisJust, ptokenSpent, pkeysEqual, + pnub, + pisUniq, -- * Functions which should (probably) not be upstreamed anyOutput, @@ -38,6 +40,7 @@ module Agora.Utils ( findOutputsToAddress, findTxOutDatum, validatorHashToTokenName, + getMintingPolicySymbol, ) where -------------------------------------------------------------------------------- @@ -54,6 +57,7 @@ import Plutarch.Api.V1 ( PDatumHash, PMap, PMaybeData (PDJust), + PMintingPolicy, PPubKeyHash, PTokenName (PTokenName), PTuple, @@ -63,6 +67,8 @@ import Plutarch.Api.V1 ( PTxOutRef, PValidatorHash, PValue, + mintingPolicySymbol, + mkMintingPolicy, ) import Plutarch.Api.V1.AssocMap (PMap (PMap)) import Plutarch.Api.V1.Extra (PAssetClass, passetClassValueOf, pvalueOf) @@ -72,6 +78,7 @@ import Plutarch.Internal (punsafeCoerce) import Plutarch.Map.Extra (pkeys) import Plutarch.Monadic qualified as P import Plutarch.TryFrom (PTryFrom, ptryFrom) +import Plutus.V1.Ledger.Api (CurrencySymbol) -------------------------------------------------------------------------------- -- Validator-level utility functions @@ -88,7 +95,7 @@ pfindDatum = phoistAcyclic $ -- | Find a datum with the given hash, and `ptryFrom` it. ptryFindDatum :: forall (a :: PType) (s :: S). PTryFrom PData a => Term s (PDatumHash :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PMaybe a) ptryFindDatum = phoistAcyclic $ - plam $ \datumHash inputs -> P.do + plam $ \datumHash inputs -> pmatch (pfindDatum # datumHash # inputs) $ \case PNothing -> pcon PNothing PJust datum -> P.do @@ -330,6 +337,30 @@ pkeysEqual = phoistAcyclic $ pall # plam (\pk -> pelem # pk # qks) # pks #&& pall # plam (\qk -> pelem # qk # pks) # qks +-- | / O(n^2) /. Clear out duplicates in a list. The order is not preserved. +pnub :: forall list a (s :: S). (PEq a, PIsListLike list a) => Term s (list a :--> list a) +pnub = + phoistAcyclic $ + precList + ( \self x xs -> + pif + (pnot #$ pelem # x # xs) + (pcons # x # (self # xs)) + (self # xs) + ) + (const pnil) + +-- | / O(n^2) /. Check if a list contains no duplicates. +pisUniq :: forall list a (s :: S). (PEq a, PIsListLike list a) => Term s (list a :--> PBool) +pisUniq = + phoistAcyclic $ + precList + ( \self x xs -> + (pnot #$ pelem # x # xs) + #&& (self # xs) + ) + (const $ pcon PTrue) + -------------------------------------------------------------------------------- {- Functions which should (probably) not be upstreamed All of these functions are quite inefficient. @@ -447,5 +478,12 @@ findTxOutDatum = phoistAcyclic $ PDJust ((pfield @"_0" #) -> datumHash) -> pfindDatum # datumHash # datums _ -> pcon PNothing +{- | Safely convert a 'PValidatorHash' into a 'PTokenName'. This can be useful for tagging + tokens for extra safety. +-} validatorHashToTokenName :: forall (s :: S). Term s PValidatorHash -> Term s PTokenName validatorHashToTokenName vh = pcon (PTokenName (pto vh)) + +-- | Get the CurrencySymbol of a PMintingPolicy. +getMintingPolicySymbol :: ClosedTerm PMintingPolicy -> CurrencySymbol +getMintingPolicySymbol v = mintingPolicySymbol $ mkMintingPolicy v diff --git a/docs/tech-design/proposals.md b/docs/tech-design/proposals.md index 2be2a23..3a4a82d 100644 --- a/docs/tech-design/proposals.md +++ b/docs/tech-design/proposals.md @@ -37,38 +37,29 @@ Initiating a proposal requires the proposer to have more than a certain amount o The life-cycle of a proposal is neatly represented by a state machine, with the 'draft' state being the initial state, and 'executed' and 'failed' being the terminating states. -**Please note that this state-machine representation is purely conceptual and should not be expected to reflect technical implementation.** This is because some state transitions in the state machine representation don't need to happen in the actual implementation as a transaction. A key example is going from the "lock" phase to the "execution" phase. The only thing that needs to happen is that time goes by. So under the hood, they are represented the same in the Proposal's datum. Furthermore, in order to make our wording consistent, we use _"period"_ to mean a time-based, and _"status"_ to mean what is encoded in the datum. "State", then, refers to the more vague notion of what the state machine would look like. +Note: this state-machine representation is purely conceptual and should not be expected to reflect technical implementation. +**Please note that this state-machine representation is purely conceptual and should not be expected to reflect technical implementation.** This is because some transitions in the state machine representation don't need to happen on-chain, as a transaction. A key example of this is a proposal going from the "lock" phase to the "execution" phase. No on-chain transition takes place: it is simply that we have reached the time in the real-world, when the proposal is allowed to be executed. -> Emily 2022-04-27: This is quite confusing still, I feel. @Jack, could you try to reword this and make it more clear? +To make the following diagram clear, we employ the following terminology: + + +> state +> A 'state' in our conceptual FSM representation above. Useful for thinking about proposals. Does not necessarily reflect a change occurring on-chain. + + +> period +> A segment of real-world, POSIX time. As we transition from one period to another, a proposal's status (see below) will not be updated. + + +> status +> The 'status' of a proposal is stored in the proposal's datum and is thus always represented on-chain. Changing this requires a transaction to take place. ![](../diagrams/ProposalStateMachine.svg) -#### When may interactions occur? - -Consider the following 'stages' of a proposal: - -- `S`: when the proposal was created. -- `D`: the length of the draft period. -- `V`: the length of the voting period. -- `L`: the length of the locking period. -- `E`: the length of the execution period. - -| Action | Valid POSIXTimeRange | Valid _stored_ status(es) | -|-------------------------------------|-------------------------------------|---------------------------| -| Witness | \[S, ∞) | \* | -| Cosign | \[S, S + D) | Draft | -| AdvanceProposal | \[S, S + D) | Draft | -| Vote | \[S + D, S + D + V) | Voting | -| Unlock | \[S + D, ∞) | \* | -| CountVotes | \[S + D + V, S + D + V + L) | Voting | -| ExecuteProposal (if quorum reached) | \[S + D + V + L, S + D + V + L + E) | Voting | - -> Jack 2022-02-02: I will consider revising this table further at a later time. - #### Draft phase -During the draft phase, a new UTXO at the proposal script has been created. At this stage, only votes in favor of co-signing the draft are counted. For the proposal to transition to the voting phase, a threshold of GT will have to be staked backing the proposal. This threshold will be determined on a per-system basis and could itself be a 'governable' parameter. It's important to note that cosignatures are not locking votes. Cosignatures are more like a delegated approval to a proposal. The sum of all cosignatures must tally to the threshold, and all cosigner stake datums must fit into a single transaction to witness their size. A limit on the maximum amount of cosigners is placed in order to prevent a situation where the stake datums no longer fit in the transaction. The number doesn't matter and may be expressed in a parametrized way. +During the draft phase, a new UTXO at the proposal script has been created. At this stage, only votes in favor of co-signing the draft are counted. For the proposal to transition to the voting phase, a threshold of GT will have to be staked backing the proposal. This threshold will be determined on a per-system basis and could itself be a 'governable' parameter. It's important to note that cosignatures are not locking votes. Cosignatures are more like a delegated approval to a proposal. The sum of all cosignatures must tally to the threshold, and all cosigner stake datums must fit into a single transaction to witness their size. A limit on the maximum amount of cosigners is placed in order to prevent a situation where the stake datums no longer fit in the transaction. The number doesn't matter and may be expressed in a parameterized way. #### Voting phase From c8f5c6af8fbb5abbe9ca21df2e8165675543717d Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Thu, 28 Apr 2022 16:20:05 +0200 Subject: [PATCH 26/28] remove `pfindDatum'`, in favour of `ptryFindDatum` --- agora-test/Spec/Sample/Proposal.hs | 13 +++++++------ agora/Agora/Utils.hs | 11 ++--------- 2 files changed, 9 insertions(+), 15 deletions(-) diff --git a/agora-test/Spec/Sample/Proposal.hs b/agora-test/Spec/Sample/Proposal.hs index 7ca6514..91aa9a4 100644 --- a/agora-test/Spec/Sample/Proposal.hs +++ b/agora-test/Spec/Sample/Proposal.hs @@ -154,19 +154,20 @@ stakeRef = TxOutRef "0ca36f3a357bc69579ab2531aecd1e7d3714d993c7820f40b864be15" 0 cosignProposal :: [PubKeyHash] -> TxInfo cosignProposal newSigners = let st = Value.singleton proposalPolicySymbol "" 1 -- Proposal ST + effects = + AssocMap.fromList + [ (ResultTag 0, []) + , (ResultTag 1, []) + ] proposalBefore :: ProposalDatum proposalBefore = ProposalDatum { proposalId = ProposalId 0 - , effects = - AssocMap.fromList - [ (ResultTag 0, []) - , (ResultTag 1, []) - ] + , effects = effects , status = Draft , cosigners = [signer] , thresholds = defaultProposalThresholds - , votes = ProposalVotes AssocMap.empty + , votes = emptyVotesFor effects } stakeDatum :: StakeDatum stakeDatum = StakeDatum (Tagged 50_000_000) signer2 [] diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index bb852c4..874ecfe 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -10,7 +10,6 @@ module Agora.Utils ( passert, pfind', pfindDatum, - pfindDatum', ptryFindDatum, pvalueSpent, ptxSignedBy, @@ -74,7 +73,6 @@ import Plutarch.Api.V1.AssocMap (PMap (PMap)) import Plutarch.Api.V1.Extra (PAssetClass, passetClassValueOf, pvalueOf) import Plutarch.Api.V1.Value (PValue (PValue)) import Plutarch.Builtin (ppairDataBuiltin) -import Plutarch.Internal (punsafeCoerce) import Plutarch.Map.Extra (pkeys) import Plutarch.Monadic qualified as P import Plutarch.TryFrom (PTryFrom, ptryFrom) @@ -102,12 +100,6 @@ ptryFindDatum = phoistAcyclic $ (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. --} -pfindDatum' :: PIsData a => Term s (PDatumHash :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PMaybe (PAsData a)) -pfindDatum' = phoistAcyclic $ plam $ \dh x -> punsafeCoerce $ pfindDatum # dh # x - -- | Check if a PubKeyHash signs this transaction. ptxSignedBy :: Term s (PBuiltinList (PAsData PPubKeyHash) :--> PAsData PPubKeyHash :--> PBool) ptxSignedBy = phoistAcyclic $ @@ -416,6 +408,7 @@ allOutputs = phoistAcyclic $ anyInput :: forall (datum :: PType) s. ( PIsData datum + , PTryFrom PData (PAsData datum) ) => Term s (PTxInfo :--> (PValue :--> PAddress :--> datum :--> PBool) :--> PBool) anyInput = phoistAcyclic $ @@ -429,7 +422,7 @@ anyInput = phoistAcyclic $ PTxOut txOut' <- pmatch (pfromData txOut'') txOut <- pletFields @'["value", "datumHash", "address"] txOut' PDJust dh <- pmatch txOut.datumHash - pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo.datums) $ \case + pmatch (ptryFindDatum @(PAsData datum) # (pfield @"_0" # dh) # txInfo.datums) $ \case PJust datum -> P.do predicate # txOut.value # txOut.address # pfromData datum PNothing -> pcon PFalse From cf14d9edd830dadf42e5b97944b5a67ef228d6ce Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Thu, 28 Apr 2022 17:00:19 +0200 Subject: [PATCH 27/28] remove infinities in ProposalTime, fix test build --- agora-test/Spec/Proposal.hs | 9 +++++-- agora-test/Spec/Sample/Proposal.hs | 1 - agora-test/Spec/Sample/Shared.hs | 2 +- agora/Agora/Proposal/Scripts.hs | 3 +-- agora/Agora/Proposal/Time.hs | 42 +++++++++++++++--------------- 5 files changed, 30 insertions(+), 27 deletions(-) diff --git a/agora-test/Spec/Proposal.hs b/agora-test/Spec/Proposal.hs index b80d144..bd79762 100644 --- a/agora-test/Spec/Proposal.hs +++ b/agora-test/Spec/Proposal.hs @@ -16,10 +16,10 @@ import Agora.Proposal ( ProposalId (ProposalId), ProposalRedeemer (Cosign), ProposalStatus (Draft), - ProposalVotes (ProposalVotes), ResultTag (ResultTag), cosigners, effects, + emptyVotesFor, proposalId, status, thresholds, @@ -70,7 +70,12 @@ tests = , status = Draft , cosigners = [signer] , thresholds = Shared.defaultProposalThresholds - , votes = ProposalVotes AssocMap.empty + , votes = + emptyVotesFor $ + AssocMap.fromList + [ (ResultTag 0, []) + , (ResultTag 1, []) + ] } ) (Cosign [signer2]) diff --git a/agora-test/Spec/Sample/Proposal.hs b/agora-test/Spec/Sample/Proposal.hs index 91aa9a4..6112ec0 100644 --- a/agora-test/Spec/Sample/Proposal.hs +++ b/agora-test/Spec/Sample/Proposal.hs @@ -43,7 +43,6 @@ import Agora.Proposal ( ProposalDatum (..), ProposalId (..), ProposalStatus (..), - ProposalVotes (..), ResultTag (..), emptyVotesFor, ) diff --git a/agora-test/Spec/Sample/Shared.hs b/agora-test/Spec/Sample/Shared.hs index 56b136a..bd4957f 100644 --- a/agora-test/Spec/Sample/Shared.hs +++ b/agora-test/Spec/Sample/Shared.hs @@ -129,5 +129,5 @@ defaultProposalThresholds = ProposalThresholds { countVoting = Tagged 1000 , create = Tagged 1 - , vote = Tagged 10 + , startVoting = Tagged 10 } diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs index 1d06853..2e7a52d 100644 --- a/agora/Agora/Proposal/Scripts.hs +++ b/agora/Agora/Proposal/Scripts.hs @@ -212,8 +212,7 @@ proposalValidator proposal = foldr1 (#&&) - [ pcon PTrue - , ptraceIfFalse "Datum must be correct" correctDatum + [ ptraceIfFalse "Datum must be correct" correctDatum , ptraceIfFalse "Value should be correct" $ pdata txOutF.value #== pdata newValue , ptraceIfFalse "Must be sent to Proposal's address" $ diff --git a/agora/Agora/Proposal/Time.hs b/agora/Agora/Proposal/Time.hs index 560bc73..ec20f53 100644 --- a/agora/Agora/Proposal/Time.hs +++ b/agora/Agora/Proposal/Time.hs @@ -34,7 +34,6 @@ import Plutarch.Api.V1 ( PExtended (PFinite), PInterval (PInterval), PLowerBound (PLowerBound), - PMaybeData (PDJust, PDNothing), PPOSIXTime, PPOSIXTimeRange, PUpperBound (PUpperBound), @@ -71,8 +70,8 @@ import Prelude hiding ((+)) We avoid 'PPOSIXTimeRange' where we can in order to save on operations. -} data ProposalTime = ProposalTime - { lowerBound :: Maybe POSIXTime - , upperBound :: Maybe POSIXTime + { lowerBound :: POSIXTime + , upperBound :: POSIXTime } deriving stock (Eq, Show, GHC.Generic) @@ -111,8 +110,8 @@ newtype PProposalTime (s :: S) ( Term s ( PDataRecord - '[ "lowerBound" ':= PMaybeData PPOSIXTime - , "upperBound" ':= PMaybeData PPOSIXTime + '[ "lowerBound" ':= PPOSIXTime + , "upperBound" ':= PPOSIXTime ] ) ) @@ -153,7 +152,11 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig instance AdditiveSemigroup (Term s PPOSIXTime) where (punsafeCoerce @_ @_ @PInteger -> x) + (punsafeCoerce @_ @_ @PInteger -> y) = punsafeCoerce $ x + y --- | Get the current proposal time, from the 'Plutus.V1.Ledger.Api.txInfoValidPeriod' field. +{- | Get the current proposal time, from the 'Plutus.V1.Ledger.Api.txInfoValidPeriod' field. + + If it's impossible to get a fully-bounded time, (e.g. either end of the 'PPOSIXTimeRange' is + an infinity) then we error out. +-} currentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PProposalTime) currentProposalTime = phoistAcyclic $ plam $ \iv -> P.do @@ -165,17 +168,18 @@ currentProposalTime = phoistAcyclic $ ubf <- pletFields @'["_0", "_1"] ub mkRecordConstr PProposalTime $ #lowerBound - .= pdata - ( pmatch lbf._0 $ - \case - PFinite d -> pcon (PDJust d) - _ -> pcon (PDNothing pdnil) + .= pmatch + lbf._0 + ( \case + PFinite ((pfield @"_0" #) -> d) -> d + _ -> ptraceError "currentProposalTime: Can't get fully-bounded proposal time." ) .& #upperBound - .= pdata - ( pmatch ubf._0 $ \case - PFinite d -> pcon (PDJust d) - _ -> pcon (PDNothing pdnil) + .= pmatch + ubf._0 + ( \case + PFinite ((pfield @"_0" #) -> d) -> d + _ -> ptraceError "currentProposalTime: Can't get fully-bounded proposal time." ) -- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive. @@ -193,12 +197,8 @@ proposalTimeWithin = phoistAcyclic $ ptf <- pletFields @'["lowerBound", "upperBound"] proposalTime foldr1 (#&&) - [ pmatch ptf.lowerBound $ \case - PDJust lb -> l #<= pfromData (pfield @"_0" # lb) - _ -> pcon PFalse - , pmatch ptf.upperBound $ \case - PDJust lb -> pfromData (pfield @"_0" # lb) #<= h - _ -> pcon PFalse + [ l #<= pfromData ptf.lowerBound + , pfromData ptf.upperBound #<= h ] -- | True if the 'PProposalTime' is in the draft period. From be3b8ea5af7baa4a2f924a8109c6e2f8b3699fb2 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Thu, 28 Apr 2022 17:22:40 +0200 Subject: [PATCH 28/28] fix formatting fourmolu breaks weirdly on some spacing --- agora/Agora/Stake/Scripts.hs | 104 +++++++++++++++++------------------ 1 file changed, 50 insertions(+), 54 deletions(-) diff --git a/agora/Agora/Stake/Scripts.hs b/agora/Agora/Stake/Scripts.hs index 48483d3..10e0df9 100644 --- a/agora/Agora/Stake/Scripts.hs +++ b/agora/Agora/Stake/Scripts.hs @@ -160,59 +160,56 @@ stakePolicy gtClassRef = -------------------------------------------------------------------------------- --- | Validator intended for Stake UTXOs to be locked by. --- --- --- == What this Validator does: --- --- === 'DepositWithdraw' --- --- Deposit or withdraw some GT to the stake. --- --- - Tx must be signed by the owner. --- - The 'stakedAmount' field must be updated. --- - The stake must not be locked. --- - The new UTXO must have the previous value plus the difference --- as stated by the redeemer. --- --- === 'PermitVote' --- --- Allow a 'ProposalLock' to be put on the stake in order to vote --- on a proposal. --- --- - A proposal token must be spent alongside the stake. --- --- * Its total votes must be correctly updated to include this stake's --- contribution. --- --- - Tx must be signed by the owner. --- --- --- === 'RetractVotes' --- --- Remove a 'ProposalLock' set when voting on a proposal. --- --- - A proposal token must be spent alongside the stake. --- - Tx must be signed by the owner. --- --- --- === 'Destroy' --- --- Destroy the stake in order to reclaim the min ADA. --- --- - The stake must not be locked. --- - Tx must be signed by the owner. --- --- --- === 'WitnessStake' --- --- Allow this Stake to be included in a transaction without making --- any changes to it. In the future, --- this could use [CIP-31](https://cips.cardano.org/cips/cip31/) instead. --- --- - Tx must be signed by the owner __or__ a proposal ST token must be spent --- alongside the stake. --- - The datum and value must remain unchanged. +{- | Validator intended for Stake UTXOs to be locked by. + +== What this Validator does: + +=== 'DepositWithdraw' + +Deposit or withdraw some GT to the stake. + +- Tx must be signed by the owner. +- The 'stakedAmount' field must be updated. +- The stake must not be locked. +- The new UTXO must have the previous value plus the difference + as stated by the redeemer. + +=== 'PermitVote' + +Allow a 'ProposalLock' to be put on the stake in order to vote +on a proposal. + +- A proposal token must be spent alongside the stake. + + * Its total votes must be correctly updated to include this stake's + contribution. + +- Tx must be signed by the owner. + +=== 'RetractVotes' + +Remove a 'ProposalLock' set when voting on a proposal. + +- A proposal token must be spent alongside the stake. +- Tx must be signed by the owner. + +=== 'Destroy' + +Destroy the stake in order to reclaim the min ADA. + +- The stake must not be locked. +- Tx must be signed by the owner. + +=== 'WitnessStake' + +Allow this Stake to be included in a transaction without making +any changes to it. In the future, +this could use [CIP-31](https://cips.cardano.org/cips/cip31/) instead. + +- Tx must be signed by the owner __or__ a proposal ST token must be spent + alongside the stake. +- The datum and value must remain unchanged. +-} stakeValidator :: Stake -> ClosedTerm PValidator stakeValidator stake = plam $ \datum redeemer ctx' -> P.do @@ -298,7 +295,6 @@ stakeValidator stake = "Owner signs this transaction" ownerSignsTransaction - -- This puts trust into the Proposal. The Proposal must necessarily check -- that this is not abused. passert "Proposal ST spent" $