Sulkta-OSS/agora
3
0
Fork 0
Code Issues 1 Pull requests Projects Releases Packages Wiki Activity Actions

Merge pull request #168 from Liqwid-Labs/connor/witness-ref-stake

Browse source 
Witness stakes with reference input
This commit is contained in:
方泓睿 2022-09-13 21:08:54 +08:00 • committed by GitHub
commit edad8d6d42
22 changed files with 1444 additions and 2454 deletions
Download patch file Download diff file Expand all files Collapse all files

4
CHANGELOG.md
View file

@ -6,6 +6,10 @@ This format is based on [Keep A Changelog](https://keepachangelog.com/en/1.0.0).
### Modified ### Modified
- Witness stakes with reference input. Stake redeemer `WitnessStake` is removed.
Included by [#168](https://github.com/Liqwid-Labs/agora/pull/168)
- `tracing` flag in `ScriptParams` of `agora-scripts` to enable/disable tracing in exported scripts. - `tracing` flag in `ScriptParams` of `agora-scripts` to enable/disable tracing in exported scripts.
NOTE: This changes the representation of `ScriptParams`. In order to preserve old behavior, the flag NOTE: This changes the representation of `ScriptParams`. In order to preserve old behavior, the flag

10
agora-specs/Sample/Effect/GovernorMutation.hs
View file

@ -74,11 +74,17 @@ atAssetClass = assetClass authorityTokenSymbol tokenName
-- | The mock reference of the governor state UTXO. -- | The mock reference of the governor state UTXO.
govRef :: TxOutRef govRef :: TxOutRef
govRef = TxOutRef "1475e1ee22330dfc55430980e5a6b100ec9d9249bb4b462256a79559" 1 govRef =
TxOutRef
"d63fe09e6ac6e55dea82291149085d0a9b901df65087b83965188ee92fb25aef"
1
-- | The mock reference of the effect UTXO. -- | The mock reference of the effect UTXO.
effectRef :: TxOutRef effectRef :: TxOutRef
effectRef = TxOutRef "a302d327d8e5553d50b9d017475369753f723d7e999ac1b68da8ad52" 1 effectRef =
TxOutRef
"3ca6864670aae61a9f3e63064284cec00bd983d77cf4e1ab1e26bef34cafb0a9"
1
-- | The input effect datum in 'mkEffectTransaction'. -- | The input effect datum in 'mkEffectTransaction'.
mkEffectDatum :: GovernorDatum -> MutateGovernorDatum mkEffectDatum :: GovernorDatum -> MutateGovernorDatum

89
agora-specs/Sample/Proposal/Advance.hs
View file

@ -29,7 +29,6 @@ module Sample.Proposal.Advance (
mkFromFinishedBundles, mkFromFinishedBundles,
mkInsufficientCosignsBundle, mkInsufficientCosignsBundle,
mkToNextStateTooLateBundles, mkToNextStateTooLateBundles,
mkInvalidOutputStakeBundles,
mkMintGATsForWrongEffectsBundle, mkMintGATsForWrongEffectsBundle,
mkNoGATMintedBundle, mkNoGATMintedBundle,
mkGATsWithWrongDatumBundle, mkGATsWithWrongDatumBundle,
@ -46,6 +45,7 @@ import Agora.Governor (
import Agora.Proposal ( import Agora.Proposal (
ProposalDatum (..), ProposalDatum (..),
ProposalEffectGroup, ProposalEffectGroup,
ProposalEffectMetadata (ProposalEffectMetadata),
ProposalId (ProposalId), ProposalId (ProposalId),
ProposalRedeemer (AdvanceProposal), ProposalRedeemer (AdvanceProposal),
ProposalStatus (..), ProposalStatus (..),
@ -66,7 +66,6 @@ import Agora.Proposal.Time (
import Agora.Scripts (AgoraScripts (..)) import Agora.Scripts (AgoraScripts (..))
import Agora.Stake ( import Agora.Stake (
StakeDatum (..), StakeDatum (..),
StakeRedeemer (WitnessStake),
) )
import Agora.Utils (scriptHashToTokenName) import Agora.Utils (scriptHashToTokenName)
import Control.Applicative (liftA2) import Control.Applicative (liftA2)
@ -75,15 +74,17 @@ import Data.Default (def)
import Data.List (singleton, sort) import Data.List (singleton, sort)
import Data.Map.Strict qualified as StrictMap import Data.Map.Strict qualified as StrictMap
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Data.Tagged (Tagged (..), untag) import Data.Tagged (untag)
import Plutarch.Context ( import Plutarch.Context (
input, input,
mint, mint,
output, output,
referenceInput,
script, script,
signedWith, signedWith,
timeRange, timeRange,
withDatum, withDatum,
withInlineDatum,
withRef, withRef,
withValue, withValue,
) )
@ -217,7 +218,6 @@ data StakeParameters = StakeParameters
{ numStake :: NumStake { numStake :: NumStake
, perStakeGTs :: Integer , perStakeGTs :: Integer
, transactionSignedByOwners :: Bool , transactionSignedByOwners :: Bool
, invalidStakeOutputDatum :: Bool
} }
-- | Represent the number of stakes or the number of the cosigners. -- | Represent the number of stakes or the number of the cosigners.
@ -355,7 +355,7 @@ mkStakeInputDatums :: StakeParameters -> [StakeDatum]
mkStakeInputDatums ps = mkStakeInputDatums ps =
let template = let template =
StakeDatum StakeDatum
{ stakedAmount = Tagged ps.perStakeGTs { stakedAmount = fromInteger ps.perStakeGTs
, owner = PubKeyCredential "" , owner = PubKeyCredential ""
, delegatedTo = Nothing , delegatedTo = Nothing
, lockedBy = [] , lockedBy = []
@ -363,24 +363,6 @@ mkStakeInputDatums ps =
in (\owner -> template {owner = owner}) in (\owner -> template {owner = owner})
<$> mkStakeOwners ps.numStake <$> mkStakeOwners ps.numStake
-- | Create the output stake datums given the parameters.
mkStakeOutputDatums :: StakeParameters -> [StakeDatum]
mkStakeOutputDatums ps =
let inputDatums = mkStakeInputDatums ps
outputStakedAmount =
Tagged $
if ps.invalidStakeOutputDatum
then ps.perStakeGTs * 10
else ps.perStakeGTs
modify inp = inp {stakedAmount = outputStakedAmount}
in modify <$> inputDatums
{- | Get the input stake datum given the index. The range of the index is
@[0, 'StakeParameters.numStake - 1']@
-}
getStakeInputDatumAt :: StakeParameters -> Index -> StakeDatum
getStakeInputDatumAt ps = (!!) (mkStakeInputDatums ps)
-- | Create the reference to a particular stake UTXO. -- | Create the reference to a particular stake UTXO.
mkStakeRef :: Index -> TxOutRef mkStakeRef :: Index -> TxOutRef
mkStakeRef = TxOutRef stakeTxRef . (+ 3) . fromIntegral mkStakeRef = TxOutRef stakeTxRef . (+ 3) . fromIntegral
@ -397,39 +379,26 @@ mkStakeBuilder ps =
<> Value.assetClassValue <> Value.assetClassValue
(untag governor.gtClassRef) (untag governor.gtClassRef)
ps.perStakeGTs ps.perStakeGTs
perStake idx i o = perStake idx i =
let withSig = let withSig =
case (i.owner, ps.transactionSignedByOwners) of case (i.owner, ps.transactionSignedByOwners) of
(PubKeyCredential owner, True) -> signedWith owner (PubKeyCredential owner, True) -> signedWith owner
_ -> mempty _ -> mempty
in mconcat in mconcat
[ withSig [ withSig
, input $ , referenceInput $
mconcat mconcat
[ script stakeValidatorHash [ script stakeValidatorHash
, withRef (mkStakeRef idx) , withRef (mkStakeRef idx)
, withValue perStakeValue , withValue perStakeValue
, withDatum i , withInlineDatum i
]
, output $
mconcat
[ script stakeValidatorHash
, withValue perStakeValue
, withDatum o
] ]
] ]
in mconcat $ in mconcat $
zipWith3 zipWith
perStake perStake
[0 :: Index ..] [0 :: Index ..]
(mkStakeInputDatums ps) (mkStakeInputDatums ps)
(mkStakeOutputDatums ps)
{- | The proposal redeemer used to spend the stake UTXO, which is always
'WitnessStake' in this case.
-}
stakeRedeemer :: StakeRedeemer
stakeRedeemer = WitnessStake
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -553,7 +522,7 @@ mkTestTree ::
Validity -> Validity ->
SpecificationTree SpecificationTree
mkTestTree name pb val = mkTestTree name pb val =
group name $ mconcat [proposal, stake, governor, authority] group name $ mconcat [proposal, governor, authority]
where where
spend = mkSpending advance pb spend = mkSpending advance pb
@ -567,22 +536,6 @@ mkTestTree name pb val =
proposalInputDatum proposalInputDatum
proposalRedeemer proposalRedeemer
(spend proposalRef) (spend proposalRef)
stake =
if pb.stakeParameters.numStake == 0
then mempty
else
let idx = 0
in singleton $
testValidator
val.forStakeValidator
"stake"
agoraScripts.compiledStakeValidator
(getStakeInputDatumAt pb.stakeParameters idx)
stakeRedeemer
( spend (mkStakeRef idx)
)
governor = governor =
maybe [] singleton $ maybe [] singleton $
testValidator testValidator
@ -747,7 +700,7 @@ mkMockEffects useAuthScript n = effects
datums = repeat dummyDatumHash datums = repeat dummyDatumHash
effectMetadata = zip datums authScripts effectMetadata = zipWith ProposalEffectMetadata datums authScripts
effectScripts = validatorHashes effectScripts = validatorHashes
effects = effects =
@ -822,7 +775,6 @@ mkValidToNextStateBundle nCosigners nEffects authScript from =
compPerStakeGTsForDraft $ compPerStakeGTsForDraft $
fromIntegral nCosigners fromIntegral nCosigners
, transactionSignedByOwners = False , transactionSignedByOwners = False
, invalidStakeOutputDatum = False
} }
, governorParameters = Nothing , governorParameters = Nothing
, authorityTokenParameters = [] , authorityTokenParameters = []
@ -857,7 +809,7 @@ mkValidToNextStateBundle nCosigners nEffects authScript from =
let aut = let aut =
StrictMap.elems $ StrictMap.elems $
StrictMap.mapWithKey StrictMap.mapWithKey
( \vh (_, authScript) -> ( \vh (ProposalEffectMetadata _ authScript) ->
AuthorityTokenParameters AuthorityTokenParameters
{ mintGATsFor = vh { mintGATsFor = vh
, carryDatum = Just dummyDatum , carryDatum = Just dummyDatum
@ -920,7 +872,6 @@ mkValidToFailedStateBundles nCosigners nEffects =
compPerStakeGTsForDraft $ compPerStakeGTsForDraft $
fromIntegral nCosigners fromIntegral nCosigners
, transactionSignedByOwners = False , transactionSignedByOwners = False
, invalidStakeOutputDatum = False
} }
, governorParameters = Nothing , governorParameters = Nothing
, authorityTokenParameters = [] , authorityTokenParameters = []
@ -965,22 +916,6 @@ mkToNextStateTooLateBundles nCosigners nEffects =
{ transactionTimeRange = mkTooLateTimeRange from { transactionTimeRange = mkTooLateTimeRange from
} }
mkInvalidOutputStakeBundles :: Word -> Word -> [ParameterBundle]
mkInvalidOutputStakeBundles nCosigners nEffects =
liftA2
mkBundle
[True, False]
[Draft]
where
mkBundle authScript from =
let template = mkValidToNextStateBundle nCosigners nEffects authScript from
in template
{ stakeParameters =
template.stakeParameters
{ invalidStakeOutputDatum = True
}
}
mkUnexpectedOutputStakeBundles :: Word -> Word -> [ParameterBundle] mkUnexpectedOutputStakeBundles :: Word -> Word -> [ParameterBundle]
mkUnexpectedOutputStakeBundles nCosigners nEffects = mkUnexpectedOutputStakeBundles nCosigners nEffects =
liftA2 liftA2

85
agora-specs/Sample/Proposal/Cosign.hs
View file

@ -10,7 +10,6 @@ module Sample.Proposal.Cosign (
validCosignNParameters, validCosignNParameters,
duplicateCosignersParameters, duplicateCosignersParameters,
statusNotDraftCosignNParameters, statusNotDraftCosignNParameters,
invalidStakeOutputParameters,
mkTestTree, mkTestTree,
) where ) where
@ -31,25 +30,26 @@ import Agora.SafeMoney (GTTag)
import Agora.Scripts (AgoraScripts (..)) import Agora.Scripts (AgoraScripts (..))
import Agora.Stake ( import Agora.Stake (
StakeDatum (StakeDatum, owner), StakeDatum (StakeDatum, owner),
StakeRedeemer (WitnessStake),
stakedAmount,
) )
import Data.Coerce (coerce) import Data.Coerce (coerce)
import Data.Default (def) import Data.Default (def)
import Data.List (sort) import Data.List (sort)
import Data.Map.Strict qualified as StrictMap import Data.Map.Strict qualified as StrictMap
import Data.Tagged (Tagged, untag) import Data.Tagged (untag)
import Plutarch.Context ( import Plutarch.Context (
input, input,
output, output,
referenceInput,
script, script,
signedWith, signedWith,
timeRange, timeRange,
txId, txId,
withDatum, withDatum,
withInlineDatum,
withRef, withRef,
withValue, withValue,
) )
import Plutarch.SafeMoney (Discrete)
import PlutusLedgerApi.V1.Value qualified as Value import PlutusLedgerApi.V1.Value qualified as Value
import PlutusLedgerApi.V2 ( import PlutusLedgerApi.V2 (
Credential (PubKeyCredential), Credential (PubKeyCredential),
@ -61,6 +61,7 @@ import PlutusLedgerApi.V2 (
import Sample.Proposal.Shared (proposalTxRef, stakeTxRef) import Sample.Proposal.Shared (proposalTxRef, stakeTxRef)
import Sample.Shared ( import Sample.Shared (
agoraScripts, agoraScripts,
fromDiscrete,
governor, governor,
minAda, minAda,
proposalPolicySymbol, proposalPolicySymbol,
@ -71,7 +72,6 @@ import Sample.Shared (
) )
import Test.Specification ( import Test.Specification (
SpecificationTree, SpecificationTree,
group,
testValidator, testValidator,
) )
import Test.Util (CombinableBuilder, closedBoundedInterval, mkSpending, pubKeyHashes, sortValue) import Test.Util (CombinableBuilder, closedBoundedInterval, mkSpending, pubKeyHashes, sortValue)
@ -82,9 +82,6 @@ data Parameters = Parameters
-- ^ New cosigners to be added, and the owners of the generated stakes. -- ^ New cosigners to be added, and the owners of the generated stakes.
, proposalStatus :: ProposalStatus , proposalStatus :: ProposalStatus
-- ^ Current state of the proposal. -- ^ 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. -- | Owner of the creator stake, doesn't really matter in this case.
@ -92,7 +89,7 @@ proposalCreator :: PubKeyHash
proposalCreator = signer proposalCreator = signer
-- | The amount of GTs every generated stake has, doesn't really matter in this case. -- | The amount of GTs every generated stake has, doesn't really matter in this case.
perStakedGTs :: Tagged GTTag Integer perStakedGTs :: Discrete GTTag
perStakedGTs = 5 perStakedGTs = 5
{- | Create input proposal datum given the parameters. {- | Create input proposal datum given the parameters.
@ -151,34 +148,24 @@ cosign ps = builder
minAda minAda
<> Value.assetClassValue <> Value.assetClassValue
(untag governor.gtClassRef) (untag governor.gtClassRef)
(untag perStakedGTs) (fromDiscrete perStakedGTs)
<> sst <> sst
stakeBuilder = stakeBuilder =
foldMap foldMap
( \(stakeDatum, refIdx) -> ( \(stakeDatum, refIdx) ->
let stakeOutputDatum = mconcat
if ps.alterOutputStakes [ referenceInput $
then stakeDatum {stakedAmount = 0} mconcat
else stakeDatum [ script stakeValidatorHash
in mconcat , withValue stakeValue
[ input $ , withInlineDatum stakeDatum
mconcat , withRef (mkStakeRef refIdx)
[ script stakeValidatorHash ]
, withValue stakeValue , case stakeDatum.owner of
, withDatum stakeDatum PubKeyCredential k -> signedWith k
, withRef (mkStakeRef refIdx) _ -> mempty
] ]
, output $
mconcat
[ script stakeValidatorHash
, withValue stakeValue
, withDatum stakeOutputDatum
]
, case stakeDatum.owner of
PubKeyCredential k -> signedWith k
_ -> mempty
]
) )
$ zip $ zip
stakeInputDatums stakeInputDatums
@ -246,10 +233,6 @@ mkStakeRef idx =
mkProposalRedeemer :: Parameters -> ProposalRedeemer mkProposalRedeemer :: Parameters -> ProposalRedeemer
mkProposalRedeemer = Cosign . sort . newCosigners mkProposalRedeemer = Cosign . sort . newCosigners
-- | 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. -- | Create a valid parameters that cosign the proposal with a given number of cosigners.
@ -259,7 +242,6 @@ validCosignNParameters n
Parameters Parameters
{ newCosigners = take n (fmap PubKeyCredential pubKeyHashes) { newCosigners = take n (fmap PubKeyCredential pubKeyHashes)
, proposalStatus = Draft , proposalStatus = Draft
, alterOutputStakes = False
} }
| otherwise = error "Number of cosigners should be positive" | otherwise = error "Number of cosigners should be positive"
@ -273,7 +255,6 @@ duplicateCosignersParameters =
Parameters Parameters
{ newCosigners = [PubKeyCredential proposalCreator] { newCosigners = [PubKeyCredential proposalCreator]
, proposalStatus = Draft , proposalStatus = Draft
, alterOutputStakes = False
} }
--- ---
@ -288,24 +269,12 @@ statusNotDraftCosignNParameters n =
Parameters Parameters
{ newCosigners = take n (fmap PubKeyCredential pubKeyHashes) { newCosigners = take n (fmap PubKeyCredential pubKeyHashes)
, proposalStatus = st , proposalStatus = st
, alterOutputStakes = False
} }
) )
[VotingReady, Locked, Finished] [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. -- | Create a test tree given the parameters. Both the proposal validator and stake validator will be run.
mkTestTree :: mkTestTree ::
-- | The name of the test group. -- | The name of the test group.
@ -314,7 +283,7 @@ mkTestTree ::
-- | Are the parameters valid for the proposal validator? -- | Are the parameters valid for the proposal validator?
Bool -> Bool ->
SpecificationTree SpecificationTree
mkTestTree name ps isValid = group name [proposal, stake] mkTestTree name ps isValid = proposal
where where
spend = mkSpending cosign ps spend = mkSpending cosign ps
@ -322,20 +291,8 @@ mkTestTree name ps isValid = group name [proposal, stake]
let proposalInputDatum = mkProposalInputDatum ps let proposalInputDatum = mkProposalInputDatum ps
in testValidator in testValidator
isValid isValid
"proposal" (name <> ": proposal")
agoraScripts.compiledProposalValidator agoraScripts.compiledProposalValidator
proposalInputDatum proposalInputDatum
(mkProposalRedeemer ps) (mkProposalRedeemer ps)
(spend proposalRef) (spend proposalRef)
stake =
let idx = 0
stakeInputDatum = mkStakeInputDatums ps !! idx
isValid = not ps.alterOutputStakes
in testValidator
isValid
"stake"
agoraScripts.compiledStakeValidator
stakeInputDatum
stakeRedeemer
(spend $ mkStakeRef idx)

9
agora-specs/Sample/Proposal/Create.hs
View file

@ -38,6 +38,7 @@ import Agora.Proposal.Time (
), ),
ProposalStartingTime (..), ProposalStartingTime (..),
) )
import Agora.SafeMoney (GTTag)
import Agora.Scripts (AgoraScripts (..)) import Agora.Scripts (AgoraScripts (..))
import Agora.Stake ( import Agora.Stake (
ProposalLock (..), ProposalLock (..),
@ -47,7 +48,7 @@ import Agora.Stake (
import Data.Coerce (coerce) import Data.Coerce (coerce)
import Data.Default (Default (def)) import Data.Default (Default (def))
import Data.Map.Strict qualified as StrictMap import Data.Map.Strict qualified as StrictMap
import Data.Tagged (Tagged, untag) import Data.Tagged (untag)
import Plutarch.Context ( import Plutarch.Context (
input, input,
mint, mint,
@ -60,6 +61,7 @@ import Plutarch.Context (
withRef, withRef,
withValue, withValue,
) )
import Plutarch.SafeMoney (Discrete)
import PlutusLedgerApi.V1.Value qualified as Value import PlutusLedgerApi.V1.Value qualified as Value
import PlutusLedgerApi.V2 ( import PlutusLedgerApi.V2 (
Credential (PubKeyCredential), Credential (PubKeyCredential),
@ -71,6 +73,7 @@ import PlutusLedgerApi.V2 (
import Sample.Proposal.Shared (stakeTxRef) import Sample.Proposal.Shared (stakeTxRef)
import Sample.Shared ( import Sample.Shared (
agoraScripts, agoraScripts,
fromDiscrete,
govAssetClass, govAssetClass,
govValidatorHash, govValidatorHash,
governor, governor,
@ -123,7 +126,7 @@ thisProposalId :: ProposalId
thisProposalId = ProposalId 25 thisProposalId = ProposalId 25
-- | The arbitrary staked amount. Doesn;t really matter in this case. -- | The arbitrary staked amount. Doesn;t really matter in this case.
stakedGTs :: Tagged _ Integer stakedGTs :: Discrete GTTag
stakedGTs = 5 stakedGTs = 5
-- | The owner of the stake. -- | The owner of the stake.
@ -289,7 +292,7 @@ createProposal ps = builder
sortValue $ sortValue $
sortValue $ sortValue $
sst sst
<> Value.assetClassValue (untag governor.gtClassRef) (untag stakedGTs) <> Value.assetClassValue (untag governor.gtClassRef) (fromDiscrete stakedGTs)
<> minAda <> minAda
proposalValue = sortValue $ pst <> minAda proposalValue = sortValue $ pst <> minAda

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

@ -36,6 +36,7 @@ import Agora.Proposal (
ResultTag (..), ResultTag (..),
) )
import Agora.Proposal.Time (ProposalStartingTime (ProposalStartingTime)) import Agora.Proposal.Time (ProposalStartingTime (ProposalStartingTime))
import Agora.SafeMoney (GTTag)
import Agora.Scripts (AgoraScripts (..)) import Agora.Scripts (AgoraScripts (..))
import Agora.Stake ( import Agora.Stake (
ProposalLock (..), ProposalLock (..),
@ -44,7 +45,7 @@ import Agora.Stake (
) )
import Data.Default.Class (Default (def)) import Data.Default.Class (Default (def))
import Data.Map.Strict qualified as StrictMap import Data.Map.Strict qualified as StrictMap
import Data.Tagged (Tagged (..), untag) import Data.Tagged (untag)
import Plutarch.Context ( import Plutarch.Context (
input, input,
output, output,
@ -52,9 +53,11 @@ import Plutarch.Context (
signedWith, signedWith,
txId, txId,
withDatum, withDatum,
withRedeemer,
withRef, withRef,
withValue, withValue,
) )
import Plutarch.SafeMoney (Discrete)
import PlutusLedgerApi.V1.Value qualified as Value import PlutusLedgerApi.V1.Value qualified as Value
import PlutusLedgerApi.V2 ( import PlutusLedgerApi.V2 (
Credential (PubKeyCredential), Credential (PubKeyCredential),
@ -64,6 +67,7 @@ import PlutusLedgerApi.V2 (
import Sample.Proposal.Shared (stakeTxRef) import Sample.Proposal.Shared (stakeTxRef)
import Sample.Shared ( import Sample.Shared (
agoraScripts, agoraScripts,
fromDiscrete,
governor, governor,
minAda, minAda,
proposalPolicySymbol, proposalPolicySymbol,
@ -99,13 +103,13 @@ defVoteFor :: ResultTag
defVoteFor = ResultTag 0 defVoteFor = ResultTag 0
-- | The default number of GTs the stake will have. -- | The default number of GTs the stake will have.
defStakedGTs :: Tagged _ Integer defStakedGTs :: Discrete GTTag
defStakedGTs = 100000 defStakedGTs = 100000
{- | If 'Parameters.alterOutputStake' is set to true, the {- | If 'Parameters.alterOutputStake' is set to true, the
'StakeDatum.stakedAmount' will be set to this. 'StakeDatum.stakedAmount' will be set to this.
-} -}
alteredStakedGTs :: Tagged _ Integer alteredStakedGTs :: Discrete GTTag
alteredStakedGTs = 100 alteredStakedGTs = 100
-- | Default owner of the stakes. -- | Default owner of the stakes.
@ -212,7 +216,7 @@ mkProposalDatumPair ::
ProposalId -> ProposalId ->
(ProposalDatum, ProposalDatum) (ProposalDatum, ProposalDatum)
mkProposalDatumPair params pid = mkProposalDatumPair params pid =
let inputVotes = mkInputVotes params.stakeRole $ untag defStakedGTs let inputVotes = mkInputVotes params.stakeRole $ fromDiscrete defStakedGTs
input = input =
ProposalDatum ProposalDatum
@ -266,6 +270,7 @@ unlockStake ps =
, withValue pst , withValue pst
, withDatum i , withDatum i
, withRef (mkProposalRef idx) , withRef (mkProposalRef idx)
, withRedeemer proposalRedeemer
] ]
, output $ , output $
mconcat mconcat
@ -282,7 +287,7 @@ unlockStake ps =
mconcat mconcat
[ Value.assetClassValue [ Value.assetClassValue
(untag governor.gtClassRef) (untag governor.gtClassRef)
(untag defStakedGTs) (fromDiscrete defStakedGTs)
, sst , sst
, minAda , minAda
] ]

6
agora-specs/Sample/Proposal/Vote.hs
View file

@ -32,7 +32,7 @@ import Agora.Stake (
) )
import Data.Default (Default (def)) import Data.Default (Default (def))
import Data.Map.Strict qualified as StrictMap import Data.Map.Strict qualified as StrictMap
import Data.Tagged (Tagged (Tagged), untag) import Data.Tagged (untag)
import Plutarch.Context ( import Plutarch.Context (
input, input,
output, output,
@ -41,6 +41,7 @@ import Plutarch.Context (
timeRange, timeRange,
txId, txId,
withDatum, withDatum,
withRedeemer,
withRef, withRef,
withValue, withValue,
) )
@ -139,7 +140,7 @@ delegate = head pubKeyHashes
mkStakeInputDatum :: Parameters -> StakeDatum mkStakeInputDatum :: Parameters -> StakeDatum
mkStakeInputDatum params = mkStakeInputDatum params =
StakeDatum StakeDatum
{ stakedAmount = Tagged params.voteCount { stakedAmount = fromInteger params.voteCount
, owner = PubKeyCredential stakeOwner , owner = PubKeyCredential stakeOwner
, delegatedTo = , delegatedTo =
if params.voteAsDelegate if params.voteAsDelegate
@ -230,6 +231,7 @@ vote params =
, withValue pst , withValue pst
, withDatum proposalInputDatum , withDatum proposalInputDatum
, withRef proposalRef , withRef proposalRef
, withRedeemer $ mkProposalRedeemer params
] ]
, input $ , input $
mconcat mconcat

6
agora-specs/Sample/Shared.hs
View file

@ -15,6 +15,7 @@ module Sample.Shared (
deterministicTracingConfing, deterministicTracingConfing,
mkEffect, mkEffect,
mkRedeemer, mkRedeemer,
fromDiscrete,
-- * Agora Scripts -- * Agora Scripts
agoraScripts, agoraScripts,
@ -73,6 +74,7 @@ import Agora.Utils (
CompiledValidator (getCompiledValidator), CompiledValidator (getCompiledValidator),
validatorHashToTokenName, validatorHashToTokenName,
) )
import Data.Coerce (coerce)
import Data.Default.Class (Default (..)) import Data.Default.Class (Default (..))
import Data.Tagged (Tagged (..)) import Data.Tagged (Tagged (..))
import Plutarch (Config (..), TracingMode (DetTracing)) import Plutarch (Config (..), TracingMode (DetTracing))
@ -82,6 +84,7 @@ import Plutarch.Api.V2 (
mkValidator, mkValidator,
validatorHash, validatorHash,
) )
import Plutarch.SafeMoney (Discrete (Discrete))
import PlutusLedgerApi.V1.Address (scriptHashAddress) import PlutusLedgerApi.V1.Address (scriptHashAddress)
import PlutusLedgerApi.V1.Contexts (TxOut (..)) import PlutusLedgerApi.V1.Contexts (TxOut (..))
import PlutusLedgerApi.V1.Scripts (Validator, ValidatorHash (..)) import PlutusLedgerApi.V1.Scripts (Validator, ValidatorHash (..))
@ -225,6 +228,9 @@ mkEffect v = CompiledEffect $ mkValidator deterministicTracingConfing v
mkRedeemer :: forall redeemer. PlutusTx.ToData redeemer => redeemer -> Redeemer mkRedeemer :: forall redeemer. PlutusTx.ToData redeemer => redeemer -> Redeemer
mkRedeemer = Redeemer . toBuiltinData mkRedeemer = Redeemer . toBuiltinData
fromDiscrete :: forall tag. Discrete tag -> Integer
fromDiscrete = coerce
------------------------------------------------------------------ ------------------------------------------------------------------
treasuryOut :: TxOut treasuryOut :: TxOut

12
agora-specs/Sample/Stake.hs
View file

@ -23,7 +23,7 @@ import Agora.SafeMoney (GTTag)
import Agora.Stake ( import Agora.Stake (
StakeDatum (StakeDatum, stakedAmount), StakeDatum (StakeDatum, stakedAmount),
) )
import Data.Tagged (Tagged, untag) import Data.Tagged (untag)
import Plutarch.Context ( import Plutarch.Context (
MintingBuilder, MintingBuilder,
SpendingBuilder, SpendingBuilder,
@ -41,6 +41,7 @@ import Plutarch.Context (
withSpendingOutRef, withSpendingOutRef,
withValue, withValue,
) )
import Plutarch.SafeMoney (Discrete)
import PlutusLedgerApi.V1.Contexts (TxOutRef (..)) import PlutusLedgerApi.V1.Contexts (TxOutRef (..))
import PlutusLedgerApi.V1.Value qualified as Value ( import PlutusLedgerApi.V1.Value qualified as Value (
assetClassValue, assetClassValue,
@ -56,6 +57,7 @@ import PlutusLedgerApi.V2 (
) )
import PlutusTx.AssocMap qualified as AssocMap import PlutusTx.AssocMap qualified as AssocMap
import Sample.Shared ( import Sample.Shared (
fromDiscrete,
governor, governor,
signer, signer,
stakeAssetClass, stakeAssetClass,
@ -112,9 +114,9 @@ stakeCreationUnsigned =
-- | Config for creating a ScriptContext that deposits or withdraws. -- | Config for creating a ScriptContext that deposits or withdraws.
data DepositWithdrawExample = DepositWithdrawExample data DepositWithdrawExample = DepositWithdrawExample
{ startAmount :: Tagged GTTag Integer { startAmount :: Discrete GTTag
-- ^ The amount of GT stored before the transaction. -- ^ The amount of GT stored before the transaction.
, delta :: Tagged GTTag Integer , delta :: Discrete GTTag
-- ^ The amount of GT deposited or withdrawn from the Stake. -- ^ The amount of GT deposited or withdrawn from the Stake.
} }
@ -143,7 +145,7 @@ stakeDepositWithdraw config =
, withValue , withValue
( sortValue $ ( sortValue $
st st
<> Value.assetClassValue (untag governor.gtClassRef) (untag stakeBefore.stakedAmount) <> Value.assetClassValue (untag governor.gtClassRef) (fromDiscrete stakeBefore.stakedAmount)
) )
, withDatum stakeAfter , withDatum stakeAfter
, withRef stakeRef , withRef stakeRef
@ -154,7 +156,7 @@ stakeDepositWithdraw config =
, withValue , withValue
( sortValue $ ( sortValue $
st st
<> Value.assetClassValue (untag governor.gtClassRef) (untag stakeAfter.stakedAmount) <> Value.assetClassValue (untag governor.gtClassRef) (fromDiscrete stakeAfter.stakedAmount)
) )
, withDatum stakeAfter , withDatum stakeAfter
] ]

3
agora-specs/Sample/Stake/SetDelegate.hs
View file

@ -48,6 +48,7 @@ import PlutusLedgerApi.V2 (
) )
import Sample.Shared ( import Sample.Shared (
agoraScripts, agoraScripts,
fromDiscrete,
governor, governor,
minAda, minAda,
signer, signer,
@ -123,7 +124,7 @@ setDelegate ps = buildSpending' builder
[ st [ st
, Value.assetClassValue , Value.assetClassValue
(untag governor.gtClassRef) (untag governor.gtClassRef)
(untag stakeInput.stakedAmount) (fromDiscrete stakeInput.stakedAmount)
, minAda , minAda
] ]

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

@ -121,10 +121,6 @@ specs =
"duplicate cosigners" "duplicate cosigners"
Cosign.duplicateCosignersParameters Cosign.duplicateCosignersParameters
False False
, Cosign.mkTestTree
"altered output stake"
Cosign.invalidStakeOutputParameters
False
, illegalStatusNotDraftGroup , illegalStatusNotDraftGroup
] ]
in [legalGroup, illegalGroup] in [legalGroup, illegalGroup]
@ -234,26 +230,6 @@ specs =
, forGovernorValidator = Just True , forGovernorValidator = Just True
, forAuthorityTokenPolicy = Just True , forAuthorityTokenPolicy = Just True
} }
, Advance.mkTestTree'
"altered output stake datum"
(\b -> unwords ["from", show b.proposalParameters.fromStatus])
(Advance.mkInvalidOutputStakeBundles cs es)
Advance.Validity
{ forProposalValidator = False
, forStakeValidator = False
, forGovernorValidator = Just True
, forAuthorityTokenPolicy = Just True
}
, Advance.mkTestTree'
"unexpected stake datum"
(\b -> unwords ["from", show b.proposalParameters.fromStatus])
(Advance.mkUnexpectedOutputStakeBundles cs es)
Advance.Validity
{ forProposalValidator = False
, forStakeValidator = True
, forGovernorValidator = Just True
, forAuthorityTokenPolicy = Just True
}
, Advance.mkTestTree , Advance.mkTestTree
"forget to mint GATs" "forget to mint GATs"
(Advance.mkNoGATMintedBundle cs es) (Advance.mkNoGATMintedBundle cs es)

7
agora-testlib/Test/Specification.hs
View file

@ -56,6 +56,7 @@ import Agora.Utils (
) )
import Control.Composition ((.**), (.***)) import Control.Composition ((.**), (.***))
import Data.Coerce (coerce) import Data.Coerce (coerce)
import Data.Text qualified as Text
import Plutarch.Evaluate (evalScript) import Plutarch.Evaluate (evalScript)
import PlutusLedgerApi.V1.Scripts ( import PlutusLedgerApi.V1.Scripts (
Context (..), Context (..),
@ -137,8 +138,12 @@ toTestTree (Terminal (Specification name expectation script)) =
Failure -> onFailure Failure -> onFailure
FailureWith s -> onFailureWith s FailureWith s -> onFailureWith s
where where
beautifyTraces =
Text.unpack
. Text.intercalate "\n"
. map (" " <>)
(res, _budget, traces) = evalScript script (res, _budget, traces) = evalScript script
ts = " Traces: " <> show traces ts = " Traces:\n" <> beautifyTraces traces
onSuccess = case res of onSuccess = case res of
Left e -> Left e ->
assertFailure $ assertFailure $

47
agora/Agora/Governor/Scripts.hs
View file

@ -21,8 +21,8 @@ import Agora.AuthorityToken (
singleAuthorityTokenBurned, singleAuthorityTokenBurned,
) )
import Agora.Governor ( import Agora.Governor (
GovernorRedeemer (..),
PGovernorDatum (PGovernorDatum), PGovernorDatum (PGovernorDatum),
PGovernorRedeemer (..),
pgetNextProposalId, pgetNextProposalId,
pisGovernorDatumValid, pisGovernorDatumValid,
) )
@ -36,7 +36,7 @@ import Agora.Proposal (
pneutralOption, pneutralOption,
pwinner, pwinner,
) )
import Agora.Proposal.Time (createProposalStartingTime) import Agora.Proposal.Time (validateProposalStartingTime)
import Agora.Scripts ( import Agora.Scripts (
AgoraScripts, AgoraScripts,
authorityTokenSymbol, authorityTokenSymbol,
@ -60,6 +60,7 @@ import Plutarch.Api.V1 (
PTokenName, PTokenName,
PValue (PValue), PValue (PValue),
) )
import Plutarch.Api.V1.AssocMap (plookup)
import Plutarch.Api.V1.AssocMap qualified as AssocMap import Plutarch.Api.V1.AssocMap qualified as AssocMap
import Plutarch.Api.V2 ( import Plutarch.Api.V2 (
PAddress, PAddress,
@ -71,13 +72,9 @@ import Plutarch.Api.V2 (
import Plutarch.Builtin (ppairDataBuiltin) import Plutarch.Builtin (ppairDataBuiltin)
import Plutarch.Extra.AssetClass (passetClass, passetClassValueOf) import Plutarch.Extra.AssetClass (passetClass, passetClassValueOf)
import Plutarch.Extra.Field (pletAllC) import Plutarch.Extra.Field (pletAllC)
import Plutarch.Extra.IsData (pmatchEnumFromData)
import Plutarch.Extra.List (pfirstJust) import Plutarch.Extra.List (pfirstJust)
import Plutarch.Extra.Map ( import Plutarch.Extra.Map (ptryLookup)
plookup, import Plutarch.Extra.Maybe (passertPJust, pmaybeData, pnothing)
plookup',
)
import Plutarch.Extra.Maybe (passertPJust, pfromJust, pmaybeData, pnothing)
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=)) import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
import Plutarch.Extra.ScriptContext ( import Plutarch.Extra.ScriptContext (
pfindOutputsToAddress, pfindOutputsToAddress,
@ -90,7 +87,6 @@ import Plutarch.Extra.ScriptContext (
pvalueSpent, pvalueSpent,
) )
import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC) import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC)
import Plutarch.Extra.Tuple (pfstTuple, psndTuple)
import Plutarch.Extra.Value (phasOnlyOneTokenOfCurrencySymbol, psymbolValueOf) import Plutarch.Extra.Value (phasOnlyOneTokenOfCurrencySymbol, psymbolValueOf)
import PlutusLedgerApi.V1 (TxOutRef) import PlutusLedgerApi.V1 (TxOutRef)
@ -253,6 +249,8 @@ governorValidator as =
plam $ \datum' redeemer' ctx' -> unTermCont $ do plam $ \datum' redeemer' ctx' -> unTermCont $ do
ctxF <- pletAllC ctx' ctxF <- pletAllC ctx'
redeemer <- pfromData . fst <$> ptryFromC redeemer'
txInfo' <- pletC $ pfromData $ ctxF.txInfo txInfo' <- pletC $ pfromData $ ctxF.txInfo
txInfoF <- pletFieldsC @'["mint", "inputs", "outputs", "datums", "signatories", "validRange"] txInfo' txInfoF <- pletFieldsC @'["mint", "inputs", "outputs", "datums", "signatories", "validRange"] txInfo'
@ -289,8 +287,8 @@ governorValidator as =
pguardC "New datum is valid" $ pisGovernorDatumValid # newGovernorDatum pguardC "New datum is valid" $ pisGovernorDatumValid # newGovernorDatum
pure $ pure $
pmatchEnumFromData redeemer' $ \case pmatch redeemer $ \case
Just CreateProposal -> unTermCont $ do PCreateProposal -> unTermCont $ do
-- Check that the transaction advances proposal id. -- Check that the transaction advances proposal id.
let expectedNextProposalId = pgetNextProposalId # oldGovernorDatumF.nextProposalId let expectedNextProposalId = pgetNextProposalId # oldGovernorDatumF.nextProposalId
@ -369,12 +367,7 @@ governorValidator as =
proposalOutputDatum <- pletAllC $ pto $ pfromData proposalOutputDatum' proposalOutputDatum <- pletAllC $ pto $ pfromData proposalOutputDatum'
let expectedStartingTime = let expectedCosigners = psingleton @PBuiltinList # stakeInputDatumF.owner
pfromJust #$ createProposalStartingTime
# oldGovernorDatumF.createProposalTimeRangeMaxWidth
# txInfoF.validRange
expectedCosigners = psingleton @PBuiltinList # stakeInputDatumF.owner
pguardC "Proposal datum correct" $ pguardC "Proposal datum correct" $
foldl1 foldl1
@ -391,8 +384,11 @@ governorValidator as =
proposalOutputDatum.status #== pconstantData Draft proposalOutputDatum.status #== pconstantData Draft
, ptraceIfFalse "cosigners correct" $ , ptraceIfFalse "cosigners correct" $
plistEquals # pfromData proposalOutputDatum.cosigners # expectedCosigners plistEquals # pfromData proposalOutputDatum.cosigners # expectedCosigners
, ptraceIfFalse "starting time correct" $ , ptraceIfFalse "starting time valid" $
proposalOutputDatum.startingTime #== expectedStartingTime validateProposalStartingTime
# oldGovernorDatumF.createProposalTimeRangeMaxWidth
# txInfoF.validRange
# proposalOutputDatum.startingTime
, ptraceIfFalse "copy over configurations" $ , ptraceIfFalse "copy over configurations" $
proposalOutputDatum.thresholds #== oldGovernorDatumF.proposalThresholds proposalOutputDatum.thresholds #== oldGovernorDatumF.proposalThresholds
#&& proposalOutputDatum.timingConfig #== oldGovernorDatumF.proposalTimings #&& proposalOutputDatum.timingConfig #== oldGovernorDatumF.proposalTimings
@ -435,7 +431,7 @@ governorValidator as =
-------------------------------------------------------------------------- --------------------------------------------------------------------------
Just MintGATs -> unTermCont $ do PMintGATs -> unTermCont $ do
pguardC "Governor state should not be changed" $ newGovernorDatum #== oldGovernorDatum pguardC "Governor state should not be changed" $ newGovernorDatum #== oldGovernorDatum
-- Filter out proposal inputs and ouputs using PST and the address of proposal validator. -- Filter out proposal inputs and ouputs using PST and the address of proposal validator.
@ -479,7 +475,7 @@ governorValidator as =
finalResultTag = pwinner # proposalInputDatumF.votes # quorum # neutralOption finalResultTag = pwinner # proposalInputDatumF.votes # quorum # neutralOption
-- The effects of the winner outcome. -- The effects of the winner outcome.
effectGroup <- pletC $ plookup' # finalResultTag #$ proposalInputDatumF.effects effectGroup <- pletC $ ptryLookup # finalResultTag #$ proposalInputDatumF.effects
gatCount <- pletC $ plength #$ pto $ pto effectGroup gatCount <- pletC $ plength #$ pto $ pto effectGroup
@ -520,7 +516,7 @@ governorValidator as =
let tagToken :: Term _ PTokenName let tagToken :: Term _ PTokenName
tagToken = tagToken =
pmaybeData # pconstant "" # plam (pscriptHashToTokenName . pfromData) pmaybeData # pconstant "" # plam (pscriptHashToTokenName . pfromData)
#$ psndTuple # effect #$ pfield @"scriptHash" # effect
receiverScriptHash = receiverScriptHash =
passertPJust # "GAT receiver should be a script" passertPJust # "GAT receiver should be a script"
#$ pscriptHashFromAddress # outputF.address #$ pscriptHashFromAddress # outputF.address
@ -531,7 +527,7 @@ governorValidator as =
authorityTokens authorityTokens
#== psingleton # (ppairDataBuiltin # pdata tagToken # pdata 1) #== psingleton # (ppairDataBuiltin # pdata tagToken # pdata 1)
hasCorrectDatum = hasCorrectDatum =
pfstTuple # effect #== pfromDatumHash # outputF.datum pfield @"datumHash" # effect #== pfromDatumHash # outputF.datum
pure $ pure $
foldr1 foldr1
@ -560,15 +556,12 @@ governorValidator as =
-------------------------------------------------------------------------- --------------------------------------------------------------------------
Just MutateGovernor -> unTermCont $ do PMutateGovernor -> unTermCont $ do
-- Check that a GAT is burnt. -- Check that a GAT is burnt.
pguardC "One valid GAT burnt" $ pguardC "One valid GAT burnt" $
singleAuthorityTokenBurned atSymbol txInfoF.inputs txInfoF.mint singleAuthorityTokenBurned atSymbol txInfoF.inputs txInfoF.mint
pure $ popaque $ pconstant () pure $ popaque $ pconstant ()
--------------------------------------------------------------------------
Nothing -> ptraceError "Unknown redeemer"
where where
-- The currency symbol of authority token. -- The currency symbol of authority token.
atSymbol :: forall (s :: S). Term s PCurrencySymbol atSymbol :: forall (s :: S). Term s PCurrencySymbol

96
agora/Agora/Proposal.hs
View file

@ -9,8 +9,7 @@ Proposal scripts encoding effects that operate on the system.
-} -}
module Agora.Proposal ( module Agora.Proposal (
-- * Haskell-land -- * Haskell-land
ProposalEffectMetadata (..),
-- Proposal (..),
ProposalEffectGroup, ProposalEffectGroup,
ProposalDatum (..), ProposalDatum (..),
ProposalRedeemer (..), ProposalRedeemer (..),
@ -22,6 +21,7 @@ module Agora.Proposal (
emptyVotesFor, emptyVotesFor,
-- * Plutarch-land -- * Plutarch-land
PProposalEffectMetadata (..),
PProposalEffectGroup, PProposalEffectGroup,
PProposalDatum (..), PProposalDatum (..),
PProposalRedeemer (..), PProposalRedeemer (..),
@ -60,7 +60,6 @@ import Plutarch.Api.V2 (
PDatumHash, PDatumHash,
PMaybeData, PMaybeData,
PScriptHash, PScriptHash,
PTuple,
) )
import Plutarch.DataRepr ( import Plutarch.DataRepr (
DerivePConstantViaData ( DerivePConstantViaData (
@ -75,6 +74,7 @@ import Plutarch.Extra.IsData (
DerivePConstantViaDataList (DerivePConstantViaDataList), DerivePConstantViaDataList (DerivePConstantViaDataList),
DerivePConstantViaEnum (DerivePConstantEnum), DerivePConstantViaEnum (DerivePConstantEnum),
EnumIsData (EnumIsData), EnumIsData (EnumIsData),
PlutusTypeDataList,
PlutusTypeEnumData, PlutusTypeEnumData,
ProductIsData (ProductIsData), ProductIsData (ProductIsData),
) )
@ -285,8 +285,35 @@ newtype ProposalVotes = ProposalVotes
emptyVotesFor :: forall a. StrictMap.Map ResultTag a -> ProposalVotes emptyVotesFor :: forall a. StrictMap.Map ResultTag a -> ProposalVotes
emptyVotesFor = ProposalVotes . StrictMap.mapWithKey (const . const 0) emptyVotesFor = ProposalVotes . StrictMap.mapWithKey (const . const 0)
-- | @since 0.3.0 -- | @since 1.0.0
type ProposalEffectGroup = StrictMap.Map ValidatorHash (DatumHash, Maybe ScriptHash) data ProposalEffectMetadata = ProposalEffectMetadata
{ datumHash :: DatumHash
-- ^ Hash of datum sent to effect validator with GAT
, scriptHash :: Maybe ScriptHash
-- ^ A 'ScriptHash' that encodes the authority script.
}
deriving stock
( -- | @since 1.0.0
Generic
, -- | @since 1.0.0
Show
, -- | @since 1.0.0
Eq
)
deriving anyclass
( -- | @since 1.0.0
SOP.Generic
)
deriving
( -- | @since 1.0.0
PlutusTx.ToData
, -- | @since 1.0.0
PlutusTx.FromData
)
via (ProductIsData ProposalEffectMetadata)
-- | @since 1.0.0
type ProposalEffectGroup = StrictMap.Map ValidatorHash ProposalEffectMetadata
{- | Haskell-level datum for Proposal scripts. {- | Haskell-level datum for Proposal scripts.
@ -608,6 +635,52 @@ deriving via
instance instance
(PConstantDecl ProposalVotes) (PConstantDecl ProposalVotes)
{- | Plutarch-level version of 'ProposalEffectMetadata'.
@since 1.0.0
-}
newtype PProposalEffectMetadata (s :: S)
= PProposalEffectMetadata
( Term
s
( PDataRecord
'[ "datumHash" ':= PDatumHash
, "scriptHash" ':= PMaybeData (PAsData PScriptHash)
]
)
)
deriving stock
( -- | @since 1.0.0
Generic
)
deriving anyclass
( -- | @since 1.0.0
PlutusType
, -- | @since 1.0.0
PIsData
, -- | @since 1.0.0
PEq
, -- | @since 1.0.0
PDataFields
)
-- | @since 1.0.0
instance DerivePlutusType PProposalEffectMetadata where
type DPTStrat _ = PlutusTypeDataList
-- | @since 1.0.0
instance PUnsafeLiftDecl PProposalEffectMetadata where
type PLifted _ = ProposalEffectMetadata
-- | @since 1.0.0
deriving via
(DerivePConstantViaDataList ProposalEffectMetadata PProposalEffectMetadata)
instance
(PConstantDecl ProposalEffectMetadata)
-- | @since 1.0.0
instance PTryFrom PData (PAsData PProposalEffectMetadata)
{- | The effect script hashes and their associated datum hash and authority check script hash {- | The effect script hashes and their associated datum hash and authority check script hash
belonging to a particular effect group or result. belonging to a particular effect group or result.
@ -617,10 +690,7 @@ type PProposalEffectGroup =
PMap PMap
'Sorted 'Sorted
PValidatorHash PValidatorHash
( PTuple PProposalEffectMetadata
PDatumHash
(PMaybeData (PAsData PScriptHash))
)
{- | Plutarch-level version of 'ProposalDatum'. {- | Plutarch-level version of 'ProposalDatum'.
@ -655,14 +725,14 @@ newtype PProposalDatum (s :: S) = PProposalDatum
PEq PEq
) )
-- | @since 0.2.0 -- | @since 1.0.0
instance DerivePlutusType PProposalDatum where instance DerivePlutusType PProposalDatum where
type DPTStrat _ = PlutusTypeNewtype type DPTStrat _ = PlutusTypeDataList
instance PTryFrom PData (PAsData PProposalDatum) instance PTryFrom PData (PAsData PProposalDatum)
-- | @since 0.1.0 -- | @since 0.1.0
instance PUnsafeLiftDecl PProposalDatum where type PLifted PProposalDatum = ProposalDatum instance PUnsafeLiftDecl PProposalDatum where type PLifted _ = ProposalDatum
-- | @since 0.1.0 -- | @since 0.1.0
deriving via (DerivePConstantViaDataList ProposalDatum PProposalDatum) instance (PConstantDecl ProposalDatum) deriving via (DerivePConstantViaDataList ProposalDatum PProposalDatum) instance (PConstantDecl ProposalDatum)
@ -735,7 +805,7 @@ pisEffectsVotesCompatible ::
:--> PBool :--> PBool
) )
pisEffectsVotesCompatible = phoistAcyclic $ pisEffectsVotesCompatible = phoistAcyclic $
plam $ \((PM.pkeys #) -> effectKeys) ((PM.pkeys #) . pto -> voteKeys) -> plam $ \((PM.pkeys @PList #) -> effectKeys) ((PM.pkeys #) . pto -> voteKeys) ->
plistEquals # effectKeys # voteKeys plistEquals # effectKeys # voteKeys
{- | Retutns true if vote counts of /all/ the options are zero. {- | Retutns true if vote counts of /all/ the options are zero.

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

@ -39,31 +39,41 @@ import Agora.Stake (
pisVoter, pisVoter,
) )
import Agora.Utils ( import Agora.Utils (
plistEqualsBy,
pltAsData, pltAsData,
) )
import Plutarch.Api.V1 (PCredential) import Plutarch.Api.V1 (PCredential)
import Plutarch.Api.V1.AssocMap (plookup)
import Plutarch.Api.V2 ( import Plutarch.Api.V2 (
PDatumHash,
PMintingPolicy, PMintingPolicy,
PScriptContext (PScriptContext), PScriptContext (PScriptContext),
PScriptPurpose (PMinting, PSpending), PScriptPurpose (PMinting, PSpending),
PTxInInfo,
PTxInfo (PTxInfo), PTxInfo (PTxInfo),
PTxOut, PTxOut,
PValidator, PValidator,
) )
import Plutarch.Extra.AssetClass (passetClass, passetClassValueOf) import Plutarch.Extra.AssetClass (passetClass, passetClassValueOf)
import Plutarch.Extra.Category (PCategory (pidentity))
import Plutarch.Extra.Comonad (pextract) import Plutarch.Extra.Comonad (pextract)
import Plutarch.Extra.Field (pletAllC) import Plutarch.Extra.Field (pletAll, pletAllC)
import Plutarch.Extra.List (pisUniq', pmapMaybe, pmergeBy, pmsortBy) import Plutarch.Extra.Functor (pfmap)
import Plutarch.Extra.Map (plookup, pupdate) import Plutarch.Extra.List (pfirstJust, pisUniq', pmergeBy, pmsort)
import Plutarch.Extra.Maybe (passertPJust, pfromJust, pisJust) import Plutarch.Extra.Map (pupdate)
import Plutarch.Extra.Maybe (
passertPJust,
pfromJust,
pfromMaybe,
pisJust,
pjust,
pnothing,
)
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=)) import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
import Plutarch.Extra.ScriptContext ( import Plutarch.Extra.ScriptContext (
pfindTxInByTxOutRef, pfindTxInByTxOutRef,
pfromDatumHash,
pfromOutputDatum, pfromOutputDatum,
pisTokenSpent, pisTokenSpent,
ptryFindDatum, ptryFromOutputDatum,
) )
import Plutarch.Extra.TermCont ( import Plutarch.Extra.TermCont (
pguardC, pguardC,
@ -124,6 +134,49 @@ proposalPolicy (AssetClass (govCs, govTn)) =
pure $ popaque (pconstant ()) pure $ popaque (pconstant ())
{- | Validation context for redeemers which witness multiple stake in the reference
inputs.
@since 1.0.0
-}
data PWitnessMultipleStakeContext (s :: S) = PWitnessMultipleStakeContext
{ totalAmount :: Term s PInteger
, orderedOwners :: Term s (PList PCredential)
}
deriving stock
( -- | @since 1.0.0
Generic
)
deriving anyclass
( -- | @since 1.0.0
PlutusType
)
-- | @since 1.0.0
instance DerivePlutusType PWitnessMultipleStakeContext where
type DPTStrat _ = PlutusTypeScott
{- | Validation context for redeemers which need to modify a single stake.
@since 1.0.0
-}
data PSpendSingleStakeContext (s :: S) = PSpendSingleStakeContext
{ inputStake :: Term s PStakeDatum
, outputStake :: Term s PStakeDatum
}
deriving stock
( -- | @since 1.0.0
Generic
)
deriving anyclass
( -- | @since 1.0.0
PlutusType
)
-- | @since 1.0.0
instance DerivePlutusType PSpendSingleStakeContext where
type DPTStrat _ = PlutusTypeScott
{- | The validator for Proposals. {- | The validator for Proposals.
The documentation for various of the redeemers lives at 'Agora.Proposal.ProposalRedeemer'. The documentation for various of the redeemers lives at 'Agora.Proposal.ProposalRedeemer'.
@ -166,7 +219,8 @@ proposalValidator as maximumCosigners =
PTxInfo txInfo' <- pmatchC txInfo PTxInfo txInfo' <- pmatchC txInfo
txInfoF <- txInfoF <-
pletFieldsC pletFieldsC
@'[ "inputs" @'[ "referenceInputs"
, "inputs"
, "outputs" , "outputs"
, "mint" , "mint"
, "datums" , "datums"
@ -176,7 +230,11 @@ proposalValidator as maximumCosigners =
txInfo' txInfo'
PSpending ((pfield @"_0" #) -> txOutRef) <- pmatchC $ pfromData ctx.purpose PSpending ((pfield @"_0" #) -> txOutRef) <- pmatchC $ pfromData ctx.purpose
PJust ((pfield @"resolved" #) -> txOut) <- pmatchC $ pfindTxInByTxOutRef # txOutRef # txInfoF.inputs PJust ((pfield @"resolved" #) -> txOut) <-
pmatchC $
pfindTxInByTxOutRef
# txOutRef
# txInfoF.inputs
txOutF <- pletFieldsC @'["address", "value"] $ txOut txOutF <- pletFieldsC @'["address", "value"] $ txOut
proposalDatum <- pfromData . fst <$> ptryFromC @(PAsData PProposalDatum) datum proposalDatum <- pfromData . fst <$> ptryFromC @(PAsData PProposalDatum) datum
@ -203,36 +261,44 @@ proposalValidator as maximumCosigners =
-- --
-- We match the proposal id here so that we can support multiple -- We match the proposal id here so that we can support multiple
-- proposal inputs in one thansaction. -- proposal inputs in one thansaction.
ownOutput <-
pletC $
passertPJust # "Own output should be present" #$ pfind
# plam
( \input -> unTermCont $ do
inputF <- pletAllC input
-- TODO: this is highly inefficient: O(n) for every output,
-- Maybe we can cache the sorted datum map?
let datum =
pfromData $
pfromOutputDatum @(PAsData PProposalDatum)
# inputF.datum
# txInfoF.datums
proposalId = pfield @"proposalId" # pto datum
pure $
inputF.address #== ownAddress
#&& psymbolValueOf # stCurrencySymbol # inputF.value #== 1
#&& proposalId #== proposalF.proposalId
)
# pfromData txInfoF.outputs
proposalOut <- proposalOut <-
pletC $ pletC $
pfromData $ passertPJust
pfromOutputDatum @(PAsData PProposalDatum) # "Own output should be present"
# (pfield @"datum" # ownOutput) #$ pfirstJust
# txInfoF.datums # plam
( flip pletAll $ \outputF ->
let isProposalUTxO =
foldl1
(#&&)
[ ptraceIfFalse "Own by proposal validator" $
outputF.address #== ownAddress
, ptraceIfFalse "Has proposal ST" $
psymbolValueOf # stCurrencySymbol # outputF.value #== 1
]
handleProposalUTxO = unTermCont $ do
-- Using inline datum to avoid O(n^2) lookup.
datum <-
pletC $
pfromData $
pfromOutputDatum @(PAsData PProposalDatum)
# outputF.datum
# txInfoF.datums
pure $
pif
( pfield @"proposalId" # pto datum
#== proposalF.proposalId
)
(pjust # datum)
pnothing
in pif
isProposalUTxO
handleProposalUTxO
pnothing
)
# pfromData txInfoF.outputs
proposalUnchanged <- pletC $ proposalOut #== proposalDatum proposalUnchanged <- pletC $ proposalOut #== proposalDatum
@ -261,141 +327,130 @@ proposalValidator as maximumCosigners =
-- Find the stake inputs/outputs by SST. -- Find the stake inputs/outputs by SST.
let AssetClass (stakeSym, stakeTn) = stakeSTAssetClass as getStakeDatum :: Term _ (PTxOut :--> PMaybe PStakeDatum) <-
stakeSTAssetClass <-
pletC $ passetClass # pconstant stakeSym # pconstant stakeTn
filterStakeDatumHash :: Term _ (PTxOut :--> PMaybe (PAsData PDatumHash)) <-
pletC $ pletC $
plam $ \txOut -> unTermCont $ do plam $
txOutF <- pletFieldsC @'["value", "datum"] txOut flip (pletFields @'["value", "datum"]) $ \txOutF ->
pure $ let AssetClass (stakeSym, _) = stakeSTAssetClass as
pif
(passetClassValueOf # txOutF.value # stakeSTAssetClass #== 1)
( let datumHash = pfromDatumHash # txOutF.datum
in pcon $ PJust $ pdata datumHash
)
(pcon PNothing)
stakeInputDatumHashes <- isStakeUTxO =
pletC $ psymbolValueOf
pmapMaybe @PBuiltinList # pconstant stakeSym
# plam ((filterStakeDatumHash #) . (pfield @"resolved" #)) # txOutF.value
# txInfoF.inputs #== 1
stakeOutputDatumHashes <- stake =
pletC $ pfromData $
pmapMaybe @PBuiltinList pfromJust
# filterStakeDatumHash -- Use inline datum to avoid extra map lookup.
# txInfoF.outputs #$ ptryFromOutputDatum @(PAsData PStakeDatum)
# txOutF.datum
# txInfoF.datums
in pif isStakeUTxO (pjust # stake) pnothing
stakeInputNum <- pletC $ plength # stakeInputDatumHashes witnessStakes' ::
pguardC "Every stake input should have a correspoding output" $
stakeInputNum #== plength # stakeOutputDatumHashes
----------------------------------------------------------------------------
withMultipleStakes' ::
Term Term
_ s
( ( PInteger ( (PWitnessMultipleStakeContext :--> PUnit) :--> PUnit
:--> PBuiltinList (PAsData PCredential)
:--> PUnit
)
:--> PUnit
) <- ) <-
pletC $ pletC $
plam $ \validationLogic -> unTermCont $ do let updateCtx = plam $ \ctx' stake -> unTermCont $ do
-- The following code ensures that all the stake datums are not ctxF <- pmatchC ctx'
-- 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 = stakeF <-
sortDatumHashes # stakeInputDatumHashes pletFieldsC @'["stakedAmount", "owner"] $
pto stake
sortedStakeOutputDatumHashes = pure $
sortDatumHashes # stakeOutputDatumHashes pcon $
PWitnessMultipleStakeContext
{ totalAmount =
ctxF.totalAmount
+ punsafeCoerce
(pfromData stakeF.stakedAmount)
, orderedOwners =
pcons # stakeF.owner
# ctxF.orderedOwners
}
pguardC "All stake datum are unchanged" $ f :: Term _ (_ :--> PTxInInfo :--> _)
plistEquals f = plam $ \ctx' ((pfield @"resolved" #) -> txOut) ->
# sortedStakeInputDatumHashes pfromMaybe # ctx'
# sortedStakeOutputDatumHashes #$ (pfmap # (updateCtx # ctx') #$ getStakeDatum # txOut)
PPair totalStakedAmount stakeOwners <- sortOwners = plam $
pmatchC $ flip pmatch $ \ctxF ->
pfoldl pcon $
# plam PWitnessMultipleStakeContext
( \l dh -> unTermCont $ do { totalAmount = ctxF.totalAmount
let stake = , orderedOwners = pmsort # ctxF.orderedOwners
pfromData $ }
pfromJust
#$ ptryFindDatum @(PAsData PStakeDatum)
# pfromData dh
# txInfoF.datums
stakeF <- pletFieldsC @'["stakedAmount", "owner"] $ pto stake ctx =
sortOwners
#$ pfoldl
# f
# pcon (PWitnessMultipleStakeContext 0 pnil)
# txInfoF.referenceInputs
in plam (# ctx)
PPair amount owners <- pmatchC l let witnessStakes ::
( PWitnessMultipleStakeContext _ ->
TermCont _ ()
) ->
Term _ POpaque
witnessStakes c = popaque $
witnessStakes' #$ plam $ \sctxF ->
unTermCont $ pmatchC sctxF >>= c >> pure (pconstant ())
let newAmount = amount + punsafeCoerce (pfromData stakeF.stakedAmount) spendSingleStake' ::
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 Term
_ s
( ( PStakeDatum :--> PStakeDatum :--> PBool :--> PUnit ((PSpendSingleStakeContext :--> PUnit) :--> PUnit) <-
) pletC $
:--> PUnit let singleInput ::
) <- pletC $ Term
plam $ \validationLogic -> unTermCont $ do _
pguardC "Can only deal with one stake" $ ( PMaybe PStakeDatum
stakeInputNum #== 1 :--> PTxInInfo
:--> PMaybe PStakeDatum
)
singleInput = plam $ \l ((pfield @"resolved" #) -> txOut) ->
unTermCont $ do
lF <- pmatchC l
t <- pletC $ getStakeDatum # txOut
tF <- pmatchC t
stakeInputHash <- pletC $ pfromData $ phead # stakeInputDatumHashes pure $ case (lF, tF) of
stakeOutputHash <- pletC $ pfromData $ phead # stakeOutputDatumHashes (PJust _, PJust _) ->
ptraceError "Can only deal with one stake"
(PNothing, _) -> t
(_, PNothing) -> l
stakeIn :: Term _ PStakeDatum <- stakeInput =
pletC $ pfromData $ pfromJust #$ ptryFindDatum # stakeInputHash # txInfoF.datums passertPJust # "Stake input not found"
#$ pfoldl # singleInput # pnothing # txInfoF.inputs
stakeOut :: Term _ PStakeDatum <- stakeOutput =
pletC $ pfromData $ pfromJust #$ ptryFindDatum # stakeOutputHash # txInfoF.datums pfromJust
#$ pfirstJust # getStakeDatum # txInfoF.outputs
stakeUnchanged <- pletC $ stakeInputHash #== stakeOutputHash ctx = pcon $ PSpendSingleStakeContext stakeInput stakeOutput
in plam (# ctx)
pure $ validationLogic # stakeIn # stakeOut # stakeUnchanged let spendSingleStake ::
( PSpendSingleStakeContext _ ->
let withMultipleStakes val = TermCont _ ()
withMultipleStakes' ) ->
#$ plam Term _ POpaque
$ \totalStakedAmount sortedStakeOwner -> spendSingleStake c = popaque $
unTermCont $ spendSingleStake' #$ plam $ \sctx ->
val totalStakedAmount sortedStakeOwner unTermCont $ pmatchC sctx >>= c >> pure (pconstant ())
withSingleStake val =
withSingleStake' #$ plam $ \stakeIn stakeOut stakeUnchange -> unTermCont $ do
stakeInF <- pletAllC $ pto stakeIn
val stakeInF stakeOut stakeUnchange
pure $ pure $
popaque $ popaque $
pmatch proposalRedeemer $ \case pmatch proposalRedeemer $ \case
PCosign r -> withMultipleStakes $ \_ sortedStakeOwners -> do PCosign r -> witnessStakes $ \sctxF -> do
pguardC "Should be in draft state" $ pguardC "Should be in draft state" $
currentStatus #== pconstant Draft currentStatus #== pconstant Draft
@ -417,7 +472,10 @@ proposalValidator as maximumCosigners =
pisUniq' # updatedSigs pisUniq' # updatedSigs
pguardC "All new cosigners are witnessed by their Stake datums" $ pguardC "All new cosigners are witnessed by their Stake datums" $
plistEquals # sortedStakeOwners # newSigs plistEqualsBy
# plam (\x (pfromData -> y) -> x #== y)
# sctxF.orderedOwners
# newSigs
let expectedDatum = let expectedDatum =
mkRecordConstr mkRecordConstr
@ -435,11 +493,11 @@ proposalValidator as maximumCosigners =
pguardC "Signatures are correctly added to cosignature list" $ pguardC "Signatures are correctly added to cosignature list" $
proposalOut #== expectedDatum proposalOut #== expectedDatum
pure $ pconstant ()
---------------------------------------------------------------------- ----------------------------------------------------------------------
PVote r -> withSingleStake $ \stakeInF stakeOut _ -> do PVote r -> spendSingleStake $ \sctxF -> do
stakeInF <- pletAllC $ pto sctxF.inputStake
pguardC "Input proposal must be in VotingReady state" $ pguardC "Input proposal must be in VotingReady state" $
currentStatus #== pconstant VotingReady currentStatus #== pconstant VotingReady
@ -458,7 +516,7 @@ proposalValidator as maximumCosigners =
-- Ensure that no lock with the current proposal id has been put on the stake. -- 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" $ pguardC "Same stake shouldn't vote on the same proposal twice" $
pnot #$ pisVoter #$ pgetStakeRole # proposalF.proposalId # pfromData stakeInF.lockedBy pnot #$ pisVoter #$ pgetStakeRole # proposalF.proposalId # stakeInF.lockedBy
let -- The amount of new votes should be the 'stakedAmount'. let -- The amount of new votes should be the 'stakedAmount'.
-- Update the vote counter of the proposal, and leave other stuff as is. -- Update the vote counter of the proposal, and leave other stuff as is.
@ -512,13 +570,13 @@ proposalValidator as maximumCosigners =
.& #lockedBy .= pdata expectedProposalLocks .& #lockedBy .= pdata expectedProposalLocks
) )
pguardC "Output stake should be locked by the proposal" $ expectedStakeOut #== stakeOut pguardC "Output stake should be locked by the proposal" $ expectedStakeOut #== sctxF.outputStake
pure $ pconstant ()
---------------------------------------------------------------------- ----------------------------------------------------------------------
PUnlock _ -> withSingleStake $ \stakeInF stakeOut _ -> do PUnlock _ -> spendSingleStake $ \sctxF -> do
stakeInF <- pletAllC $ pto sctxF.inputStake
stakeRole <- pletC $ pgetStakeRole # proposalF.proposalId # stakeInF.lockedBy stakeRole <- pletC $ pgetStakeRole # proposalF.proposalId # stakeInF.lockedBy
pguardC "Stake input should be relevant" $ pguardC "Stake input should be relevant" $
@ -579,7 +637,7 @@ proposalValidator as maximumCosigners =
$ ptraceIfFalse "Proposal unchanged" proposalUnchanged $ ptraceIfFalse "Proposal unchanged" proposalUnchanged
-- At last, we ensure that all locks belong to this proposal will be removed. -- At last, we ensure that all locks belong to this proposal will be removed.
stakeOutputLocks <- pletC $ pfield @"lockedBy" # pto stakeOut stakeOutputLocks <- pletC $ pfield @"lockedBy" # pto sctxF.outputStake
let templateStakeOut = let templateStakeOut =
mkRecordConstr mkRecordConstr
@ -591,102 +649,99 @@ proposalValidator as maximumCosigners =
) )
pguardC "Only locks updated in the output stake" $ pguardC "Only locks updated in the output stake" $
templateStakeOut #== stakeOut templateStakeOut #== sctxF.outputStake
pguardC "All relevant locks removed from the stake" $ pguardC "All relevant locks removed from the stake" $
validateOutputLocks # stakeOutputLocks validateOutputLocks # stakeOutputLocks
pure $ pconstant ()
---------------------------------------------------------------------- ----------------------------------------------------------------------
PAdvanceProposal _ -> unTermCont $ do PAdvanceProposal _ -> unTermCont $ do
currentTime' <- pletC $ pfromJust # currentTime currentTime' <- pletC $ pfromJust # currentTime
let inDraftPeriod = isDraftPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime' let inDraftPeriod = isDraftPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime'
inVotingPeriod = isVotingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime' inVotingPeriod = isVotingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime'
inExecutionPeriod = isExecutionPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime' inExecutionPeriod = isExecutionPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime'
inLockedPeriod <- pletC $ isLockingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime' inLockedPeriod <- pletC $ isLockingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime'
pguardC "Only status changes in the output proposal" onlyStatusChanged pguardC "Only status changes in the output proposal" onlyStatusChanged
let gstSymbol = pconstant $ governorSTSymbol as
gstMoved <-
pletC $
pany
# plam
( \( (pfield @"value" #)
. (pfield @"resolved" #) ->
value
) ->
psymbolValueOf # gstSymbol # value #== 1
)
# pfromData txInfoF.inputs
let toFailedState = unTermCont $ do
-- -> 'Finished'
pguardC "Proposal should fail: not on time" $
proposalOutStatus #== pconstant Finished
pguardC "GST not moved" $ pnot # gstMoved
pure $ pconstant ()
pure $ pure $
pmatch currentStatus $ \case pmatch currentStatus $ \case
PDraft -> PDraft ->
withMultipleStakes $ \totalStakedAmount sortedStakeOwners -> witnessStakes $ \sctxF -> do
pmatchC inDraftPeriod >>= \case let notTooLate = inDraftPeriod
pmatchC notTooLate >>= \case
PTrue -> do PTrue -> do
pguardC "More cosigns than minimum amount" $ pguardC "More cosigns than minimum amount" $
punsafeCoerce (pfromData thresholdsF.vote) #< totalStakedAmount punsafeCoerce (pfromData thresholdsF.vote) #< sctxF.totalAmount
pguardC "All new cosigners are witnessed by their Stake datums" $ pguardC "All new cosigners are witnessed by their Stake datums" $
plistEquals # sortedStakeOwners # proposalF.cosigners plistEqualsBy
# plam (\x (pfromData -> y) -> x #== y)
# sctxF.orderedOwners
# proposalF.cosigners
-- 'Draft' -> 'VotingReady' -- 'Draft' -> 'VotingReady'
pguardC "Proposal status set to VotingReady" $ pguardC "Proposal status set to VotingReady" $
proposalOutStatus #== pconstant VotingReady proposalOutStatus #== pconstant VotingReady
-- Too late: failed proposal, status set to 'Finished'.
pure $ pconstant () PFalse ->
PFalse -> do pguardC "Proposal should fail: not on time" $
pguardC "Advance to failed state" $ proposalOutStatus #== pconstant Finished proposalOutStatus #== pconstant Finished
pure $ pconstant ()
PVotingReady -> unTermCont $ do PVotingReady -> unTermCont $ do
let notTooLate = inLockedPeriod let notTooLate = inLockedPeriod
notTooEarly = pnot # inVotingPeriod notTooEarly = pnot # inVotingPeriod
pguardC "Cannot advance ahead of time" notTooEarly pguardC "Cannot advance ahead of time" notTooEarly
-- FIXME: This should be checked by Stake, as opposed to here.
pguardC "No stakes must be present" $ stakeInputNum #== 0
pure $
pif
notTooLate
( unTermCont $ do
-- 'VotingReady' -> 'Locked'
pguardC "Proposal status set to Locked" $
proposalOutStatus #== pconstant Locked
pguardC "Winner outcome not found" $ pmatchC notTooLate >>= \case
pisJust #$ pwinner' # proposalF.votes PTrue -> do
#$ punsafeCoerce -- 'VotingReady' -> 'Locked'
$ pfromData thresholdsF.execute pguardC "Proposal status set to Locked" $
proposalOutStatus #== pconstant Locked
pure $ pconstant () pguardC "Winner outcome not found" $
) pisJust #$ pwinner' # proposalF.votes
-- Too late: failed proposal, status set to 'Finished'. #$ punsafeCoerce
toFailedState $ pfromData thresholdsF.execute
-- Too late: failed proposal, status set to 'Finished'.
PFalse ->
pguardC "Proposal should fail: not on time" $
proposalOutStatus #== pconstant Finished
pure $ popaque $ pconstant ()
PLocked -> unTermCont $ do PLocked -> unTermCont $ do
let notTooLate = inExecutionPeriod let notTooLate = inExecutionPeriod
notTooEarly = pnot # inLockedPeriod notTooEarly = pnot # inLockedPeriod
pguardC "Not too early" notTooEarly pguardC "Not too early" notTooEarly
pguardC "No stakes must be present" $ stakeInputNum #== 0
pure $ pguardC "Proposal status set to Finished" $
proposalOutStatus #== pconstant Finished
let gstSymbol = pconstant $ governorSTSymbol as
gstMoved =
pany
# plam
( \( (pfield @"value" #)
. (pfield @"resolved" #) ->
value
) ->
psymbolValueOf # gstSymbol # value #== 1
)
# pfromData txInfoF.inputs
pguardC "GST not moved if too late, moved otherwise" $
pif pif
notTooLate notTooLate
( unTermCont $ do -- Not too late: GST should moved
-- 'Locked' -> 'Finished' pidentity
pguardC "Proposal status set to Finished" $ -- Not too late: GST should not moved
proposalOutStatus #== pconstant Finished pnot
# gstMoved
pguardC "GST moved" gstMoved pure $ popaque $ pconstant ()
pure $ pconstant ()
)
toFailedState
PFinished -> ptraceError "Finished proposals cannot be advanced" PFinished -> ptraceError "Finished proposals cannot be advanced"

111
agora/Agora/Proposal/Time.hs
View file

@ -14,13 +14,13 @@ module Agora.Proposal.Time (
MaxTimeRangeWidth (..), MaxTimeRangeWidth (..),
-- * Plutarch-land -- * Plutarch-land
PProposalTime (..), PProposalTime,
PProposalTimingConfig (..), PProposalTimingConfig (..),
PProposalStartingTime (..), PProposalStartingTime (..),
PMaxTimeRangeWidth (..), PMaxTimeRangeWidth (..),
-- * Compute periods given config and starting time. -- * Compute periods given config and starting time.
createProposalStartingTime, validateProposalStartingTime,
currentProposalTime, currentProposalTime,
isDraftPeriod, isDraftPeriod,
isVotingPeriod, isVotingPeriod,
@ -30,6 +30,7 @@ module Agora.Proposal.Time (
pisMaxTimeRangeWidthValid, pisMaxTimeRangeWidthValid,
) where ) where
import Agora.Utils (pcurrentTimeDuration)
import Control.Composition ((.*)) import Control.Composition ((.*))
import Plutarch.Api.V1 ( import Plutarch.Api.V1 (
PExtended (PFinite), PExtended (PFinite),
@ -44,10 +45,14 @@ import Plutarch.DataRepr (
PDataFields, PDataFields,
) )
import Plutarch.Extra.Applicative (PApply (pliftA2)) import Plutarch.Extra.Applicative (PApply (pliftA2))
import Plutarch.Extra.Bind ((#>>=))
import Plutarch.Extra.Field (pletAll, pletAllC) import Plutarch.Extra.Field (pletAll, pletAllC)
import Plutarch.Extra.Maybe (pjust, pnothing) import Plutarch.Extra.Maybe (pjust, pmaybe, pnothing)
import Plutarch.Extra.TermCont (pmatchC) import Plutarch.Extra.TermCont (pmatchC)
import Plutarch.Extra.Time (
PCurrentTime (PCurrentTime),
pisCurrentTimeWithin,
pisWithinCurrentTime,
)
import Plutarch.Lift ( import Plutarch.Lift (
DerivePConstantViaNewtype (DerivePConstantViaNewtype), DerivePConstantViaNewtype (DerivePConstantViaNewtype),
PConstantDecl, PConstantDecl,
@ -160,23 +165,7 @@ newtype MaxTimeRangeWidth = MaxTimeRangeWidth {getMaxWidth :: POSIXTime}
@since 0.1.0 @since 0.1.0
-} -}
data PProposalTime (s :: S) = PProposalTime type PProposalTime = PCurrentTime
{ lowerBound :: Term s PPOSIXTime
, upperBound :: Term s PPOSIXTime
}
deriving stock
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PEq
)
instance DerivePlutusType PProposalTime where
type DPTStrat _ = PlutusTypeScott
-- | Plutarch-level version of 'ProposalStartingTime'. -- | Plutarch-level version of 'ProposalStartingTime'.
newtype PProposalStartingTime (s :: S) = PProposalStartingTime (Term s PPOSIXTime) newtype PProposalStartingTime (s :: S) = PProposalStartingTime (Term s PPOSIXTime)
@ -327,38 +316,41 @@ pisMaxTimeRangeWidthValid =
ptraceIfFalse "greater than 0" ptraceIfFalse "greater than 0"
. (pconstant (MaxTimeRangeWidth 0) #<) . (pconstant (MaxTimeRangeWidth 0) #<)
{- | Get the starting time of a proposal, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field. {- | Validate starting time of a proposal, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field.
For every proposal, this is only meant to run once upon creation. Given time range should be For every proposal, this is only meant to run once upon creation. Given time range should be
tight enough, meaning that the width of the time range should be less than the maximum value. tight enough, meaning that the width of the time range should be less than the maximum value.
@since 0.1.0 @since 1.0.0
-} -}
createProposalStartingTime :: validateProposalStartingTime ::
forall (s :: S). forall (s :: S).
Term Term
s s
( PMaxTimeRangeWidth ( PMaxTimeRangeWidth
:--> PPOSIXTimeRange :--> PPOSIXTimeRange
:--> PMaybe PProposalStartingTime :--> PProposalStartingTime
:--> PBool
) )
createProposalStartingTime = phoistAcyclic $ validateProposalStartingTime = phoistAcyclic $
plam $ \(pto -> maxDuration) iv -> plam $ \(pto -> maxDuration) iv (pto -> st) ->
let ct = currentProposalTime # iv pmaybe
# ptrace
f :: Term _ (PProposalTime :--> PMaybe PProposalStartingTime) "validateProposalStartingTime: unable to get current time"
f = plam $ (pconstant False)
flip pmatch $ \(PProposalTime lb ub) -> # plam
let duration = ub - lb ( \ct ->
let duration = pcurrentTimeDuration # ct
startingTime = pdiv # (lb + ub) # 2 isTightEnough =
in pif ptraceIfFalse
(duration #<= maxDuration) "createProposalStartingTime: given time range should be tight enough"
(pjust #$ pcon $ PProposalStartingTime startingTime) $ duration #<= maxDuration
( ptrace isInCurrentTimeRange =
"createProposalStartingTime: given time range should be tight enough" ptraceIfFalse
pnothing "createProposalStartingTime: starting time should be in current time range"
) $ pisWithinCurrentTime # st # ct
in ct #>>= f in isTightEnough #&& isInCurrentTimeRange
)
# (currentProposalTime # iv)
{- | Get the current proposal time, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field. {- | Get the current proposal time, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field.
@ -389,32 +381,9 @@ currentProposalTime = phoistAcyclic $
lowerBound = getBound # lb lowerBound = getBound # lb
upperBound = getBound # ub upperBound = getBound # ub
mkTime = phoistAcyclic $ plam $ pcon .* PProposalTime mkTime = phoistAcyclic $ plam $ pcon .* PCurrentTime
pure $ pliftA2 # mkTime # lowerBound # upperBound pure $ pliftA2 # mkTime # lowerBound # upperBound
{- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive.
@since 0.1.0
-}
proposalTimeWithin ::
forall (s :: S).
Term
s
( PPOSIXTime
:--> PPOSIXTime
:--> PProposalTime
:--> PBool
)
proposalTimeWithin = phoistAcyclic $
plam $ \l h proposalTime' -> unTermCont $ do
PProposalTime ut lt <- pmatchC proposalTime'
pure $
foldr1
(#&&)
[ l #<= lt
, ut #<= h
]
{- | True if the 'PProposalTime' is in the draft period. {- | True if the 'PProposalTime' is in the draft period.
@since 0.1.0 @since 0.1.0
@ -430,7 +399,7 @@ isDraftPeriod ::
) )
isDraftPeriod = phoistAcyclic $ isDraftPeriod = phoistAcyclic $
plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) -> plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
proposalTimeWithin # s # (s + (pfield @"draftTime" # config)) pisCurrentTimeWithin # s # (s + (pfield @"draftTime" # config))
{- | True if the 'PProposalTime' is in the voting period. {- | True if the 'PProposalTime' is in the voting period.
@ -448,7 +417,7 @@ isVotingPeriod ::
isVotingPeriod = phoistAcyclic $ isVotingPeriod = phoistAcyclic $
plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) -> plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
pletFields @'["draftTime", "votingTime"] config $ \f -> pletFields @'["draftTime", "votingTime"] config $ \f ->
proposalTimeWithin # s # (s + f.draftTime + f.votingTime) pisCurrentTimeWithin # s # (s + f.draftTime + f.votingTime)
{- | True if the 'PProposalTime' is in the locking period. {- | True if the 'PProposalTime' is in the locking period.
@ -466,7 +435,7 @@ isLockingPeriod ::
isLockingPeriod = phoistAcyclic $ isLockingPeriod = phoistAcyclic $
plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) -> plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
pletFields @'["draftTime", "votingTime", "lockingTime"] config $ \f -> pletFields @'["draftTime", "votingTime", "lockingTime"] config $ \f ->
proposalTimeWithin # s # (s + f.draftTime + f.votingTime + f.lockingTime) pisCurrentTimeWithin # s # (s + f.draftTime + f.votingTime + f.lockingTime)
{- | True if the 'PProposalTime' is in the execution period. {- | True if the 'PProposalTime' is in the execution period.
@ -484,5 +453,5 @@ isExecutionPeriod ::
isExecutionPeriod = phoistAcyclic $ isExecutionPeriod = phoistAcyclic $
plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) -> plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
pletFields @'["draftTime", "votingTime", "lockingTime", "executingTime"] config $ \f -> pletFields @'["draftTime", "votingTime", "lockingTime", "executingTime"] config $ \f ->
proposalTimeWithin # s pisCurrentTimeWithin # s
# (s + f.draftTime + f.votingTime + f.lockingTime + f.executingTime) # (s + f.draftTime + f.votingTime + f.lockingTime + f.executingTime)

36
agora/Agora/Stake.hs
View file

@ -44,6 +44,7 @@ import Plutarch.DataRepr (
import Plutarch.Extra.Field (pletAll) import Plutarch.Extra.Field (pletAll)
import Plutarch.Extra.IsData ( import Plutarch.Extra.IsData (
DerivePConstantViaDataList (DerivePConstantViaDataList), DerivePConstantViaDataList (DerivePConstantViaDataList),
PlutusTypeDataList,
ProductIsData (ProductIsData), ProductIsData (ProductIsData),
) )
import Plutarch.Extra.List (pnotNull) import Plutarch.Extra.List (pnotNull)
@ -51,10 +52,9 @@ import Plutarch.Extra.Sum (PSum (PSum))
import Plutarch.Extra.Traversable (pfoldMap) import Plutarch.Extra.Traversable (pfoldMap)
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted)) import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
import Plutarch.Orphans () import Plutarch.Orphans ()
import Plutarch.SafeMoney (PDiscrete) import Plutarch.SafeMoney (Discrete, PDiscrete)
import PlutusLedgerApi.V2 (Credential) import PlutusLedgerApi.V2 (Credential)
import PlutusTx qualified import PlutusTx qualified
import Prelude hiding (Num (..))
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -123,7 +123,7 @@ PlutusTx.makeIsDataIndexed
{- | Haskell-level redeemer for Stake scripts. {- | Haskell-level redeemer for Stake scripts.
@since 0.1.0 @since 1.0.0
-} -}
data StakeRedeemer data StakeRedeemer
= -- | Deposit or withdraw a discrete amount of the staked governance token. = -- | Deposit or withdraw a discrete amount of the staked governance token.
@ -143,9 +143,6 @@ data StakeRedeemer
-- always allowed to have votes retracted and won't affect the Proposal datum, -- always allowed to have votes retracted and won't affect the Proposal datum,
-- allowing 'Stake's to be unlocked. -- allowing 'Stake's to be unlocked.
RetractVotes RetractVotes
| -- | The owner can consume stake if nothing is changed about it.
-- If the proposal token moves, this is equivalent to the owner consuming it.
WitnessStake
| -- | The owner can delegate the stake to another user, allowing the | -- | The owner can delegate the stake to another user, allowing the
-- delegate to vote on prooposals with the stake. -- delegate to vote on prooposals with the stake.
DelegateTo Credential DelegateTo Credential
@ -164,9 +161,8 @@ PlutusTx.makeIsDataIndexed
, ('Destroy, 1) , ('Destroy, 1)
, ('PermitVote, 2) , ('PermitVote, 2)
, ('RetractVotes, 3) , ('RetractVotes, 3)
, ('WitnessStake, 4) , ('DelegateTo, 4)
, ('DelegateTo, 5) , ('ClearDelegate, 5)
, ('ClearDelegate, 6)
] ]
{- | Haskell-level datum for Stake scripts. {- | Haskell-level datum for Stake scripts.
@ -174,7 +170,7 @@ PlutusTx.makeIsDataIndexed
@since 0.1.0 @since 0.1.0
-} -}
data StakeDatum = StakeDatum data StakeDatum = StakeDatum
{ stakedAmount :: Tagged GTTag Integer { stakedAmount :: Discrete GTTag
-- ^ Tracks the amount of governance token staked in the datum. -- ^ Tracks the amount of governance token staked in the datum.
-- This also acts as the voting weight for 'Agora.Proposal.Proposal's. -- This also acts as the voting weight for 'Agora.Proposal.Proposal's.
, owner :: Credential , owner :: Credential
@ -238,24 +234,24 @@ newtype PStakeDatum (s :: S) = PStakeDatum
) )
instance DerivePlutusType PStakeDatum where instance DerivePlutusType PStakeDatum where
type DPTStrat _ = PlutusTypeNewtype type DPTStrat _ = PlutusTypeDataList
-- | @since 0.1.0 -- | @since 1.0.0
instance Plutarch.Lift.PUnsafeLiftDecl PStakeDatum where instance PUnsafeLiftDecl PStakeDatum where
type PLifted PStakeDatum = StakeDatum type PLifted PStakeDatum = StakeDatum
-- | @since 0.1.0 -- | @since 0.1.0
deriving via deriving via
(DerivePConstantViaDataList StakeDatum PStakeDatum) (DerivePConstantViaDataList StakeDatum PStakeDatum)
instance instance
(Plutarch.Lift.PConstantDecl StakeDatum) (PConstantDecl StakeDatum)
-- | @since 0.1.0 -- | @since 0.1.0
instance PTryFrom PData (PAsData PStakeDatum) instance PTryFrom PData (PAsData PStakeDatum)
{- | Plutarch-level redeemer for Stake scripts. {- | Plutarch-level redeemer for Stake scripts.
@since 0.1.0 @since 1.0.0
-} -}
data PStakeRedeemer (s :: S) data PStakeRedeemer (s :: S)
= -- | Deposit or withdraw a discrete amount of the staked governance token. = -- | Deposit or withdraw a discrete amount of the staked governance token.
@ -264,7 +260,6 @@ data PStakeRedeemer (s :: S)
PDestroy (Term s (PDataRecord '[])) PDestroy (Term s (PDataRecord '[]))
| PPermitVote (Term s (PDataRecord '[])) | PPermitVote (Term s (PDataRecord '[]))
| PRetractVotes (Term s (PDataRecord '[])) | PRetractVotes (Term s (PDataRecord '[]))
| PWitnessStake (Term s (PDataRecord '[]))
| PDelegateTo (Term s (PDataRecord '["pkh" ':= PCredential])) | PDelegateTo (Term s (PDataRecord '["pkh" ':= PCredential]))
| PClearDelegate (Term s (PDataRecord '[])) | PClearDelegate (Term s (PDataRecord '[]))
deriving stock deriving stock
@ -280,6 +275,7 @@ data PStakeRedeemer (s :: S)
PIsData PIsData
) )
-- | @since 0.2.0
instance DerivePlutusType PStakeRedeemer where instance DerivePlutusType PStakeRedeemer where
type DPTStrat _ = PlutusTypeData type DPTStrat _ = PlutusTypeData
@ -287,14 +283,14 @@ instance DerivePlutusType PStakeRedeemer where
instance PTryFrom PData PStakeRedeemer instance PTryFrom PData PStakeRedeemer
-- | @since 0.1.0 -- | @since 0.1.0
instance Plutarch.Lift.PUnsafeLiftDecl PStakeRedeemer where instance PUnsafeLiftDecl PStakeRedeemer where
type PLifted PStakeRedeemer = StakeRedeemer type PLifted PStakeRedeemer = StakeRedeemer
-- | @since 0.1.0 -- | @since 0.1.0
deriving via deriving via
(DerivePConstantViaData StakeRedeemer PStakeRedeemer) (DerivePConstantViaData StakeRedeemer PStakeRedeemer)
instance instance
(Plutarch.Lift.PConstantDecl StakeRedeemer) (PConstantDecl StakeRedeemer)
{- | Plutarch-level version of 'ProposalLock'. {- | Plutarch-level version of 'ProposalLock'.
@ -342,14 +338,14 @@ instance PTryFrom PData PProposalLock
instance PTryFrom PData (PAsData PProposalLock) instance PTryFrom PData (PAsData PProposalLock)
-- | @since 0.1.0 -- | @since 0.1.0
instance Plutarch.Lift.PUnsafeLiftDecl PProposalLock where instance PUnsafeLiftDecl PProposalLock where
type PLifted PProposalLock = ProposalLock type PLifted PProposalLock = ProposalLock
-- | @since 0.1.0 -- | @since 0.1.0
deriving via deriving via
(DerivePConstantViaData ProposalLock PProposalLock) (DerivePConstantViaData ProposalLock PProposalLock)
instance instance
(Plutarch.Lift.PConstantDecl ProposalLock) (PConstantDecl ProposalLock)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

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

@ -8,28 +8,30 @@ Plutus Scripts for Stakes.
module Agora.Stake.Scripts (stakePolicy, stakeValidator) where module Agora.Stake.Scripts (stakePolicy, stakeValidator) where
import Agora.Credential (authorizationContext, pauthorizedBy) import Agora.Credential (authorizationContext, pauthorizedBy)
import Agora.Proposal (PProposalRedeemer (PUnlock, PVote))
import Agora.SafeMoney (GTTag) import Agora.SafeMoney (GTTag)
import Agora.Scripts (AgoraScripts, proposalSTAssetClass, stakeSTSymbol) import Agora.Scripts (AgoraScripts, proposalSTAssetClass, stakeSTSymbol)
import Agora.Stake ( import Agora.Stake (
PStakeDatum (PStakeDatum), PStakeDatum (PStakeDatum),
PStakeRedeemer (..), PStakeRedeemer (..),
StakeRedeemer (WitnessStake),
pstakeLocked, pstakeLocked,
) )
import Data.Function (on)
import Data.Tagged (Tagged, untag) import Data.Tagged (Tagged, untag)
import Plutarch.Api.V1 ( import Plutarch.Api.V1 (
PCredential (PPubKeyCredential, PScriptCredential), PCredential (PPubKeyCredential, PScriptCredential),
PTokenName, PTokenName,
PValue, PValue,
) )
import Plutarch.Api.V1.AssocMap (plookup)
import Plutarch.Api.V2 ( import Plutarch.Api.V2 (
AmountGuarantees (Positive), AmountGuarantees (Positive),
PDatumHash, KeyGuarantees (Sorted),
PMaybeData,
PMintingPolicy, PMintingPolicy,
PScriptPurpose (PMinting, PSpending), PScriptPurpose (PMinting, PSpending),
PTxInInfo,
PTxInfo, PTxInfo,
PTxOut, PTxOutRef,
PValidator, PValidator,
) )
import Plutarch.Extra.AssetClass ( import Plutarch.Extra.AssetClass (
@ -37,23 +39,40 @@ import Plutarch.Extra.AssetClass (
passetClassValueOf, passetClassValueOf,
pvalueOf, pvalueOf,
) )
import Plutarch.Extra.Bind (PBind ((#>>=)))
import Plutarch.Extra.Field (pletAllC) import Plutarch.Extra.Field (pletAllC)
import Plutarch.Extra.List (pmapMaybe, pmsortBy) import Plutarch.Extra.Functor (PFunctor (pfmap))
import Plutarch.Extra.Maybe (passertPJust, pdjust, pdnothing, pmaybeData) import Plutarch.Extra.List (pfirstJust)
import Plutarch.Extra.Maybe (
passertPJust,
pdjust,
pdnothing,
pjust,
pmaybeData,
pnothing,
)
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=)) import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
import Plutarch.Extra.ScriptContext ( import Plutarch.Extra.ScriptContext (
pfindTxInByTxOutRef, pfindTxInByTxOutRef,
pfromDatumHash,
pfromOutputDatum, pfromOutputDatum,
pvalueSpent, pvalueSpent,
) )
import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC) import Plutarch.Extra.TermCont (
pguardC,
pletC,
pletFieldsC,
pmatchC,
ptryFromC,
)
import Plutarch.Extra.Value ( import Plutarch.Extra.Value (
pgeqByClass', pgeqByClass',
pgeqBySymbol, pgeqBySymbol,
psymbolValueOf, psymbolValueOf,
) )
import Plutarch.Numeric.Additive (AdditiveMonoid (zero), AdditiveSemigroup ((+))) import Plutarch.Numeric.Additive (
AdditiveMonoid (zero),
AdditiveSemigroup ((+)),
)
import Plutarch.SafeMoney ( import Plutarch.SafeMoney (
pdiscreteValue', pdiscreteValue',
pvalueDiscrete', pvalueDiscrete',
@ -178,6 +197,30 @@ stakePolicy gtClassRef =
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
{- | Validation context for stake redeemers that allow only one stake to be
spent in the transaction.
@since 1.0.0
-}
data POnlyOneStakeContext (s :: S) = POnlyOneStakeContext
{ ownOutputDatum :: Term s PStakeDatum
, ownOutputValue :: Term s (PValue 'Sorted 'Positive)
, ownOutputValueUnchanged :: Term s PBool
, onlyLocksUpdated :: Term s PBool
}
deriving stock
( -- | @since 1.0.0
Generic
)
deriving anyclass
( -- | @since 1.0.0
PlutusType
)
-- | @since 1.0.0
instance DerivePlutusType POnlyOneStakeContext where
type DPTStrat _ = PlutusTypeScott
{- | Validator intended for Stake UTXOs to be locked by. {- | Validator intended for Stake UTXOs to be locked by.
== What this Validator does: == What this Validator does:
@ -247,6 +290,7 @@ stakeValidator as gtClassRef =
, "outputs" , "outputs"
, "signatories" , "signatories"
, "datums" , "datums"
, "redeemers"
] ]
txInfo txInfo
@ -304,9 +348,33 @@ stakeValidator as gtClassRef =
_ -> unTermCont $ do _ -> unTermCont $ do
let AssetClass (propCs, propTn) = proposalSTAssetClass as let AssetClass (propCs, propTn) = proposalSTAssetClass as
proposalSTClass = passetClass # pconstant propCs # pconstant propTn proposalSTClass = passetClass # pconstant propCs # pconstant propTn
spentProposalST = passetClassValueOf # valueSpent # proposalSTClass
proposalTokenMoved <- pletC $ 1 #<= spentProposalST proposalRedeemer <-
pletC $
let convertRedeemer = plam $ \(pto -> dt) ->
ptryFrom @PProposalRedeemer dt fst
findRedeemer = plam $ \ref ->
plookup
# pcon
( PSpending $
pdcons @_0
# pdata ref
# pdnil
)
# txInfoF.redeemers
f :: Term _ (PTxInInfo :--> PMaybe PTxOutRef)
f = plam $ \inInfo ->
let value = pfield @"value" #$ pfield @"resolved" # inInfo
ref = pfield @"outRef" # inInfo
in pif
(passetClassValueOf # value # proposalSTClass #== 1)
(pjust # ref)
pnothing
proposalRef = pfirstJust # f # txInfoF.inputs
in pfmap # convertRedeemer #$ proposalRef #>>= findRedeemer
-- Filter out own outputs using own address and ST. -- Filter out own outputs using own address and ST.
ownOutputs <- ownOutputs <-
@ -322,234 +390,217 @@ stakeValidator as gtClassRef =
) )
# pfromData txInfoF.outputs # pfromData txInfoF.outputs
let witnessStake = unTermCont $ do
pguardC "Either owner signs the transaction or proposal token moved" $
ownerSignsTransaction #|| proposalTokenMoved
-- 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
sortTxOuts :: Term _ (PBuiltinList PTxOut :--> PBuiltinList PTxOut)
sortTxOuts = phoistAcyclic $ plam (pmsortBy # plam ((#<) `on` (getDatumHash #)) #)
where
getDatumHash :: Term _ (PTxOut :--> PDatumHash)
getDatumHash = phoistAcyclic $ plam ((pfromDatumHash #) . (pfield @"datum" #))
sortedOwnInputs = sortTxOuts # ownInputs
sortedOwnOutputs = sortTxOuts # ownOutputs
pguardC "Every stake inputs has a corresponding unchanged output" $
plistEquals # sortedOwnInputs # sortedOwnOutputs
pure $ popaque $ pconstant ()
---------------------------------------------------------------------- ----------------------------------------------------------------------
let onlyAcceptOneStake = unTermCont $ do withSingleStake' ::
Term
s
( (POnlyOneStakeContext :--> PUnit)
:--> POpaque
) <-
pletC $
plam $ \validationLogic -> unTermCont $ do
pguardC "ST at inputs must be 1" $ pguardC "ST at inputs must be 1" $
spentST #== 1 spentST #== 1
ownOutput <- pletC $ phead # ownOutputs ownOutput <- pletC $ phead # ownOutputs
stakeOut <- let ownOutputDatum =
pletC $ pfromData $
pfromData $ pfromOutputDatum @(PAsData PStakeDatum)
pfromOutputDatum @(PAsData PStakeDatum) # (pfield @"datum" # ownOutput)
# (pfield @"datum" # ownOutput) # txInfoF.datums
# txInfoF.datums
ownOutputValue <- ownOutputValue =
pletC $ pfield @"value" # ownOutput
pfield @"value" # ownOutput
ownOutputValueUnchanged <- ownOutputValueUnchanged =
pletC $ pdata resolvedF.value #== pdata ownOutputValue
pdata resolvedF.value #== pdata ownOutputValue
onlyLocksUpdated <- onlyLocksUpdated =
pletC $ let templateStakeDatum =
let templateStakeDatum = mkRecordConstr
mkRecordConstr PStakeDatum
( #stakedAmount .= stakeDatum.stakedAmount
.& #owner .= stakeDatum.owner
.& #delegatedTo .= stakeDatum.delegatedTo
.& #lockedBy .= pfield @"lockedBy"
# pto ownOutputDatum
)
in ownOutputDatum #== templateStakeDatum
ctx =
pcon $
POnlyOneStakeContext
ownOutputDatum
ownOutputValue
ownOutputValueUnchanged
onlyLocksUpdated
pure $ popaque $ validationLogic # ctx
let withSingleStake val = withSingleStake' #$ plam $ \ctx ->
unTermCont $ do
ctxF <- pmatchC ctx
val ctxF
pure $ pconstant ()
setDelegate :: Term s (PMaybeData (PAsData PCredential) :--> POpaque) <-
pletC $
plam $ \maybePkh -> withSingleStake $ \ctx -> do
pguardC
"Owner signs this transaction"
ownerSignsTransaction
pguardC "Cannot delegate to the owner" $
pmaybeData
# pcon PTrue
# plam (\pkh -> pnot #$ stakeDatum.owner #== pkh)
# maybePkh
pguardC "A UTXO must exist with the correct output" $
let correctOutputDatum =
ctx.ownOutputDatum
#== mkRecordConstr
PStakeDatum PStakeDatum
( #stakedAmount .= stakeDatum.stakedAmount ( #stakedAmount .= stakeDatum.stakedAmount
.& #owner .= stakeDatum.owner .& #owner .= stakeDatum.owner
.& #delegatedTo .= stakeDatum.delegatedTo .& #delegatedTo .= pdata maybePkh
.& #lockedBy .= pfield @"lockedBy" # pto stakeOut .& #lockedBy .= stakeDatum.lockedBy
) )
in stakeOut #== templateStakeDatum valueCorrect = ctx.ownOutputValueUnchanged
in foldl1
setDelegate <- pletC $ (#&&)
plam $ \maybePkh -> unTermCont $ do [ ptraceIfFalse "valueCorrect" valueCorrect
pguardC , ptraceIfFalse "datumCorrect" correctOutputDatum
"Owner signs this transaction" ]
ownerSignsTransaction
pguardC "A UTXO must exist with the correct output" $
let correctOutputDatum =
stakeOut
#== mkRecordConstr
PStakeDatum
( #stakedAmount .= stakeDatum.stakedAmount
.& #owner .= stakeDatum.owner
.& #delegatedTo .= pdata maybePkh
.& #lockedBy .= stakeDatum.lockedBy
)
valueCorrect = ownOutputValueUnchanged
in foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" correctOutputDatum
]
pure $ popaque (pconstant ())
pure $
pmatch stakeRedeemer $ \case
PRetractVotes _ -> unTermCont $ do
pguardC
"Owner or delegate signs this transaction"
$ ownerSignsTransaction #|| delegateSignsTransaction
-- 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 valueCorrect = ownOutputValueUnchanged
outputDatumCorrect = onlyLocksUpdated
in foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" outputDatumCorrect
]
pure $ popaque (pconstant ())
------------------------------------------------------------
PPermitVote _ -> unTermCont $ do
pguardC
"Owner or delegate signs this transaction"
$ ownerSignsTransaction #|| delegateSignsTransaction
let proposalTokenMinted =
passetClassValueOf # txInfoF.mint # proposalSTClass #== 1
-- This puts trust into the Proposal. The Proposal must necessarily check
-- that this is not abused.
pguardC "Proposal ST spent or minted" $
proposalTokenMoved #|| proposalTokenMinted
pguardC "A UTXO must exist with the correct output" $
let correctOutputDatum = onlyLocksUpdated
valueCorrect = ownOutputValueUnchanged
in foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" correctOutputDatum
]
pure $ 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
.& #delegatedTo .= stakeDatum.delegatedTo
.& #lockedBy .= stakeDatum.lockedBy
)
datumCorrect = stakeOut #== expectedDatum
let valueDelta :: Term _ (PValue _ 'Positive)
valueDelta = pdiscreteValue' gtClassRef # delta
expectedValue =
resolvedF.value <> valueDelta
valueCorrect =
foldr1
(#&&)
[ pgeqByClass' (AssetClass ("", ""))
# ownOutputValue
# expectedValue
, pgeqByClass' (untag gtClassRef)
# ownOutputValue
# expectedValue
, pgeqBySymbol
# stCurrencySymbol
# ownOutputValue
# expectedValue
]
--
pure $
foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" datumCorrect
]
--
pure $ popaque (pconstant ())
------------------------------------------------------------
PDelegateTo ((pfromData . (pfield @"pkh" #)) -> pkh) -> unTermCont $ do
pguardC "Cannot delegate to the owner" $
pnot #$ stakeDatum.owner #== pkh
pure $ setDelegate #$ pdjust # pdata pkh
------------------------------------------------------------
PClearDelegate _ ->
setDelegate # pdnothing
------------------------------------------------------------
_ -> popaque (pconstant ())
pure $ pure $
pif pmatch stakeRedeemer $ \case
(pdata stakeRedeemer #== pconstantData WitnessStake) PRetractVotes _ -> withSingleStake $ \ctx -> do
witnessStake pguardC
onlyAcceptOneStake "Owner or delegate signs this transaction"
$ ownerSignsTransaction #|| delegateSignsTransaction
-- This puts trust into the Proposal. The Proposal must necessarily check
-- that this is not abused.
pguardC "Proposal ST spent" $
pmatch proposalRedeemer $ \case
PJust redeemer -> pmatch redeemer $ \case
PUnlock _ -> pconstant True
_ ->
ptrace "Expected PUnlock, but got other" $
pconstant False
PNothing ->
ptrace "Proposal redeemer not found" $
pconstant False
pguardC "A UTXO must exist with the correct output" $
let valueCorrect = ctx.ownOutputValueUnchanged
outputDatumCorrect = ctx.onlyLocksUpdated
in foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" outputDatumCorrect
]
------------------------------------------------------------------
PPermitVote _ -> withSingleStake $ \ctx -> do
pguardC
"Owner or delegate signs this transaction"
$ ownerSignsTransaction #|| delegateSignsTransaction
let proposalTokenMinted =
passetClassValueOf # txInfoF.mint # proposalSTClass #== 1
-- This puts trust into the Proposal. The Proposal must necessarily check
-- that this is not abused.
pguardC "Proposal ST spent or minted" $
pmatch
proposalRedeemer
( \case
PJust proposalRedeemer' ->
pmatch proposalRedeemer' $ \case
PVote _ -> pconstant True
_ -> ptrace "Expected PVote" $ pconstant False
_ -> proposalTokenMinted
)
pguardC "A UTXO must exist with the correct output" $
let correctOutputDatum = ctx.onlyLocksUpdated
valueCorrect = ctx.ownOutputValueUnchanged
in foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" correctOutputDatum
]
------------------------------------------------------------------
PDelegateTo ((pfromData . (pfield @"pkh" #)) -> pkh) ->
setDelegate #$ pdjust # pdata pkh
------------------------------------------------------------------
PClearDelegate _ ->
setDelegate # pdnothing
------------------------------------------------------------------
PDepositWithdraw r -> withSingleStake $ \ctx -> 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
.& #delegatedTo .= stakeDatum.delegatedTo
.& #lockedBy .= stakeDatum.lockedBy
)
datumCorrect = ctx.ownOutputDatum #== expectedDatum
let valueDelta :: Term _ (PValue _ 'Positive)
valueDelta = pdiscreteValue' gtClassRef # delta
expectedValue =
resolvedF.value <> valueDelta
valueCorrect =
foldr1
(#&&)
[ pgeqByClass' (AssetClass ("", ""))
# ctx.ownOutputValue
# expectedValue
, pgeqByClass' (untag gtClassRef)
# ctx.ownOutputValue
# expectedValue
, pgeqBySymbol
# stCurrencySymbol
# ctx.ownOutputValue
# expectedValue
]
--
pure $
foldl1
(#&&)
[ ptraceIfFalse "valueCorrect" valueCorrect
, ptraceIfFalse "datumCorrect" datumCorrect
]
------------------------------------------------------------------
_ -> ptraceError "unreachable"

64
agora/Agora/Utils.hs
View file

@ -18,10 +18,17 @@ module Agora.Utils (
pvalidatorHashToTokenName, pvalidatorHashToTokenName,
pscriptHashToTokenName, pscriptHashToTokenName,
scriptHashToTokenName, scriptHashToTokenName,
plistEqualsBy,
pstringIntercalate,
punwords,
pcurrentTimeDuration,
) where ) where
import Plutarch.Api.V1 (PTokenName, PValidatorHash) import Plutarch.Api.V1 (PPOSIXTime, PTokenName, PValidatorHash)
import Plutarch.Api.V2 (PScriptHash) import Plutarch.Api.V2 (PScriptHash)
import Plutarch.Extra.TermCont (pmatchC)
import Plutarch.Extra.Time (PCurrentTime (PCurrentTime))
import Plutarch.List (puncons)
import Plutarch.Unsafe (punsafeCoerce) import Plutarch.Unsafe (punsafeCoerce)
import PlutusLedgerApi.V2 ( import PlutusLedgerApi.V2 (
Address (Address), Address (Address),
@ -128,3 +135,58 @@ newtype CompiledMintingPolicy (redeemer :: Type) = CompiledMintingPolicy
newtype CompiledEffect (datum :: Type) = CompiledEffect newtype CompiledEffect (datum :: Type) = CompiledEffect
{ getCompiledEffect :: Validator { getCompiledEffect :: Validator
} }
-- | @since 1.0.0
plistEqualsBy ::
forall
(list1 :: PType -> PType)
(list2 :: PType -> PType)
(a :: PType)
(b :: PType)
(s :: S).
(PIsListLike list1 a, PIsListLike list2 b) =>
Term s ((a :--> b :--> PBool) :--> list1 a :--> (list2 b :--> PBool))
plistEqualsBy = phoistAcyclic $ pfix # go
where
go = plam $ \self eq l1 l2 -> unTermCont $ do
l1' <- pmatchC $ puncons # l1
l2' <- pmatchC $ puncons # l2
case (l1', l2') of
(PJust l1'', PJust l2'') -> do
(PPair h1 t1) <- pmatchC l1''
(PPair h2 t2) <- pmatchC l2''
pure $ eq # h1 # h2 #&& self # eq # t1 # t2
(PNothing, PNothing) -> pure $ pconstant True
_ -> pure $ pconstant False
-- | @since 1.0.0
pstringIntercalate ::
forall (s :: S).
Term s PString ->
[Term s PString] ->
Term s PString
pstringIntercalate _ [x] = x
pstringIntercalate i (x : xs) = x <> i <> pstringIntercalate i xs
pstringIntercalate _ _ = ""
-- | @since 1.0.0
punwords ::
forall (s :: S).
[Term s PString] ->
Term s PString
punwords = pstringIntercalate " "
-- | @since 1.0.0
pcurrentTimeDuration ::
forall (s :: S).
Term
s
( PCurrentTime
:--> PPOSIXTime
)
pcurrentTimeDuration = phoistAcyclic $
plam $
flip pmatch $
\(PCurrentTime lb ub) -> ub - lb

1092
bench.csv
View file

File diff suppressed because it is too large Load diff

1186
flake.lock generated
View file

File diff suppressed because it is too large Load diff

2
flake.nix
View file

@ -15,7 +15,7 @@
# Plutarch and its friends # Plutarch and its friends
plutarch = { plutarch = {
url = "github:Plutonomicon/plutarch-plutus?ref=staging"; url = "github:Plutonomicon/plutarch-plutus?ref=master";
inputs.emanote.follows = inputs.emanote.follows =
"plutarch/haskell-nix/nixpkgs-unstable"; "plutarch/haskell-nix/nixpkgs-unstable";