From 50b89107ed2a31f9c1f5394bc84977281a058fca Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Fri, 17 Jun 2022 12:35:33 -0500 Subject: [PATCH 1/3] Moved samples to PCB * Cleaner imports --- agora-specs/Property/MultiSig.hs | 24 +- agora-specs/Sample/Effect/GovernorMutation.hs | 22 +- .../Sample/Effect/TreasuryWithdrawal.hs | 18 +- agora-specs/Sample/Governor.hs | 596 ++++++------------ agora-specs/Sample/Proposal.hs | 514 +++++++-------- agora-specs/Sample/Shared.hs | 27 +- agora-specs/Sample/Stake.hs | 157 +++-- agora-specs/Sample/Treasury.hs | 180 +++--- agora-specs/Spec/AuthorityToken.hs | 26 +- agora-specs/Spec/Governor.hs | 2 - agora-specs/Spec/Proposal.hs | 34 +- agora-specs/Spec/Stake.hs | 35 +- agora-specs/Spec/Treasury.hs | 10 +- agora-specs/Spec/Utils.hs | 2 - bench.csv | 36 +- flake.lock | 20 +- flake.nix | 2 +- 17 files changed, 701 insertions(+), 1004 deletions(-) diff --git a/agora-specs/Property/MultiSig.hs b/agora-specs/Property/MultiSig.hs index 1e4f0bb..1000e03 100644 --- a/agora-specs/Property/MultiSig.hs +++ b/agora-specs/Property/MultiSig.hs @@ -12,23 +12,18 @@ import Agora.MultiSig ( PMultiSig, pvalidatedByMultisig, ) -import Data.Maybe (fromJust) +import Plutarch.Extra.TermCont (pletC) import Data.Tagged (Tagged (Tagged)) import Data.Universe (Finite (..), Universe (..)) import Plutarch.Api.V1 (PScriptContext) -import Plutarch.Context.Config (defaultConfig) -import Plutarch.Context.Spending ( - ValidatorUTXO (ValidatorUTXO), - inputSelfExtra, - signedWith, - spendingContext, - ) -import Plutarch.Extra.TermCont (pletC) +import Plutarch.Context import PlutusLedgerApi.V1 ( - ScriptContext (scriptContextTxInfo), + ScriptContext (..), + ScriptPurpose (..), TxInfo (txInfoSignatories), + TxOutRef (..), ) -import Property.Generator (genPubKeyHash, genSingletonValue) +import Property.Generator (genPubKeyHash) import Test.Tasty (TestTree) import Test.Tasty.Plutarch.Property (classifiedPropertyNative) import Test.Tasty.QuickCheck ( @@ -63,7 +58,6 @@ genMultiSigProp :: MultiSigProp -> Gen MultiSigModel genMultiSigProp prop = do size <- chooseInt (4, 20) pkhs <- vectorOf size genPubKeyHash - vutxo <- ValidatorUTXO () <$> genSingletonValue minSig <- chooseInt (1, length pkhs) othersigners <- take 20 <$> listOf genPubKeyHash @@ -73,9 +67,9 @@ genMultiSigProp prop = do MeetsMinSigs -> chooseInt (minSig, length pkhs) DoesNotMeetMinSigs -> chooseInt (0, minSig - 1) - let builder = foldr (<>) (inputSelfExtra mempty ()) (signedWith <$> take n pkhs <> othersigners) - ctx = fromJust $ spendingContext defaultConfig builder vutxo - pure (ms, ctx) + let builder = mconcat $ signedWith <$> take n pkhs <> othersigners + txinfo = either error id $ buildTxInfo builder + pure (ms, ScriptContext txinfo (Spending (TxOutRef "" 0))) -- | Classify model into propositions. classifyMultiSigProp :: MultiSigModel -> MultiSigProp diff --git a/agora-specs/Sample/Effect/GovernorMutation.hs b/agora-specs/Sample/Effect/GovernorMutation.hs index 053df7b..7394b70 100644 --- a/agora-specs/Sample/Effect/GovernorMutation.hs +++ b/agora-specs/Sample/Effect/GovernorMutation.hs @@ -11,17 +11,13 @@ module Sample.Effect.GovernorMutation ( mkEffectDatum, ) where --------------------------------------------------------------------------------- - import Agora.Effect.GovernorMutation ( MutateGovernorDatum (..), mutateGovernorValidator, ) import Agora.Governor (GovernorDatum (..)) import Agora.Proposal (ProposalId (..), ProposalThresholds (..)) - --------------------------------------------------------------------------------- - +import Data.Default.Class (Default (def)) import Data.Tagged (Tagged (..)) import Plutarch.Api.V1 (mkValidator, validatorHash) import PlutusLedgerApi.V1 ( @@ -36,13 +32,13 @@ import PlutusLedgerApi.V1 ( Validator, ValidatorHash (..), ) -import PlutusLedgerApi.V1 qualified as Interval +import PlutusLedgerApi.V1 qualified as Interval (always) import PlutusLedgerApi.V1.Address (scriptHashAddress) import PlutusLedgerApi.V1.Value (AssetClass, assetClass) -import PlutusLedgerApi.V1.Value qualified as Value - --------------------------------------------------------------------------------- - +import PlutusLedgerApi.V1.Value qualified as Value ( + assetClassValue, + singleton, + ) import Sample.Shared ( authorityTokenSymbol, govAssetClass, @@ -53,12 +49,6 @@ import Sample.Shared ( ) import Test.Util (datumPair, toDatumHash) --------------------------------------------------------------------------------- - -import Data.Default.Class (Default (def)) - --------------------------------------------------------------------------------- - -- | The effect validator instance. effectValidator :: Validator effectValidator = mkValidator $ mutateGovernorValidator governor diff --git a/agora-specs/Sample/Effect/TreasuryWithdrawal.hs b/agora-specs/Sample/Effect/TreasuryWithdrawal.hs index 1459539..c164dd4 100644 --- a/agora-specs/Sample/Effect/TreasuryWithdrawal.hs +++ b/agora-specs/Sample/Effect/TreasuryWithdrawal.hs @@ -19,6 +19,12 @@ module Sample.Effect.TreasuryWithdrawal ( buildScriptContext, ) where +import Agora.Effect.TreasuryWithdrawal ( + TreasuryWithdrawalDatum (TreasuryWithdrawalDatum), + treasuryWithdrawalValidator, + ) +import Data.ByteString.Char8 qualified as C (pack) +import Data.ByteString.Hash (sha2_256) import Plutarch.Api.V1 (mkValidator, validatorHash) import PlutusLedgerApi.V1 ( Address (Address), @@ -50,16 +56,8 @@ import PlutusLedgerApi.V1 ( Value, toBuiltin, ) -import PlutusLedgerApi.V1.Interval qualified as Interval -import PlutusLedgerApi.V1.Value qualified as Value - -import Data.ByteString.Char8 qualified as C -import Data.ByteString.Hash (sha2_256) - -import Agora.Effect.TreasuryWithdrawal ( - TreasuryWithdrawalDatum (TreasuryWithdrawalDatum), - treasuryWithdrawalValidator, - ) +import PlutusLedgerApi.V1.Interval qualified as Interval (always) +import PlutusLedgerApi.V1.Value qualified as Value (singleton) -- | A sample Currency Symbol. currSymbol :: CurrencySymbol diff --git a/agora-specs/Sample/Governor.hs b/agora-specs/Sample/Governor.hs index d771f55..cd6d688 100644 --- a/agora-specs/Sample/Governor.hs +++ b/agora-specs/Sample/Governor.hs @@ -12,40 +12,6 @@ module Sample.Governor ( mintGST, ) where --------------------------------------------------------------------------------- - -import Data.Tagged (Tagged (..), untag) -import Plutarch.Api.V1 (mkValidator, validatorHash) - --------------------------------------------------------------------------------- - -import PlutusLedgerApi.V1 ( - Address (..), - BuiltinData (BuiltinData), - Credential (ScriptCredential), - Data (I), - Datum (..), - ScriptContext (..), - ScriptPurpose (Minting, Spending), - ToData (toBuiltinData), - TokenName (..), - TxInInfo (TxInInfo), - TxInfo (..), - TxOut (..), - TxOutRef (..), - Validator, - ValidatorHash (..), - ) -import PlutusLedgerApi.V1.Address (scriptHashAddress) -import PlutusLedgerApi.V1.Interval qualified as Interval -import PlutusLedgerApi.V1.Value ( - AssetClass (..), - ) -import PlutusLedgerApi.V1.Value qualified as Value -import PlutusTx.AssocMap qualified as AssocMap - --------------------------------------------------------------------------------- - import Agora.Effect.NoOp (noOpValidator) import Agora.Governor (GovernorDatum (..), getNextProposalId) import Agora.Proposal ( @@ -56,42 +22,70 @@ import Agora.Proposal ( ResultTag (..), emptyVotesFor, ) -import Agora.Proposal qualified as P +import Agora.Proposal qualified as P (ProposalDatum (proposalId)) import Agora.Proposal.Time ( ProposalStartingTime (ProposalStartingTime), ProposalTimingConfig (..), ) -import Agora.Stake ( - ProposalLock (..), - Stake (..), - StakeDatum (..), +import Agora.Stake (ProposalLock (..), Stake (..), StakeDatum (..)) +import Data.Default.Class (Default (def)) +import Data.Tagged (Tagged (..), untag) +import Plutarch.Api.V1 (mkValidator, validatorHash) +import Plutarch.Context ( + MintingBuilder, + SpendingBuilder, + buildMinting, + buildSpending, + fee, + input, + mint, + output, + script, + signedWith, + timeRange, + txId, + withDatum, + withRefIndex, + withSpending, + withTxId, + withValue, + ) +import PlutusLedgerApi.V1 ( + BuiltinData (BuiltinData), + Data (I), + Datum (Datum), + ScriptContext, + TokenName (TokenName), + TxOutRef (txOutRefId), + Validator, + ValidatorHash (..), + ) +import PlutusLedgerApi.V1.Value (AssetClass (AssetClass)) +import PlutusLedgerApi.V1.Value qualified as Value ( + assetClassValue, + singleton, + ) +import PlutusTx.AssocMap qualified as AssocMap ( + empty, + fromList, + singleton, ) - --------------------------------------------------------------------------------- - import Sample.Shared ( authorityTokenSymbol, govAssetClass, - govSymbol, - govValidatorAddress, + govValidatorHash, gstUTXORef, minAda, proposalPolicySymbol, proposalStartingTimeFromTimeRange, - proposalValidatorAddress, + proposalValidatorHash, signer, signer2, stake, - stakeAddress, stakeAssetClass, + stakeValidatorHash, ) -import Test.Util (closedBoundedInterval, datumPair, toDatumHash) - --------------------------------------------------------------------------------- - -import Data.Default.Class (Default (def)) - --------------------------------------------------------------------------------- +import Test.Util (closedBoundedInterval, toDatumHash) -- | Unit datum unitDatum :: Datum @@ -118,65 +112,34 @@ mintGST :: ScriptContext mintGST = let gst = Value.assetClassValue govAssetClass 1 - --- - - governorOutputDatum' :: GovernorDatum - governorOutputDatum' = + governorOutputDatum :: GovernorDatum + governorOutputDatum = GovernorDatum { proposalThresholds = def , nextProposalId = ProposalId 0 , proposalTimings = def , createProposalTimeRangeMaxWidth = def } - governorOutputDatum :: Datum - governorOutputDatum = Datum $ toBuiltinData governorOutputDatum' - governorOutput :: TxOut - governorOutput = - TxOut - { txOutAddress = govValidatorAddress - , txOutValue = gst <> minAda - , txOutDatumHash = Just $ toDatumHash governorOutputDatum - } - - --- witness :: ValidatorHash witness = "a926a9a72a0963f428e3252caa8354e655603996fb8892d6b8323fd072345924" - witnessAddress :: Address - witnessAddress = Address (ScriptCredential witness) Nothing - --- - - -- The witness UTXO must be consumed. - witnessInput :: TxOut - witnessInput = - TxOut - { txOutAddress = witnessAddress - , txOutValue = mempty - , txOutDatumHash = Nothing - } - initialSpend :: TxInInfo - initialSpend = TxInInfo gstUTXORef witnessInput - in ScriptContext - { scriptContextTxInfo = - TxInfo - { txInfoInputs = - [ initialSpend - ] - , txInfoOutputs = [governorOutput] - , -- Some ada to cover the transaction fee - txInfoFee = Value.singleton "" "" 2 - , -- Exactly one GST is minted - txInfoMint = gst - , txInfoDCert = [] - , txInfoWdrl = [] - , txInfoValidRange = Interval.always - , txInfoSignatories = [signer] - , txInfoData = [datumPair governorOutputDatum] - , txInfoId = "90906d3e6b4d6dec2e747dcdd9617940ea8358164c7244694cfa39dec18bd9d4" - } - , scriptContextPurpose = Minting govSymbol - } + builder :: MintingBuilder + builder = + mconcat + [ txId "90906d3e6b4d6dec2e747dcdd9617940ea8358164c7244694cfa39dec18bd9d4" + , signedWith signer + , mint gst + , input $ + script witness + . withTxId (txOutRefId gstUTXORef) + . withRefIndex 0 + , output $ + script govValidatorHash + . withValue (gst <> minAda) + . withDatum governorOutputDatum + ] + in either error id $ buildMinting builder {- | A valid script context to create a proposal. @@ -213,143 +176,90 @@ createProposal = stackedGTs = 424242424242 thisProposalId = ProposalId 0 - --- - - governorInputDatum' :: GovernorDatum - governorInputDatum' = + governorInputDatum :: GovernorDatum + governorInputDatum = GovernorDatum { proposalThresholds = def , nextProposalId = thisProposalId , proposalTimings = def , createProposalTimeRangeMaxWidth = def } - governorInputDatum :: Datum - governorInputDatum = Datum $ toBuiltinData governorInputDatum' - governorInput :: TxOut - governorInput = - TxOut - { txOutAddress = govValidatorAddress - , txOutValue = gst - , txOutDatumHash = Just $ toDatumHash governorInputDatum - } - - --- effects = AssocMap.fromList [ (ResultTag 0, AssocMap.empty) , (ResultTag 1, AssocMap.empty) ] - proposalDatum :: Datum + proposalDatum :: ProposalDatum proposalDatum = - Datum - ( toBuiltinData $ - ProposalDatum - { P.proposalId = ProposalId 0 - , effects = effects - , status = Draft - , cosigners = [signer] - , thresholds = def - , votes = emptyVotesFor effects - , timingConfig = def - , startingTime = proposalStartingTimeFromTimeRange validTimeRange - } - ) - proposalOutput :: TxOut - proposalOutput = - TxOut - { txOutAddress = proposalValidatorAddress - , txOutValue = pst <> minAda - , txOutDatumHash = Just (toDatumHash proposalDatum) + ProposalDatum + { P.proposalId = ProposalId 0 + , effects = effects + , status = Draft + , cosigners = [signer] + , thresholds = def + , votes = emptyVotesFor effects + , timingConfig = def + , startingTime = proposalStartingTimeFromTimeRange validTimeRange } - --- - - stakeInputDatum' :: StakeDatum - stakeInputDatum' = + stakeInputDatum :: StakeDatum + stakeInputDatum = StakeDatum { stakedAmount = Tagged stackedGTs , owner = signer , lockedBy = [] } - stakeInputDatum :: Datum - stakeInputDatum = Datum $ toBuiltinData stakeInputDatum' - stakeInput :: TxOut - stakeInput = - TxOut - { txOutAddress = stakeAddress - , txOutValue = sst <> Value.assetClassValue (untag stake.gtClassRef) stackedGTs - , txOutDatumHash = Just (toDatumHash stakeInputDatum) - } - --- - governorOutputDatum' :: GovernorDatum - governorOutputDatum' = governorInputDatum' {nextProposalId = getNextProposalId thisProposalId} - governorOutputDatum :: Datum - governorOutputDatum = Datum $ toBuiltinData governorOutputDatum' - governorOutput :: TxOut - governorOutput = - governorInput - { txOutDatumHash = Just $ toDatumHash governorOutputDatum - , txOutValue = gst <> minAda - } - - --- + governorOutputDatum :: GovernorDatum + governorOutputDatum = governorInputDatum {nextProposalId = getNextProposalId thisProposalId} proposalLocks :: [ProposalLock] proposalLocks = [ ProposalLock (ResultTag 0) thisProposalId , ProposalLock (ResultTag 1) thisProposalId ] - stakeOutputDatum' :: StakeDatum - stakeOutputDatum' = stakeInputDatum' {lockedBy = proposalLocks} - stakeOutputDatum :: Datum - stakeOutputDatum = Datum $ toBuiltinData stakeOutputDatum' - stakeOutput :: TxOut - stakeOutput = - stakeInput - { txOutDatumHash = Just $ toDatumHash stakeOutputDatum - , txOutValue = sst <> Value.assetClassValue (untag stake.gtClassRef) stackedGTs <> minAda - } - - --- - - ownInputRef :: TxOutRef - ownInputRef = TxOutRef "4355a46b19d348dc2f57c046f8ef63d4538ebb936000f3c9ee954a27460dd865" 1 - - --- + stakeOutputDatum :: StakeDatum + stakeOutputDatum = stakeInputDatum {lockedBy = proposalLocks} validTimeRange = closedBoundedInterval 10 15 - in ScriptContext - { scriptContextTxInfo = - TxInfo - { txInfoInputs = - [ TxInInfo - ownInputRef - governorInput - , TxInInfo - (TxOutRef "4262bbd0b3fc926b74eaa8abab5def6ce5e6b94f19cf221c02a16e7da8cd470f" 1) - stakeInput - ] - , txInfoOutputs = [proposalOutput, governorOutput, stakeOutput] - , txInfoFee = Value.singleton "" "" 2 - , txInfoMint = pst - , txInfoDCert = [] - , txInfoWdrl = [] - , txInfoValidRange = validTimeRange - , txInfoSignatories = [signer] - , txInfoData = - datumPair - <$> [ governorInputDatum - , governorOutputDatum - , proposalDatum - , stakeInputDatum - , stakeOutputDatum - ] - , txInfoId = "1ffb9669335c908d9a4774a4bf7aa7bfafec91d015249b4138bc83fde4a3330a" - } - , scriptContextPurpose = Spending ownInputRef - } + + builder :: SpendingBuilder + builder = + mconcat + [ txId "1ffb9669335c908d9a4774a4bf7aa7bfafec91d015249b4138bc83fde4a3330a" + , fee $ Value.singleton "" "" 2 + , timeRange $ closedBoundedInterval 10 15 + , signedWith signer + , mint pst + , input $ + script govValidatorHash + . withValue gst + . withDatum governorInputDatum + . withTxId "4355a46b19d348dc2f57c046f8ef63d4538ebb936000f3c9ee954a27460dd865" + , input $ + script stakeValidatorHash + . withValue (sst <> Value.assetClassValue (untag stake.gtClassRef) stackedGTs) + . withDatum stakeInputDatum + . withTxId "4262bbd0b3fc926b74eaa8abab5def6ce5e6b94f19cf221c02a16e7da8cd470f" + , output $ + script proposalValidatorHash + . withValue (pst <> minAda) + . withDatum proposalDatum + , output $ + script govValidatorHash + . withValue (gst <> minAda) + . withDatum governorOutputDatum + , output $ + script stakeValidatorHash + . withValue (sst <> Value.assetClassValue (untag stake.gtClassRef) stackedGTs <> minAda) + . withDatum stakeOutputDatum + , withSpending $ + script govValidatorHash + . withValue gst + . withDatum governorInputDatum + ] + in either error id $ buildSpending builder {- This script context should be a valid transaction for minting authority for the effect scrips. @@ -374,14 +284,10 @@ mintGATs = gst = Value.assetClassValue govAssetClass 1 gat = Value.assetClassValue atAssetClass 1 - --- - mockEffect :: Validator mockEffect = mkValidator $ noOpValidator "" mockEffectHash :: ValidatorHash mockEffectHash = validatorHash mockEffect - mockEffectAddress :: Address - mockEffectAddress = scriptHashAddress mockEffectHash mockEffectOutputDatum :: Datum mockEffectOutputDatum = unitDatum atTokenName :: TokenName @@ -391,27 +297,14 @@ mintGATs = atAssetClass :: AssetClass atAssetClass = AssetClass (authorityTokenSymbol, atTokenName) - --- - - governorInputDatum' :: GovernorDatum - governorInputDatum' = + governorInputDatum :: GovernorDatum + governorInputDatum = GovernorDatum { proposalThresholds = def , nextProposalId = ProposalId 5 , proposalTimings = def , createProposalTimeRangeMaxWidth = def } - governorInputDatum :: Datum - governorInputDatum = Datum $ toBuiltinData governorInputDatum' - governorInput :: TxOut - governorInput = - TxOut - { txOutAddress = govValidatorAddress - , txOutValue = gst - , txOutDatumHash = Just $ toDatumHash governorInputDatum - } - - --- effects = AssocMap.fromList @@ -425,8 +318,8 @@ mintGATs = [ (ResultTag 0, 100) , (ResultTag 1, 2000) -- The winner ] - proposalInputDatum' :: ProposalDatum - proposalInputDatum' = + proposalInputDatum :: ProposalDatum + proposalInputDatum = ProposalDatum { P.proposalId = ProposalId 0 , effects = effects @@ -437,94 +330,55 @@ mintGATs = , timingConfig = def , startingTime = ProposalStartingTime 10 } - proposalInputDatum :: Datum - proposalInputDatum = Datum $ toBuiltinData proposalInputDatum' - proposalInput :: TxOut - proposalInput = - TxOut - { txOutAddress = proposalValidatorAddress - , txOutValue = pst - , txOutDatumHash = Just (toDatumHash proposalInputDatum) - } - --- + governorOutputDatum :: GovernorDatum + governorOutputDatum = governorInputDatum - governorOutputDatum' :: GovernorDatum - governorOutputDatum' = governorInputDatum' - governorOutputDatum :: Datum - governorOutputDatum = Datum $ toBuiltinData governorOutputDatum' - governorOutput :: TxOut - governorOutput = - governorInput - { txOutDatumHash = Just $ toDatumHash governorOutputDatum - , txOutValue = gst <> minAda - } + proposalOutputDatum :: ProposalDatum + proposalOutputDatum = proposalInputDatum {status = Finished} - --- - - proposalOutputDatum' :: ProposalDatum - proposalOutputDatum' = proposalInputDatum' {status = Finished} - proposalOutputDatum :: Datum - proposalOutputDatum = Datum $ toBuiltinData proposalOutputDatum' - proposalOutput :: TxOut - proposalOutput = - proposalInput - { txOutDatumHash = Just $ toDatumHash proposalOutputDatum - , txOutValue = pst <> minAda - } - - -- - - mockEffectOutput :: TxOut - mockEffectOutput = - TxOut - { txOutAddress = mockEffectAddress - , txOutDatumHash = Just $ toDatumHash mockEffectOutputDatum - , txOutValue = gat <> minAda - } - - -- - - ownInputRef :: TxOutRef - ownInputRef = TxOutRef "4355a46b19d348dc2f57c046f8ef63d4538ebb936000f3c9ee954a27460dd865" 1 - - -- validTimeRange = closedBoundedInterval ((def :: ProposalTimingConfig).lockingTime + 11) ((def :: ProposalTimingConfig).executingTime - 11) - in ScriptContext - { scriptContextTxInfo = - TxInfo - { txInfoInputs = - [ TxInInfo ownInputRef governorInput - , TxInInfo - (TxOutRef "11b2162f267614b803761032b6333040fc61478ae788c088614ee9487ab0c1b7" 1) - proposalInput - ] - , txInfoOutputs = - [ governorOutput - , proposalOutput - , mockEffectOutput - ] - , txInfoFee = Value.singleton "" "" 2 - , txInfoMint = gat - , txInfoDCert = [] - , txInfoWdrl = [] - , txInfoValidRange = validTimeRange - , txInfoSignatories = [signer, signer2] - , txInfoData = - datumPair - <$> [ governorInputDatum - , governorOutputDatum - , proposalInputDatum - , proposalOutputDatum - , mockEffectOutputDatum - ] - , txInfoId = "ff755f613c1f7487dfbf231325c67f481f7a97e9faf4d8b09ad41176fd65cbe7" - } - , scriptContextPurpose = Spending ownInputRef - } + + builder :: SpendingBuilder + builder = + mconcat + [ txId "ff755f613c1f7487dfbf231325c67f481f7a97e9faf4d8b09ad41176fd65cbe7" + , signedWith signer + , signedWith signer2 + , timeRange validTimeRange + , fee (Value.singleton "" "" 2) + , mint gat + , input $ + script govValidatorHash + . withValue gst + . withDatum governorInputDatum + . withTxId "4355a46b19d348dc2f57c046f8ef63d4538ebb936000f3c9ee954a27460dd865" + , input $ + script proposalValidatorHash + . withValue pst + . withDatum proposalInputDatum + . withTxId "11b2162f267614b803761032b6333040fc61478ae788c088614ee9487ab0c1b7" + , output $ + script govValidatorHash + . withValue (gst <> minAda) + . withDatum governorOutputDatum + , output $ + script proposalValidatorHash + . withValue (pst <> minAda) + . withDatum proposalOutputDatum + , output $ + script mockEffectHash + . withValue (gat <> minAda) + . withDatum mockEffectOutputDatum + , withSpending $ + script govValidatorHash + . withValue gst + . withDatum governorInputDatum + ] + in either error id $ buildSpending builder {- | A valid script context for changing the state datum of the governor. @@ -546,110 +400,62 @@ mutateState = gat = Value.assetClassValue atAssetClass 1 burntGAT = Value.assetClassValue atAssetClass (-1) - --- - -- TODO: Use the *real* effect, see https://github.com/Liqwid-Labs/agora/pull/62 - mockEffect :: Validator mockEffect = mkValidator $ noOpValidator "" mockEffectHash :: ValidatorHash mockEffectHash = validatorHash mockEffect - mockEffectAddress :: Address - mockEffectAddress = scriptHashAddress mockEffectHash atTokenName :: TokenName atTokenName = TokenName hash where ValidatorHash hash = mockEffectHash atAssetClass :: AssetClass atAssetClass = AssetClass (authorityTokenSymbol, atTokenName) - - -- - mockEffectInputDatum :: Datum mockEffectInputDatum = unitDatum - mockEffectInput :: TxOut - mockEffectInput = - TxOut - { txOutAddress = mockEffectAddress - , txOutValue = gat -- Will be burnt - , txOutDatumHash = Just $ toDatumHash mockEffectInputDatum - } - - -- - mockEffectOutputDatum :: Datum mockEffectOutputDatum = mockEffectInputDatum - mockEffectOutput :: TxOut - mockEffectOutput = - mockEffectInput - { txOutValue = minAda - , txOutDatumHash = Just $ toDatumHash mockEffectOutputDatum - } - -- - - governorInputDatum' :: GovernorDatum - governorInputDatum' = + governorInputDatum :: GovernorDatum + governorInputDatum = GovernorDatum { proposalThresholds = def , nextProposalId = ProposalId 5 , proposalTimings = def , createProposalTimeRangeMaxWidth = def } - governorInputDatum :: Datum - governorInputDatum = Datum $ toBuiltinData governorInputDatum' - governorInput :: TxOut - governorInput = - TxOut - { txOutAddress = govValidatorAddress - , txOutValue = gst - , txOutDatumHash = Just $ toDatumHash governorInputDatum - } - -- + governorOutputDatum :: GovernorDatum + governorOutputDatum = governorInputDatum - governorOutputDatum' :: GovernorDatum - governorOutputDatum' = governorInputDatum' - governorOutputDatum :: Datum - governorOutputDatum = Datum $ toBuiltinData governorOutputDatum' - governorOutput :: TxOut - governorOutput = - governorInput - { txOutDatumHash = Just $ toDatumHash governorOutputDatum - , txOutValue = gst <> minAda - } - - -- - - ownInputRef :: TxOutRef - ownInputRef = TxOutRef "f867238a04597c99a0b9858746557d305025cca3b9f78ea14d5c88c4cfcf58ff" 1 - in ScriptContext - { scriptContextTxInfo = - TxInfo - { txInfoInputs = - [ TxInInfo ownInputRef governorInput - , TxInInfo - (TxOutRef "ecff06d7cf99089294569cc8b92609e44927278f9901730715d14634fbc10089" 1) - mockEffectInput - ] - , txInfoOutputs = - [ governorOutput - , mockEffectOutput - ] - , txInfoFee = Value.singleton "" "" 2 - , txInfoMint = burntGAT - , txInfoDCert = [] - , txInfoWdrl = [] - , txInfoValidRange = Interval.always - , txInfoSignatories = [signer] - , txInfoData = - datumPair - <$> [ governorInputDatum - , governorOutputDatum - , mockEffectInputDatum - , mockEffectOutputDatum - ] - , txInfoId = "9a12a605086a9f866731869a42d0558036fc739c74fea3849aa41562c015aaf9" - } - , scriptContextPurpose = Spending ownInputRef - } + builder :: SpendingBuilder + builder = + mconcat + [ txId "9a12a605086a9f866731869a42d0558036fc739c74fea3849aa41562c015aaf9" + , signedWith signer + , mint burntGAT + , fee $ Value.singleton "" "" 2 + , input $ + script govValidatorHash + . withValue gst + . withDatum governorInputDatum + . withTxId "f867238a04597c99a0b9858746557d305025cca3b9f78ea14d5c88c4cfcf58ff" + , input $ + script mockEffectHash + . withValue gat + . withDatum mockEffectInputDatum + . withTxId "ecff06d7cf99089294569cc8b92609e44927278f9901730715d14634fbc10089" + , output $ + script govValidatorHash + . withValue (gst <> minAda) + . withDatum governorOutputDatum + , input $ + script mockEffectHash + . withValue minAda + . withDatum mockEffectOutputDatum + , withSpending $ + script govValidatorHash + . withValue gst + . withDatum governorInputDatum + ] + in either error id $ buildSpending builder diff --git a/agora-specs/Sample/Proposal.hs b/agora-specs/Sample/Proposal.hs index 2379ecd..7955228 100644 --- a/agora-specs/Sample/Proposal.hs +++ b/agora-specs/Sample/Proposal.hs @@ -21,39 +21,7 @@ module Sample.Proposal ( advancePropsoalWithsStake, ) where --------------------------------------------------------------------------------- - -import Plutarch.Api.V1 ( - validatorHash, - ) - --------------------------------------------------------------------------------- - -import PlutusLedgerApi.V1 ( - Address (Address), - Credential (ScriptCredential), - Datum (Datum), - DatumHash, - POSIXTime, - POSIXTimeRange, - PubKeyHash, - ScriptContext (..), - ScriptPurpose (..), - ToData (toBuiltinData), - TxInInfo (TxInInfo), - TxInfo (..), - TxOut (TxOut, txOutAddress, txOutDatumHash, txOutValue), - TxOutRef (TxOutRef), - ValidatorHash, - ) -import PlutusLedgerApi.V1.Value qualified as Value -import PlutusTx.AssocMap qualified as AssocMap - --------------------------------------------------------------------------------- - -import Agora.Governor ( - GovernorDatum (..), - ) +import Agora.Governor (GovernorDatum (..)) import Agora.Proposal ( Proposal (..), ProposalDatum (..), @@ -64,19 +32,78 @@ import Agora.Proposal ( ResultTag (..), emptyVotesFor, ) -import Agora.Proposal.Time (ProposalStartingTime (ProposalStartingTime), ProposalTimingConfig (..)) -import Agora.Stake (ProposalLock (ProposalLock), Stake (..), StakeDatum (..)) -import Data.Tagged (Tagged (..), untag) -import Sample.Shared -import Test.Util (closedBoundedInterval, datumPair, toDatumHash, updateMap) - --------------------------------------------------------------------------------- - +import Agora.Proposal.Time ( + ProposalStartingTime (ProposalStartingTime), + ProposalTimingConfig (..), + ) +import Agora.Stake ( + ProposalLock (ProposalLock), + Stake (..), + StakeDatum (..), + ) import Data.Default.Class (Default (def)) +import Data.Tagged (Tagged (..), untag) +import Plutarch.Context ( + BaseBuilder, + MintingBuilder, + buildMinting, + buildTxInfo, + input, + mint, + output, + script, + signedWith, + timeRange, + txId, + withDatum, + withRefIndex, + withTxId, + withValue, + ) +import PlutusLedgerApi.V1 ( + Datum (Datum), + DatumHash, + POSIXTime, + POSIXTimeRange, + PubKeyHash, + ScriptContext (..), + ToData (toBuiltinData), + TxInInfo (TxInInfo), + TxInfo (..), + TxOut (TxOut, txOutAddress, txOutDatumHash, txOutValue), + TxOutRef (..), + ValidatorHash, + ) +import PlutusLedgerApi.V1.Value qualified as Value ( + assetClassValue, + singleton, + ) +import PlutusTx.AssocMap qualified as AssocMap ( + Map, + empty, + fromList, + ) +import Sample.Shared ( + govValidatorHash, + minAda, + proposal, + proposalPolicySymbol, + proposalStartingTimeFromTimeRange, + proposalValidatorHash, + signer, + signer2, + stake, + stakeAddress, + stakeAssetClass, + stakeValidatorHash, + ) +import Test.Util ( + closedBoundedInterval, + datumPair, + toDatumHash, + updateMap, + ) --------------------------------------------------------------------------------- - --- | This script context should be a valid transaction. proposalCreation :: ScriptContext proposalCreation = let st = Value.singleton proposalPolicySymbol "" 1 -- Proposal ST @@ -85,93 +112,57 @@ proposalCreation = [ (ResultTag 0, AssocMap.empty) , (ResultTag 1, AssocMap.empty) ] - proposalDatum :: Datum + proposalDatum :: ProposalDatum proposalDatum = - Datum - ( toBuiltinData $ - ProposalDatum - { proposalId = ProposalId 0 - , effects = effects - , status = Draft - , cosigners = [signer] - , thresholds = def - , votes = emptyVotesFor effects - , timingConfig = def - , startingTime = proposalStartingTimeFromTimeRange validTimeRange - } - ) + ProposalDatum + { proposalId = ProposalId 0 + , effects = effects + , status = Draft + , cosigners = [signer] + , thresholds = def + , votes = emptyVotesFor effects + , timingConfig = def + , startingTime = proposalStartingTimeFromTimeRange validTimeRange + } - govBefore :: Datum + govBefore :: GovernorDatum govBefore = - Datum - ( toBuiltinData $ - GovernorDatum - { proposalThresholds = def - , nextProposalId = ProposalId 0 - , proposalTimings = def - , createProposalTimeRangeMaxWidth = def - } - ) - govAfter :: Datum - govAfter = - Datum - ( toBuiltinData $ - GovernorDatum - { proposalThresholds = def - , nextProposalId = ProposalId 1 - , proposalTimings = def - , createProposalTimeRangeMaxWidth = def - } - ) + GovernorDatum + { proposalThresholds = def + , nextProposalId = ProposalId 0 + , proposalTimings = def + , createProposalTimeRangeMaxWidth = def + } + + govAfter :: GovernorDatum + govAfter = govBefore {nextProposalId = ProposalId 1} validTimeRange = closedBoundedInterval 10 15 - in ScriptContext - { scriptContextTxInfo = - TxInfo - { txInfoInputs = - [ TxInInfo - (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) - TxOut - { txOutAddress = Address (ScriptCredential $ validatorHash govValidator) Nothing - , txOutValue = Value.assetClassValue proposal.governorSTAssetClass 1 - , txOutDatumHash = Just (toDatumHash govBefore) - } - ] - , txInfoOutputs = - [ TxOut - { txOutAddress = Address (ScriptCredential proposalValidatorHash) Nothing - , txOutValue = - mconcat - [ st - , Value.singleton "" "" 10_000_000 - ] - , txOutDatumHash = Just (toDatumHash proposalDatum) - } - , TxOut - { txOutAddress = Address (ScriptCredential $ validatorHash govValidator) Nothing - , txOutValue = - mconcat - [ Value.assetClassValue proposal.governorSTAssetClass 1 - , Value.singleton "" "" 10_000_000 - ] - , txOutDatumHash = Just (toDatumHash govAfter) - } - ] - , txInfoFee = Value.singleton "" "" 2 - , txInfoMint = st - , txInfoDCert = [] - , txInfoWdrl = [] - , txInfoValidRange = validTimeRange - , txInfoSignatories = [signer] - , txInfoData = - [ datumPair proposalDatum - , datumPair govBefore - , datumPair govAfter - ] - , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" - } - , scriptContextPurpose = Minting proposalPolicySymbol - } + + builder :: MintingBuilder + builder = + mconcat + [ txId "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" + , signedWith signer + , mint st + , input $ + script govValidatorHash + . withValue (Value.assetClassValue proposal.governorSTAssetClass 1) + . withDatum govBefore + . withTxId "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" + , output $ + script proposalValidatorHash + . withValue (st <> Value.singleton "" "" 10_000_000) + . withDatum proposalDatum + , output $ + script govValidatorHash + . withValue + ( Value.assetClassValue proposal.governorSTAssetClass 1 + <> Value.singleton "" "" 10_000_000 + ) + . withDatum govAfter + ] + in either error id $ buildMinting builder proposalRef :: TxOutRef proposalRef = TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1 @@ -209,66 +200,43 @@ cosignProposal newSigners = closedBoundedInterval 10 ((def :: ProposalTimingConfig).draftTime - 10) - in TxInfo - { txInfoInputs = - [ TxInInfo - proposalRef - TxOut - { txOutAddress = proposalValidatorAddress - , txOutValue = - mconcat - [ st - , Value.singleton "" "" 10_000_000 - ] - , txOutDatumHash = Just (toDatumHash proposalBefore) - } - , TxInInfo - stakeRef - TxOut - { txOutAddress = stakeAddress - , txOutValue = - mconcat - [ Value.singleton "" "" 10_000_000 - , Value.assetClassValue (untag stake.gtClassRef) 50_000_000 - , Value.assetClassValue stakeAssetClass 1 - ] - , txOutDatumHash = Just (toDatumHash stakeDatum) - } - ] - , txInfoOutputs = - [ TxOut - { txOutAddress = Address (ScriptCredential proposalValidatorHash) Nothing - , txOutValue = - mconcat - [ st - , Value.singleton "" "" 10_000_000 - ] - , txOutDatumHash = Just (toDatumHash . Datum $ toBuiltinData proposalAfter) - } - , TxOut - { txOutAddress = stakeAddress - , txOutValue = - mconcat - [ Value.singleton "" "" 10_000_000 - , Value.assetClassValue (untag stake.gtClassRef) 50_000_000 - , Value.assetClassValue stakeAssetClass 1 - ] - , txOutDatumHash = Just (toDatumHash stakeDatum) - } - ] - , txInfoFee = Value.singleton "" "" 2 - , txInfoMint = st - , txInfoDCert = [] - , txInfoWdrl = [] - , txInfoValidRange = validTimeRange - , txInfoSignatories = newSigners - , txInfoData = - [ datumPair . Datum $ toBuiltinData proposalBefore - , datumPair . Datum $ toBuiltinData proposalAfter - , datumPair . Datum $ toBuiltinData stakeDatum - ] - , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" - } + builder :: BaseBuilder + builder = + mconcat + [ txId "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" + , mint st + , mconcat $ signedWith <$> newSigners + , timeRange validTimeRange + , input $ + script proposalValidatorHash + . withValue (st <> Value.singleton "" "" 10_000_000) + . withDatum proposalBefore + . withTxId (txOutRefId proposalRef) + . withRefIndex (txOutRefIdx proposalRef) + , input $ + script stakeValidatorHash + . withValue + ( Value.singleton "" "" 10_000_000 + <> Value.assetClassValue (untag stake.gtClassRef) 50_000_000 + <> Value.assetClassValue stakeAssetClass 1 + ) + . withDatum stakeDatum + . withTxId (txOutRefId stakeRef) + . withRefIndex (txOutRefIdx stakeRef) + , output $ + script proposalValidatorHash + . withValue (st <> Value.singleton "" "" 10_000_000) + . withDatum proposalAfter + , output $ + script stakeValidatorHash + . withValue + ( Value.singleton "" "" 10_000_000 + <> Value.assetClassValue (untag stake.gtClassRef) 50_000_000 + <> Value.assetClassValue stakeAssetClass 1 + ) + . withDatum stakeDatum + ] + in either error id $ buildTxInfo builder -------------------------------------------------------------------------------- @@ -309,8 +277,8 @@ voteOnProposal params = --- - proposalInputDatum' :: ProposalDatum - proposalInputDatum' = + proposalInputDatum :: ProposalDatum + proposalInputDatum = ProposalDatum { proposalId = ProposalId 42 , effects = effects @@ -321,15 +289,6 @@ voteOnProposal params = , timingConfig = def , startingTime = ProposalStartingTime 0 } - proposalInputDatum :: Datum - proposalInputDatum = Datum $ toBuiltinData proposalInputDatum' - proposalInput :: TxOut - proposalInput = - TxOut - { txOutAddress = proposalValidatorAddress - , txOutValue = pst - , txOutDatumHash = Just $ toDatumHash proposalInputDatum - } --- @@ -341,27 +300,13 @@ voteOnProposal params = --- - stakeInputDatum' :: StakeDatum - stakeInputDatum' = + stakeInputDatum :: StakeDatum + stakeInputDatum = StakeDatum { stakedAmount = Tagged params.voteCount , owner = stakeOwner , lockedBy = existingLocks } - stakeInputDatum :: Datum - stakeInputDatum = Datum $ toBuiltinData stakeInputDatum' - stakeInput :: TxOut - stakeInput = - TxOut - { txOutAddress = stakeAddress - , txOutValue = - mconcat - [ sst - , Value.assetClassValue (untag stake.gtClassRef) params.voteCount - , minAda - ] - , txOutDatumHash = Just $ toDatumHash stakeInputDatum - } --- @@ -370,39 +315,25 @@ voteOnProposal params = --- - proposalOutputDatum' :: ProposalDatum - proposalOutputDatum' = - proposalInputDatum' + proposalOutputDatum :: ProposalDatum + proposalOutputDatum = + proposalInputDatum { votes = ProposalVotes updatedVotes } - proposalOutputDatum :: Datum - proposalOutputDatum = Datum $ toBuiltinData proposalOutputDatum' - proposalOutput :: TxOut - proposalOutput = - proposalInput - { txOutDatumHash = Just $ toDatumHash proposalOutputDatum - } --- -- Off-chain code should do exactly like this: prepend new lock toStatus the list. updatedLocks :: [ProposalLock] - updatedLocks = ProposalLock params.voteFor proposalInputDatum'.proposalId : existingLocks + updatedLocks = ProposalLock params.voteFor proposalInputDatum.proposalId : existingLocks --- - stakeOutputDatum' :: StakeDatum - stakeOutputDatum' = - stakeInputDatum' + stakeOutputDatum :: StakeDatum + stakeOutputDatum = + stakeInputDatum { lockedBy = updatedLocks } - stakeOutputDatum :: Datum - stakeOutputDatum = Datum $ toBuiltinData stakeOutputDatum' - stakeOutput :: TxOut - stakeOutput = - stakeInput - { txOutDatumHash = Just $ toDatumHash stakeOutputDatum - } --- @@ -410,21 +341,43 @@ voteOnProposal params = closedBoundedInterval ((def :: ProposalTimingConfig).draftTime + 1) ((def :: ProposalTimingConfig).votingTime - 1) - in TxInfo - { txInfoInputs = - [ TxInInfo proposalRef proposalInput - , TxInInfo stakeRef stakeInput - ] - , txInfoOutputs = [proposalOutput, stakeOutput] - , txInfoFee = Value.singleton "" "" 2 - , txInfoMint = mempty - , txInfoDCert = [] - , txInfoWdrl = [] - , txInfoValidRange = validTimeRange - , txInfoSignatories = [stakeOwner] - , txInfoData = datumPair <$> [proposalInputDatum, proposalOutputDatum, stakeInputDatum, stakeOutputDatum] - , txInfoId = "827598fb2d69a896bbd9e645bb14c307df907f422b39eecbe4d6329bc30b428c" - } + + builder :: BaseBuilder + builder = + mconcat + [ txId "827598fb2d69a896bbd9e645bb14c307df907f422b39eecbe4d6329bc30b428c" + , signedWith stakeOwner + , timeRange validTimeRange + , input $ + script proposalValidatorHash + . withValue pst + . withDatum proposalInputDatum + . withTxId (txOutRefId proposalRef) + . withRefIndex (txOutRefIdx proposalRef) + , input $ + script stakeValidatorHash + . withValue + ( sst + <> Value.assetClassValue (untag stake.gtClassRef) params.voteCount + <> minAda + ) + . withDatum stakeInputDatum + . withTxId (txOutRefId stakeRef) + . withRefIndex (txOutRefIdx stakeRef) + , output $ + script proposalValidatorHash + . withValue pst + . withDatum proposalOutputDatum + , output $ + script stakeValidatorHash + . withValue + ( sst + <> Value.assetClassValue (untag stake.gtClassRef) params.voteCount + <> minAda + ) + . withDatum stakeOutputDatum + ] + in either error id $ buildTxInfo builder -------------------------------------------------------------------------------- @@ -451,13 +404,11 @@ mkTransitionTxInfo :: -- | Valid time range of the transaction. POSIXTimeRange -> TxInfo -mkTransitionTxInfo from to effects votes startingTime timeRange = +mkTransitionTxInfo from to effects votes startingTime validTime = let pst = Value.singleton proposalPolicySymbol "" 1 - --- - - proposalInputDatum' :: ProposalDatum - proposalInputDatum' = + proposalInputDatum :: ProposalDatum + proposalInputDatum = ProposalDatum { proposalId = ProposalId 0 , effects = effects @@ -468,43 +419,30 @@ mkTransitionTxInfo from to effects votes startingTime timeRange = , timingConfig = def , startingTime = startingTime } - proposalInputDatum :: Datum - proposalInputDatum = Datum $ toBuiltinData proposalInputDatum' - proposalInput :: TxOut - proposalInput = - TxOut - { txOutAddress = proposalValidatorAddress - , txOutValue = pst - , txOutDatumHash = Just $ toDatumHash proposalInputDatum - } - --- - - proposalOutputDatum' :: ProposalDatum - proposalOutputDatum' = - proposalInputDatum' + proposalOutputDatum :: ProposalDatum + proposalOutputDatum = + proposalInputDatum { status = to } - proposalOutputDatum :: Datum - proposalOutputDatum = Datum $ toBuiltinData proposalOutputDatum' - proposalOutput :: TxOut - proposalOutput = - proposalInput - { txOutValue = proposalInput.txOutValue <> minAda - , txOutDatumHash = Just $ toDatumHash proposalOutputDatum - } - in TxInfo - { txInfoInputs = [TxInInfo proposalRef proposalInput] - , txInfoOutputs = [proposalOutput] - , txInfoFee = Value.singleton "" "" 2 - , txInfoMint = mempty - , txInfoDCert = [] - , txInfoWdrl = [] - , txInfoValidRange = timeRange - , txInfoSignatories = [signer] - , txInfoData = datumPair <$> [proposalInputDatum, proposalOutputDatum] - , txInfoId = "95ba4015e30aef16a3461ea97a779f814aeea6b8009d99a94add4b8293be737a" - } + + builder :: BaseBuilder + builder = + mconcat + [ txId "95ba4015e30aef16a3461ea97a779f814aeea6b8009d99a94add4b8293be737a" + , signedWith signer + , timeRange validTime + , input $ + script proposalValidatorHash + . withValue pst + . withDatum proposalInputDatum + . withTxId (txOutRefId proposalRef) + , output $ + script proposalValidatorHash + . withValue (pst <> minAda) + . withDatum proposalOutputDatum + ] + in either error id $ buildTxInfo builder {- | Create a valid 'TxInfo' that advances a proposal, given the parameters. Note that 'TransitionParameters.initialProposalStatus' should not be 'Finished'. diff --git a/agora-specs/Sample/Shared.hs b/agora-specs/Sample/Shared.hs index dda6ae0..c1197e3 100644 --- a/agora-specs/Sample/Shared.hs +++ b/agora-specs/Sample/Shared.hs @@ -48,15 +48,14 @@ module Sample.Shared ( gatTn, gatCs, mockTrEffect, + mockTrEffectHash, trCredential, wrongEffHash, ) where -import Agora.AuthorityToken +import Agora.AuthorityToken (AuthorityToken) import Agora.Effect.NoOp (noOpValidator) -import Agora.Governor ( - Governor (Governor), - ) +import Agora.Governor (Governor (Governor)) import Agora.Governor.Scripts ( authorityTokenFromGovernor, authorityTokenSymbolFromGovernor, @@ -72,10 +71,7 @@ import Agora.Governor.Scripts ( stakeSTSymbolFromGovernor, stakeValidatorHashFromGovernor, ) -import Agora.Proposal ( - Proposal (..), - ProposalThresholds (..), - ) +import Agora.Proposal (Proposal (..), ProposalThresholds (..)) import Agora.Proposal.Time ( MaxTimeRangeWidth (..), ProposalStartingTime (ProposalStartingTime), @@ -107,14 +103,13 @@ import PlutusLedgerApi.V1 ( Value, ) import PlutusLedgerApi.V1.Address (scriptHashAddress) -import PlutusLedgerApi.V1.Contexts ( - TxOut (..), - ) +import PlutusLedgerApi.V1.Contexts (TxOut (..)) import PlutusLedgerApi.V1.Scripts (Validator, ValidatorHash (..)) import PlutusLedgerApi.V1.Value (AssetClass, TokenName) -import PlutusLedgerApi.V1.Value qualified as Value - --------------------------------------------------------------------------------- +import PlutusLedgerApi.V1.Value qualified as Value ( + assetClass, + singleton, + ) stake :: Stake stake = stakeFromGovernor governor @@ -258,6 +253,10 @@ gatTn = validatorHashToTokenName $ validatorHash mockTrEffect mockTrEffect :: Validator mockTrEffect = mkValidator $ noOpValidator gatCs +-- | Mock treasury effect validator hash +mockTrEffectHash :: ValidatorHash +mockTrEffectHash = validatorHash mockTrEffect + {- | A SHA-256 hash which (in all certainty) should not match the hash of the dummy effect script. -} diff --git a/agora-specs/Sample/Stake.hs b/agora-specs/Sample/Stake.hs index bc153d7..51611e6 100644 --- a/agora-specs/Sample/Stake.hs +++ b/agora-specs/Sample/Stake.hs @@ -20,39 +20,50 @@ module Sample.Stake ( DepositWithdrawExample (..), ) where --------------------------------------------------------------------------------- -import Plutarch.Api.V1 ( - mkValidator, - validatorHash, +import Agora.SafeMoney (GTTag) +import Agora.Stake ( + Stake (gtClassRef), + StakeDatum (StakeDatum, stakedAmount), + ) +import Agora.Stake.Scripts (stakeValidator) +import Data.Tagged (Tagged, untag) +import Plutarch.Api.V1 (mkValidator, validatorHash) +import Plutarch.Context ( + MintingBuilder, + SpendingBuilder, + buildMinting, + buildSpending, + input, + mint, + output, + script, + signedWith, + txId, + withDatum, + withSpending, + withTxId, + withValue, ) import PlutusLedgerApi.V1 ( - Address (Address), - Credential (ScriptCredential), Datum (Datum), - DatumHash (DatumHash), ScriptContext (..), - ScriptPurpose (..), + ScriptPurpose (Minting), ToData (toBuiltinData), - TxInInfo (TxInInfo), - TxInfo (..), - TxOut (txOutAddress, txOutDatumHash, txOutValue), + TokenName (TokenName), + TxInfo (txInfoData, txInfoSignatories), ValidatorHash (ValidatorHash), ) -import PlutusLedgerApi.V1.Contexts (TxOut (TxOut), TxOutRef (TxOutRef)) -import PlutusLedgerApi.V1.Interval qualified as Interval -import PlutusLedgerApi.V1.Value (TokenName (TokenName)) -import PlutusLedgerApi.V1.Value qualified as Value - --------------------------------------------------------------------------------- - -import Agora.SafeMoney (GTTag) -import Agora.Stake -import Agora.Stake.Scripts (stakeValidator) -import Data.Tagged (Tagged (..), untag) -import Sample.Shared -import Test.Util (datumPair, toDatumHash) - --------------------------------------------------------------------------------- +import PlutusLedgerApi.V1.Value qualified as Value ( + assetClassValue, + singleton, + ) +import Sample.Shared ( + signer, + stake, + stakeAssetClass, + stakeSymbol, + stakeValidatorHash, + ) -- | 'TokenName' that represents the hash of the 'Stake' validator. validatorHashTN :: TokenName @@ -62,30 +73,21 @@ validatorHashTN = let ValidatorHash vh = validatorHash (mkValidator $ stakeValid stakeCreation :: ScriptContext stakeCreation = let st = Value.assetClassValue stakeAssetClass 1 -- Stake ST - datum :: Datum - datum = Datum (toBuiltinData $ StakeDatum 424242424242 signer []) - in ScriptContext - { scriptContextTxInfo = - TxInfo - { txInfoInputs = [] - , txInfoOutputs = - [ TxOut - { txOutAddress = Address (ScriptCredential stakeValidatorHash) Nothing - , txOutValue = st <> Value.singleton "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" "LQ" 424242424242 - , txOutDatumHash = Just (DatumHash "") - } - ] - , txInfoFee = Value.singleton "" "" 2 - , txInfoMint = st - , txInfoDCert = [] - , txInfoWdrl = [] - , txInfoValidRange = Interval.always - , txInfoSignatories = [signer] - , txInfoData = [("", datum)] - , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" - } - , scriptContextPurpose = Minting stakeSymbol - } + datum :: StakeDatum + datum = StakeDatum 424242424242 signer [] + + builder :: MintingBuilder + builder = + mconcat + [ txId "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" + , signedWith signer + , mint st + , output $ + script stakeValidatorHash + . withValue (st <> Value.singleton "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" "LQ" 424242424242) + . withDatum datum + ] + in either error id $ buildMinting builder -- | This ScriptContext should fail because the datum has too much GT. stakeCreationWrongDatum :: ScriptContext @@ -127,36 +129,25 @@ stakeDepositWithdraw config = stakeAfter :: StakeDatum stakeAfter = stakeBefore {stakedAmount = stakeBefore.stakedAmount + config.delta} - in ScriptContext - { scriptContextTxInfo = - TxInfo - { txInfoInputs = - [ TxInInfo - (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) - TxOut - { txOutAddress = Address (ScriptCredential stakeValidatorHash) Nothing - , txOutValue = - st - <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeBefore.stakedAmount) - , txOutDatumHash = Just (toDatumHash stakeAfter) - } - ] - , txInfoOutputs = - [ TxOut - { txOutAddress = Address (ScriptCredential stakeValidatorHash) Nothing - , txOutValue = - st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount) - , txOutDatumHash = Just (toDatumHash stakeAfter) - } - ] - , txInfoFee = Value.singleton "" "" 2 - , txInfoMint = st - , txInfoDCert = [] - , txInfoWdrl = [] - , txInfoValidRange = Interval.always - , txInfoSignatories = [signer] - , txInfoData = [datumPair stakeAfter] - , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" - } - , scriptContextPurpose = Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) - } + + builder :: SpendingBuilder + builder = + mconcat + [ txId "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" + , signedWith signer + , mint st + , input $ + script stakeValidatorHash + . withValue (st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeBefore.stakedAmount)) + . withDatum stakeAfter + . withTxId "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" + , output $ + script stakeValidatorHash + . withValue (st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount)) + . withDatum stakeAfter + , withSpending $ + script stakeValidatorHash + . withValue (st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeBefore.stakedAmount)) + . withDatum stakeAfter + ] + in either error id $ buildSpending builder diff --git a/agora-specs/Sample/Treasury.hs b/agora-specs/Sample/Treasury.hs index 66514b4..39d0303 100644 --- a/agora-specs/Sample/Treasury.hs +++ b/agora-specs/Sample/Treasury.hs @@ -17,147 +17,111 @@ module Sample.Treasury ( trCtxGATNameNotAddress, ) where -import Plutarch.Api.V1 (validatorHash) +import Plutarch.Context ( + MintingBuilder, + UTXO, + buildMinting, + credential, + input, + mint, + output, + script, + signedWith, + txId, + withTxId, + withValue, + ) import PlutusLedgerApi.V1 ( - BuiltinByteString, Credential (PubKeyCredential), PubKeyHash (PubKeyHash), ) import PlutusLedgerApi.V1.Address (Address (..)) import PlutusLedgerApi.V1.Contexts ( ScriptContext (..), - ScriptPurpose (Minting), TxInInfo (..), - TxInfo (..), TxOut (..), TxOutRef (..), ) -import PlutusLedgerApi.V1.Credential (Credential (ScriptCredential)) -import PlutusLedgerApi.V1.Interval qualified as Interval -import PlutusLedgerApi.V1.Scripts ( - ValidatorHash (ValidatorHash), - ) -import PlutusLedgerApi.V1.Value qualified as Value +import PlutusLedgerApi.V1.Scripts (ValidatorHash (ValidatorHash)) +import PlutusLedgerApi.V1.Value qualified as Value (singleton) import Sample.Shared ( gatCs, gatTn, minAda, - mockTrEffect, + mockTrEffectHash, signer, - treasuryOut, + trCredential, wrongEffHash, ) -import Test.Util (datumPair) + +baseCtxBuilder :: MintingBuilder +baseCtxBuilder = + let treasury :: UTXO -> UTXO + treasury = + credential trCredential + . withValue minAda + . withTxId "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049" + in mconcat + [ txId "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049" + , signedWith signer + , mint (Value.singleton gatCs gatTn (-1)) + , input treasury + , output treasury + ] {- | A `ScriptContext` that should be compatible with treasury transactions. -} validCtx :: ScriptContext validCtx = - ScriptContext - { scriptContextPurpose = Minting gatCs - , scriptContextTxInfo = - TxInfo - { txInfoInputs = - [ treasuryIn - , effectIn - ] - , txInfoOutputs = - [ treasuryOut - ] - , -- Ensure sufficient ADA for transaction costs. - txInfoFee = Value.singleton "" "" 2 -- 2 ADA. - , -- Burn the GAT. - txInfoMint = Value.singleton gatCs gatTn (-1) - , txInfoDCert = [] - , txInfoWdrl = [] - , txInfoValidRange = Interval.always - , txInfoSignatories = [signer] - , txInfoData = - [ datumPair treasuryIn - , datumPair treasuryOut - , datumPair effectIn - ] - , txInfoId = - "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049" - } - } - where - treasuryIn = - TxInInfo - { txInInfoOutRef = treasuryRef - , txInInfoResolved = treasuryOut - } - effectIn = - TxInInfo - { txInInfoOutRef = effectRef - , txInInfoResolved = - TxOut - { txOutAddress = - Address (ScriptCredential $ validatorHash mockTrEffect) Nothing - , txOutValue = - mconcat - [ Value.singleton gatCs gatTn 1 - , minAda - ] - , txOutDatumHash = Nothing - } - } + let builder :: MintingBuilder + builder = + mconcat + [ baseCtxBuilder + , input $ + script mockTrEffectHash + . withValue (Value.singleton gatCs gatTn 1 <> minAda) + . withTxId "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3" + ] + in either error id $ buildMinting builder --- | Reference to treasury output. treasuryRef :: TxOutRef treasuryRef = TxOutRef "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049" 1 --- | Reference to dummy effect output. -effectRef :: TxOutRef -effectRef = - TxOutRef - "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3" - 0 - --- | Input representing a user wallet with a valid GAT. +{- | Input representing a user wallet with a valid GAT. + TODO: Resturcture this part of test. +-} walletIn :: TxInInfo walletIn = - TxInInfo - { txInInfoOutRef = - TxOutRef - "cf4a8b33dd8e4493187e3339ecc3802d0cc000c947fb5559b7614153947d4e83" - 0 - , txInInfoResolved = - TxOut - { txOutDatumHash = Nothing - , txOutValue = Value.singleton gatCs gatTn 1 - , txOutAddress = - Address - (PubKeyCredential $ PubKeyHash addressBs) - Nothing - } - } - -addressBs :: BuiltinByteString -(ValidatorHash addressBs) = validatorHash mockTrEffect + let (ValidatorHash addressBs) = mockTrEffectHash + in TxInInfo + { txInInfoOutRef = + TxOutRef + "cf4a8b33dd8e4493187e3339ecc3802d0cc000c947fb5559b7614153947d4e83" + 0 + , txInInfoResolved = + TxOut + { txOutDatumHash = Nothing + , txOutValue = Value.singleton gatCs gatTn 1 + , txOutAddress = + Address + (PubKeyCredential $ PubKeyHash addressBs) + Nothing + } + } trCtxGATNameNotAddress :: ScriptContext trCtxGATNameNotAddress = - let txInfo = validCtx.scriptContextTxInfo - inputs = txInfo.txInfoInputs - effectIn = inputs !! 1 - invalidEff = - effectIn - { txInInfoResolved = - effectIn.txInInfoResolved - { txOutAddress = Address (ScriptCredential wrongEffHash) Nothing - } - } - in validCtx - { scriptContextTxInfo = - txInfo - { txInfoInputs = - [ head inputs - , invalidEff - ] - } - } + let builder :: MintingBuilder + builder = + mconcat + [ baseCtxBuilder + , input $ + script wrongEffHash + . withValue (Value.singleton gatCs gatTn 1 <> minAda) + . withTxId "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3" + ] + in either error id $ buildMinting builder diff --git a/agora-specs/Spec/AuthorityToken.hs b/agora-specs/Spec/AuthorityToken.hs index 380fb33..46b7423 100644 --- a/agora-specs/Spec/AuthorityToken.hs +++ b/agora-specs/Spec/AuthorityToken.hs @@ -9,14 +9,8 @@ Tests for Authority token functions -} module Spec.AuthorityToken (specs) where --------------------------------------------------------------------------------- - import Agora.AuthorityToken (singleAuthorityTokenBurned) -import Plutarch -import Prelude - --------------------------------------------------------------------------------- - +import Plutarch (ClosedTerm, POpaque, compile, perror, popaque) import PlutusLedgerApi.V1 ( Address (Address), Credential (PubKeyCredential, ScriptCredential), @@ -29,15 +23,27 @@ import PlutusLedgerApi.V1 ( ValidatorHash (ValidatorHash), Value, ) -import PlutusLedgerApi.V1.Interval qualified as Interval -import PlutusLedgerApi.V1.Value qualified as Value -import PlutusTx.AssocMap qualified as AssocMap +import PlutusLedgerApi.V1.Interval qualified as Interval (always) +import PlutusLedgerApi.V1.Value qualified as Value ( + Value (Value), + singleton, + ) +import PlutusTx.AssocMap qualified as AssocMap (empty) import Test.Specification ( SpecificationTree, group, scriptFails, scriptSucceeds, ) +import Prelude ( + Functor (fmap), + Maybe (Nothing), + PBool, + Semigroup ((<>)), + pconstant, + pconstantData, + pif, + ) currencySymbol :: CurrencySymbol currencySymbol = "deadbeef" diff --git a/agora-specs/Spec/Governor.hs b/agora-specs/Spec/Governor.hs index ca5f5d5..b488928 100644 --- a/agora-specs/Spec/Governor.hs +++ b/agora-specs/Spec/Governor.hs @@ -26,8 +26,6 @@ import Test.Specification ( validatorSucceedsWith, ) --------------------------------------------------------------------------------- - -- | The SpecificationTree exported by this module. specs :: [SpecificationTree] specs = diff --git a/agora-specs/Spec/Proposal.hs b/agora-specs/Spec/Proposal.hs index f4beee5..fa1fd1c 100644 --- a/agora-specs/Spec/Proposal.hs +++ b/agora-specs/Spec/Proposal.hs @@ -9,8 +9,6 @@ Tests for Proposal policy and validator -} module Spec.Proposal (specs) where --------------------------------------------------------------------------------- - import Agora.Proposal ( Proposal (..), ProposalDatum (..), @@ -28,11 +26,10 @@ import Agora.Proposal ( thresholds, votes, ) -import Agora.Proposal.Scripts ( - proposalPolicy, - proposalValidator, +import Agora.Proposal.Scripts (proposalPolicy, proposalValidator) +import Agora.Proposal.Time ( + ProposalStartingTime (ProposalStartingTime), ) -import Agora.Proposal.Time (ProposalStartingTime (ProposalStartingTime)) import Agora.Stake ( ProposalLock (ProposalLock), StakeDatum (StakeDatum), @@ -42,10 +39,27 @@ import Agora.Stake.Scripts (stakeValidator) import Data.Default.Class (Default (def)) import Data.Tagged (Tagged (Tagged), untag) import PlutusLedgerApi.V1 (ScriptContext (..), ScriptPurpose (..)) -import PlutusTx.AssocMap qualified as AssocMap -import Sample.Proposal qualified as Proposal +import PlutusTx.AssocMap qualified as AssocMap (empty, fromList) +import Sample.Proposal qualified as Proposal ( + TransitionParameters ( + TransitionParameters, + initialProposalStatus, + proposalStartingTime + ), + VotingParameters (VotingParameters, voteCount, voteFor), + advanceFinishedPropsoal, + advanceProposalFailureTimeout, + advanceProposalInsufficientVotes, + advanceProposalSuccess, + advancePropsoalWithsStake, + cosignProposal, + proposalCreation, + proposalRef, + stakeRef, + voteOnProposal, + ) import Sample.Shared (signer, signer2) -import Sample.Shared qualified as Shared +import Sample.Shared qualified as Shared (proposal, stake) import Test.Specification ( SpecificationTree, group, @@ -54,8 +68,6 @@ import Test.Specification ( validatorSucceedsWith, ) --------------------------------------------------------------------------------- - -- | Stake specs. specs :: [SpecificationTree] specs = diff --git a/agora-specs/Spec/Stake.hs b/agora-specs/Spec/Stake.hs index 169ad3f..e8f0c78 100644 --- a/agora-specs/Spec/Stake.hs +++ b/agora-specs/Spec/Stake.hs @@ -9,19 +9,27 @@ Tests for Stake policy and validator -} module Spec.Stake (specs) where --------------------------------------------------------------------------------- - -import Prelude - --------------------------------------------------------------------------------- - -import Agora.Stake (Stake (..), StakeDatum (StakeDatum), StakeRedeemer (DepositWithdraw)) +import Agora.Stake ( + Stake (..), + StakeDatum (StakeDatum), + StakeRedeemer (DepositWithdraw), + ) import Agora.Stake.Scripts (stakePolicy, stakeValidator) - --------------------------------------------------------------------------------- - -import Sample.Stake (DepositWithdrawExample (DepositWithdrawExample, delta, startAmount), signer) -import Sample.Stake qualified as Stake +import Sample.Stake ( + DepositWithdrawExample ( + DepositWithdrawExample, + delta, + startAmount + ), + signer, + ) +import Sample.Stake qualified as Stake ( + stake, + stakeCreation, + stakeCreationUnsigned, + stakeCreationWrongDatum, + stakeDepositWithdraw, + ) import Test.Specification ( SpecificationTree, group, @@ -31,8 +39,7 @@ import Test.Specification ( validatorSucceedsWith, ) import Test.Util (toDatum) - --------------------------------------------------------------------------------- +import Prelude (Num (negate), ($)) -- | The SpecificationTree exported by this module. specs :: [SpecificationTree] diff --git a/agora-specs/Spec/Treasury.hs b/agora-specs/Spec/Treasury.hs index 4327f25..6d29bc6 100644 --- a/agora-specs/Spec/Treasury.hs +++ b/agora-specs/Spec/Treasury.hs @@ -25,9 +25,7 @@ import Agora.Treasury ( TreasuryRedeemer (SpendTreasuryGAT), treasuryValidator, ) -import PlutusLedgerApi.V1 ( - DCert (DCertDelegRegKey), - ) +import PlutusLedgerApi.V1 (DCert (DCertDelegRegKey)) import PlutusLedgerApi.V1.Contexts ( ScriptContext (scriptContextPurpose, scriptContextTxInfo), ScriptPurpose (Certifying, Rewarding, Spending), @@ -36,10 +34,8 @@ import PlutusLedgerApi.V1.Contexts ( import PlutusLedgerApi.V1.Credential ( StakingCredential (StakingHash), ) -import PlutusLedgerApi.V1.Value qualified as Value -import Sample.Shared ( - trCredential, - ) +import PlutusLedgerApi.V1.Value qualified as Value (singleton) +import Sample.Shared (trCredential) import Sample.Treasury ( gatCs, gatTn, diff --git a/agora-specs/Spec/Utils.hs b/agora-specs/Spec/Utils.hs index 97e1972..16e62d9 100644 --- a/agora-specs/Spec/Utils.hs +++ b/agora-specs/Spec/Utils.hs @@ -9,7 +9,5 @@ module Spec.Utils (tests) where import Test.Tasty (TestTree) --------------------------------------------------------------------------------- - tests :: [TestTree] tests = [] diff --git a/bench.csv b/bench.csv index b3c1eff..08cfa2c 100644 --- a/bench.csv +++ b/bench.csv @@ -4,26 +4,26 @@ Agora/Effects/Treasury Withdrawal Effect/effect/Simple with multiple treasuries Agora/Effects/Treasury Withdrawal Effect/effect/Mixed Assets,408085321,966048,3383 Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/governor validator should pass,83758582,229228,7665 Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/effect validator should pass,97345575,266935,3358 -Agora/Stake/policy/stakeCreation,43114609,124549,2094 -Agora/Stake/validator/stakeDepositWithdraw deposit,171823342,464745,4069 -Agora/Stake/validator/stakeDepositWithdraw withdraw,171823342,464745,4061 -Agora/Proposal/policy/proposalCreation,23140177,69194,1525 -Agora/Proposal/validator/cosignature/proposal,147258436,403167,5646 -Agora/Proposal/validator/cosignature/stake,117270039,287783,4606 -Agora/Proposal/validator/voting/proposal,154824944,415642,5654 -Agora/Proposal/validator/voting/stake,99545453,256941,4659 -Agora/Proposal/validator/advancing/successfully advance to next state/Draft -> VotringReady,94701799,249495,5031 -Agora/Proposal/validator/advancing/successfully advance to next state/VotingReady -> Locked,93858377,247992,5034 -Agora/Proposal/validator/advancing/successfully advance to next state/Locked -> Finished,95554844,251598,5034 -Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/Draft -> Finished,93571998,246765,5033 -Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/VotingReady -> Finished,92163087,244060,5034 -Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/Locked -> Finished,93294065,246464,5034 +Agora/Stake/policy/stakeCreation,43114795,124549,2156 +Agora/Stake/validator/stakeDepositWithdraw deposit,171823342,464745,4144 +Agora/Stake/validator/stakeDepositWithdraw withdraw,171823342,464745,4132 +Agora/Proposal/policy/proposalCreation,23140177,69194,1517 +Agora/Proposal/validator/cosignature/proposal,145357978,397941,5721 +Agora/Proposal/validator/cosignature/stake,115369581,282557,4681 +Agora/Proposal/validator/voting/proposal,154824944,415642,5650 +Agora/Proposal/validator/voting/stake,99545453,256941,4655 +Agora/Proposal/validator/advancing/successfully advance to next state/Draft -> VotringReady,94701799,249495,5027 +Agora/Proposal/validator/advancing/successfully advance to next state/VotingReady -> Locked,93858377,247992,5030 +Agora/Proposal/validator/advancing/successfully advance to next state/Locked -> Finished,95554844,251598,5030 +Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/Draft -> Finished,93571998,246765,5029 +Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/VotingReady -> Finished,92163087,244060,5030 +Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/Locked -> Finished,93294065,246464,5030 Agora/AuthorityToken/singleAuthorityTokenBurned/Correct simple,21017788,55883,806 Agora/AuthorityToken/singleAuthorityTokenBurned/Correct many inputs,33204186,88241,900 -Agora/Treasury/Validator/Positive/Allows for effect changes,29938856,79744,1841 +Agora/Treasury/Validator/Positive/Allows for effect changes,29938856,79744,1390 Agora/AuthorityToken/singleAuthorityTokenBurned/Correct simple,21017788,55883,806 Agora/AuthorityToken/singleAuthorityTokenBurned/Correct many inputs,33204186,88241,900 -Agora/Governor/policy/GST minting,43087287,120125,1833 +Agora/Governor/policy/GST minting,43087287,120125,1829 Agora/Governor/validator/proposal creation,261928725,689487,8181 -Agora/Governor/validator/GATs minting,351749811,938560,8302 -Agora/Governor/validator/mutate governor state,81730538,223502,7718 +Agora/Governor/validator/GATs minting,349849353,933334,8302 +Agora/Governor/validator/mutate governor state,84905433,234687,7766 diff --git a/flake.lock b/flake.lock index bc60c44..d33722c 100644 --- a/flake.lock +++ b/flake.lock @@ -7459,11 +7459,11 @@ }, "nixpkgs-2111_5": { "locked": { - "lastModified": 1654115789, - "narHash": "sha256-k9Qr8dLrmgEn+xIVbneJdQgCYG8FbbqOrTVaExUrLFI=", + "lastModified": 1655355951, + "narHash": "sha256-uroxR5FTZWEqpakNtwiZBABj6SpX+TOuUZ4G0PtSy94=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "bce6d15455f8c15c9ef511368947e7ef789c5316", + "rev": "b882c61856522467f866f3d6321e1aa5b0b393b5", "type": "github" }, "original": { @@ -9286,16 +9286,16 @@ "plutarch": "plutarch_4" }, "locked": { - "lastModified": 1654950895, - "narHash": "sha256-HfTdkaPkyGDUiw+E8tUb/CHRzumuF+sDNcpuNRusVqM=", + "lastModified": 1654627196, + "narHash": "sha256-OohlZsi0/j55Sq6U/hA7gl6SQyTHIGT9Pg+R61veCJw=", "owner": "Liqwid-Labs", "repo": "plutarch-context-builder", - "rev": "ae73a43ecfc51475376d2f8a9928cf27f7f10b4c", + "rev": "b6c6e50c60c87f2b63d8027ff66728fabbb569fe", "type": "github" }, "original": { "owner": "Liqwid-Labs", - "ref": "main", + "ref": "staging", "repo": "plutarch-context-builder", "type": "github" } @@ -9418,11 +9418,11 @@ "plutarch": "plutarch_6" }, "locked": { - "lastModified": 1654293728, - "narHash": "sha256-6Pd410I03CetLM4YYrJmMldOYDyqGPATlmorhKKWU0Q=", + "lastModified": 1655307888, + "narHash": "sha256-hv9tzB3IGvga6/SBDnk16S3Sfp03tvtkWd8COW0It30=", "owner": "liqwid-labs", "repo": "plutarch-quickcheck", - "rev": "cd7df08176e0ee5111980ead903764979d920147", + "rev": "541c57675eefc2ecd0fb6c6477d0b7fb8900b5fc", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index 5c5c29d..2573c31 100644 --- a/flake.nix +++ b/flake.nix @@ -27,7 +27,7 @@ inputs.plutarch-quickcheck.url = "github:liqwid-labs/plutarch-quickcheck?ref=staging"; inputs.plutarch-context-builder.url = - "github:Liqwid-Labs/plutarch-context-builder?ref=main"; + "github:Liqwid-Labs/plutarch-context-builder?ref=staging"; outputs = inputs@{ self, nixpkgs, nixpkgs-latest, haskell-nix, plutarch, ... }: let From 0bc5706770497f2c7b5fd7f7a81534310e69d241 Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Thu, 16 Jun 2022 13:07:45 -0500 Subject: [PATCH 2/3] `governorDatumValid` property --- agora-specs/Property/Governor.hs | 121 +++++++++++++++++++++++++++++++ agora-specs/Property/MultiSig.hs | 2 +- agora-test/Spec.hs | 2 + agora.cabal | 1 + 4 files changed, 125 insertions(+), 1 deletion(-) create mode 100644 agora-specs/Property/Governor.hs diff --git a/agora-specs/Property/Governor.hs b/agora-specs/Property/Governor.hs new file mode 100644 index 0000000..bf200b0 --- /dev/null +++ b/agora-specs/Property/Governor.hs @@ -0,0 +1,121 @@ +{- | +Module : Property.Governor +Maintainer : seungheon.ooh@gmail.com +Description: Property tests for 'Governor' related functions. + +Property model and tests for 'Governor' related functions +-} +module Property.Governor (props) where + +import Agora.Governor ( + GovernorDatum (GovernorDatum, proposalThresholds), + governorDatumValid, + ) +import Agora.Proposal ( + ProposalId (ProposalId), + ProposalThresholds (ProposalThresholds), + ) +import Agora.Proposal.Time ( + MaxTimeRangeWidth (MaxTimeRangeWidth), + ProposalTimingConfig (ProposalTimingConfig), + ) +import Data.Tagged (Tagged (Tagged), untag) +import Data.Universe (Finite (..), Universe (..)) +import Test.Tasty (TestTree) +import Test.Tasty.Plutarch.Property (classifiedPropertyNative) +import Test.Tasty.QuickCheck ( + Gen, + Property, + chooseInteger, + testProperty, + ) + +data GovernorDatumCases + = ExecuteLE0 + | CreateLE0 + | VoteLE0 + | CreateLEVote + | ExecuteLVote + | Correct + deriving stock (Eq, Show) + +instance Universe GovernorDatumCases where + universe = + [ ExecuteLE0 + , CreateLE0 + , VoteLE0 + , CreateLEVote + , ExecuteLVote + , Correct + ] + +instance Finite GovernorDatumCases where + universeF = universe + cardinality = Tagged 6 + +{- | Property that checks `governorDatumValid`. + `governorDatumValid` determines if given governor datum is valid or not. This property + ensures `governorDatumValid` is checking the datum correctly and ruling out improper datum. +-} +governorDatumValidProperty :: Property +governorDatumValidProperty = + classifiedPropertyNative gen (const []) expected classifier governorDatumValid + where + classifier :: GovernorDatum -> GovernorDatumCases + classifier (proposalThresholds -> ProposalThresholds e c v) + | e < 0 = ExecuteLE0 + | c < 0 = CreateLE0 + | v < 0 = VoteLE0 + | c > v = CreateLEVote + | v >= e = ExecuteLVote + | otherwise = Correct + + expected :: GovernorDatum -> Maybe Bool + expected c = Just $ classifier c == Correct + + gen :: GovernorDatumCases -> Gen GovernorDatum + gen c = do + thres <- genProposalThresholds c + + let timing = ProposalTimingConfig 0 0 0 0 + return $ GovernorDatum thres (ProposalId 0) timing (MaxTimeRangeWidth 0) + where + taggedInteger p = Tagged <$> chooseInteger p + genProposalThresholds :: GovernorDatumCases -> Gen ProposalThresholds + genProposalThresholds c = do + let validGT = taggedInteger (0, 1000000000) + execute <- validGT + create <- validGT + vote <- validGT + le0 <- taggedInteger (-1000, -1) + + case c of + ExecuteLE0 -> + -- execute < 0 + return $ ProposalThresholds le0 create vote + CreateLE0 -> + -- c < 0 + return $ ProposalThresholds execute le0 vote + VoteLE0 -> + -- vote < 0 + return $ ProposalThresholds execute create le0 + CreateLEVote -> do + -- c > vote + nv <- taggedInteger (0, untag create - 1) + ne <- taggedInteger (untag nv + 1, 1000000000) + return $ ProposalThresholds ne create nv + ExecuteLVote -> do + -- vote >= execute + ne <- taggedInteger (0, untag vote) + nc <- taggedInteger (0, untag vote) + return $ ProposalThresholds ne nc vote + Correct -> do + -- c <= vote < execute + nv <- taggedInteger (0, untag execute - 1) + nc <- taggedInteger (0, untag nv) + return $ ProposalThresholds execute nc nv + +props :: [TestTree] +props = + [ testProperty "governorDatumValid" governorDatumValidProperty + ] diff --git a/agora-specs/Property/MultiSig.hs b/agora-specs/Property/MultiSig.hs index 1000e03..caa35cc 100644 --- a/agora-specs/Property/MultiSig.hs +++ b/agora-specs/Property/MultiSig.hs @@ -12,11 +12,11 @@ import Agora.MultiSig ( PMultiSig, pvalidatedByMultisig, ) -import Plutarch.Extra.TermCont (pletC) import Data.Tagged (Tagged (Tagged)) import Data.Universe (Finite (..), Universe (..)) import Plutarch.Api.V1 (PScriptContext) import Plutarch.Context +import Plutarch.Extra.TermCont (pletC) import PlutusLedgerApi.V1 ( ScriptContext (..), ScriptPurpose (..), diff --git a/agora-test/Spec.hs b/agora-test/Spec.hs index 4e8399a..e11a5e1 100644 --- a/agora-test/Spec.hs +++ b/agora-test/Spec.hs @@ -7,6 +7,7 @@ import Test.Tasty (defaultMain, testGroup) -------------------------------------------------------------------------------- +import Property.Governor qualified as Governer import Property.MultiSig qualified as MultiSig import Spec.AuthorityToken qualified as AuthorityToken import Spec.Effect.GovernorMutation qualified as GovernorMutation @@ -37,6 +38,7 @@ main = do , toTestTree $ group "Treasury tests" Treasury.specs , toTestTree $ group "AuthorityToken tests" AuthorityToken.specs , toTestTree $ group "Governor tests" Governor.specs + , testGroup "Governor properties" Governer.props , testGroup "Utility tests" Utils.tests diff --git a/agora.cabal b/agora.cabal index a3c6d21..7cf71c2 100644 --- a/agora.cabal +++ b/agora.cabal @@ -176,6 +176,7 @@ library agora-specs import: lang, deps, test-deps exposed-modules: Property.Generator + Property.Governor Property.MultiSig Sample.Effect.GovernorMutation Sample.Effect.TreasuryWithdrawal From e386cc5e755a889cc1979c86d3fcbc550e375a27 Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Fri, 17 Jun 2022 14:29:00 -0500 Subject: [PATCH 3/3] Remove `either error id` pattern in Samples --- agora-specs/Property/MultiSig.hs | 5 +++-- agora-specs/Sample/Governor.hs | 12 ++++++------ agora-specs/Sample/Proposal.hs | 12 ++++++------ agora-specs/Sample/Stake.hs | 8 ++++---- agora-specs/Sample/Treasury.hs | 6 +++--- flake.lock | 18 +++++++++--------- 6 files changed, 31 insertions(+), 30 deletions(-) diff --git a/agora-specs/Property/MultiSig.hs b/agora-specs/Property/MultiSig.hs index caa35cc..3d0d98c 100644 --- a/agora-specs/Property/MultiSig.hs +++ b/agora-specs/Property/MultiSig.hs @@ -67,8 +67,9 @@ genMultiSigProp prop = do MeetsMinSigs -> chooseInt (minSig, length pkhs) DoesNotMeetMinSigs -> chooseInt (0, minSig - 1) - let builder = mconcat $ signedWith <$> take n pkhs <> othersigners - txinfo = either error id $ buildTxInfo builder + let builder :: BaseBuilder + builder = mconcat $ signedWith <$> take n pkhs <> othersigners + txinfo = buildTxInfoUnsafe builder pure (ms, ScriptContext txinfo (Spending (TxOutRef "" 0))) -- | Classify model into propositions. diff --git a/agora-specs/Sample/Governor.hs b/agora-specs/Sample/Governor.hs index cd6d688..1641640 100644 --- a/agora-specs/Sample/Governor.hs +++ b/agora-specs/Sample/Governor.hs @@ -34,8 +34,8 @@ import Plutarch.Api.V1 (mkValidator, validatorHash) import Plutarch.Context ( MintingBuilder, SpendingBuilder, - buildMinting, - buildSpending, + buildMintingUnsafe, + buildSpendingUnsafe, fee, input, mint, @@ -139,7 +139,7 @@ mintGST = . withValue (gst <> minAda) . withDatum governorOutputDatum ] - in either error id $ buildMinting builder + in buildMintingUnsafe builder {- | A valid script context to create a proposal. @@ -259,7 +259,7 @@ createProposal = . withValue gst . withDatum governorInputDatum ] - in either error id $ buildSpending builder + in buildSpendingUnsafe builder {- This script context should be a valid transaction for minting authority for the effect scrips. @@ -378,7 +378,7 @@ mintGATs = . withValue gst . withDatum governorInputDatum ] - in either error id $ buildSpending builder + in buildSpendingUnsafe builder {- | A valid script context for changing the state datum of the governor. @@ -458,4 +458,4 @@ mutateState = . withValue gst . withDatum governorInputDatum ] - in either error id $ buildSpending builder + in buildSpendingUnsafe builder diff --git a/agora-specs/Sample/Proposal.hs b/agora-specs/Sample/Proposal.hs index 7955228..0ec892d 100644 --- a/agora-specs/Sample/Proposal.hs +++ b/agora-specs/Sample/Proposal.hs @@ -46,8 +46,8 @@ import Data.Tagged (Tagged (..), untag) import Plutarch.Context ( BaseBuilder, MintingBuilder, - buildMinting, - buildTxInfo, + buildMintingUnsafe, + buildTxInfoUnsafe, input, mint, output, @@ -162,7 +162,7 @@ proposalCreation = ) . withDatum govAfter ] - in either error id $ buildMinting builder + in buildMintingUnsafe builder proposalRef :: TxOutRef proposalRef = TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1 @@ -236,7 +236,7 @@ cosignProposal newSigners = ) . withDatum stakeDatum ] - in either error id $ buildTxInfo builder + in buildTxInfoUnsafe builder -------------------------------------------------------------------------------- @@ -377,7 +377,7 @@ voteOnProposal params = ) . withDatum stakeOutputDatum ] - in either error id $ buildTxInfo builder + in buildTxInfoUnsafe builder -------------------------------------------------------------------------------- @@ -442,7 +442,7 @@ mkTransitionTxInfo from to effects votes startingTime validTime = . withValue (pst <> minAda) . withDatum proposalOutputDatum ] - in either error id $ buildTxInfo builder + in buildTxInfoUnsafe builder {- | Create a valid 'TxInfo' that advances a proposal, given the parameters. Note that 'TransitionParameters.initialProposalStatus' should not be 'Finished'. diff --git a/agora-specs/Sample/Stake.hs b/agora-specs/Sample/Stake.hs index 51611e6..88e5dc7 100644 --- a/agora-specs/Sample/Stake.hs +++ b/agora-specs/Sample/Stake.hs @@ -31,8 +31,8 @@ import Plutarch.Api.V1 (mkValidator, validatorHash) import Plutarch.Context ( MintingBuilder, SpendingBuilder, - buildMinting, - buildSpending, + buildMintingUnsafe, + buildSpendingUnsafe, input, mint, output, @@ -87,7 +87,7 @@ stakeCreation = . withValue (st <> Value.singleton "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" "LQ" 424242424242) . withDatum datum ] - in either error id $ buildMinting builder + in buildMintingUnsafe builder -- | This ScriptContext should fail because the datum has too much GT. stakeCreationWrongDatum :: ScriptContext @@ -150,4 +150,4 @@ stakeDepositWithdraw config = . withValue (st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeBefore.stakedAmount)) . withDatum stakeAfter ] - in either error id $ buildSpending builder + in buildSpendingUnsafe builder diff --git a/agora-specs/Sample/Treasury.hs b/agora-specs/Sample/Treasury.hs index 39d0303..632f559 100644 --- a/agora-specs/Sample/Treasury.hs +++ b/agora-specs/Sample/Treasury.hs @@ -20,7 +20,7 @@ module Sample.Treasury ( import Plutarch.Context ( MintingBuilder, UTXO, - buildMinting, + buildMintingUnsafe, credential, input, mint, @@ -83,7 +83,7 @@ validCtx = . withValue (Value.singleton gatCs gatTn 1 <> minAda) . withTxId "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3" ] - in either error id $ buildMinting builder + in buildMintingUnsafe builder treasuryRef :: TxOutRef treasuryRef = @@ -124,4 +124,4 @@ trCtxGATNameNotAddress = . withValue (Value.singleton gatCs gatTn 1 <> minAda) . withTxId "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3" ] - in either error id $ buildMinting builder + in buildMintingUnsafe builder diff --git a/flake.lock b/flake.lock index d33722c..0d12bf7 100644 --- a/flake.lock +++ b/flake.lock @@ -6339,11 +6339,11 @@ "plutarch-quickcheck": "plutarch-quickcheck" }, "locked": { - "lastModified": 1655470312, - "narHash": "sha256-O4Dy803SFOS+S1OFEecfCRkjWc8y0iHbO+EVKtBqsGk=", + "lastModified": 1655492974, + "narHash": "sha256-FNshUKtfs8tbxAUlqhP3AgmkjKMiKyw+kEBULmg6bVM=", "owner": "Liqwid-Labs", "repo": "liqwid-plutarch-extra", - "rev": "fd9b2e6e713c36efef30bcef8d97a069fda7d71a", + "rev": "4a9cdc642b85e16e487b789012bb8417c3e197d8", "type": "github" }, "original": { @@ -7459,11 +7459,11 @@ }, "nixpkgs-2111_5": { "locked": { - "lastModified": 1655355951, - "narHash": "sha256-uroxR5FTZWEqpakNtwiZBABj6SpX+TOuUZ4G0PtSy94=", + "lastModified": 1655415671, + "narHash": "sha256-WD7HxxW1m8D/fkV1QlCYlZvnE5gQdg7ckq3myI4gPtE=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "b882c61856522467f866f3d6321e1aa5b0b393b5", + "rev": "f96729212602f15a6a226d2f27f5de70492ad095", "type": "github" }, "original": { @@ -9286,11 +9286,11 @@ "plutarch": "plutarch_4" }, "locked": { - "lastModified": 1654627196, - "narHash": "sha256-OohlZsi0/j55Sq6U/hA7gl6SQyTHIGT9Pg+R61veCJw=", + "lastModified": 1655492019, + "narHash": "sha256-ZwU9wjSaC1BCukLqx3swqD30mwppVr7Fg2Y8jEkQ2c8=", "owner": "Liqwid-Labs", "repo": "plutarch-context-builder", - "rev": "b6c6e50c60c87f2b63d8027ff66728fabbb569fe", + "rev": "fa0e90bf0cdb258c5be500d066d5698fb360cfc3", "type": "github" }, "original": {