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 ->