Sulkta-Coop/agora
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

add checks to cosign

Browse source
This commit is contained in:
Emily Martins 2022-04-19 22:31:38 +02:00
parent 7634460241
commit 18df6ead55
7 changed files with 241 additions and 44 deletions
Download patch file Download diff file Expand all files Collapse all files

42
agora-test/Spec/Proposal.hs
View file

@ -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])
]
]

138
agora-test/Spec/Sample/Proposal.hs
View file

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

3
agora-test/Spec/Sample/Stake.hs
View file

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

8
agora-test/Spec/Stake.hs
View file

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

39
agora/Agora/Proposal.hs
View file

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

49
agora/Agora/Stake.hs
View file

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

6
agora/Agora/Utils.hs
View file

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