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

Merge pull request #136 from Liqwid-Labs/connor/draft-phrase

Browse source
This commit is contained in:
方泓睿 2022-07-06 22:20:35 +08:00 • committed by GitHub
commit 79563c8d64
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
16 changed files with 2150 additions and 1664 deletions
Download patch file Download diff file Expand all files Collapse all files

15
agora-specs/Sample/Effect/TreasuryWithdrawal.hs
View file

@ -23,17 +23,13 @@ import Agora.Effect.TreasuryWithdrawal (
TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
treasuryWithdrawalValidator,
)
import Crypto.Hash qualified as Crypto
import Data.ByteArray qualified as BA
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as C (pack)
import Plutarch.Api.V1 (mkValidator, validatorHash)
import PlutusLedgerApi.V1 (
Address (Address),
Credential (..),
CurrencySymbol (CurrencySymbol),
DatumHash (DatumHash),
PubKeyHash (PubKeyHash),
PubKeyHash,
ScriptContext (..),
ScriptPurpose (Spending),
TokenName (TokenName),
@ -56,10 +52,10 @@ import PlutusLedgerApi.V1 (
Validator,
ValidatorHash (ValidatorHash),
Value,
toBuiltin,
)
import PlutusLedgerApi.V1.Interval qualified as Interval (always)
import PlutusLedgerApi.V1.Value qualified as Value (singleton)
import Test.Util (scriptCredentials, userCredentials)
-- | A sample Currency Symbol.
currSymbol :: CurrencySymbol
@ -69,16 +65,13 @@ currSymbol = CurrencySymbol "12312099"
signer :: PubKeyHash
signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
blake2b_224 :: BS.ByteString -> BS.ByteString
blake2b_224 = BS.pack . BA.unpack . Crypto.hashWith Crypto.Blake2b_224
-- | List of users who the effect will pay to.
users :: [Credential]
users = PubKeyCredential . PubKeyHash . toBuiltin . blake2b_224 . C.pack . show <$> ([1 ..] :: [Integer])
users = userCredentials
-- | List of users who the effect will pay to.
treasuries :: [Credential]
treasuries = ScriptCredential . ValidatorHash . toBuiltin . blake2b_224 . C.pack . show <$> ([1 ..] :: [Integer])
treasuries = scriptCredentials
inputGAT :: TxInInfo
inputGAT =

701
agora-specs/Sample/Proposal.hs
View file

@ -8,17 +8,6 @@ This module tests primarily the happy path for Proposal interactions
module Sample.Proposal (
-- * Script contexts
proposalCreation,
cosignProposal,
proposalRef,
stakeRef,
voteOnProposal,
VotingParameters (..),
advanceProposalSuccess,
advanceProposalFailureTimeout,
TransitionParameters (..),
advanceFinishedProposal,
advanceProposalInsufficientVotes,
advanceProposalWithInvalidOutputStake,
) where
import Agora.Governor (GovernorDatum (..))
@ -27,78 +16,41 @@ import Agora.Proposal (
ProposalDatum (..),
ProposalId (..),
ProposalStatus (..),
ProposalThresholds (..),
ProposalVotes (..),
ResultTag (..),
emptyVotesFor,
)
import Agora.Proposal.Time (
ProposalStartingTime (ProposalStartingTime),
ProposalTimingConfig (..),
)
import Agora.Stake (
ProposalLock (ProposalLock),
Stake (..),
StakeDatum (..),
)
import Data.Default.Class (Default (def))
import Data.Tagged (Tagged (..), untag)
import Plutarch.Context (
BaseBuilder,
MintingBuilder,
buildMintingUnsafe,
buildTxInfoUnsafe,
input,
mint,
output,
script,
signedWith,
timeRange,
txId,
withDatum,
withRefIndex,
withTxId,
withValue,
)
import PlutusLedgerApi.V1 (
Datum (Datum),
DatumHash,
POSIXTime,
POSIXTimeRange,
PubKeyHash,
ScriptContext (..),
ToData (toBuiltinData),
TxInInfo (TxInInfo),
TxInfo (..),
TxOut (TxOut, txOutAddress, txOutDatumHash, txOutValue),
TxOutRef (..),
ValidatorHash,
)
import PlutusLedgerApi.V1.Value qualified as Value (
assetClassValue,
singleton,
)
import PlutusTx.AssocMap qualified as AssocMap
import Sample.Proposal.Shared (proposalRef, stakeRef)
import Sample.Shared (
govValidatorHash,
minAda,
proposal,
proposalPolicySymbol,
proposalStartingTimeFromTimeRange,
proposalValidatorHash,
signer,
signer2,
stake,
stakeAddress,
stakeAssetClass,
stakeValidatorHash,
)
import Test.Util (
closedBoundedInterval,
datumPair,
toDatumHash,
updateMap,
)
proposalCreation :: ScriptContext
@ -160,656 +112,3 @@ proposalCreation =
. withDatum govAfter
]
in buildMintingUnsafe builder
-- | This script context should be a valid transaction.
cosignProposal :: [PubKeyHash] -> TxInfo
cosignProposal newSigners =
let st = Value.singleton proposalPolicySymbol "" 1 -- Proposal ST
effects =
AssocMap.fromList
[ (ResultTag 0, AssocMap.empty)
, (ResultTag 1, AssocMap.empty)
]
proposalBefore :: ProposalDatum
proposalBefore =
ProposalDatum
{ proposalId = ProposalId 0
, effects = effects
, status = Draft
, cosigners = [signer]
, thresholds = def
, votes = emptyVotesFor effects
, timingConfig = def
, startingTime = ProposalStartingTime 0
}
stakeDatum :: StakeDatum
stakeDatum = StakeDatum (Tagged 50_000_000) signer2 []
proposalAfter :: ProposalDatum
proposalAfter = proposalBefore {cosigners = newSigners <> proposalBefore.cosigners}
validTimeRange :: POSIXTimeRange
validTimeRange =
closedBoundedInterval
10
((def :: ProposalTimingConfig).draftTime - 10)
builder :: BaseBuilder
builder =
mconcat
[ txId "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
, mint st
, mconcat $ signedWith <$> newSigners
, timeRange validTimeRange
, input $
script proposalValidatorHash
. withValue (st <> Value.singleton "" "" 10_000_000)
. withDatum proposalBefore
. withTxId (txOutRefId proposalRef)
. withRefIndex (txOutRefIdx proposalRef)
, input $
script stakeValidatorHash
. withValue
( Value.singleton "" "" 10_000_000
<> Value.assetClassValue (untag stake.gtClassRef) 50_000_000
<> Value.assetClassValue stakeAssetClass 1
)
. withDatum stakeDatum
. withTxId (txOutRefId stakeRef)
. withRefIndex (txOutRefIdx stakeRef)
, output $
script proposalValidatorHash
. withValue (st <> Value.singleton "" "" 10_000_000)
. withDatum proposalAfter
, output $
script stakeValidatorHash
. withValue
( Value.singleton "" "" 10_000_000
<> Value.assetClassValue (untag stake.gtClassRef) 50_000_000
<> Value.assetClassValue stakeAssetClass 1
)
. withDatum stakeDatum
]
in buildTxInfoUnsafe builder
--------------------------------------------------------------------------------
-- | Parameters for creating a voting transaction.
data VotingParameters = VotingParameters
{ voteFor :: ResultTag
-- ^ The outcome the transaction is voting for.
, voteCount :: Integer
-- ^ The count of votes.
}
-- | Create a valid transaction that votes on a propsal, given the parameters.
voteOnProposal :: VotingParameters -> TxInfo
voteOnProposal params =
let pst = Value.singleton proposalPolicySymbol "" 1
sst = Value.assetClassValue stakeAssetClass 1
---
stakeOwner = signer
---
effects =
AssocMap.fromList
[ (ResultTag 0, AssocMap.empty)
, (ResultTag 1, AssocMap.empty)
]
---
initialVotes :: AssocMap.Map ResultTag Integer
initialVotes =
AssocMap.fromList
[ (ResultTag 0, 42)
, (ResultTag 1, 4242)
]
---
proposalInputDatum :: ProposalDatum
proposalInputDatum =
ProposalDatum
{ proposalId = ProposalId 42
, effects = effects
, status = VotingReady
, cosigners = [stakeOwner]
, thresholds = def
, votes = ProposalVotes initialVotes
, timingConfig = def
, startingTime = ProposalStartingTime 0
}
---
existingLocks :: [ProposalLock]
existingLocks =
[ ProposalLock (ResultTag 0) (ProposalId 0)
, ProposalLock (ResultTag 2) (ProposalId 1)
]
---
stakeInputDatum :: StakeDatum
stakeInputDatum =
StakeDatum
{ stakedAmount = Tagged params.voteCount
, owner = stakeOwner
, lockedBy = existingLocks
}
---
updatedVotes :: AssocMap.Map ResultTag Integer
updatedVotes = updateMap (Just . (+ params.voteCount)) params.voteFor initialVotes
---
proposalOutputDatum :: ProposalDatum
proposalOutputDatum =
proposalInputDatum
{ votes = ProposalVotes updatedVotes
}
---
-- Off-chain code should do exactly like this: prepend new lock toStatus the list.
updatedLocks :: [ProposalLock]
updatedLocks = ProposalLock params.voteFor proposalInputDatum.proposalId : existingLocks
---
stakeOutputDatum :: StakeDatum
stakeOutputDatum =
stakeInputDatum
{ lockedBy = updatedLocks
}
---
validTimeRange =
closedBoundedInterval
((def :: ProposalTimingConfig).draftTime + 1)
((def :: ProposalTimingConfig).votingTime - 1)
builder :: BaseBuilder
builder =
mconcat
[ txId "827598fb2d69a896bbd9e645bb14c307df907f422b39eecbe4d6329bc30b428c"
, signedWith stakeOwner
, timeRange validTimeRange
, input $
script proposalValidatorHash
. withValue pst
. withDatum proposalInputDatum
. withTxId (txOutRefId proposalRef)
. withRefIndex (txOutRefIdx proposalRef)
, input $
script stakeValidatorHash
. withValue
( sst
<> Value.assetClassValue (untag stake.gtClassRef) params.voteCount
<> minAda
)
. withDatum stakeInputDatum
. withTxId (txOutRefId stakeRef)
. withRefIndex (txOutRefIdx stakeRef)
, output $
script proposalValidatorHash
. withValue pst
. withDatum proposalOutputDatum
, output $
script stakeValidatorHash
. withValue
( sst
<> Value.assetClassValue (untag stake.gtClassRef) params.voteCount
<> minAda
)
. withDatum stakeOutputDatum
]
in buildTxInfoUnsafe builder
--------------------------------------------------------------------------------
-- | Parameters for state transition of proposals.
data TransitionParameters = TransitionParameters
{ -- The initial status of the proposal.
initialProposalStatus :: ProposalStatus
, -- The starting time of the proposal.
proposalStartingTime :: ProposalStartingTime
}
-- | Create a 'TxInfo' that update the status of a proposal.
mkTransitionTxInfo ::
-- | Initial state of the proposal.
ProposalStatus ->
-- | Next state of the proposal.
ProposalStatus ->
-- | Effects.
AssocMap.Map ResultTag (AssocMap.Map ValidatorHash DatumHash) ->
-- | Votes.
ProposalVotes ->
-- | Starting time of the proposal.
ProposalStartingTime ->
-- | Valid time range of the transaction.
POSIXTimeRange ->
-- | Whether to add an unchanged stake or not.
Bool ->
TxInfo
mkTransitionTxInfo from to effects votes startingTime validTime shouldAddUnchangedStake =
let pst = Value.singleton proposalPolicySymbol "" 1
sst = Value.assetClassValue stakeAssetClass 1
proposalInputDatum :: ProposalDatum
proposalInputDatum =
ProposalDatum
{ proposalId = ProposalId 0
, effects = effects
, status = from
, cosigners = [signer]
, thresholds = def
, votes = votes
, timingConfig = def
, startingTime = startingTime
}
proposalOutputDatum :: ProposalDatum
proposalOutputDatum =
proposalInputDatum
{ status = to
}
stakeOwner = signer
stakedAmount = 200
existingLocks :: [ProposalLock]
existingLocks =
[ ProposalLock (ResultTag 0) (ProposalId 0)
, ProposalLock (ResultTag 2) (ProposalId 1)
]
stakeInputDatum :: StakeDatum
stakeInputDatum =
StakeDatum
{ stakedAmount = Tagged stakedAmount
, owner = stakeOwner
, lockedBy = existingLocks
}
stakeOutputDatum :: StakeDatum
stakeOutputDatum = stakeInputDatum
stakeBuilder :: BaseBuilder
stakeBuilder =
if shouldAddUnchangedStake
then
mconcat
[ input $
script stakeValidatorHash
. withValue sst
. withDatum stakeInputDatum
. withTxId (txOutRefId stakeRef)
, output $
script stakeValidatorHash
. withValue (sst <> minAda)
. withDatum stakeOutputDatum
]
else mempty
builder :: BaseBuilder
builder =
mconcat
[ txId "95ba4015e30aef16a3461ea97a779f814aeea6b8009d99a94add4b8293be737a"
, signedWith stakeOwner
, timeRange validTime
, input $
script proposalValidatorHash
. withValue pst
. withDatum proposalInputDatum
. withTxId (txOutRefId proposalRef)
, output $
script proposalValidatorHash
. withValue (pst <> minAda)
. withDatum proposalOutputDatum
]
in buildTxInfoUnsafe $ builder <> stakeBuilder
-- | Wrapper around 'advanceProposalSuccess'', with valid stake.
advanceProposalSuccess :: TransitionParameters -> TxInfo
advanceProposalSuccess ps = advanceProposalSuccess' ps True
{- | Create a valid 'TxInfo' that advances a proposal, given the parameters.
The second parameter determines wherther valid stake should be included.
Note that 'TransitionParameters.initialProposalStatus' should not be 'Finished'.
-}
advanceProposalSuccess' :: TransitionParameters -> Bool -> TxInfo
advanceProposalSuccess' params =
let -- Status of the output proposal.
toStatus :: ProposalStatus
toStatus = case params.initialProposalStatus of
Draft -> VotingReady
VotingReady -> Locked
Locked -> Finished
Finished -> error "Cannot advance 'Finished' proposal"
effects =
AssocMap.fromList
[ (ResultTag 0, AssocMap.empty)
, (ResultTag 1, AssocMap.empty)
]
emptyVotes@(ProposalVotes emptyVotes') = emptyVotesFor effects
-- Set the vote count of outcome 0 to @def.countingVoting + 1@,
-- meaning that outcome 0 will be the winner.
outcome0WinningVotes =
ProposalVotes $
updateMap
(\_ -> Just $ untag (def :: ProposalThresholds).execute + 1)
(ResultTag 0)
emptyVotes'
votes :: ProposalVotes
votes = case params.initialProposalStatus of
Draft -> emptyVotes
-- With sufficient votes
_ -> outcome0WinningVotes
proposalStartingTime :: POSIXTime
proposalStartingTime =
let (ProposalStartingTime startingTime) = params.proposalStartingTime
in startingTime
timeRange :: POSIXTimeRange
timeRange = case params.initialProposalStatus of
-- [S + 1, S + D - 1]
Draft ->
closedBoundedInterval
(proposalStartingTime + 1)
(proposalStartingTime + (def :: ProposalTimingConfig).draftTime - 1)
-- [S + D + V + 1, S + D + V + L - 1]
VotingReady ->
closedBoundedInterval
( proposalStartingTime
+ (def :: ProposalTimingConfig).draftTime
+ (def :: ProposalTimingConfig).votingTime
+ 1
)
( proposalStartingTime
+ (def :: ProposalTimingConfig).draftTime
+ (def :: ProposalTimingConfig).votingTime
+ (def :: ProposalTimingConfig).lockingTime
- 1
)
-- [S + D + V + L + 1, S + + D + V + L + E - 1]
Locked ->
closedBoundedInterval
( proposalStartingTime
+ (def :: ProposalTimingConfig).draftTime
+ (def :: ProposalTimingConfig).votingTime
+ (def :: ProposalTimingConfig).lockingTime
+ 1
)
( proposalStartingTime
+ (def :: ProposalTimingConfig).draftTime
+ (def :: ProposalTimingConfig).votingTime
+ (def :: ProposalTimingConfig).lockingTime
+ (def :: ProposalTimingConfig).executingTime - 1
)
Finished -> error "Cannot advance 'Finished' proposal"
in mkTransitionTxInfo
params.initialProposalStatus
toStatus
effects
votes
params.proposalStartingTime
timeRange
{- | Create a valid 'TxInfo' that advances a proposal to failed state, given the parameters.
The reason why the proposal fails is the proposal has ran out of time.
Note that 'TransitionParameters.initialProposalStatus' should not be 'Finished'.
-}
advanceProposalFailureTimeout :: TransitionParameters -> TxInfo
advanceProposalFailureTimeout params =
let effects =
AssocMap.fromList
[ (ResultTag 0, AssocMap.empty)
, (ResultTag 1, AssocMap.empty)
]
emptyVotes@(ProposalVotes emptyVotes') = emptyVotesFor effects
-- Set the vote count of outcome 0 to @def.countingVoting + 1@,
-- meaning that outcome 0 will be the winner.
outcome0WinningVotes =
ProposalVotes $
updateMap
(\_ -> Just $ untag (def :: ProposalThresholds).vote + 1)
(ResultTag 0)
emptyVotes'
votes :: ProposalVotes
votes = case params.initialProposalStatus of
Draft -> emptyVotes
-- With sufficient votes
_ -> outcome0WinningVotes
proposalStartingTime :: POSIXTime
proposalStartingTime =
let (ProposalStartingTime startingTime) = params.proposalStartingTime
in startingTime
timeRange :: POSIXTimeRange
timeRange = case params.initialProposalStatus of
-- [S + D + 1, S + D + V - 1]
Draft ->
closedBoundedInterval
(proposalStartingTime + (def :: ProposalTimingConfig).draftTime + 1)
( proposalStartingTime
+ (def :: ProposalTimingConfig).draftTime
+ (def :: ProposalTimingConfig).votingTime - 1
)
-- [S + D + V + L + 1, S + D + V + L + E -1]
VotingReady ->
closedBoundedInterval
( proposalStartingTime
+ (def :: ProposalTimingConfig).draftTime
+ (def :: ProposalTimingConfig).votingTime
+ (def :: ProposalTimingConfig).lockingTime
+ 1
)
( proposalStartingTime
+ (def :: ProposalTimingConfig).draftTime
+ (def :: ProposalTimingConfig).votingTime
+ (def :: ProposalTimingConfig).lockingTime
+ (def :: ProposalTimingConfig).executingTime
- 1
)
-- [S + D + V + L + E + 1, S + D + V + L + E + 100]
Locked ->
closedBoundedInterval
( proposalStartingTime
+ (def :: ProposalTimingConfig).draftTime
+ (def :: ProposalTimingConfig).votingTime
+ (def :: ProposalTimingConfig).lockingTime
+ (def :: ProposalTimingConfig).executingTime
+ 1
)
( proposalStartingTime
+ (def :: ProposalTimingConfig).draftTime
+ (def :: ProposalTimingConfig).votingTime
+ (def :: ProposalTimingConfig).lockingTime
+ (def :: ProposalTimingConfig).executingTime
+ 100
)
Finished -> error "Cannot advance 'Finished' proposal"
in mkTransitionTxInfo
params.initialProposalStatus
Finished
effects
votes
params.proposalStartingTime
timeRange
True
-- | An invalid 'TxInfo' that tries to advance a 'VotingReady' proposal without sufficient votes.
advanceProposalInsufficientVotes :: TxInfo
advanceProposalInsufficientVotes =
let effects =
AssocMap.fromList
[ (ResultTag 0, AssocMap.empty)
, (ResultTag 1, AssocMap.empty)
]
-- Insufficient votes.
votes =
ProposalVotes
( AssocMap.fromList
[ (ResultTag 0, 1)
, (ResultTag 1, 0)
]
)
proposalStartingTime = 0
-- Valid time range.
-- [S + D + 1, S + V + 10]
timeRange =
closedBoundedInterval
( proposalStartingTime
+ (def :: ProposalTimingConfig).draftTime
+ (def :: ProposalTimingConfig).votingTime
+ 1
)
( proposalStartingTime
+ (def :: ProposalTimingConfig).draftTime
+ (def :: ProposalTimingConfig).votingTime
+ 10
)
in mkTransitionTxInfo
VotingReady
Locked
effects
votes
(ProposalStartingTime proposalStartingTime)
timeRange
True
-- | An invalid 'TxInfo' that tries to advance a 'Finished' proposal.
advanceFinishedProposal :: TxInfo
advanceFinishedProposal =
let effects =
AssocMap.fromList
[ (ResultTag 0, AssocMap.empty)
, (ResultTag 1, AssocMap.empty)
]
-- Set the vote count of outcome 0 to @def.countingVoting + 1@,
-- meaning that outcome 0 will be the winner.
outcome0WinningVotes =
ProposalVotes $
AssocMap.fromList
[ (ResultTag 0, untag (def :: ProposalThresholds).vote + 1)
, (ResultTag 1, 0)
]
---
timeRange =
closedBoundedInterval
((def :: ProposalTimingConfig).lockingTime + 1)
((def :: ProposalTimingConfig).executingTime - 1)
in mkTransitionTxInfo
Finished
Finished
effects
outcome0WinningVotes
(ProposalStartingTime 0)
timeRange
True
{- | An illegal 'TxInfo' that tries to output a changed stake with 'AdvanceProposal'.
From the perspective of stake validator, the transition is totally valid,
so the proposal validator should reject this.
-}
advanceProposalWithInvalidOutputStake :: TxInfo
advanceProposalWithInvalidOutputStake =
let templateTxInfo =
advanceProposalSuccess'
TransitionParameters
{ initialProposalStatus = VotingReady
, proposalStartingTime = ProposalStartingTime 0
}
False
---
-- Now we create a new lock on an arbitrary stake
sst = Value.assetClassValue stakeAssetClass 1
---
stakeOwner = signer
stakedAmount = 200
---
existingLocks :: [ProposalLock]
existingLocks =
[ ProposalLock (ResultTag 0) (ProposalId 0)
, ProposalLock (ResultTag 2) (ProposalId 1)
]
---
stakeInputDatum' :: StakeDatum
stakeInputDatum' =
StakeDatum
{ stakedAmount = Tagged stakedAmount
, owner = stakeOwner
, lockedBy = existingLocks
}
stakeInputDatum :: Datum
stakeInputDatum = Datum $ toBuiltinData stakeInputDatum'
stakeInput :: TxOut
stakeInput =
TxOut
{ txOutAddress = stakeAddress
, txOutValue =
mconcat
[ sst
, Value.assetClassValue (untag stake.gtClassRef) stakedAmount
, minAda
]
, txOutDatumHash = Just $ toDatumHash stakeInputDatum
}
---
updatedLocks :: [ProposalLock]
updatedLocks = ProposalLock (ResultTag 42) (ProposalId 27) : existingLocks
---
stakeOutputDatum' :: StakeDatum
stakeOutputDatum' =
stakeInputDatum'
{ lockedBy = updatedLocks
}
stakeOutputDatum :: Datum
stakeOutputDatum = Datum $ toBuiltinData stakeOutputDatum'
stakeOutput :: TxOut
stakeOutput =
stakeInput
{ txOutDatumHash = Just $ toDatumHash stakeOutputDatum
}
in templateTxInfo
{ txInfoInputs = TxInInfo stakeRef stakeInput : templateTxInfo.txInfoInputs
, txInfoOutputs = stakeOutput : templateTxInfo.txInfoOutputs
, txInfoData =
(datumPair <$> [stakeInputDatum, stakeOutputDatum])
<> templateTxInfo.txInfoData
, txInfoSignatories = [stakeOwner]
}

509
agora-specs/Sample/Proposal/Advance.hs Normal file
View file

@ -0,0 +1,509 @@
module Sample.Proposal.Advance (
advanceToNextStateInTimeParameters,
advanceToFailedStateDueToTimeoutParameters,
insufficientVotesParameters,
insufficientCosignsParameters,
advanceFromFinishedParameters,
invalidOutputStakeParameters,
mkTestTree,
Parameters (..),
) where
import Agora.Proposal (
ProposalDatum (..),
ProposalId (ProposalId),
ProposalRedeemer (AdvanceProposal),
ProposalStatus (..),
ProposalThresholds (..),
ProposalVotes (ProposalVotes),
ResultTag (ResultTag),
emptyVotesFor,
)
import Agora.Proposal.Scripts (proposalValidator)
import Agora.Proposal.Time (
ProposalStartingTime (ProposalStartingTime),
ProposalTimingConfig (
draftTime,
executingTime,
lockingTime,
votingTime
),
)
import Agora.SafeMoney (GTTag)
import Agora.Stake (
ProposalLock (ProposalLock),
Stake (gtClassRef),
StakeDatum (..),
StakeRedeemer (WitnessStake),
)
import Agora.Stake.Scripts (stakeValidator)
import Data.Coerce (coerce)
import Data.Default (def)
import Data.List (sort)
import Data.Tagged (Tagged (..), untag)
import Plutarch.Context (
BaseBuilder,
buildTxInfoUnsafe,
input,
output,
script,
signedWith,
timeRange,
txId,
withDatum,
withOutRef,
withTxId,
withValue,
)
import PlutusLedgerApi.V1 (
DatumHash,
POSIXTime,
POSIXTimeRange,
PubKeyHash,
ScriptContext (ScriptContext),
ScriptPurpose (Spending),
TxInfo,
TxOutRef (TxOutRef),
ValidatorHash,
always,
)
import PlutusLedgerApi.V1.Value qualified as Value
import PlutusTx.AssocMap qualified as AssocMap
import Sample.Proposal.Shared (proposalTxRef, stakeTxRef, testFunc)
import Sample.Shared (
minAda,
proposalPolicySymbol,
proposalValidatorHash,
stake,
stakeAssetClass,
stakeValidatorHash,
)
import Sample.Shared qualified as Shared
import Test.Specification (SpecificationTree, group)
import Test.Util (closedBoundedInterval, pubKeyHashes, sortValue, updateMap)
-- | Parameters for state transition of proposals.
data Parameters = Parameters
{ fromStatus :: ProposalStatus
-- ^ Initial state of the proposal.
, toStatus :: ProposalStatus
-- ^ Next state of the proposal.
, votes :: ProposalVotes
-- ^ Votes.
, includeAllStakes :: Bool
-- ^ Whether to add an extra cosigner without stake or not.
, validTimeRange :: POSIXTimeRange
-- ^ Valid time range of the transaction.
, alterOutputStakes :: Bool
-- ^ Whether to alter th output stakes or not.
, stakeCount :: Integer
-- ^ The number of stakes.
, signByAllCosigners :: Bool
, perStakeGTs :: Tagged GTTag Integer
}
---
proposalRef :: TxOutRef
proposalRef = TxOutRef proposalTxRef 1
mkStakeRef :: Int -> TxOutRef
mkStakeRef = TxOutRef stakeTxRef . (+ 2) . fromIntegral
---
defEffects :: AssocMap.Map ResultTag (AssocMap.Map ValidatorHash DatumHash)
defEffects =
AssocMap.fromList
[ (ResultTag 0, AssocMap.empty)
, (ResultTag 1, AssocMap.empty)
]
emptyVotes :: ProposalVotes
emptyVotes = emptyVotesFor defEffects
proposalStartingTime :: POSIXTime
proposalStartingTime = 0
---
mkProposalInputDatum :: Parameters -> ProposalDatum
mkProposalInputDatum ps =
ProposalDatum
{ proposalId = ProposalId 0
, effects = defEffects
, status = ps.fromStatus
, cosigners = mkStakeOwners ps
, thresholds = def
, votes = ps.votes
, timingConfig = def
, startingTime = ProposalStartingTime proposalStartingTime
}
mkStakeInputDatums :: Parameters -> [StakeDatum]
mkStakeInputDatums ps =
map
( \pk ->
StakeDatum
{ stakedAmount = ps.perStakeGTs
, owner = pk
, lockedBy = existingLocks
}
)
$ mkStakeOwners ps
where
existingLocks :: [ProposalLock]
existingLocks =
[ ProposalLock (ResultTag 0) (ProposalId 0)
, ProposalLock (ResultTag 2) (ProposalId 1)
]
---
proposalScriptPurpose :: ScriptPurpose
proposalScriptPurpose = Spending proposalRef
mkStakeScriptPurpose :: Int -> ScriptPurpose
mkStakeScriptPurpose = Spending . mkStakeRef
---
proposalRedeemer :: ProposalRedeemer
proposalRedeemer = AdvanceProposal
stakeRedeemer :: StakeRedeemer
stakeRedeemer = WitnessStake
---
mkStakeOwners :: Parameters -> [PubKeyHash]
mkStakeOwners ps =
sort $
take
(fromIntegral ps.stakeCount)
pubKeyHashes
---
-- | Create a 'TxInfo' that update the status of a proposal.
advance ::
Parameters ->
TxInfo
advance ps =
let pst = Value.singleton proposalPolicySymbol "" 1
sst = Value.assetClassValue stakeAssetClass 1
proposalInputDatum :: ProposalDatum
proposalInputDatum =
mkProposalInputDatum ps
proposalOutputDatum :: ProposalDatum
proposalOutputDatum =
proposalInputDatum
{ status = ps.toStatus
}
stakeInputDatums :: [StakeDatum]
stakeInputDatums = mkStakeInputDatums ps
mkStakeOutputDatum :: StakeDatum -> StakeDatum
mkStakeOutputDatum si =
if ps.alterOutputStakes
then
si
{ stakedAmount = ps.perStakeGTs + 1
}
else si
stakeValue =
let gts =
if ps.perStakeGTs == 0
then mempty
else
Value.assetClassValue
(untag stake.gtClassRef)
(untag ps.perStakeGTs)
in sortValue $
sst <> minAda
<> gts
stakeBuilder :: BaseBuilder
stakeBuilder =
foldMap
( \(si, idx) ->
let so = mkStakeOutputDatum si
in mconcat @BaseBuilder
[ input $
script stakeValidatorHash
. withValue stakeValue
. withDatum si
. withOutRef (mkStakeRef idx)
, output $
script stakeValidatorHash
. withValue stakeValue
. withDatum so
]
)
$ let withIds = zip stakeInputDatums [0 ..]
in if ps.includeAllStakes
then withIds
else [head withIds]
signBuilder :: BaseBuilder
signBuilder =
let sos = mkStakeOwners ps
in if ps.signByAllCosigners
then foldMap signedWith sos
else signedWith $ head sos
builder :: BaseBuilder
builder =
mconcat
[ txId "95ba4015e30aef16a3461ea97a779f814aeea6b8009d99a94add4b8293be737a"
, signBuilder
, timeRange ps.validTimeRange
, input $
script proposalValidatorHash
. withValue pst
. withDatum proposalInputDatum
. withTxId proposalTxRef
, output $
script proposalValidatorHash
. withValue (pst <> minAda)
. withDatum proposalOutputDatum
]
in buildTxInfoUnsafe $ builder <> stakeBuilder
---
mkInTimeTimeRange :: ProposalStatus -> POSIXTimeRange
mkInTimeTimeRange advanceFrom =
case advanceFrom of
-- [S + 1, S + D - 1]
Draft ->
closedBoundedInterval
(proposalStartingTime + 1)
(proposalStartingTime + (def :: ProposalTimingConfig).draftTime - 1)
-- [S + D + V + 1, S + D + V + L - 1]
VotingReady ->
closedBoundedInterval
( proposalStartingTime
+ (def :: ProposalTimingConfig).draftTime
+ (def :: ProposalTimingConfig).votingTime
+ 1
)
( proposalStartingTime
+ (def :: ProposalTimingConfig).draftTime
+ (def :: ProposalTimingConfig).votingTime
+ (def :: ProposalTimingConfig).lockingTime
- 1
)
-- [S + D + V + L + 1, S + + D + V + L + E - 1]
Locked ->
closedBoundedInterval
( proposalStartingTime
+ (def :: ProposalTimingConfig).draftTime
+ (def :: ProposalTimingConfig).votingTime
+ (def :: ProposalTimingConfig).lockingTime
+ 1
)
( proposalStartingTime
+ (def :: ProposalTimingConfig).draftTime
+ (def :: ProposalTimingConfig).votingTime
+ (def :: ProposalTimingConfig).lockingTime
+ (def :: ProposalTimingConfig).executingTime - 1
)
Finished -> error "Cannot advance 'Finished' proposal"
mkTooLateTimeRange :: ProposalStatus -> POSIXTimeRange
mkTooLateTimeRange advanceFrom =
case advanceFrom of
-- [S + D + 1, S + D + V - 1]
Draft ->
closedBoundedInterval
(proposalStartingTime + (def :: ProposalTimingConfig).draftTime + 1)
( proposalStartingTime
+ (def :: ProposalTimingConfig).draftTime
+ (def :: ProposalTimingConfig).votingTime - 1
)
-- [S + D + V + L + 1, S + D + V + L + E -1]
VotingReady ->
closedBoundedInterval
( proposalStartingTime
+ (def :: ProposalTimingConfig).draftTime
+ (def :: ProposalTimingConfig).votingTime
+ (def :: ProposalTimingConfig).lockingTime
+ 1
)
( proposalStartingTime
+ (def :: ProposalTimingConfig).draftTime
+ (def :: ProposalTimingConfig).votingTime
+ (def :: ProposalTimingConfig).lockingTime
+ (def :: ProposalTimingConfig).executingTime
- 1
)
-- [S + D + V + L + E + 1, S + D + V + L + E + 100]
Locked ->
closedBoundedInterval
( proposalStartingTime
+ (def :: ProposalTimingConfig).draftTime
+ (def :: ProposalTimingConfig).votingTime
+ (def :: ProposalTimingConfig).lockingTime
+ (def :: ProposalTimingConfig).executingTime
+ 1
)
( proposalStartingTime
+ (def :: ProposalTimingConfig).draftTime
+ (def :: ProposalTimingConfig).votingTime
+ (def :: ProposalTimingConfig).lockingTime
+ (def :: ProposalTimingConfig).executingTime
+ 100
)
Finished -> error "Cannot advance 'Finished' proposal"
---
getNextState :: ProposalStatus -> ProposalStatus
getNextState = \case
Draft -> VotingReady
VotingReady -> Locked
Locked -> Finished
Finished -> error "Cannot advance 'Finished' proposal"
---
advanceToNextStateInTimeParameters :: Int -> [Parameters]
advanceToNextStateInTimeParameters nCosigners =
map
( \from ->
let -- Set the vote count of outcome 0 to @def.countingVoting + 1@,
-- meaning that outcome 0 will be the winner.
outcome0WinningVotes =
ProposalVotes $
updateMap
(\_ -> Just $ untag (def :: ProposalThresholds).execute + 1)
(ResultTag 0)
(coerce emptyVotes)
votes = case from of
Draft -> emptyVotes
-- With sufficient votes
_ -> outcome0WinningVotes
includeAllStakes = case from of
Draft -> True
_ -> False
signByAllCosigners = case from of
Draft -> True
_ -> False
in Parameters
{ fromStatus = from
, toStatus = getNextState from
, votes = votes
, includeAllStakes = includeAllStakes
, validTimeRange = mkInTimeTimeRange from
, alterOutputStakes = False
, stakeCount = fromIntegral nCosigners
, signByAllCosigners = signByAllCosigners
, perStakeGTs =
(def :: ProposalThresholds).vote
`div` fromIntegral nCosigners + 1
}
)
[Draft, VotingReady, Locked]
advanceToFailedStateDueToTimeoutParameters :: Int -> [Parameters]
advanceToFailedStateDueToTimeoutParameters nCosigners =
map
( \from ->
Parameters
{ fromStatus = from
, toStatus = Finished
, votes = emptyVotes
, includeAllStakes = False
, validTimeRange = mkTooLateTimeRange from
, alterOutputStakes = False
, stakeCount = fromIntegral nCosigners
, signByAllCosigners = False
, perStakeGTs = 1
}
)
[Draft, VotingReady, Locked]
insufficientVotesParameters :: Parameters
insufficientVotesParameters =
let votes = emptyVotes
from = VotingReady
to = getNextState from
in Parameters
{ fromStatus = from
, toStatus = to
, votes = votes
, includeAllStakes = False
, validTimeRange = mkInTimeTimeRange from
, alterOutputStakes = False
, stakeCount = 1
, signByAllCosigners = True
, perStakeGTs = 20
}
insufficientCosignsParameters :: Int -> Parameters
insufficientCosignsParameters nCosigners =
(\ps -> ps {perStakeGTs = 0}) $
head $
advanceToNextStateInTimeParameters nCosigners
advanceFromFinishedParameters :: Parameters
advanceFromFinishedParameters =
Parameters
{ fromStatus = Finished
, toStatus = Finished
, votes = emptyVotes
, includeAllStakes = False
, validTimeRange = always
, alterOutputStakes = False
, stakeCount = 1
, signByAllCosigners = True
, perStakeGTs = 20
}
invalidOutputStakeParameters :: Int -> [Parameters]
invalidOutputStakeParameters nCosigners =
(\ps -> ps {alterOutputStakes = True})
<$> advanceToNextStateInTimeParameters nCosigners
---
mkTestTree :: String -> Parameters -> Bool -> SpecificationTree
mkTestTree name ps isValidForProposalValidator = group name [proposal, stake]
where
txInfo = advance ps
proposal =
let proposalInputDatum = mkProposalInputDatum ps
in testFunc
isValidForProposalValidator
"propsoal"
(proposalValidator Shared.proposal)
proposalInputDatum
proposalRedeemer
( ScriptContext
txInfo
proposalScriptPurpose
)
stake =
let idx = 0
stakeInputDatum = mkStakeInputDatums ps !! idx
isValid = not $ ps.alterOutputStakes
in testFunc
isValid
"stake"
(stakeValidator Shared.stake)
stakeInputDatum
stakeRedeemer
( ScriptContext
txInfo
(mkStakeScriptPurpose idx)
)

344
agora-specs/Sample/Proposal/Cosign.hs Normal file
View file

@ -0,0 +1,344 @@
module Sample.Proposal.Cosign (
Parameters (..),
validCosignNParameters,
duplicateCosignersParameters,
statusNotDraftCosignNParameters,
invalidStakeOutputParameters,
mkTestTree,
) where
import Agora.Proposal (
ProposalDatum (..),
ProposalId (ProposalId),
ProposalRedeemer (Cosign),
ProposalStatus (..),
ResultTag (ResultTag),
emptyVotesFor,
)
import Agora.Proposal.Scripts (proposalValidator)
import Agora.Proposal.Time (
ProposalStartingTime (ProposalStartingTime),
ProposalTimingConfig (draftTime),
)
import Agora.SafeMoney (GTTag)
import Agora.Stake (
Stake (gtClassRef),
StakeDatum (StakeDatum, owner),
StakeRedeemer (WitnessStake),
stakedAmount,
)
import Agora.Stake.Scripts (stakeValidator)
import Data.Coerce (coerce)
import Data.Default (def)
import Data.List (sort)
import Data.Tagged (Tagged, untag)
import Plutarch.Context (
BaseBuilder,
buildTxInfoUnsafe,
input,
output,
script,
signedWith,
timeRange,
txId,
withDatum,
withRefIndex,
withTxId,
withValue,
)
import PlutusLedgerApi.V1 (
POSIXTimeRange,
PubKeyHash,
ScriptContext (ScriptContext),
ScriptPurpose (Spending),
TxInfo,
TxOutRef (..),
Value,
)
import PlutusLedgerApi.V1.Value qualified as Value
import PlutusTx.AssocMap qualified as AssocMap
import Sample.Proposal.Shared (proposalTxRef, stakeTxRef, testFunc)
import Sample.Shared (
minAda,
proposalPolicySymbol,
proposalValidatorHash,
signer,
stake,
stakeAssetClass,
stakeValidatorHash,
)
import Sample.Shared qualified as Shared
import Test.Specification (
SpecificationTree,
group,
)
import Test.Util (closedBoundedInterval, pubKeyHashes, sortValue)
-- | Parameters for cosigning a proposal.
data Parameters = Parameters
{ newCosigners :: [PubKeyHash]
-- ^ New cosigners to be added, and the owners of the generated stakes.
, proposalStatus :: ProposalStatus
-- ^ Current state of the proposal.
, alterOutputStakes :: Bool
-- ^ Whether to generate invalid stake outputs.
-- In particular, the 'stakedAmount' of all the stake datums will be set to zero.
}
-- | Owner of the creator stake, doesn't really matter in this case.
proposalCreator :: PubKeyHash
proposalCreator = signer
-- | The amount of GTs every generated stake has, doesn't really matter in this case.
perStakedGTs :: Tagged GTTag Integer
perStakedGTs = 5
{- | Create input proposal datum given the parameters.
In particular, 'status' is set to 'proposalStstus'.
-}
mkProposalInputDatum :: Parameters -> ProposalDatum
mkProposalInputDatum ps =
let effects =
AssocMap.fromList
[ (ResultTag 0, AssocMap.empty)
, (ResultTag 1, AssocMap.empty)
]
in ProposalDatum
{ proposalId = ProposalId 0
, effects = effects
, status = ps.proposalStatus
, cosigners = [proposalCreator]
, thresholds = def
, votes = emptyVotesFor effects
, timingConfig = def
, startingTime = ProposalStartingTime 0
}
{- | Create the output proposal datum given the parameters.
The 'newCosigners' is added to the exisiting list of cosigners, note the said list should be sorted in
ascending order.
-}
mkProposalOutputDatum :: Parameters -> ProposalDatum
mkProposalOutputDatum ps =
let inputDatum = mkProposalInputDatum ps
in inputDatum
{ cosigners = sort $ inputDatum.cosigners <> ps.newCosigners
}
-- | Create all the input stakes given the parameters.
mkStakeInputDatums :: Parameters -> [StakeDatum]
mkStakeInputDatums = fmap (\pk -> StakeDatum perStakedGTs pk []) . newCosigners
-- | Create a 'TxInfo' that tries to cosign a proposal with new cosigners.
cosign :: Parameters -> TxInfo
cosign ps = buildTxInfoUnsafe builder
where
pst = Value.singleton proposalPolicySymbol "" 1
sst = Value.assetClassValue stakeAssetClass 1
---
stakeInputDatums :: [StakeDatum]
stakeInputDatums = mkStakeInputDatums ps
stakeValue :: Value
stakeValue =
sortValue $
minAda
<> Value.assetClassValue
(untag stake.gtClassRef)
(untag perStakedGTs)
<> sst
stakeBuilder :: BaseBuilder
stakeBuilder =
foldMap
( \(stakeDatum, refIdx) ->
let stakeOutputDatum =
if ps.alterOutputStakes
then stakeDatum {stakedAmount = 0}
else stakeDatum
in mconcat @BaseBuilder
[ input $
script stakeValidatorHash
. withValue stakeValue
. withDatum stakeDatum
. withTxId stakeTxRef
. withRefIndex refIdx
, output $
script stakeValidatorHash
. withValue stakeValue
. withDatum stakeOutputDatum
, signedWith stakeDatum.owner
]
)
$ zip
stakeInputDatums
[2 ..]
---
proposalInputDatum :: ProposalDatum
proposalInputDatum = mkProposalInputDatum ps
proposalOutputDatum :: ProposalDatum
proposalOutputDatum = mkProposalOutputDatum ps
proposalBuilder :: BaseBuilder
proposalBuilder =
mconcat
[ input $
script proposalValidatorHash
. withValue pst
. withDatum proposalInputDatum
. withTxId proposalTxRef
. withRefIndex proposalRefIdx
, output $
script proposalValidatorHash
. withValue (sortValue (pst <> minAda))
. withDatum proposalOutputDatum
]
validTimeRange :: POSIXTimeRange
validTimeRange =
closedBoundedInterval
(coerce proposalInputDatum.startingTime + 1)
( coerce proposalInputDatum.startingTime
+ proposalInputDatum.timingConfig.draftTime - 1
)
---
builder :: BaseBuilder
builder =
mconcat
[ txId "05c67819fc3381a2052b929ab439244b7b5fe3b3bd07f2134055bbbb21bd9e52"
, timeRange validTimeRange
, proposalBuilder
, stakeBuilder
]
-- | Reference index of the proposal UTXO.
proposalRefIdx :: Integer
proposalRefIdx = 1
-- | Spend the proposal ST.
proposalScriptPurpose :: ScriptPurpose
proposalScriptPurpose =
Spending
( TxOutRef
proposalTxRef
proposalRefIdx
)
-- | Consume the given stake.
mkStakeScriptPurpose :: Int -> ScriptPurpose
mkStakeScriptPurpose idx =
Spending $
TxOutRef
stakeTxRef
$ proposalRefIdx + 1 + fromIntegral idx
-- | Create a proposal redeemer which cosigns with the new cosginers.
mkProposalRedeemer :: Parameters -> ProposalRedeemer
mkProposalRedeemer (sort . newCosigners -> cs) = Cosign cs
-- | Stake redeemer for cosuming all the stakes generated in the module.
stakeRedeemer :: StakeRedeemer
stakeRedeemer = WitnessStake
---
-- | Create a valid parameters that cosign the proposal with a given number of cosigners.
validCosignNParameters :: Int -> Parameters
validCosignNParameters n
| n > 0 =
Parameters
{ newCosigners = take n pubKeyHashes
, proposalStatus = Draft
, alterOutputStakes = False
}
| otherwise = error "Number of cosigners should be positive"
---
{- | Parameters that make 'cosign' yield duplicate cosigners.
Invalid for the ptoposal validator, perfectly valid for stake validator.
-}
duplicateCosignersParameters :: Parameters
duplicateCosignersParameters =
Parameters
{ newCosigners = [proposalCreator]
, proposalStatus = Draft
, alterOutputStakes = False
}
---
{- | Generate a list of parameters that sets proposal status to something other than 'Draft'.
Invalid for the ptoposal validator, perfectly valid for stake validator.
-}
statusNotDraftCosignNParameters :: Int -> [Parameters]
statusNotDraftCosignNParameters n =
map
( \st ->
Parameters
{ newCosigners = take n pubKeyHashes
, proposalStatus = st
, alterOutputStakes = False
}
)
[VotingReady, Locked, Finished]
---
{- | Parameters thet change the output stake datums.
Invalid for both proposal validator and stake validator.
-}
invalidStakeOutputParameters :: Parameters
invalidStakeOutputParameters =
(validCosignNParameters 2)
{ alterOutputStakes = True
}
---
-- | Create a test tree given the parameters. Both the proposal validator and stake validator will be run.
mkTestTree ::
-- | The name of the test group.
String ->
Parameters ->
-- | Are the parameters valid for the proposal validator?
Bool ->
SpecificationTree
mkTestTree name ps isValid = group name [proposal, stake]
where
txInfo = cosign ps
proposal =
let proposalInputDatum = mkProposalInputDatum ps
in testFunc
isValid
"propsoal"
(proposalValidator Shared.proposal)
proposalInputDatum
(mkProposalRedeemer ps)
( ScriptContext
txInfo
proposalScriptPurpose
)
stake =
let idx = 0
stakeInputDatum = mkStakeInputDatums ps !! idx
isValid = not ps.alterOutputStakes
in testFunc
isValid
"stake"
(stakeValidator Shared.stake)
stakeInputDatum
stakeRedeemer
( ScriptContext
txInfo
(mkStakeScriptPurpose idx)
)

42
agora-specs/Sample/Proposal/Shared.hs
View file

@ -1,9 +1,39 @@
module Sample.Proposal.Shared (proposalRef, stakeRef) where
module Sample.Proposal.Shared (proposalTxRef, stakeTxRef, testFunc) where
import PlutusLedgerApi.V1 (TxOutRef (..))
import Plutarch.Api.V1 (PValidator)
import Plutarch.Lift (PUnsafeLiftDecl (..))
import PlutusLedgerApi.V1 (ScriptContext, ToData, TxId)
import Test.Specification (
SpecificationTree,
validatorFailsWith,
validatorSucceedsWith,
)
proposalRef :: TxOutRef
proposalRef = TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1
-- | 'TxId' of all the propsoal inputs in the samples.
proposalTxRef :: TxId
proposalTxRef = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
stakeRef :: TxOutRef
stakeRef = TxOutRef "0ca36f3a357bc69579ab2531aecd1e7d3714d993c7820f40b864be15" 0
-- | 'TxId' of all the stake inputs in the samples.
stakeTxRef :: TxId
stakeTxRef = "0ca36f3a357bc69579ab2531aecd1e7d3714d993c7820f40b864be15"
-- | Get the test function given whether a test case is valid.
testFunc ::
forall {datum :: PType} {redeemer :: PType}.
( PUnsafeLiftDecl datum
, PUnsafeLiftDecl redeemer
, ToData (PLifted datum)
, ToData (PLifted redeemer)
) =>
-- | Should the validator pass?
Bool ->
String ->
ClosedTerm PValidator ->
PLifted datum ->
PLifted redeemer ->
ScriptContext ->
SpecificationTree
testFunc isValid =
if isValid
then validatorSucceedsWith
else validatorFailsWith

77
agora-specs/Sample/Proposal/UnlockStake.hs
View file

@ -11,6 +11,33 @@ module Sample.Proposal.UnlockStake (
--------------------------------------------------------------------------------
import Agora.Proposal (
ProposalDatum (..),
ProposalId (..),
ProposalRedeemer (Unlock),
ProposalStatus (..),
ProposalVotes (..),
ResultTag (..),
)
import Agora.Proposal.Scripts (proposalValidator)
import Agora.Proposal.Time (ProposalStartingTime (ProposalStartingTime))
import Agora.Stake (ProposalLock (ProposalLock), Stake (..), StakeDatum (..))
import Control.Monad (join)
import Data.Coerce (coerce)
import Data.Default.Class (Default (def))
import Data.Tagged (Tagged (..), untag)
import Plutarch.Context (
BaseBuilder,
buildTxInfoUnsafe,
input,
output,
script,
txId,
withDatum,
withRefIndex,
withTxId,
withValue,
)
import PlutusLedgerApi.V1 (
DatumHash,
ScriptContext (..),
@ -21,19 +48,7 @@ import PlutusLedgerApi.V1 (
)
import PlutusLedgerApi.V1.Value qualified as Value
import PlutusTx.AssocMap qualified as AssocMap
--------------------------------------------------------------------------------
import Agora.Proposal (
ProposalDatum (..),
ProposalId (..),
ProposalRedeemer (Unlock),
ProposalStatus (..),
ProposalVotes (..),
ResultTag (..),
)
import Agora.Proposal.Time (ProposalStartingTime (ProposalStartingTime))
import Agora.Stake (ProposalLock (ProposalLock), Stake (..), StakeDatum (..))
import Sample.Proposal.Shared (proposalTxRef, stakeTxRef, testFunc)
import Sample.Shared (
minAda,
proposalPolicySymbol,
@ -43,19 +58,9 @@ import Sample.Shared (
stakeAssetClass,
stakeValidatorHash,
)
import Test.Util (sortValue, updateMap)
--------------------------------------------------------------------------------
import Agora.Proposal.Scripts (proposalValidator)
import Control.Monad (join)
import Data.Coerce (coerce)
import Data.Default.Class (Default (def))
import Data.Tagged (Tagged (..), untag)
import Plutarch.Context (BaseBuilder, buildTxInfoUnsafe, input, output, script, txId, withDatum, withRefIndex, withTxId, withValue)
import Sample.Proposal.Shared (proposalRef, stakeRef)
import Sample.Shared qualified as Shared
import Test.Specification (SpecificationTree, validatorFailsWith, validatorSucceedsWith)
import Test.Specification (SpecificationTree)
import Test.Util (sortValue, updateMap)
--------------------------------------------------------------------------------
@ -223,8 +228,8 @@ unlockStake p =
script proposalValidatorHash
. withValue pst
. withDatum i
. withTxId (txOutRefId proposalRef)
. withRefIndex (txOutRefIdx proposalRef + coerce i.proposalId)
. withTxId proposalTxRef
. withRefIndex (coerce i.proposalId + 2)
, output $
script proposalValidatorHash
. withValue (sortValue $ pst <> minAda)
@ -249,8 +254,8 @@ unlockStake p =
script stakeValidatorHash
. withValue stakeValue
. withDatum sInDatum
. withTxId (txOutRefId stakeRef)
. withRefIndex (txOutRefIdx stakeRef)
. withTxId stakeTxRef
. withRefIndex 1
, output $
script stakeValidatorHash
. withValue stakeValue
@ -271,6 +276,14 @@ mkProposalValidatorTestCase p shouldSucceed =
let datum = mkProposalInputDatum p $ ProposalId 0
redeemer = Unlock (ResultTag 0)
name = show p
scriptContext = ScriptContext (unlockStake p) (Spending proposalRef)
f = if shouldSucceed then validatorSucceedsWith else validatorFailsWith
in f name (proposalValidator Shared.proposal) datum redeemer scriptContext
scriptContext =
ScriptContext
(unlockStake p)
(Spending (TxOutRef proposalTxRef 2))
in testFunc
shouldSucceed
name
(proposalValidator Shared.proposal)
datum
redeemer
scriptContext

249
agora-specs/Sample/Proposal/Vote.hs Normal file
View file

@ -0,0 +1,249 @@
module Sample.Proposal.Vote (
validVoteParameters,
mkTestTree,
) where
import Agora.Proposal (
ProposalDatum (..),
ProposalId (ProposalId),
ProposalRedeemer (Vote),
ProposalStatus (VotingReady),
ProposalVotes (ProposalVotes),
ResultTag (ResultTag),
)
import Agora.Proposal.Scripts (proposalValidator)
import Agora.Proposal.Time (
ProposalStartingTime (ProposalStartingTime),
ProposalTimingConfig (draftTime, votingTime),
)
import Agora.Stake (
ProposalLock (ProposalLock),
Stake (gtClassRef),
StakeDatum (..),
StakeRedeemer (PermitVote),
)
import Agora.Stake.Scripts (stakeValidator)
import Data.Default (Default (def))
import Data.Tagged (Tagged (Tagged), untag)
import Plutarch.Context (
BaseBuilder,
buildTxInfoUnsafe,
input,
output,
script,
signedWith,
timeRange,
txId,
withDatum,
withOutRef,
withValue,
)
import PlutusLedgerApi.V1 (
PubKeyHash,
ScriptContext (..),
ScriptPurpose (Spending),
TxInfo,
TxOutRef (TxOutRef),
)
import PlutusLedgerApi.V1.Value qualified as Value
import PlutusTx.AssocMap qualified as AssocMap
import Sample.Proposal.Shared (proposalTxRef, stakeTxRef, testFunc)
import Sample.Shared (
minAda,
proposalPolicySymbol,
proposalValidatorHash,
signer,
stake,
stakeAssetClass,
stakeValidatorHash,
)
import Sample.Shared qualified as Shared
import Test.Specification (
SpecificationTree,
group,
validatorSucceedsWith,
)
import Test.Util (closedBoundedInterval, sortValue, updateMap)
proposalRef :: TxOutRef
proposalRef = TxOutRef proposalTxRef 0
stakeRef :: TxOutRef
stakeRef = TxOutRef stakeTxRef 1
-- | Parameters for creating a voting transaction.
data Parameters = Parameters
{ voteFor :: ResultTag
-- ^ The outcome the transaction is voting for.
, voteCount :: Integer
-- ^ The count of votes.
}
stakeOwner :: PubKeyHash
stakeOwner = signer
initialVotes :: AssocMap.Map ResultTag Integer
initialVotes =
AssocMap.fromList
[ (ResultTag 0, 42)
, (ResultTag 1, 4242)
]
proposalInputDatum :: ProposalDatum
proposalInputDatum =
ProposalDatum
{ proposalId = ProposalId 42
, effects =
AssocMap.fromList
[ (ResultTag 0, AssocMap.empty)
, (ResultTag 1, AssocMap.empty)
]
, status = VotingReady
, cosigners = [stakeOwner]
, thresholds = def
, votes = ProposalVotes initialVotes
, timingConfig = def
, startingTime = ProposalStartingTime 0
}
existingLocks :: [ProposalLock]
existingLocks =
[ ProposalLock (ResultTag 0) (ProposalId 0)
, ProposalLock (ResultTag 2) (ProposalId 1)
]
mkStakeInputDatum :: Parameters -> StakeDatum
mkStakeInputDatum params =
StakeDatum
{ stakedAmount = Tagged params.voteCount
, owner = stakeOwner
, lockedBy = existingLocks
}
mkProposalRedeemer :: Parameters -> ProposalRedeemer
mkProposalRedeemer = Vote . voteFor
mkNewLock :: Parameters -> ProposalLock
mkNewLock ps = ProposalLock ps.voteFor proposalInputDatum.proposalId
mkStakeRedeemer :: Parameters -> StakeRedeemer
mkStakeRedeemer = PermitVote . mkNewLock
-- | Create a valid transaction that votes on a propsal, given the parameters.
vote :: Parameters -> TxInfo
vote params =
let pst = Value.singleton proposalPolicySymbol "" 1
sst = Value.assetClassValue stakeAssetClass 1
---
stakeInputDatum = mkStakeInputDatum params
---
updatedVotes :: AssocMap.Map ResultTag Integer
updatedVotes = updateMap (Just . (+ params.voteCount)) params.voteFor initialVotes
---
proposalOutputDatum :: ProposalDatum
proposalOutputDatum =
proposalInputDatum
{ votes = ProposalVotes updatedVotes
}
---
-- Off-chain code should do exactly like this: prepend new lock toStatus the list.
updatedLocks :: [ProposalLock]
updatedLocks = mkNewLock params : existingLocks
---
stakeOutputDatum :: StakeDatum
stakeOutputDatum =
stakeInputDatum
{ lockedBy = updatedLocks
}
---
validTimeRange =
closedBoundedInterval
((def :: ProposalTimingConfig).draftTime + 1)
((def :: ProposalTimingConfig).votingTime - 1)
---
stakeValue =
sortValue $
sst
<> Value.assetClassValue (untag stake.gtClassRef) params.voteCount
<> minAda
builder :: BaseBuilder
builder =
mconcat
[ txId "827598fb2d69a896bbd9e645bb14c307df907f422b39eecbe4d6329bc30b428c"
, signedWith stakeOwner
, timeRange validTimeRange
, input $
script proposalValidatorHash
. withValue pst
. withDatum proposalInputDatum
. withOutRef proposalRef
, input $
script stakeValidatorHash
. withValue stakeValue
. withDatum stakeInputDatum
. withOutRef stakeRef
, output $
script proposalValidatorHash
. withValue pst
. withDatum proposalOutputDatum
, output $
script stakeValidatorHash
. withValue stakeValue
. withDatum stakeOutputDatum
]
in buildTxInfoUnsafe builder
---
validVoteParameters :: Parameters
validVoteParameters =
Parameters
{ voteFor = ResultTag 0
, voteCount = 27
}
---
mkTestTree :: String -> Parameters -> Bool -> SpecificationTree
mkTestTree name ps isValid = group name [proposal, stake]
where
txInfo = vote ps
proposal =
testFunc
isValid
"propsoal"
(proposalValidator Shared.proposal)
proposalInputDatum
(mkProposalRedeemer ps)
( ScriptContext
txInfo
(Spending proposalRef)
)
stake =
let stakeInputDatum = mkStakeInputDatum ps
in validatorSucceedsWith
"stake"
(stakeValidator Shared.stake)
stakeInputDatum
(mkStakeRedeemer ps)
( ScriptContext
txInfo
(Spending stakeRef)
)

428
agora-specs/Spec/Proposal.hs
View file

@ -1,5 +1,3 @@
{-# LANGUAGE QuasiQuotes #-}
{- |
Module : Spec.Proposal
Maintainer : emi@haskell.fyi
@ -11,45 +9,19 @@ module Spec.Proposal (specs) where
import Agora.Proposal (
Proposal (..),
ProposalDatum (..),
ProposalId (ProposalId),
ProposalRedeemer (..),
ProposalStatus (..),
ProposalThresholds (..),
ProposalVotes (ProposalVotes),
ResultTag (ResultTag),
cosigners,
effects,
emptyVotesFor,
proposalId,
status,
thresholds,
votes,
)
import Agora.Proposal.Scripts (proposalPolicy, proposalValidator)
import Agora.Proposal.Time (
ProposalStartingTime (ProposalStartingTime),
)
import Agora.Stake (
ProposalLock (ProposalLock),
StakeDatum (StakeDatum),
StakeRedeemer (PermitVote, WitnessStake),
)
import Agora.Stake.Scripts (stakeValidator)
import Data.Default.Class (Default (def))
import Data.Tagged (Tagged (Tagged), untag)
import PlutusLedgerApi.V1 (ScriptContext (..), ScriptPurpose (..))
import PlutusTx.AssocMap qualified as AssocMap
import Agora.Proposal.Scripts (proposalPolicy)
import Sample.Proposal qualified as Proposal
import Sample.Proposal.Advance qualified as Advance
import Sample.Proposal.Cosign qualified as Cosign
import Sample.Proposal.UnlockStake qualified as UnlockStake
import Sample.Shared (signer, signer2)
import Sample.Shared qualified as Shared (proposal, stake)
import Sample.Proposal.Vote qualified as Vote
import Sample.Shared qualified as Shared (proposal)
import Test.Specification (
SpecificationTree,
group,
policySucceedsWith,
validatorFailsWith,
validatorSucceedsWith,
)
-- | Stake specs.
@ -67,279 +39,133 @@ specs =
"validator"
[ group
"cosignature"
[ validatorSucceedsWith
"proposal"
(proposalValidator Shared.proposal)
( ProposalDatum
{ proposalId = ProposalId 0
, effects =
AssocMap.fromList
[ (ResultTag 0, AssocMap.empty)
, (ResultTag 1, AssocMap.empty)
]
, status = Draft
, cosigners = [signer]
, thresholds = def
, votes =
emptyVotesFor $
AssocMap.fromList
[ (ResultTag 0, AssocMap.empty)
, (ResultTag 1, AssocMap.empty)
]
, timingConfig = def
, startingTime = ProposalStartingTime 0
}
)
(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))
]
$ let cosignerCases = [1, 5, 10]
mkLegalGroup nCosigners =
Cosign.mkTestTree
("with " <> show nCosigners <> " cosigners")
(Cosign.validCosignNParameters nCosigners)
True
legalGroup =
group "legal" $
map mkLegalGroup cosignerCases
mkIllegalStatusNotDraftGroup nCosigners =
group ("with " <> show nCosigners <> " cosigners") $
map
( \ps ->
Cosign.mkTestTree
("status: " <> show ps.proposalStatus)
ps
False
)
(Cosign.statusNotDraftCosignNParameters nCosigners)
illegalStatusNotDraftGroup =
group "proposal status not Draft" $
map mkIllegalStatusNotDraftGroup cosignerCases
illegalGroup =
group
"illegal"
[ Cosign.mkTestTree
"duplicate cosigners"
Cosign.duplicateCosignersParameters
False
, Cosign.mkTestTree
"altered output stake"
Cosign.invalidStakeOutputParameters
False
, illegalStatusNotDraftGroup
]
in [legalGroup, illegalGroup]
, group
"voting"
[ validatorSucceedsWith
"proposal"
(proposalValidator Shared.proposal)
( ProposalDatum
{ proposalId = ProposalId 42
, effects =
AssocMap.fromList
[ (ResultTag 0, AssocMap.empty)
, (ResultTag 1, AssocMap.empty)
[ Vote.mkTestTree "legal" Vote.validVoteParameters True
-- TODO: add negative test cases
]
, group "advancing" $
let mkFromDraft nCosigners =
let name = "with " <> show nCosigners <> " cosigner(s)"
legalGroup =
group
"legal"
[ Advance.mkTestTree
"to next state"
( head $
Advance.advanceToNextStateInTimeParameters
nCosigners
)
True
, Advance.mkTestTree
"to failed state"
( head $
Advance.advanceToFailedStateDueToTimeoutParameters
nCosigners
)
True
]
, status = VotingReady
, cosigners = [signer]
, thresholds = def
, votes =
ProposalVotes
( AssocMap.fromList
[ (ResultTag 0, 42)
, (ResultTag 1, 4242)
]
illegalGroup =
group
"illegal"
[ Advance.mkTestTree
"insufficient cosigns"
(Advance.insufficientCosignsParameters nCosigners)
False
, Advance.mkTestTree
"invalid stake output"
(head $ Advance.invalidOutputStakeParameters nCosigners)
False
]
in group name [legalGroup, illegalGroup]
draftGroup = group "from draft" $ map mkFromDraft [1, 5, 10]
legalGroup =
group
"legal"
[ group "advance to next state" $
map
( \ps ->
let name = "from: " <> show ps.fromStatus
in Advance.mkTestTree name ps True
)
, timingConfig = def
, startingTime = ProposalStartingTime 0
}
)
(Vote (ResultTag 0))
( ScriptContext
( Proposal.voteOnProposal
Proposal.VotingParameters
{ Proposal.voteFor = ResultTag 0
, Proposal.voteCount = 27
}
)
(Spending Proposal.proposalRef)
)
, validatorSucceedsWith
"stake"
(stakeValidator Shared.stake)
( StakeDatum
(Tagged 27)
signer
[ ProposalLock (ResultTag 0) (ProposalId 0)
, ProposalLock (ResultTag 2) (ProposalId 1)
(tail $ Advance.advanceToNextStateInTimeParameters 1)
, group "advance to failed state" $
map
( \ps ->
let name = "from: " <> show ps.fromStatus
in Advance.mkTestTree name ps True
)
(tail $ Advance.advanceToFailedStateDueToTimeoutParameters 1)
]
)
(PermitVote $ ProposalLock (ResultTag 0) (ProposalId 42))
( ScriptContext
( Proposal.voteOnProposal
Proposal.VotingParameters
{ Proposal.voteFor = ResultTag 0
, Proposal.voteCount = 27
}
)
(Spending Proposal.stakeRef)
)
]
, group
"advancing"
[ group "successfully advance to next state" $
map
( \(name, initialState) ->
validatorSucceedsWith
name
(proposalValidator Shared.proposal)
( ProposalDatum
{ proposalId = ProposalId 0
, effects =
AssocMap.fromList
[ (ResultTag 0, AssocMap.empty)
, (ResultTag 1, AssocMap.empty)
]
, status = initialState
, cosigners = [signer]
, thresholds = def
, votes =
ProposalVotes
( AssocMap.fromList
[
( ResultTag 0
, case initialState of
Draft -> 0
_ -> untag (def :: ProposalThresholds).execute + 1
)
, (ResultTag 1, 0)
]
)
, timingConfig = def
, startingTime = ProposalStartingTime 0
}
)
AdvanceProposal
( ScriptContext
( Proposal.advanceProposalSuccess
Proposal.TransitionParameters
{ Proposal.initialProposalStatus = initialState
, Proposal.proposalStartingTime = ProposalStartingTime 0
}
)
(Spending Proposal.proposalRef)
)
)
[ ("Draft -> VotringReady", Draft)
, ("VotingReady -> Locked", VotingReady)
, ("Locked -> Finished", Locked)
]
, group "successfully advance to failed state: timeout" $
map
( \(name, initialState) ->
validatorSucceedsWith
name
(proposalValidator Shared.proposal)
( ProposalDatum
{ proposalId = ProposalId 0
, effects =
AssocMap.fromList
[ (ResultTag 0, AssocMap.empty)
, (ResultTag 1, AssocMap.empty)
]
, status = initialState
, cosigners = [signer]
, thresholds = def
, votes =
ProposalVotes
( AssocMap.fromList
[
( ResultTag 0
, case initialState of
Draft -> 0
_ -> untag (def :: ProposalThresholds).vote + 1
)
, (ResultTag 1, 0)
]
)
, timingConfig = def
, startingTime = ProposalStartingTime 0
}
)
AdvanceProposal
( ScriptContext
( Proposal.advanceProposalFailureTimeout
Proposal.TransitionParameters
{ Proposal.initialProposalStatus = initialState
, Proposal.proposalStartingTime = ProposalStartingTime 0
}
)
(Spending Proposal.proposalRef)
)
)
[ ("Draft -> Finished", Draft)
, ("VotingReady -> Finished", VotingReady)
, ("Locked -> Finished", Locked)
]
, validatorFailsWith
"illegal: insufficient votes"
(proposalValidator Shared.proposal)
( ProposalDatum
{ proposalId = ProposalId 0
, effects =
AssocMap.fromList
[ (ResultTag 0, AssocMap.empty)
, (ResultTag 1, AssocMap.empty)
]
, status = VotingReady
, cosigners = [signer]
, thresholds = def
, votes =
ProposalVotes
( AssocMap.fromList
[ (ResultTag 0, 1)
, (ResultTag 1, 0)
]
)
, timingConfig = def
, startingTime = ProposalStartingTime 0
}
)
AdvanceProposal
( ScriptContext
Proposal.advanceProposalInsufficientVotes
(Spending Proposal.proposalRef)
)
, validatorFailsWith
"illegal: initial state is Finished"
(proposalValidator Shared.proposal)
( ProposalDatum
{ proposalId = ProposalId 0
, effects =
AssocMap.fromList
[ (ResultTag 0, AssocMap.empty)
, (ResultTag 1, AssocMap.empty)
]
, status = Finished
, cosigners = [signer]
, thresholds = def
, votes =
ProposalVotes
( AssocMap.fromList
[ (ResultTag 0, untag (def :: ProposalThresholds).vote + 1)
, (ResultTag 1, 0)
]
)
, timingConfig = def
, startingTime = ProposalStartingTime 0
}
)
AdvanceProposal
( ScriptContext
Proposal.advanceFinishedProposal
(Spending Proposal.proposalRef)
)
, validatorFailsWith
"illegal: with stake input"
(proposalValidator Shared.proposal)
( ProposalDatum
{ proposalId = ProposalId 0
, effects =
AssocMap.fromList
[ (ResultTag 0, AssocMap.empty)
, (ResultTag 1, AssocMap.empty)
]
, status = VotingReady
, cosigners = [signer]
, thresholds = def
, votes =
ProposalVotes
( AssocMap.fromList
[ (ResultTag 0, 0)
, (ResultTag 1, 0)
]
)
, timingConfig = def
, startingTime = ProposalStartingTime 0
}
)
AdvanceProposal
( ScriptContext
Proposal.advanceProposalWithInvalidOutputStake
(Spending Proposal.proposalRef)
)
]
illegalGroup =
group
"illegal"
[ Advance.mkTestTree
"insufficient votes"
Advance.insufficientVotesParameters
False
, Advance.mkTestTree
"initial state is Finished"
Advance.advanceFromFinishedParameters
False
, group
"invalid stake output"
$ do
nStake <- [1, 5]
ps <- tail $ Advance.invalidOutputStakeParameters nStake
let name =
"from " <> show ps.fromStatus <> "with "
<> show nStake
<> " stakes"
pure $ Advance.mkTestTree name ps False
]
in [draftGroup, legalGroup, illegalGroup]
, group "unlocking" $ do
proposalCount <- [1, 42]

41
agora-testlib/Test/Util.hs
View file

@ -13,22 +13,24 @@ module Test.Util (
updateMap,
sortMap,
sortValue,
blake2b_224,
pubKeyHashes,
userCredentials,
scriptCredentials,
) where
--------------------------------------------------------------------------------
import Prelude
--------------------------------------------------------------------------------
import Codec.Serialise (serialise)
import Data.ByteString.Lazy qualified as ByteString.Lazy
--------------------------------------------------------------------------------
import Crypto.Hash qualified as Crypto
import Data.Bifunctor (second)
import Data.ByteArray qualified as BA
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as C
import Data.ByteString.Lazy qualified as ByteString.Lazy
import Data.List (sortOn)
import Plutarch.Crypto (pblake2b_256)
import PlutusLedgerApi.V1 (Credential (PubKeyCredential, ScriptCredential), PubKeyHash (..), ValidatorHash (ValidatorHash))
import PlutusLedgerApi.V1.Interval qualified as PlutusTx
import PlutusLedgerApi.V1.Scripts (Datum (Datum), DatumHash (DatumHash))
import PlutusLedgerApi.V1.Value (Value (..))
@ -36,6 +38,7 @@ import PlutusTx.AssocMap qualified as AssocMap
import PlutusTx.Builtins qualified as PlutusTx
import PlutusTx.IsData qualified as PlutusTx
import PlutusTx.Ord qualified as PlutusTx
import Prelude
--------------------------------------------------------------------------------
@ -106,3 +109,25 @@ sortValue =
. fmap (second sortMap)
. AssocMap.toList
. getValue
--------------------------------------------------------------------------------
-- | Compute the hash of a given byte string using blake2b_224 algorithm.
blake2b_224 :: BS.ByteString -> BS.ByteString
blake2b_224 = BS.pack . BA.unpack . Crypto.hashWith Crypto.Blake2b_224
-- | An infinite list of blake2b_224 hashes.
blake2b_224Hashes :: [BS.ByteString]
blake2b_224Hashes = blake2b_224 . C.pack . show @Integer <$> [0 ..]
-- | An infinite list of *valid* 'PubKeyHash'.
pubKeyHashes :: [PubKeyHash]
pubKeyHashes = PubKeyHash . PlutusTx.toBuiltin <$> blake2b_224Hashes
-- | An infinite list of *valid* user credentials.
userCredentials :: [Credential]
userCredentials = PubKeyCredential <$> pubKeyHashes
-- | An infinite list of *valid* script credentials.
scriptCredentials :: [Credential]
scriptCredentials = ScriptCredential . ValidatorHash . PlutusTx.toBuiltin <$> blake2b_224Hashes

5
agora.cabal
View file

@ -16,7 +16,7 @@ common lang
-Wno-unused-do-bind -Wno-partial-type-signatures
-Wmissing-export-lists -Wincomplete-record-updates
-Wmissing-deriving-strategies -Wno-name-shadowing -Wunused-foralls
-fprint-explicit-foralls -fprint-explicit-kinds
-fprint-explicit-foralls -fprint-explicit-kinds -Wunused-do-bind
mixins:
base hiding (Prelude),
@ -189,8 +189,11 @@ library agora-specs
Sample.Effect.TreasuryWithdrawal
Sample.Governor
Sample.Proposal
Sample.Proposal.Advance
Sample.Proposal.Cosign
Sample.Proposal.Shared
Sample.Proposal.UnlockStake
Sample.Proposal.Vote
Sample.Shared
Sample.Stake
Sample.Treasury

6
agora/Agora/Proposal.hs
View file

@ -283,6 +283,8 @@ data ProposalDatum = ProposalDatum
-- ^ The status the proposal is in.
, cosigners :: [PubKeyHash]
-- ^ Who created the proposal initially, and who cosigned it later.
--
-- This list should be sorted in **ascending** order.
, thresholds :: ProposalThresholds
-- ^ Thresholds copied over on initialization.
, votes :: ProposalVotes
@ -321,7 +323,9 @@ data ProposalRedeemer
--
-- This is particularly used in the 'Draft' 'ProposalStatus',
-- where matching 'Agora.Stake.Stake's can be called to advance the proposal,
-- provided enough GT is shared among them.
-- provided enough GT is shared among them.
--
-- This list should be sorted in ascending order.
Cosign [PubKeyHash]
| -- | Allow unlocking one or more stakes with votes towards particular 'ResultTag'.
Unlock ResultTag

792
agora/Agora/Proposal/Scripts.hs
View file

@ -30,34 +30,38 @@ import Agora.Stake (
PProposalLock (..),
PStakeDatum (..),
PStakeUsage (..),
findStakeOwnedBy,
pgetStakeUsage,
)
import Agora.Utils (
getMintingPolicySymbol,
mustBePJust,
mustFindDatum',
pisUniq',
pltAsData,
)
import Plutarch.Api.V1 (
PDatumHash,
PMintingPolicy,
PPubKeyHash,
PScriptContext (PScriptContext),
PScriptPurpose (PMinting, PSpending),
PTxInfo (PTxInfo),
PTxOut,
PValidator,
)
import Plutarch.Api.V1.AssetClass (passetClass, passetClassValueOf)
import Plutarch.Api.V1.ScriptContext (
pfindTxInByTxOutRef,
pisTokenSpent,
ptryFindDatum,
ptxSignedBy,
pvalueSpent,
)
import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (psymbolValueOf)
import Plutarch.Extra.Comonad (pextract)
import Plutarch.Extra.IsData (pmatchEnum)
import Plutarch.Extra.List (pisUniqBy)
import Plutarch.Extra.List (pmapMaybe, pmergeBy, pmsortBy)
import Plutarch.Extra.Map (plookup, pupdate)
import Plutarch.Extra.Maybe (pisJust)
import Plutarch.Extra.Maybe (pfromDJust, pfromJust, pisJust)
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
import Plutarch.Extra.TermCont (
pguardC,
@ -191,9 +195,12 @@ proposalValidator proposal =
ownAddress <- pletC $ txOutF.address
thresholdsF <- pletFieldsC @'["execute", "create", "vote"] proposalF.thresholds
currentStatus <- pletC $ pfromData $ proposalF.status
let stCurrencySymbol =
pconstant $ getMintingPolicySymbol (proposalPolicy proposal.governorSTAssetClass)
valueSpent <- pletC $ pvalueSpent # txInfoF.inputs
signedBy <- pletC $ ptxSignedBy # txInfoF.signatories
@ -236,339 +243,460 @@ proposalValidator proposal =
# txInfoF.datums
proposalUnchanged <- pletC $ proposalOut #== proposalDatum
proposalOutStatus <-
pletC $
pfromData $
pfield @"status" # proposalOut
onlyStatusChanged <-
pletC $
-- Only the status of proposals is updated.
-- Only the status of proposals is updated.
proposalOut
#== mkRecordConstr
PProposalDatum
( #proposalId .= proposalF.proposalId
.& #effects .= proposalF.effects
.& #status .= pdata proposalOutStatus
.& #cosigners .= proposalF.cosigners
.& #thresholds .= proposalF.thresholds
.& #votes .= proposalF.votes
.& #timingConfig .= proposalF.timingConfig
.& #startingTime .= proposalF.startingTime
)
--------------------------------------------------------------------------
-- Find the stake input and stake output by SST.
-- Find the stake inputs/outputs by SST.
let AssetClass (stakeSym, stakeTn) = proposal.stakeSTAssetClass
stakeSTAssetClass <-
pletC $ passetClass # pconstant stakeSym # pconstant stakeTn
spentStakeST <-
pletC $ passetClassValueOf # valueSpent # stakeSTAssetClass
let stakeInput =
pfield @"resolved"
#$ mustBePJust
# "Stake input should be present"
#$ pfind
# plam
( \(pfromData . (pfield @"value" #) . (pfield @"resolved" #) -> value) ->
passetClassValueOf # value # stakeSTAssetClass #== 1
)
# pfromData txInfoF.inputs
stakeIn <- pletC $ mustFindDatum' @PStakeDatum # (pfield @"datumHash" # stakeInput) # txInfoF.datums
stakeInF <- pletFieldsC @'["stakedAmount", "lockedBy", "owner"] stakeIn
let stakeOutput =
mustBePJust # "Stake output should be present"
#$ pfind
# plam
( \(pfromData . (pfield @"value" #) -> value) ->
passetClassValueOf # value # stakeSTAssetClass #== 1
)
# pfromData txInfoF.outputs
stakeOut <- pletC $ mustFindDatum' @PStakeDatum # (pfield @"datumHash" # stakeOutput) # txInfoF.datums
stakeUnchanged <- pletC $ stakeIn #== stakeOut
--------------------------------------------------------------------------
pure $
pmatch proposalRedeemer $ \case
PVote r -> unTermCont $ do
pguardC "Input proposal must be in VotingReady state" $
proposalF.status #== pconstant VotingReady
pguardC "Proposal time should be wthin the voting period" $
isVotingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime
-- Ensure the transaction is voting to a valid 'ResultTag'(outcome).
PProposalVotes voteMap <- pmatchC proposalF.votes
voteFor <- pletC $ pfromData $ pfield @"resultTag" # r
pguardC "Vote option should be valid" $
pisJust #$ plookup # voteFor # voteMap
-- Ensure that no lock with the current proposal id has been put on the stake.
pguardC "Same stake shouldn't vote on the same proposal twice" $
pnot #$ pany
# plam
( \((pfield @"proposalTag" #) . pfromData -> pid) ->
pid #== proposalF.proposalId
)
# pfromData stakeInF.lockedBy
let -- The amount of new votes should be the 'stakedAmount'.
-- Update the vote counter of the proposal, and leave other stuff as is.
expectedNewVotes = pmatch (pfromData proposalF.votes) $ \(PProposalVotes m) ->
pcon $
PProposalVotes $
pupdate
# plam
( \votes -> unTermCont $ do
PDiscrete v <- pmatchC stakeInF.stakedAmount
pure $ pcon $ PJust $ votes + (pextract # v)
)
# voteFor
# m
expectedProposalOut =
mkRecordConstr
PProposalDatum
( #proposalId .= proposalF.proposalId
.& #effects .= proposalF.effects
.& #status .= proposalF.status
.& #cosigners .= proposalF.cosigners
.& #thresholds .= proposalF.thresholds
.& #votes .= pdata expectedNewVotes
.& #timingConfig .= proposalF.timingConfig
.& #startingTime .= proposalF.startingTime
)
pguardC "Output proposal should be valid" $ proposalOut #== expectedProposalOut
-- We validate the output stake datum here as well: We need the vote option
-- to create a valid 'ProposalLock', however the vote option is encoded
-- in the proposal redeemer, which is invisible for the stake validator.
let newProposalLock =
mkRecordConstr
PProposalLock
( #vote .= pdata voteFor
.& #proposalTag .= proposalF.proposalId
)
-- Prepend the new lock to existing locks
expectedProposalLocks =
pcons
# pdata newProposalLock
# pfromData stakeInF.lockedBy
expectedStakeOut =
mkRecordConstr
PStakeDatum
( #stakedAmount .= stakeInF.stakedAmount
.& #owner .= stakeInF.owner
.& #lockedBy .= pdata expectedProposalLocks
)
pguardC "Output stake should be locked by the proposal" $ expectedStakeOut #== stakeOut
pure $ popaque (pconstant ())
--------------------------------------------------------------------------
PCosign r -> unTermCont $ do
pguardC "Stake should not change" stakeUnchanged
newSigs <- pletC $ pfield @"newCosigners" # r
pguardC "Cosigners are unique" $
pisUniqBy
# phoistAcyclic (plam (#==))
# phoistAcyclic (plam $ \(pfromData -> x) (pfromData -> y) -> x #< y)
# newSigs
pguardC "Signed by all new cosigners" $
pall # signedBy # newSigs
pguardC "As many new cosigners as Stake datums" $
spentStakeST #== plength # newSigs
pguardC "All new cosigners are witnessed by their Stake datums" $
pall
# plam
( \sig ->
pmatch
( findStakeOwnedBy # stakeSTAssetClass
# pfromData sig
# txInfoF.datums
# txInfoF.inputs
)
$ \case
PNothing -> pcon PFalse
PJust _ -> pcon PTrue
)
# newSigs
let updatedSigs = pconcat # newSigs # proposalF.cosigners
expectedDatum =
mkRecordConstr
PProposalDatum
( #proposalId .= proposalF.proposalId
.& #effects .= proposalF.effects
.& #status .= proposalF.status
.& #cosigners .= pdata updatedSigs
.& #thresholds .= proposalF.thresholds
.& #votes .= proposalF.votes
.& #timingConfig .= proposalF.timingConfig
.& #startingTime .= proposalF.startingTime
)
pguardC "Signatures are correctly added to cosignature list" $
proposalOut #== expectedDatum
pure $ popaque (pconstant ())
--------------------------------------------------------------------------
PUnlock r -> unTermCont $ do
-- At draft stage, the votes should be empty.
pguardC "Shouldn't retract votes from a draft proposal" $
pnot #$ proposalF.status #== pconstantData Draft
-- This is the vote option we're retracting from.
retractFrom <- pletC $ pfield @"resultTag" # r
-- Determine if the input stake is actually locked by this proposal.
stakeUsage <- pletC $ pgetStakeUsage # stakeInF.lockedBy # proposalF.proposalId
pguardC "Stake input relevant" $
pmatch stakeUsage $ \case
PDidNothing ->
ptraceIfFalse "Stake should be relevant" $
pconstant False
PCreated ->
ptraceIfFalse "Removing creator's locks means status is Finished" $
proposalF.status #== pconstantData Finished
PVotedFor rt ->
ptraceIfFalse "Result tag should match the one given in the redeemer" $
rt #== retractFrom
-- The count of removing votes is equal to the 'stakeAmount' of input stake.
retractCount <-
pletC $
pmatch stakeInF.stakedAmount $ \(PDiscrete v) -> pextract # v
-- The votes can only change when the proposal still allows voting.
let shouldUpdateVotes =
proposalF.status #== pconstantData VotingReady
#&& pnot # (pcon PCreated #== stakeUsage)
pguardC "Proposal output correct" $
pif
shouldUpdateVotes
( let -- Remove votes and leave other parts of the proposal as it.
expectedVotes = pretractVotes # retractFrom # retractCount # proposalF.votes
expectedProposalOut =
mkRecordConstr
PProposalDatum
( #proposalId .= proposalF.proposalId
.& #effects .= proposalF.effects
.& #status .= proposalF.status
.& #cosigners .= proposalF.cosigners
.& #thresholds .= proposalF.thresholds
.& #votes .= pdata expectedVotes
.& #timingConfig .= proposalF.timingConfig
.& #startingTime .= proposalF.startingTime
)
in ptraceIfFalse "Update votes" $
expectedProposalOut #== proposalOut
)
-- No change to the proposal is allowed.
$ ptraceIfFalse "Proposal unchanged" proposalUnchanged
-- At last, we ensure that all locks belong to this proposal will be removed.
stakeOutputLocks <- pletC $ pfield @"lockedBy" # stakeOut
let templateStakeOut =
mkRecordConstr
PStakeDatum
( #stakedAmount .= stakeInF.stakedAmount
.& #owner .= stakeInF.owner
.& #lockedBy .= stakeOutputLocks
)
pguardC "Only locks updated in the output stake" $
templateStakeOut #== stakeOut
pguardC "All relevant locks removed from the stake" $
pgetStakeUsage # pfromData stakeOutputLocks
# proposalF.proposalId #== pcon PDidNothing
pure $ popaque (pconstant ())
--------------------------------------------------------------------------
PAdvanceProposal _r -> unTermCont $ do
pguardC "Stake should not change" stakeUnchanged
proposalOutStatus <- pletC $ pfield @"status" # proposalOut
let -- Only the status of proposals should be updated in this case.
templateProposalOut =
mkRecordConstr
PProposalDatum
( #proposalId .= proposalF.proposalId
.& #effects .= proposalF.effects
.& #status .= proposalOutStatus
.& #cosigners .= proposalF.cosigners
.& #thresholds .= proposalF.thresholds
.& #votes .= proposalF.votes
.& #timingConfig .= proposalF.timingConfig
.& #startingTime .= proposalF.startingTime
)
pguardC "Only status changes in the output proposal" $
templateProposalOut #== proposalOut
inDraftPeriod <- pletC $ isDraftPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime
inVotingPeriod <- pletC $ isVotingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime
inLockedPeriod <- pletC $ isLockingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime
inExecutionPeriod <- pletC $ isExecutionPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime
proposalStatus <- pletC $ pto $ pfromData proposalF.status
-- Check the timings.
let isFinished = proposalF.status #== pconstantData Finished
notTooLate = pmatchEnum proposalStatus $ \case
Draft -> inDraftPeriod
-- Can only advance after the voting period is over.
VotingReady -> inLockedPeriod
Locked -> inExecutionPeriod
_ -> pconstant False
notTooEarly = pmatchEnum (pto $ pfromData proposalF.status) $ \case
VotingReady -> pnot # inVotingPeriod
Locked -> pnot # inLockedPeriod
_ -> pconstant True
pguardC "Cannot advance ahead of time" notTooEarly
pguardC "Finished proposals cannot be advanced" $ pnot # isFinished
thresholdsF <- pletFieldsC @'["execute"] proposalF.thresholds
filterStakeDatumHash :: Term _ (PAsData PTxOut :--> PMaybe (PAsData PDatumHash)) <-
pletC $
plam $ \(pfromData -> txOut) -> unTermCont $ do
txOutF <- pletFieldsC @'["value", "datumHash"] txOut
pure $
pif
notTooLate
-- On time: advance to next status.
( pmatchEnum proposalStatus $ \case
Draft -> unTermCont $ do
-- TODO: Perform other necessary checks.
-- 'Draft' -> 'VotingReady'
pguardC "Proposal status set to VotingReady" $
proposalOutStatus #== pconstantData VotingReady
pure $ popaque (pconstant ())
VotingReady -> unTermCont $ do
-- 'VotingReady' -> 'Locked'
pguardC "Proposal status set to Locked" $
proposalOutStatus #== pconstantData Locked
pguardC "Winner outcome not found" $
pisJust #$ pwinner' # proposalF.votes
#$ punsafeCoerce
$ pfromData thresholdsF.execute
pure $ popaque (pconstant ())
Locked -> unTermCont $ do
-- 'Locked' -> 'Finished'
pguardC "Proposal status set to Finished" $
proposalOutStatus #== pconstantData Finished
-- TODO: Perform other necessary checks.
pure $ popaque (pconstant ())
_ -> popaque (pconstant ())
)
-- Too late: failed proposal, status set to 'Finished'.
( popaque $
ptraceIfFalse "Proposal should fail: not on time" $
proposalOutStatus #== pconstantData Finished
-- TODO: Should check that the GST is not moved
-- if the proposal is in 'Locked' state.
(passetClassValueOf # txOutF.value # stakeSTAssetClass #== 1)
( let datumHash = pfromDJust # txOutF.datumHash
in pcon $ PJust $ pdata datumHash
)
(pcon PNothing)
stakeInputDatumHashes <-
pletC $
pmapMaybe @PBuiltinList
# plam ((filterStakeDatumHash #) . (pfield @"resolved" #))
# txInfoF.inputs
stakeOutputDatumHashes <-
pletC $
pmapMaybe @PBuiltinList
# filterStakeDatumHash
# txInfoF.outputs
stakeInputNum <- pletC $ plength # stakeInputDatumHashes
pguardC "Every stake input should have a correspoding output" $
stakeInputNum #== plength # stakeOutputDatumHashes
----------------------------------------------------------------------------
withMultipleStakes' ::
Term
_
( ( PInteger
:--> PBuiltinList (PAsData PPubKeyHash)
:--> PUnit
)
:--> PUnit
) <-
pletC $
plam $ \validationLogic -> unTermCont $ do
-- The following code ensures that all the stake datums are not
-- changed.
--
-- TODO: This is quite inefficient (O(nlogn)) but for now we don't
-- have a nice way to check this. In plutus v2 we'll have map of
-- (Script -> Redeemer) in ScriptContext, which should be the
-- straight up solution.
let sortDatumHashes = phoistAcyclic $ pmsortBy # pltAsData
sortedStakeInputDatumHashes =
sortDatumHashes # stakeInputDatumHashes
sortedStakeOutputDatumHashes =
sortDatumHashes # stakeOutputDatumHashes
pguardC "All stake datum are unchanged" $
plistEquals
# sortedStakeInputDatumHashes
# sortedStakeOutputDatumHashes
PPair totalStakedAmount stakeOwners <-
pmatchC $
pfoldl
# plam
( \l dh -> unTermCont $ do
let stake =
pfromData $
pfromJust
#$ ptryFindDatum
@(PAsData PStakeDatum)
# pfromData dh
# txInfoF.datums
stakeF <- pletFieldsC @'["stakedAmount", "owner"] stake
PPair amount owners <- pmatchC l
let newAmount = amount + punsafeCoerce (pfromData stakeF.stakedAmount)
updatedOwners = pcons # stakeF.owner # owners
pure $ pcon $ PPair newAmount updatedOwners
)
# pcon (PPair (0 :: Term _ PInteger) (pnil @PBuiltinList))
# stakeInputDatumHashes
sortedStakeOwners <- pletC $ pmsortBy # pltAsData # stakeOwners
pure $ validationLogic # totalStakedAmount # sortedStakeOwners
withSingleStake' ::
Term
_
( ( PStakeDatum :--> PStakeDatum :--> PBool :--> PUnit
)
:--> PUnit
) <- pletC $
plam $ \validationLogic -> unTermCont $ do
pguardC "Can only deal with one stake" $
stakeInputNum #== 1
stakeInputHash <- pletC $ pfromData $ phead # stakeInputDatumHashes
stakeOutputHash <- pletC $ pfromData $ phead # stakeOutputDatumHashes
stakeIn :: Term _ PStakeDatum <-
pletC $
pfromData $
pfromJust #$ ptryFindDatum # stakeInputHash # txInfoF.datums
stakeOut :: Term _ PStakeDatum <-
pletC $
pfromData $
pfromJust #$ ptryFindDatum # stakeOutputHash # txInfoF.datums
stakeUnchanged <- pletC $ stakeInputHash #== stakeOutputHash
pure $ validationLogic # stakeIn # stakeOut # stakeUnchanged
let withMultipleStakes val =
withMultipleStakes' #$ plam $
\totalStakedAmount
sortedStakeOwner ->
unTermCont $
val totalStakedAmount sortedStakeOwner
withSingleStake val =
withSingleStake' #$ plam $ \stakeIn stakeOut stakeUnchange -> unTermCont $ do
stakeInF <- pletFieldsC @'["stakedAmount", "lockedBy", "owner"] stakeIn
val stakeInF stakeOut stakeUnchange
pure $
popaque $
pmatch proposalRedeemer $ \case
PCosign r -> withMultipleStakes $ \_ sortedStakeOwners -> do
pguardC "Should be in draft state" $
currentStatus #== pconstant Draft
newSigs <- pletC $ pfield @"newCosigners" # r
pguardC "Signed by all new cosigners" $
pall # signedBy # newSigs
updatedSigs <-
pletC $
pmergeBy # pltAsData
# newSigs
# proposalF.cosigners
pguardC "Cosigners are unique" $
pisUniq' # updatedSigs
pguardC "All new cosigners are witnessed by their Stake datums" $
plistEquals # sortedStakeOwners # newSigs
let expectedDatum =
mkRecordConstr
PProposalDatum
( #proposalId .= proposalF.proposalId
.& #effects .= proposalF.effects
.& #status .= proposalF.status
.& #cosigners .= pdata updatedSigs
.& #thresholds .= proposalF.thresholds
.& #votes .= proposalF.votes
.& #timingConfig .= proposalF.timingConfig
.& #startingTime .= proposalF.startingTime
)
pguardC "Signatures are correctly added to cosignature list" $
proposalOut #== expectedDatum
pure $ pconstant ()
----------------------------------------------------------------------
PVote r -> withSingleStake $ \stakeInF stakeOut _ -> do
pguardC "Input proposal must be in VotingReady state" $
currentStatus #== pconstant VotingReady
pguardC "Proposal time should be wthin the voting period" $
isVotingPeriod # proposalF.timingConfig
# proposalF.startingTime
# currentTime
-- Ensure the transaction is voting to a valid 'ResultTag'(outcome).
PProposalVotes voteMap <- pmatchC proposalF.votes
voteFor <- pletC $ pfromData $ pfield @"resultTag" # r
pguardC "Vote option should be valid" $
pisJust #$ plookup # voteFor # voteMap
-- Ensure that no lock with the current proposal id has been put on the stake.
pguardC "Same stake shouldn't vote on the same proposal twice" $
pnot #$ pany
# plam
( \((pfield @"proposalTag" #) . pfromData -> pid) ->
pid #== proposalF.proposalId
)
# pfromData stakeInF.lockedBy
let -- The amount of new votes should be the 'stakedAmount'.
-- Update the vote counter of the proposal, and leave other stuff as is.
expectedNewVotes = pmatch (pfromData proposalF.votes) $ \(PProposalVotes m) ->
pcon $
PProposalVotes $
pupdate
# plam
( \votes -> unTermCont $ do
PDiscrete v <- pmatchC stakeInF.stakedAmount
pure $ pcon $ PJust $ votes + (pextract # v)
)
# voteFor
# m
expectedProposalOut =
mkRecordConstr
PProposalDatum
( #proposalId .= proposalF.proposalId
.& #effects .= proposalF.effects
.& #status .= proposalF.status
.& #cosigners .= proposalF.cosigners
.& #thresholds .= proposalF.thresholds
.& #votes .= pdata expectedNewVotes
.& #timingConfig .= proposalF.timingConfig
.& #startingTime .= proposalF.startingTime
)
pguardC "Output proposal should be valid" $ proposalOut #== expectedProposalOut
-- We validate the output stake datum here as well: We need the vote option
-- to create a valid 'ProposalLock', however the vote option is encoded
-- in the proposal redeemer, which is invisible for the stake validator.
let newProposalLock =
mkRecordConstr
PProposalLock
( #vote .= pdata voteFor
.& #proposalTag .= proposalF.proposalId
)
-- Prepend the new lock to existing locks
expectedProposalLocks =
pcons
# pdata newProposalLock
# pfromData stakeInF.lockedBy
expectedStakeOut =
mkRecordConstr
PStakeDatum
( #stakedAmount .= stakeInF.stakedAmount
.& #owner .= stakeInF.owner
.& #lockedBy .= pdata expectedProposalLocks
)
pguardC "Output stake should be locked by the proposal" $ expectedStakeOut #== stakeOut
pure $ pconstant ()
----------------------------------------------------------------------
PUnlock r -> withSingleStake $ \stakeInF stakeOut _ -> do
-- At draft stage, the votes should be empty.
pguardC "Shouldn't retract votes from a draft proposal" $
pnot #$ currentStatus #== pconstant Draft
-- This is the vote option we're retracting from.
retractFrom <- pletC $ pfield @"resultTag" # r
-- Determine if the input stake is actually locked by this proposal.
stakeUsage <- pletC $ pgetStakeUsage # stakeInF.lockedBy # proposalF.proposalId
pguardC "Stake input relevant" $
pmatch stakeUsage $ \case
PDidNothing ->
ptraceIfFalse "Stake should be relevant" $
pconstant False
PCreated ->
ptraceIfFalse "Removing creator's locks means status is Finished" $
currentStatus #== pconstant Finished
PVotedFor rt ->
ptraceIfFalse "Result tag should match the one given in the redeemer" $
rt #== retractFrom
-- The count of removing votes is equal to the 'stakeAmount' of input stake.
retractCount <-
pletC $
pmatch stakeInF.stakedAmount $ \(PDiscrete v) -> pextract # v
-- The votes can only change when the proposal still allows voting.
let shouldUpdateVotes =
currentStatus #== pconstant VotingReady
#&& pnot # (pcon PCreated #== stakeUsage)
pguardC "Proposal output correct" $
pif
shouldUpdateVotes
( let -- Remove votes and leave other parts of the proposal as it.
expectedVotes = pretractVotes # retractFrom # retractCount # proposalF.votes
expectedProposalOut =
mkRecordConstr
PProposalDatum
( #proposalId .= proposalF.proposalId
.& #effects .= proposalF.effects
.& #status .= proposalF.status
.& #cosigners .= proposalF.cosigners
.& #thresholds .= proposalF.thresholds
.& #votes .= pdata expectedVotes
.& #timingConfig .= proposalF.timingConfig
.& #startingTime .= proposalF.startingTime
)
in ptraceIfFalse "Update votes" $
expectedProposalOut #== proposalOut
)
-- No change to the proposal is allowed.
$ ptraceIfFalse "Proposal unchanged" proposalUnchanged
-- At last, we ensure that all locks belong to this proposal will be removed.
stakeOutputLocks <- pletC $ pfield @"lockedBy" # stakeOut
let templateStakeOut =
mkRecordConstr
PStakeDatum
( #stakedAmount .= stakeInF.stakedAmount
.& #owner .= stakeInF.owner
.& #lockedBy .= stakeOutputLocks
)
pguardC "Only locks updated in the output stake" $
templateStakeOut #== stakeOut
pguardC "All relevant locks removed from the stake" $
pgetStakeUsage # pfromData stakeOutputLocks
# proposalF.proposalId #== pcon PDidNothing
pure $ pconstant ()
----------------------------------------------------------------------
PAdvanceProposal _ ->
let fromDraft = withMultipleStakes $ \totalStakedAmount sortedStakeOwners ->
pmatchC (isDraftPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime) >>= \case
PTrue -> do
pguardC "More cosigns than minimum amount" $
punsafeCoerce (pfromData thresholdsF.vote) #< totalStakedAmount
pguardC "All new cosigners are witnessed by their Stake datums" $
plistEquals # sortedStakeOwners # proposalF.cosigners
-- 'Draft' -> 'VotingReady'
pguardC "Proposal status set to VotingReady" $
proposalOutStatus #== pconstant VotingReady
pure $ pconstant ()
PFalse -> do
pguardC "Advance to failed state" $ proposalOutStatus #== pconstant Finished
pure $ pconstant ()
fromOther = withSingleStake $ \_ _ stakeUnchanged -> do
pguardC "Stake should not change" stakeUnchanged
pguardC
"Only status changes in the output proposal"
onlyStatusChanged
inVotingPeriod <- pletC $ isVotingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime
inLockedPeriod <- pletC $ isLockingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime
inExecutionPeriod <- pletC $ isExecutionPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime
proposalStatus <- pletC $ pto $ pfromData proposalF.status
-- Check the timings.
let isFinished = currentStatus #== pconstant Finished
notTooLate = pmatchEnum proposalStatus $ \case
-- Can only advance after the voting period is over.
VotingReady -> inLockedPeriod
Locked -> inExecutionPeriod
_ -> pconstant False
notTooEarly = pmatchEnum (pto $ pfromData proposalF.status) $ \case
VotingReady -> pnot # inVotingPeriod
Locked -> pnot # inLockedPeriod
_ -> pconstant True
pguardC "Cannot advance ahead of time" notTooEarly
pguardC "Finished proposals cannot be advanced" $ pnot # isFinished
let toFailedState = unTermCont $ do
pguardC "Proposal should fail: not on time" $
proposalOutStatus #== pconstant Finished
-- TODO: Should check that the GST is not moved
-- if the proposal is in 'Locked' state.
pure $ pconstant ()
toNextState = pmatchEnum proposalStatus $ \case
VotingReady -> unTermCont $ do
-- 'VotingReady' -> 'Locked'
pguardC "Proposal status set to Locked" $
proposalOutStatus #== pconstant Locked
pguardC "Winner outcome not found" $
pisJust #$ pwinner' # proposalF.votes
#$ punsafeCoerce
$ pfromData thresholdsF.execute
pure $ pconstant ()
Locked -> unTermCont $ do
-- 'Locked' -> 'Finished'
pguardC "Proposal status set to Finished" $
proposalOutStatus #== pconstant Finished
-- TODO: Perform other necessary checks.
pure $ pconstant ()
_ -> pconstant ()
pure $
pif
notTooLate
-- On time: advance to next status.
toNextState
-- Too late: failed proposal, status set to 'Finished'.
toFailedState
in pif (currentStatus #== pconstant Draft) fromDraft fromOther

79
agora/Agora/Stake.hs
View file

@ -22,7 +22,6 @@ module Agora.Stake (
-- * Utility functions
stakeLocked,
findStakeOwnedBy,
pgetStakeUsage,
) where
@ -33,16 +32,8 @@ import Data.Tagged (Tagged (..))
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, HasDatatypeInfo, I (I))
import Plutarch.Api.V1 (
PDatum,
PDatumHash,
PMaybeData (PDJust, PDNothing),
PPubKeyHash,
PTuple,
PTxInInfo (PTxInInfo),
PTxOut (PTxOut),
)
import Plutarch.Api.V1.AssetClass (PAssetClass, passetClassValueOf)
import Plutarch.Api.V1.ScriptContext (ptryFindDatum)
import Plutarch.DataRepr (
DerivePConstantViaData (..),
PDataFields,
@ -54,8 +45,7 @@ import Plutarch.Extra.IsData (
)
import Plutarch.Extra.List (pmapMaybe, pnotNull)
import Plutarch.Extra.Other (DerivePNewtype' (..))
import Plutarch.Extra.TermCont (pletC, pletFieldsC, pmatchC)
import Plutarch.Internal (punsafeCoerce)
import Plutarch.Extra.TermCont (pletFieldsC)
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
import Plutarch.SafeMoney (PDiscrete)
import PlutusLedgerApi.V1 (PubKeyHash)
@ -327,73 +317,6 @@ stakeLocked = phoistAcyclic $
locks = pfield @"lockedBy" # stakeDatum
in pnotNull # locks
{- | Find a stake owned by a particular PK.
@since 0.1.0
-}
findStakeOwnedBy ::
Term
s
( PAssetClass
:--> PPubKeyHash
:--> PBuiltinList (PAsData (PTuple PDatumHash PDatum))
:--> PBuiltinList (PAsData PTxInInfo)
:--> PMaybe (PAsData PStakeDatum)
)
findStakeOwnedBy = phoistAcyclic $
plam $ \ac pk datums inputs ->
pmatch (pfind # (isInputStakeOwnedBy # ac # pk # datums) # inputs) $ \case
PNothing -> pcon PNothing
PJust (pfromData -> v) -> unTermCont $ do
let txOut = pfield @"resolved" # pto v
txOutF <- pletFieldsC @'["datumHash"] $ txOut
pure $
pmatch txOutF.datumHash $ \case
PDNothing _ -> pcon PNothing
PDJust ((pfield @"_0" #) -> dh) ->
ptryFindDatum @(PAsData PStakeDatum) # dh # datums
{- | Check if a StakeDatum is owned by a particular public key.
@since 0.1.0
-}
stakeDatumOwnedBy :: Term _ (PPubKeyHash :--> PStakeDatum :--> PBool)
stakeDatumOwnedBy =
phoistAcyclic $
plam $ \pk stakeDatum ->
pletFields @'["owner"] (pto stakeDatum) $ \stakeDatumF ->
stakeDatumF.owner #== pdata pk
{- | Does the input have a `Stake` owned by a particular PK?
@since 0.1.0
-}
isInputStakeOwnedBy ::
Term
_
( PAssetClass :--> PPubKeyHash
:--> PBuiltinList (PAsData (PTuple PDatumHash PDatum))
:--> PAsData PTxInInfo
:--> PBool
)
isInputStakeOwnedBy =
plam $ \ac ss datums txInInfo' -> unTermCont $ do
PTxInInfo ((pfield @"resolved" #) -> txOut) <- pmatchC $ pfromData txInInfo'
PTxOut txOut' <- pmatchC txOut
txOutF <- pletFieldsC @'["value", "datumHash"] txOut'
outStakeST <- pletC $ passetClassValueOf # txOutF.value # ac
pure $
pmatch txOutF.datumHash $ \case
PDNothing _ -> pcon PFalse
PDJust ((pfield @"_0" #) -> datumHash) ->
pif
(outStakeST #== 1)
( pmatch (ptryFindDatum @(PAsData PStakeDatum) # datumHash # datums) $ \case
PNothing -> pcon PFalse
PJust v -> stakeDatumOwnedBy # ss # pfromData (punsafeCoerce v)
)
(pcon PFalse)
{- | Represent the usage of a stake on a particular proposal.
A stake can be used to either create or vote on a proposal.

405
agora/Agora/Stake/Scripts.hs
View file

@ -8,28 +8,44 @@ Plutus Scripts for Stakes.
module Agora.Stake.Scripts (stakePolicy, stakeValidator) where
import Agora.SafeMoney (GTTag)
import Agora.Stake
import Agora.Stake (
PStakeDatum (PStakeDatum),
PStakeRedeemer (
PDepositWithdraw,
PDestroy,
PPermitVote,
PRetractVotes
),
Stake (gtClassRef, proposalSTClass),
StakeRedeemer (WitnessStake),
stakeLocked,
)
import Agora.Utils (
mustBePJust,
mustFindDatum',
pvalidatorHashToTokenName,
)
import Data.Function (on)
import Data.Tagged (Tagged (..), untag)
import Plutarch.Api.V1 (
AmountGuarantees (Positive),
PCredential (PPubKeyCredential, PScriptCredential),
PDatumHash,
PMintingPolicy,
PScriptPurpose (PMinting, PSpending),
PTokenName,
PTxInfo,
PTxOut,
PValidator,
PValue,
mintingPolicySymbol,
mkMintingPolicy,
)
import Plutarch.Api.V1.AssetClass (passetClass, passetClassValueOf, pvalueOf)
import Plutarch.Api.V1.ScriptContext (pfindTxInByTxOutRef, pisTokenSpent, ptxSignedBy, pvalueSpent)
import Plutarch.Api.V1.ScriptContext (pfindTxInByTxOutRef, ptxSignedBy, pvalueSpent)
import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (pgeqByClass', pgeqBySymbol, psymbolValueOf)
import Plutarch.Extra.List (pmapMaybe, pmsortBy)
import Plutarch.Extra.Maybe (pfromDJust)
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC)
import Plutarch.Internal (punsafeCoerce)
@ -208,7 +224,15 @@ stakeValidator stake =
plam $ \datum redeemer ctx' -> unTermCont $ do
ctx <- pletFieldsC @'["txInfo", "purpose"] ctx'
txInfo <- pletC $ pfromData ctx.txInfo
txInfoF <- pletFieldsC @'["mint", "inputs", "outputs", "signatories", "datums"] txInfo
txInfoF <-
pletFieldsC
@'[ "mint"
, "inputs"
, "outputs"
, "signatories"
, "datums"
]
txInfo
(pfromData -> stakeRedeemer, _) <- ptryFromC redeemer
@ -219,23 +243,25 @@ stakeValidator stake =
PSpending txOutRef <- pmatchC $ pfromData ctx.purpose
PJust txInInfo <- pmatchC $ pfindTxInByTxOutRef # (pfield @"_0" # txOutRef) # txInfoF.inputs
ownAddress <- pletC $ pfield @"address" #$ pfield @"resolved" # txInInfo
let continuingValue :: Term _ (PValue _ _)
continuingValue = pfield @"value" #$ pfield @"resolved" # txInInfo
PJust ((pfield @"resolved" #) -> resolved) <-
pmatchC $
pfindTxInByTxOutRef
# (pfield @"_0" # txOutRef)
# txInfoF.inputs
resolvedF <- pletFieldsC @'["address", "value", "datumHash"] resolved
-- Whether the owner signs this transaction or not.
ownerSignsTransaction <- pletC $ ptxSignedBy # txInfoF.signatories # stakeDatum.owner
stCurrencySymbol <- pletC $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake.gtClassRef)
stCurrencySymbol <-
pletC $
pconstant $
mintingPolicySymbol $
mkMintingPolicy (stakePolicy stake.gtClassRef)
mintedST <- pletC $ psymbolValueOf # stCurrencySymbol # txInfoF.mint
valueSpent <- pletC $ pvalueSpent # txInfoF.inputs
spentST <- pletC $ psymbolValueOf # stCurrencySymbol #$ valueSpent
let AssetClass (propCs, propTn) = stake.proposalSTClass
proposalSTClass = passetClass # pconstant propCs # pconstant propTn
spentProposalST <- pletC $ passetClassValueOf # valueSpent # proposalSTClass
-- Is the stake currently locked?
stakeIsLocked <- pletC $ stakeLocked # stakeDatum'
@ -253,196 +279,229 @@ stakeValidator stake =
pguardC "Owner signs this transaction" ownerSignsTransaction
pure $ popaque (pconstant ())
--------------------------------------------------------------------------
------------------------------------------------------------------------
-- Handle redeemers that require own stake output.
_ -> unTermCont $ do
-- Filter out own output with own address and PST.
ownOutput <-
let AssetClass (propCs, propTn) = stake.proposalSTClass
proposalSTClass = passetClass # pconstant propCs # pconstant propTn
spentProposalST = passetClassValueOf # valueSpent # proposalSTClass
proposalTokenMoved <- pletC $ spentProposalST #== 1
-- Filter out own outputs using own address and ST.
ownOutputs <-
pletC $
mustBePJust # "Own output should be present" #$ pfind
pfilter
# plam
( \input -> unTermCont $ do
inputF <- pletFieldsC @'["address", "value"] input
( \output -> unTermCont $ do
outputF <- pletFieldsC @'["address", "value"] output
pure $
inputF.address #== ownAddress
#&& psymbolValueOf # stCurrencySymbol # inputF.value #== 1
outputF.address #== resolvedF.address
#&& psymbolValueOf # stCurrencySymbol # outputF.value #== 1
)
# pfromData txInfoF.outputs
stakeOut <-
pletC $
mustFindDatum' @PStakeDatum
# (pfield @"datumHash" # ownOutput)
# txInfoF.datums
let witnessStake = unTermCont $ do
pguardC "Either owner signs the transaction or proposal token moved" $
ownerSignsTransaction #|| proposalTokenMoved
ownOutputValue <-
pletC $
pfield @"value" # ownOutput
ownOutputValueUnchanged <-
pletC $
pdata continuingValue #== pdata ownOutputValue
stakeOutUnchanged <-
pletC $
pdata stakeOut #== pdata stakeDatum'
pure $
pmatch stakeRedeemer $ \case
PRetractVotes l -> unTermCont $ do
pguardC
"Owner signs this transaction"
ownerSignsTransaction
pguardC "ST at inputs must be 1" $
spentST #== 1
-- This puts trust into the Proposal. The Proposal must necessarily check
-- that this is not abused.
pguardC "Proposal ST spent" $
spentProposalST #== 1
pguardC "A UTXO must exist with the correct output" $
let expectedLocks = pfield @"locks" # l
expectedDatum =
mkRecordConstr
PStakeDatum
( #stakedAmount .= stakeDatum.stakedAmount
.& #owner .= stakeDatum.owner
.& #lockedBy .= expectedLocks
-- FIXME: remove this once we have reference input.
--
-- Our goal here is to allow multiple input stakes, and also ensure that every the input stakes has a
-- corresponding output stake, which carries the same value and the same datum as the input stake.
--
-- Validation strategy I have tried/considered so far:
-- 1. Check that the number of input stakes equals to the number of output stakes, and verify
-- that there's an output stake with the exact same value and datum hash as the stake being
-- validated , However this approach has a fatal vulnerability: let's say we have two totally
-- identical stakes, a malicious user can comsume these two stakes and remove GTs from one of them.
-- 2. Perform the same checks as the last approch does, while also checking that every output stake is
-- valid(stakedAmount == actual value). However this requires that all the output stake datum are
-- included in the transaction, and we have to find and go through them one by one to access the
-- 'stakedAmount' fields, meaning that computationally this approach is *very* expensive.
-- 3. The one implemented below. Find all the continuous input/output, sort them by 'datumHash', and
-- ensure that the two sorted lists are equal.
let ownInputs =
pmapMaybe
# plam
( \input -> plet (pfield @"resolved" # input) $ \resolvedInput ->
let value = pfield @"value" # resolvedInput
in pif
(psymbolValueOf # stCurrencySymbol # value #== 1)
(pcon $ PJust resolvedInput)
(pcon PNothing)
)
# pfromData txInfoF.inputs
valueCorrect = ownOutputValueUnchanged
outputDatumCorrect = stakeOut #== expectedDatum
in foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" outputDatumCorrect
]
sortTxOuts :: Term _ (PBuiltinList (PAsData PTxOut) :--> PBuiltinList (PAsData PTxOut))
sortTxOuts = phoistAcyclic $ plam (pmsortBy # plam ((#<) `on` (getDatumHash #)) #)
where
getDatumHash :: Term _ (PAsData PTxOut :--> PDatumHash)
getDatumHash = phoistAcyclic $ plam ((pfromDJust #) . pfromData . (pfield @"datumHash" #))
pure $ popaque (pconstant ())
--------------------------------------------------------------------------
PPermitVote l -> unTermCont $ do
pguardC
"Owner signs this transaction"
ownerSignsTransaction
sortedOwnInputs = sortTxOuts # ownInputs
sortedOwnOutputs = sortTxOuts # ownOutputs
-- This puts trust into the Proposal. The Proposal must necessarily check
-- that this is not abused.
pguardC "Proposal ST spent" $
spentProposalST #== 1
pguardC "Every stake inputs has a corresponding unchanged output" $
plistEquals # sortedOwnInputs # sortedOwnOutputs
-- Update the stake datum, but only the 'lockedBy' field.
pure $ popaque $ pconstant ()
let -- We actually don't know whether the given lock is valid or not.
-- This is checked in the proposal validator.
newLock = pfield @"lock" # l
-- Prepend the new lock to the existing locks.
expectedLocks = pcons # newLock # stakeDatum.lockedBy
----------------------------------------------------------------------
expectedDatum <-
let onlyAcceptOneStake = unTermCont $ do
pguardC "ST at inputs must be 1" $
spentST #== 1
ownOutput <- pletC $ pfromData $ phead # ownOutputs
stakeOut <-
pletC $
mkRecordConstr
PStakeDatum
( #stakedAmount .= stakeDatum.stakedAmount
.& #owner .= stakeDatum.owner
.& #lockedBy .= pdata expectedLocks
)
mustFindDatum' @PStakeDatum
# (pfield @"datumHash" # ownOutput)
# txInfoF.datums
pguardC "A UTXO must exist with the correct output" $
let correctOutputDatum = stakeOut #== expectedDatum
valueCorrect = ownOutputValueUnchanged
in foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" correctOutputDatum
]
ownOutputValue <-
pletC $
pfield @"value" # ownOutput
pure $ popaque (pconstant ())
--------------------------------------------------------------------------
PWitnessStake _ -> unTermCont $ do
pguardC "ST at inputs must be 1" $
spentST #== 1
ownOutputValueUnchanged <-
pletC $
pdata resolvedF.value #== pdata ownOutputValue
let AssetClass (propCs, propTn) = stake.proposalSTClass
propAssetClass = passetClass # pconstant propCs # pconstant propTn
proposalTokenMoved =
pisTokenSpent
# propAssetClass
# txInfoF.inputs
pure $
pmatch stakeRedeemer $ \case
PRetractVotes l -> unTermCont $ do
pguardC
"Owner signs this transaction"
ownerSignsTransaction
-- 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.
pguardC
"Owner signs this transaction OR proposal token is spent"
(ownerSignsTransaction #|| proposalTokenMoved)
-- This puts trust into the Proposal. The Proposal must necessarily check
-- that this is not abused.
pguardC "Proposal ST spent" proposalTokenMoved
pguardC "A UTXO must exist with the correct output" $
let correctOutputDatum = stakeOutUnchanged
valueCorrect = ownOutputValueUnchanged
in foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "correctOutputDatum" correctOutputDatum
]
pure $ popaque (pconstant ())
--------------------------------------------------------------------------
PDepositWithdraw r -> unTermCont $ do
pguardC "ST at inputs must be 1" $
spentST #== 1
pguardC "Stake unlocked" $
pnot #$ stakeIsLocked
pguardC
"Owner signs this transaction"
ownerSignsTransaction
pguardC "A UTXO must exist with the correct output" $
unTermCont $ do
let oldStakedAmount = pfromData $ stakeDatum.stakedAmount
delta = pfromData $ pfield @"delta" # r
pguardC "A UTXO must exist with the correct output" $
let expectedLocks = pfield @"locks" # l
newStakedAmount <- pletC $ oldStakedAmount + delta
expectedDatum =
mkRecordConstr
PStakeDatum
( #stakedAmount .= stakeDatum.stakedAmount
.& #owner .= stakeDatum.owner
.& #lockedBy .= expectedLocks
)
pguardC "New staked amount shoudl be greater than or equal to 0" $
zero #<= newStakedAmount
valueCorrect = ownOutputValueUnchanged
outputDatumCorrect = stakeOut #== expectedDatum
in foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" outputDatumCorrect
]
let expectedDatum =
pure $ popaque (pconstant ())
------------------------------------------------------------
PPermitVote l -> unTermCont $ do
pguardC
"Owner signs this transaction"
ownerSignsTransaction
-- This puts trust into the Proposal. The Proposal must necessarily check
-- that this is not abused.
pguardC "Proposal ST spent" proposalTokenMoved
-- Update the stake datum, but only the 'lockedBy' field.
let -- We actually don't know whether the given lock is valid or not.
-- This is checked in the proposal validator.
newLock = pfield @"lock" # l
-- Prepend the new lock to the existing locks.
expectedLocks = pcons # newLock # stakeDatum.lockedBy
expectedDatum <-
pletC $
mkRecordConstr
PStakeDatum
( #stakedAmount .= pdata newStakedAmount
( #stakedAmount .= stakeDatum.stakedAmount
.& #owner .= stakeDatum.owner
.& #lockedBy .= stakeDatum.lockedBy
.& #lockedBy .= pdata expectedLocks
)
datumCorrect = stakeOut #== expectedDatum
let valueDelta :: Term _ (PValue _ 'Positive)
valueDelta = pdiscreteValue' stake.gtClassRef # delta
pguardC "A UTXO must exist with the correct output" $
let correctOutputDatum = stakeOut #== expectedDatum
valueCorrect = ownOutputValueUnchanged
in foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" correctOutputDatum
]
expectedValue =
continuingValue <> valueDelta
pure $ popaque (pconstant ())
valueCorrect =
foldr1
(#&&)
[ pgeqByClass' (AssetClass ("", ""))
# ownOutputValue
# expectedValue
, pgeqByClass' (untag stake.gtClassRef)
# ownOutputValue
# expectedValue
, pgeqBySymbol
# stCurrencySymbol
# ownOutputValue
# expectedValue
]
--
pure $
foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" datumCorrect
]
--
pure $ popaque (pconstant ())
_ -> popaque (pconstant ())
------------------------------------------------------------
PDepositWithdraw r -> unTermCont $ do
pguardC "Stake unlocked" $
pnot #$ stakeIsLocked
pguardC
"Owner signs this transaction"
ownerSignsTransaction
pguardC "A UTXO must exist with the correct output" $
unTermCont $ do
let oldStakedAmount = pfromData $ stakeDatum.stakedAmount
delta = pfromData $ pfield @"delta" # r
newStakedAmount <- pletC $ oldStakedAmount + delta
pguardC "New staked amount should be greater than or equal to 0" $
zero #<= newStakedAmount
let expectedDatum =
mkRecordConstr
PStakeDatum
( #stakedAmount .= pdata newStakedAmount
.& #owner .= stakeDatum.owner
.& #lockedBy .= stakeDatum.lockedBy
)
datumCorrect = stakeOut #== expectedDatum
let valueDelta :: Term _ (PValue _ 'Positive)
valueDelta = pdiscreteValue' stake.gtClassRef # delta
expectedValue =
resolvedF.value <> valueDelta
valueCorrect =
foldr1
(#&&)
[ pgeqByClass' (AssetClass ("", ""))
# ownOutputValue
# expectedValue
, pgeqByClass' (untag stake.gtClassRef)
# ownOutputValue
# expectedValue
, pgeqBySymbol
# stCurrencySymbol
# ownOutputValue
# expectedValue
]
--
pure $
foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" datumCorrect
]
--
pure $ popaque (pconstant ())
_ -> popaque (pconstant ())
pure $
pif
(pdata stakeRedeemer #== pconstantData WitnessStake)
witnessStake
onlyAcceptOneStake

48
agora/Agora/Utils.hs
View file

@ -19,6 +19,9 @@ module Agora.Utils (
validatorHashToAddress,
isScriptAddress,
isPubKey,
pltAsData,
pisUniqBy',
pisUniq',
) where
import Plutarch.Api.V1 (
@ -193,3 +196,48 @@ mustBePDJust = phoistAcyclic $
-}
validatorHashToAddress :: ValidatorHash -> Address
validatorHashToAddress vh = Address (ScriptCredential vh) Nothing
{- | Compare two 'PAsData' value, return true if the first one is less than the second one.
@since 0.2.0
-}
pltAsData ::
forall (a :: PType) (s :: S).
(POrd a, PIsData a) =>
Term s (PAsData a :--> PAsData a :--> PBool)
pltAsData = phoistAcyclic $
plam $
\(pfromData -> l) (pfromData -> r) -> l #< r
{- | Special version of 'pisUniq'', the list elements should have 'PEq' instance.
@since 0.2.0
-}
pisUniq' ::
forall (l :: PType -> PType) (a :: PType) (s :: S).
(PEq a, PIsListLike l a) =>
Term s (l a :--> PBool)
pisUniq' = phoistAcyclic $ pisUniqBy' # phoistAcyclic (plam (#==))
{- | Return true if all the elements in the given list are unique, given the equalator function.
The list is assumed to be ordered.
@since 0.2.0
-}
pisUniqBy' ::
forall (l :: PType -> PType) (a :: PType) (s :: S).
(PIsListLike l a) =>
Term s ((a :--> a :--> PBool) :--> l a :--> PBool)
pisUniqBy' = phoistAcyclic $
plam $ \eq l ->
pif (pnull # l) (pconstant True) $
go # eq # (phead # l) # (ptail # l)
where
go :: Term _ ((a :--> a :--> PBool) :--> a :--> l a :--> PBool)
go = phoistAcyclic $
pfix #$ plam $ \self' eq x xs ->
plet (self' # eq) $ \self ->
pif (pnull # xs) (pconstant True) $
plet (phead # xs) $ \x' ->
pif (eq # x # x') (pconstant False) $
self # x' #$ ptail # xs

73
bench.csv
View file

@ -5,27 +5,60 @@ Agora/Effects/Treasury Withdrawal Effect/effect/Mixed Assets,456007605,1104500,3
Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/governor validator should pass,87839169,243032,8561
Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/effect validator should pass,106082031,292993,3609
Agora/Stake/policy/stakeCreation,50939580,148729,2387
Agora/Stake/validator/stakeDepositWithdraw deposit,181581435,493259,4413
Agora/Stake/validator/stakeDepositWithdraw withdraw,181581435,493259,4401
Agora/Stake/validator/stakeDepositWithdraw deposit,150745141,416137,4995
Agora/Stake/validator/stakeDepositWithdraw withdraw,150745141,416137,4983
Agora/Proposal/policy/proposalCreation,23140177,69194,1515
Agora/Proposal/validator/cosignature/proposal,312261341,886430,8188
Agora/Proposal/validator/cosignature/stake,125315872,312659,4942
Agora/Proposal/validator/voting/proposal,268025219,751750,8106
Agora/Proposal/validator/voting/stake,120122971,320497,4899
Agora/Proposal/validator/advancing/successfully advance to next state/Draft -> VotringReady,263397893,738746,8013
Agora/Proposal/validator/advancing/successfully advance to next state/VotingReady -> Locked,278686368,780686,8022
Agora/Proposal/validator/advancing/successfully advance to next state/Locked -> Finished,267078383,746859,8022
Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/Draft -> Finished,262901404,737844,8015
Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/VotingReady -> Finished,264319938,741149,8016
Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/Locked -> Finished,265450916,743553,8016
"Agora/Proposal/validator/unlocking/legal/1 proposals, voter, unlock stake + retract votes, VotingReady",276198245,772878,8066
"Agora/Proposal/validator/unlocking/legal/1 proposals, creator, unlock stake, Finished",246477596,697110,8068
"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/1 proposals, voter, unlock stake, Finished",242771264,688789,8070
"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/1 proposals, voter, unlock stake, Locked",242771264,688789,8070
"Agora/Proposal/validator/unlocking/legal/42 proposals, voter, unlock stake + retract votes, VotingReady",2814657239,7934307,29173
"Agora/Proposal/validator/unlocking/legal/42 proposals, creator, unlock stake, Finished",2488302451,7053012,29357
"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/42 proposals, voter, unlock stake, Finished",2379658464,6713247,29341
"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/42 proposals, voter, unlock stake, Locked",2379658464,6713247,29341
Agora/Proposal/validator/cosignature/legal/with 1 cosigners/propsoal,235408912,657765,8097
Agora/Proposal/validator/cosignature/legal/with 1 cosigners/stake,125665131,316762,5462
Agora/Proposal/validator/cosignature/legal/with 5 cosigners/propsoal,680441047,1897008,10727
Agora/Proposal/validator/cosignature/legal/with 5 cosigners/stake,576106975,1490610,7972
Agora/Proposal/validator/cosignature/legal/with 10 cosigners/propsoal,1351073436,3706315,14015
Agora/Proposal/validator/cosignature/legal/with 10 cosigners/stake,1148637636,2982695,11109
Agora/Proposal/validator/cosignature/illegal/duplicate cosigners/stake,125665131,316762,5462
Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 1 cosigners/status: VotingReady/stake,125665131,316762,5462
Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 1 cosigners/status: Locked/stake,125665131,316762,5462
Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 1 cosigners/status: Finished/stake,125665131,316762,5462
Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 5 cosigners/status: VotingReady/stake,576106975,1490610,7972
Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 5 cosigners/status: Locked/stake,576106975,1490610,7972
Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 5 cosigners/status: Finished/stake,576106975,1490610,7972
Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 10 cosigners/status: VotingReady/stake,1148637636,2982695,11109
Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 10 cosigners/status: Locked/stake,1148637636,2982695,11109
Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 10 cosigners/status: Finished/stake,1148637636,2982695,11109
Agora/Proposal/validator/voting/legal/propsoal,246896882,688919,8069
Agora/Proposal/validator/voting/legal/stake,141234659,368136,5481
Agora/Proposal/validator/advancing/from draft/with 1 cosigner(s)/legal/to next state/propsoal,222376736,631090,8052
Agora/Proposal/validator/advancing/from draft/with 1 cosigner(s)/legal/to next state/stake,125665131,316762,5459
Agora/Proposal/validator/advancing/from draft/with 1 cosigner(s)/legal/to failed state/propsoal,217322044,620369,8054
Agora/Proposal/validator/advancing/from draft/with 1 cosigner(s)/legal/to failed state/stake,125665131,316762,5461
Agora/Proposal/validator/advancing/from draft/with 1 cosigner(s)/illegal/insufficient cosigns/stake,118020743,304972,5389
Agora/Proposal/validator/advancing/from draft/with 5 cosigner(s)/legal/to next state/propsoal,614587307,1766683,10875
Agora/Proposal/validator/advancing/from draft/with 5 cosigner(s)/legal/to next state/stake,548619697,1410656,8162
Agora/Proposal/validator/advancing/from draft/with 5 cosigner(s)/legal/to failed state/propsoal,239691392,682433,8415
Agora/Proposal/validator/advancing/from draft/with 5 cosigner(s)/legal/to failed state/stake,125665131,316762,5702
Agora/Proposal/validator/advancing/from draft/with 5 cosigner(s)/illegal/insufficient cosigns/stake,446252055,1166812,7811
Agora/Proposal/validator/advancing/from draft/with 10 cosigner(s)/legal/to next state/propsoal,1196289192,3454898,14404
Agora/Proposal/validator/advancing/from draft/with 10 cosigner(s)/legal/to next state/stake,1201388310,3136405,11540
Agora/Proposal/validator/advancing/from draft/with 10 cosigner(s)/legal/to failed state/propsoal,267653077,760013,8868
Agora/Proposal/validator/advancing/from draft/with 10 cosigner(s)/legal/to failed state/stake,125665131,316762,6004
Agora/Proposal/validator/advancing/from draft/with 10 cosigner(s)/illegal/insufficient cosigns/stake,1025012867,2732083,10837
Agora/Proposal/validator/advancing/legal/advance to next state/from: VotingReady/propsoal,250229153,709227,8061
Agora/Proposal/validator/advancing/legal/advance to next state/from: VotingReady/stake,125665131,316762,5466
Agora/Proposal/validator/advancing/legal/advance to next state/from: Locked/propsoal,238990044,676396,8061
Agora/Proposal/validator/advancing/legal/advance to next state/from: Locked/stake,125665131,316762,5466
Agora/Proposal/validator/advancing/legal/advance to failed state/from: VotingReady/propsoal,236162599,670386,8055
Agora/Proposal/validator/advancing/legal/advance to failed state/from: VotingReady/stake,125665131,316762,5462
Agora/Proposal/validator/advancing/legal/advance to failed state/from: Locked/propsoal,237293577,672790,8055
Agora/Proposal/validator/advancing/legal/advance to failed state/from: Locked/stake,125665131,316762,5462
Agora/Proposal/validator/advancing/illegal/insufficient votes/stake,125665131,316762,5462
Agora/Proposal/validator/advancing/illegal/initial state is Finished/stake,125665131,316762,5454
"Agora/Proposal/validator/unlocking/legal/1 proposals, voter, unlock stake + retract votes, VotingReady",245855872,689807,8029
"Agora/Proposal/validator/unlocking/legal/1 proposals, creator, unlock stake, Finished",215131610,613807,8031
"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/1 proposals, voter, unlock stake, Finished",212428891,605718,8033
"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/1 proposals, voter, unlock stake, Locked",212428891,605718,8033
"Agora/Proposal/validator/unlocking/legal/42 proposals, voter, unlock stake + retract votes, VotingReady",1775520444,5200586,29137
"Agora/Proposal/validator/unlocking/legal/42 proposals, creator, unlock stake, Finished",1448162043,4319059,29321
"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/42 proposals, voter, unlock stake, Finished",1340521669,3979526,29305
"Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/42 proposals, voter, unlock stake, Locked",1340521669,3979526,29305
Agora/AuthorityToken/singleAuthorityTokenBurned/Correct simple,21017788,55883,806
Agora/AuthorityToken/singleAuthorityTokenBurned/Correct many inputs,33204186,88241,900
Agora/Treasury/Validator/Positive/Allows for effect changes,31556709,81546,1452

1 name cpu mem size
5 Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/governor validator should pass 87839169 243032 8561
6 Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/effect validator should pass 106082031 292993 3609
7 Agora/Stake/policy/stakeCreation 50939580 148729 2387
8 Agora/Stake/validator/stakeDepositWithdraw deposit 181581435 150745141 493259 416137 4413 4995
9 Agora/Stake/validator/stakeDepositWithdraw withdraw 181581435 150745141 493259 416137 4401 4983
10 Agora/Proposal/policy/proposalCreation 23140177 69194 1515
11 Agora/Proposal/validator/cosignature/proposal Agora/Proposal/validator/cosignature/legal/with 1 cosigners/propsoal 312261341 235408912 886430 657765 8188 8097
12 Agora/Proposal/validator/cosignature/stake Agora/Proposal/validator/cosignature/legal/with 1 cosigners/stake 125315872 125665131 312659 316762 4942 5462
13 Agora/Proposal/validator/voting/proposal Agora/Proposal/validator/cosignature/legal/with 5 cosigners/propsoal 268025219 680441047 751750 1897008 8106 10727
14 Agora/Proposal/validator/voting/stake Agora/Proposal/validator/cosignature/legal/with 5 cosigners/stake 120122971 576106975 320497 1490610 4899 7972
15 Agora/Proposal/validator/advancing/successfully advance to next state/Draft -> VotringReady Agora/Proposal/validator/cosignature/legal/with 10 cosigners/propsoal 263397893 1351073436 738746 3706315 8013 14015
16 Agora/Proposal/validator/advancing/successfully advance to next state/VotingReady -> Locked Agora/Proposal/validator/cosignature/legal/with 10 cosigners/stake 278686368 1148637636 780686 2982695 8022 11109
17 Agora/Proposal/validator/advancing/successfully advance to next state/Locked -> Finished Agora/Proposal/validator/cosignature/illegal/duplicate cosigners/stake 267078383 125665131 746859 316762 8022 5462
18 Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/Draft -> Finished Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 1 cosigners/status: VotingReady/stake 262901404 125665131 737844 316762 8015 5462
19 Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/VotingReady -> Finished Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 1 cosigners/status: Locked/stake 264319938 125665131 741149 316762 8016 5462
20 Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/Locked -> Finished Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 1 cosigners/status: Finished/stake 265450916 125665131 743553 316762 8016 5462
21 Agora/Proposal/validator/unlocking/legal/1 proposals, voter, unlock stake + retract votes, VotingReady Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 5 cosigners/status: VotingReady/stake 276198245 576106975 772878 1490610 8066 7972
22 Agora/Proposal/validator/unlocking/legal/1 proposals, creator, unlock stake, Finished Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 5 cosigners/status: Locked/stake 246477596 576106975 697110 1490610 8068 7972
23 Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/1 proposals, voter, unlock stake, Finished Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 5 cosigners/status: Finished/stake 242771264 576106975 688789 1490610 8070 7972
24 Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/1 proposals, voter, unlock stake, Locked Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 10 cosigners/status: VotingReady/stake 242771264 1148637636 688789 2982695 8070 11109
25 Agora/Proposal/validator/unlocking/legal/42 proposals, voter, unlock stake + retract votes, VotingReady Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 10 cosigners/status: Locked/stake 2814657239 1148637636 7934307 2982695 29173 11109
26 Agora/Proposal/validator/unlocking/legal/42 proposals, creator, unlock stake, Finished Agora/Proposal/validator/cosignature/illegal/proposal status not Draft/with 10 cosigners/status: Finished/stake 2488302451 1148637636 7053012 2982695 29357 11109
27 Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/42 proposals, voter, unlock stake, Finished Agora/Proposal/validator/voting/legal/propsoal 2379658464 246896882 6713247 688919 29341 8069
28 Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/42 proposals, voter, unlock stake, Locked Agora/Proposal/validator/voting/legal/stake 2379658464 141234659 6713247 368136 29341 5481
29 Agora/Proposal/validator/advancing/from draft/with 1 cosigner(s)/legal/to next state/propsoal 222376736 631090 8052
30 Agora/Proposal/validator/advancing/from draft/with 1 cosigner(s)/legal/to next state/stake 125665131 316762 5459
31 Agora/Proposal/validator/advancing/from draft/with 1 cosigner(s)/legal/to failed state/propsoal 217322044 620369 8054
32 Agora/Proposal/validator/advancing/from draft/with 1 cosigner(s)/legal/to failed state/stake 125665131 316762 5461
33 Agora/Proposal/validator/advancing/from draft/with 1 cosigner(s)/illegal/insufficient cosigns/stake 118020743 304972 5389
34 Agora/Proposal/validator/advancing/from draft/with 5 cosigner(s)/legal/to next state/propsoal 614587307 1766683 10875
35 Agora/Proposal/validator/advancing/from draft/with 5 cosigner(s)/legal/to next state/stake 548619697 1410656 8162
36 Agora/Proposal/validator/advancing/from draft/with 5 cosigner(s)/legal/to failed state/propsoal 239691392 682433 8415
37 Agora/Proposal/validator/advancing/from draft/with 5 cosigner(s)/legal/to failed state/stake 125665131 316762 5702
38 Agora/Proposal/validator/advancing/from draft/with 5 cosigner(s)/illegal/insufficient cosigns/stake 446252055 1166812 7811
39 Agora/Proposal/validator/advancing/from draft/with 10 cosigner(s)/legal/to next state/propsoal 1196289192 3454898 14404
40 Agora/Proposal/validator/advancing/from draft/with 10 cosigner(s)/legal/to next state/stake 1201388310 3136405 11540
41 Agora/Proposal/validator/advancing/from draft/with 10 cosigner(s)/legal/to failed state/propsoal 267653077 760013 8868
42 Agora/Proposal/validator/advancing/from draft/with 10 cosigner(s)/legal/to failed state/stake 125665131 316762 6004
43 Agora/Proposal/validator/advancing/from draft/with 10 cosigner(s)/illegal/insufficient cosigns/stake 1025012867 2732083 10837
44 Agora/Proposal/validator/advancing/legal/advance to next state/from: VotingReady/propsoal 250229153 709227 8061
45 Agora/Proposal/validator/advancing/legal/advance to next state/from: VotingReady/stake 125665131 316762 5466
46 Agora/Proposal/validator/advancing/legal/advance to next state/from: Locked/propsoal 238990044 676396 8061
47 Agora/Proposal/validator/advancing/legal/advance to next state/from: Locked/stake 125665131 316762 5466
48 Agora/Proposal/validator/advancing/legal/advance to failed state/from: VotingReady/propsoal 236162599 670386 8055
49 Agora/Proposal/validator/advancing/legal/advance to failed state/from: VotingReady/stake 125665131 316762 5462
50 Agora/Proposal/validator/advancing/legal/advance to failed state/from: Locked/propsoal 237293577 672790 8055
51 Agora/Proposal/validator/advancing/legal/advance to failed state/from: Locked/stake 125665131 316762 5462
52 Agora/Proposal/validator/advancing/illegal/insufficient votes/stake 125665131 316762 5462
53 Agora/Proposal/validator/advancing/illegal/initial state is Finished/stake 125665131 316762 5454
54 Agora/Proposal/validator/unlocking/legal/1 proposals, voter, unlock stake + retract votes, VotingReady 245855872 689807 8029
55 Agora/Proposal/validator/unlocking/legal/1 proposals, creator, unlock stake, Finished 215131610 613807 8031
56 Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/1 proposals, voter, unlock stake, Finished 212428891 605718 8033
57 Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/1 proposals, voter, unlock stake, Locked 212428891 605718 8033
58 Agora/Proposal/validator/unlocking/legal/42 proposals, voter, unlock stake + retract votes, VotingReady 1775520444 5200586 29137
59 Agora/Proposal/validator/unlocking/legal/42 proposals, creator, unlock stake, Finished 1448162043 4319059 29321
60 Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/42 proposals, voter, unlock stake, Finished 1340521669 3979526 29305
61 Agora/Proposal/validator/unlocking/legal/voter unlocks stake after voting/42 proposals, voter, unlock stake, Locked 1340521669 3979526 29305
62 Agora/AuthorityToken/singleAuthorityTokenBurned/Correct simple 21017788 55883 806
63 Agora/AuthorityToken/singleAuthorityTokenBurned/Correct many inputs 33204186 88241 900
64 Agora/Treasury/Validator/Positive/Allows for effect changes 31556709 81546 1452