diff --git a/agora-sample/Sample/Effect/GovernorMutation.hs b/agora-sample/Sample/Effect/GovernorMutation.hs index 7d41cb7..737783a 100644 --- a/agora-sample/Sample/Effect/GovernorMutation.hs +++ b/agora-sample/Sample/Effect/GovernorMutation.hs @@ -11,14 +11,22 @@ module Sample.Effect.GovernorMutation ( mkEffectDatum, ) where +-------------------------------------------------------------------------------- + import Agora.Effect.GovernorMutation ( MutateGovernorDatum (..), mutateGovernorValidator, ) import Agora.Governor (GovernorDatum (..)) import Agora.Proposal (ProposalId (..), ProposalThresholds (..)) + +-------------------------------------------------------------------------------- + import Plutarch.Api.V1 (mkValidator, validatorHash) import Plutarch.SafeMoney (Tagged (Tagged)) + +-------------------------------------------------------------------------------- + import Plutus.V1.Ledger.Address (scriptHashAddress) import Plutus.V1.Ledger.Api ( Address, @@ -35,6 +43,9 @@ import Plutus.V1.Ledger.Api ( import Plutus.V1.Ledger.Api qualified as Interval import Plutus.V1.Ledger.Value (AssetClass, assetClass) import Plutus.V1.Ledger.Value qualified as Value + +-------------------------------------------------------------------------------- + import Sample.Shared ( authorityTokenSymbol, defaultProposalThresholds, @@ -46,6 +57,12 @@ import Sample.Shared ( ) import Test.Util (datumPair, toDatumHash) +-------------------------------------------------------------------------------- + +import Data.Default.Class (Default (def)) + +-------------------------------------------------------------------------------- + -- | The effect validator instance. effectValidator :: Validator effectValidator = mkValidator $ mutateGovernorValidator governor @@ -101,6 +118,8 @@ mkEffectTxInfo newGovDatum = GovernorDatum { proposalThresholds = defaultProposalThresholds , nextProposalId = ProposalId 0 + , proposalTimings = def + , createProposalTimeRangeMaxWidth = def } governorInputDatum :: Datum governorInputDatum = Datum $ toBuiltinData governorInputDatum' @@ -161,6 +180,8 @@ validNewGovernorDatum = GovernorDatum { proposalThresholds = defaultProposalThresholds , nextProposalId = ProposalId 42 + , proposalTimings = def + , createProposalTimeRangeMaxWidth = def } invalidNewGovernorDatum :: GovernorDatum @@ -171,4 +192,6 @@ invalidNewGovernorDatum = { countVoting = Tagged (-1) } , nextProposalId = ProposalId 42 + , proposalTimings = def + , createProposalTimeRangeMaxWidth = def } diff --git a/agora-sample/Sample/Governor.hs b/agora-sample/Sample/Governor.hs index 8d0cab5..48329c0 100644 --- a/agora-sample/Sample/Governor.hs +++ b/agora-sample/Sample/Governor.hs @@ -56,6 +56,10 @@ import Agora.Proposal ( emptyVotesFor, ) import Agora.Proposal qualified as P +import Agora.Proposal.Time ( + ProposalStartingTime (ProposalStartingTime), + ProposalTimingConfig (..), + ) import Agora.Stake ( ProposalLock (..), Stake (..), @@ -73,16 +77,19 @@ import Sample.Shared ( gstUTXORef, minAda, proposalPolicySymbol, - proposalTimingConfig, + proposalStartingTimeFromTimeRange, proposalValidatorAddress, signer, signer2, stake, stakeAddress, stakeAssetClass, - tmpProposalStartingTime, ) -import Test.Util (datumPair, toDatumHash) +import Test.Util (closedBoundedInterval, datumPair, toDatumHash) + +-------------------------------------------------------------------------------- + +import Data.Default.Class (Default (def)) -------------------------------------------------------------------------------- @@ -114,6 +121,8 @@ mintGST = GovernorDatum { proposalThresholds = defaultProposalThresholds , nextProposalId = ProposalId 0 + , proposalTimings = def + , createProposalTimeRangeMaxWidth = def } governorOutputDatum :: Datum governorOutputDatum = Datum $ toBuiltinData governorOutputDatum' @@ -207,6 +216,8 @@ createProposal = GovernorDatum { proposalThresholds = defaultProposalThresholds , nextProposalId = thisProposalId + , proposalTimings = def + , createProposalTimeRangeMaxWidth = def } governorInputDatum :: Datum governorInputDatum = Datum $ toBuiltinData governorInputDatum' @@ -236,8 +247,8 @@ createProposal = , cosigners = [signer] , thresholds = defaultProposalThresholds , votes = emptyVotesFor effects - , timingConfig = proposalTimingConfig - , startingTime = tmpProposalStartingTime + , timingConfig = def + , startingTime = proposalStartingTimeFromTimeRange validTimeRange } ) proposalOutput :: TxOut @@ -298,8 +309,13 @@ createProposal = } --- + ownInputRef :: TxOutRef ownInputRef = TxOutRef "4355a46b19d348dc2f57c046f8ef63d4538ebb936000f3c9ee954a27460dd865" 1 + + --- + + validTimeRange = closedBoundedInterval 10 15 in ScriptContext { scriptContextTxInfo = TxInfo @@ -316,7 +332,7 @@ createProposal = , txInfoMint = pst , txInfoDCert = [] , txInfoWdrl = [] - , txInfoValidRange = Interval.always + , txInfoValidRange = validTimeRange , txInfoSignatories = [signer] , txInfoData = datumPair @@ -378,6 +394,8 @@ mintGATs = GovernorDatum { proposalThresholds = defaultProposalThresholds , nextProposalId = ProposalId 5 + , proposalTimings = def + , createProposalTimeRangeMaxWidth = def } governorInputDatum :: Datum governorInputDatum = Datum $ toBuiltinData governorInputDatum' @@ -412,8 +430,8 @@ mintGATs = , cosigners = [signer, signer2] , thresholds = defaultProposalThresholds , votes = proposalVotes - , timingConfig = proposalTimingConfig - , startingTime = tmpProposalStartingTime + , timingConfig = def + , startingTime = ProposalStartingTime 10 } proposalInputDatum :: Datum proposalInputDatum = Datum $ toBuiltinData proposalInputDatum' @@ -465,6 +483,12 @@ mintGATs = ownInputRef :: TxOutRef ownInputRef = TxOutRef "4355a46b19d348dc2f57c046f8ef63d4538ebb936000f3c9ee954a27460dd865" 1 + + -- + validTimeRange = + closedBoundedInterval + ((def :: ProposalTimingConfig).lockingTime + 11) + ((def :: ProposalTimingConfig).executingTime - 11) in ScriptContext { scriptContextTxInfo = TxInfo @@ -483,7 +507,7 @@ mintGATs = , txInfoMint = gat , txInfoDCert = [] , txInfoWdrl = [] - , txInfoValidRange = Interval.always + , txInfoValidRange = validTimeRange , txInfoSignatories = [signer, signer2] , txInfoData = datumPair @@ -565,6 +589,8 @@ mutateState = GovernorDatum { proposalThresholds = defaultProposalThresholds , nextProposalId = ProposalId 5 + , proposalTimings = def + , createProposalTimeRangeMaxWidth = def } governorInputDatum :: Datum governorInputDatum = Datum $ toBuiltinData governorInputDatum' diff --git a/agora-sample/Sample/Proposal.hs b/agora-sample/Sample/Proposal.hs index de52379..631dc9f 100644 --- a/agora-sample/Sample/Proposal.hs +++ b/agora-sample/Sample/Proposal.hs @@ -16,9 +16,14 @@ module Sample.Proposal ( ) where -------------------------------------------------------------------------------- + import Plutarch.Api.V1 ( validatorHash, ) +import Plutarch.SafeMoney (Tagged (Tagged), untag) + +-------------------------------------------------------------------------------- + import Plutus.V1.Ledger.Api ( Address (Address), Credential (ScriptCredential), @@ -33,13 +38,13 @@ import Plutus.V1.Ledger.Api ( TxOut (TxOut, txOutAddress, txOutDatumHash, txOutValue), TxOutRef (TxOutRef), ) -import Plutus.V1.Ledger.Interval qualified as Interval import Plutus.V1.Ledger.Value qualified as Value +import PlutusTx.AssocMap qualified as AssocMap -------------------------------------------------------------------------------- import Agora.Governor ( - GovernorDatum (GovernorDatum, nextProposalId, proposalThresholds), + GovernorDatum (..), ) import Agora.Proposal ( Proposal (..), @@ -50,15 +55,20 @@ import Agora.Proposal ( ResultTag (..), emptyVotesFor, ) -import Agora.Proposal.Time (ProposalTimingConfig (..)) +import Agora.Proposal.Time (ProposalStartingTime (ProposalStartingTime), ProposalTimingConfig (..)) import Agora.Stake (ProposalLock (ProposalLock), Stake (..), StakeDatum (..)) -import Plutarch.SafeMoney (Tagged (Tagged), untag) -import PlutusTx.AssocMap qualified as AssocMap + +-------------------------------------------------------------------------------- + import Sample.Shared import Test.Util (closedBoundedInterval, datumPair, toDatumHash, updateMap) -------------------------------------------------------------------------------- +import Data.Default.Class (Default (def)) + +-------------------------------------------------------------------------------- + -- | This script context should be a valid transaction. proposalCreation :: ScriptContext proposalCreation = @@ -79,8 +89,8 @@ proposalCreation = , cosigners = [signer] , thresholds = defaultProposalThresholds , votes = emptyVotesFor effects - , timingConfig = proposalTimingConfig - , startingTime = tmpProposalStartingTime + , timingConfig = def + , startingTime = proposalStartingTimeFromTimeRange validTimeRange } ) @@ -91,6 +101,8 @@ proposalCreation = GovernorDatum { proposalThresholds = defaultProposalThresholds , nextProposalId = ProposalId 0 + , proposalTimings = def + , createProposalTimeRangeMaxWidth = def } ) govAfter :: Datum @@ -100,8 +112,12 @@ proposalCreation = GovernorDatum { proposalThresholds = defaultProposalThresholds , nextProposalId = ProposalId 1 + , proposalTimings = def + , createProposalTimeRangeMaxWidth = def } ) + + validTimeRange = closedBoundedInterval 10 15 in ScriptContext { scriptContextTxInfo = TxInfo @@ -138,7 +154,7 @@ proposalCreation = , txInfoMint = st , txInfoDCert = [] , txInfoWdrl = [] - , txInfoValidRange = Interval.always + , txInfoValidRange = validTimeRange , txInfoSignatories = [signer] , txInfoData = [ datumPair proposalDatum @@ -174,8 +190,8 @@ cosignProposal newSigners = , cosigners = [signer] , thresholds = defaultProposalThresholds , votes = emptyVotesFor effects - , timingConfig = proposalTimingConfig - , startingTime = tmpProposalStartingTime + , timingConfig = def + , startingTime = ProposalStartingTime 0 } stakeDatum :: StakeDatum stakeDatum = StakeDatum (Tagged 50_000_000) signer2 [] @@ -185,7 +201,7 @@ cosignProposal newSigners = validTimeRange = closedBoundedInterval 10 - (proposalTimingConfig.draftTime - 10) + ((def :: ProposalTimingConfig).draftTime - 10) in TxInfo { txInfoInputs = [ TxInInfo @@ -295,8 +311,8 @@ voteOnProposal params = , cosigners = [stakeOwner] , thresholds = defaultProposalThresholds , votes = ProposalVotes initialVotes - , timingConfig = proposalTimingConfig - , startingTime = tmpProposalStartingTime + , timingConfig = def + , startingTime = ProposalStartingTime 0 } proposalInputDatum :: Datum proposalInputDatum = Datum $ toBuiltinData proposalInputDatum' @@ -384,7 +400,9 @@ voteOnProposal params = --- validTimeRange = - closedBoundedInterval (proposalTimingConfig.draftTime + 1) (proposalTimingConfig.votingTime - 1) + closedBoundedInterval + ((def :: ProposalTimingConfig).draftTime + 1) + ((def :: ProposalTimingConfig).votingTime - 1) in TxInfo { txInfoInputs = [ TxInInfo proposalRef proposalInput diff --git a/agora-sample/Sample/Shared.hs b/agora-sample/Sample/Shared.hs index adaed30..94801bf 100644 --- a/agora-sample/Sample/Shared.hs +++ b/agora-sample/Sample/Shared.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + {- | Module : Sample.Shared Maintainer : emi@haskell.fyi @@ -36,8 +38,7 @@ module Sample.Shared ( proposalPolicySymbol, proposalValidatorHash, proposalValidatorAddress, - proposalTimingConfig, - tmpProposalStartingTime, + proposalStartingTimeFromTimeRange, -- ** Authority authorityToken, @@ -77,12 +78,14 @@ import Agora.Proposal ( ProposalThresholds (..), ) import Agora.Proposal.Time ( - ProposalStartingTime (..), + MaxTimeRangeWidth (..), + ProposalStartingTime (ProposalStartingTime), ProposalTimingConfig (..), ) import Agora.Stake (Stake (..)) import Agora.Treasury (treasuryValidator) import Agora.Utils (validatorHashToTokenName) +import Data.Default.Class (Default (..)) import Plutarch.Api.V1 ( mintingPolicySymbol, mkMintingPolicy, @@ -95,9 +98,14 @@ import Plutus.V1.Ledger.Api ( Address (Address), Credential (ScriptCredential), CurrencySymbol, + Extended (..), + Interval (..), + LowerBound (..), MintingPolicy (..), + POSIXTimeRange, PubKeyHash, TxOutRef (TxOutRef), + UpperBound (..), Value, ) import Plutus.V1.Ledger.Contexts ( @@ -190,21 +198,32 @@ authorityToken = authorityTokenFromGovernor governor authorityTokenSymbol :: CurrencySymbol authorityTokenSymbol = authorityTokenSymbolFromGovernor governor -proposalTimingConfig :: ProposalTimingConfig -proposalTimingConfig = - ProposalTimingConfig - { draftTime = 50 - , votingTime = 1000 - , lockingTime = 2000 - , executingTime = 3000 - } - -{- | Hard coded starting time of every propoal. - This will be calculated by the governor in the future. - FIXME: Remove this. +{- | Default value of 'Agora.Governor.GovernorDatum.proposalTimings'. + For testing purpose only. -} -tmpProposalStartingTime :: ProposalStartingTime -tmpProposalStartingTime = ProposalStartingTime 0 +instance Default ProposalTimingConfig where + def = + ProposalTimingConfig + { draftTime = 50 + , votingTime = 1000 + , lockingTime = 2000 + , executingTime = 3000 + } + +{- | Default value of 'Agora.Governor.GovernorDatum.createProposalTimeRangeMaxWidth'. + For testing purpose only. +-} +instance Default MaxTimeRangeWidth where + def = MaxTimeRangeWidth 10 + +{- | Get the starting time of a proposal, given a closed finite time range. + Tightness of the time range is not checked. See 'Agora.Proposal.Time.createProposalStartingTime'. +-} +proposalStartingTimeFromTimeRange :: POSIXTimeRange -> ProposalStartingTime +proposalStartingTimeFromTimeRange + (Interval (LowerBound (Finite l) True) (UpperBound (Finite u) True)) = + ProposalStartingTime $ (l + u) `div` 2 +proposalStartingTimeFromTimeRange _ = error "Given time range should be finite and closed" ------------------------------------------------------------------ diff --git a/agora-test/Spec/Effect/GovernorMutation.hs b/agora-test/Spec/Effect/GovernorMutation.hs index 1436b5a..18ed995 100644 --- a/agora-test/Spec/Effect/GovernorMutation.hs +++ b/agora-test/Spec/Effect/GovernorMutation.hs @@ -4,6 +4,7 @@ import Agora.Effect.GovernorMutation (mutateGovernorValidator) import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor)) import Agora.Governor.Scripts (governorValidator) import Agora.Proposal (ProposalId (..)) +import Data.Default.Class (Default (def)) import Plutus.V1.Ledger.Api (ScriptContext (ScriptContext), ScriptPurpose (Spending)) import Sample.Effect.GovernorMutation ( effectRef, @@ -27,9 +28,10 @@ tests = "governor validator should pass" (governorValidator Shared.governor) ( GovernorDatum - { proposalThresholds = Shared.defaultProposalThresholds - , nextProposalId = ProposalId 0 - } + Shared.defaultProposalThresholds + (ProposalId 0) + def + def ) MutateGovernor ( ScriptContext @@ -48,9 +50,10 @@ tests = "governor validator should fail" (governorValidator Shared.governor) ( GovernorDatum - { proposalThresholds = Shared.defaultProposalThresholds - , nextProposalId = ProposalId 0 - } + Shared.defaultProposalThresholds + (ProposalId 0) + def + def ) MutateGovernor ( ScriptContext diff --git a/agora-test/Spec/Governor.hs b/agora-test/Spec/Governor.hs index 89c43f8..3ac39a2 100644 --- a/agora-test/Spec/Governor.hs +++ b/agora-test/Spec/Governor.hs @@ -16,6 +16,7 @@ module Spec.Governor (tests) where import Agora.Governor (GovernorDatum (..), GovernorRedeemer (..)) import Agora.Governor.Scripts (governorPolicy, governorValidator) import Agora.Proposal (ProposalId (..)) +import Data.Default.Class (Default (def)) import Sample.Governor (createProposal, mintGATs, mintGST, mutateState) import Sample.Shared qualified as Shared import Test.Tasty (TestTree, testGroup) @@ -38,19 +39,34 @@ tests = [ validatorSucceedsWith "proposal creation" (governorValidator Shared.governor) - (GovernorDatum Shared.defaultProposalThresholds (ProposalId 0)) + ( GovernorDatum + Shared.defaultProposalThresholds + (ProposalId 0) + def + def + ) CreateProposal createProposal , validatorSucceedsWith "GATs minting" (governorValidator Shared.governor) - (GovernorDatum Shared.defaultProposalThresholds (ProposalId 5)) + ( GovernorDatum + Shared.defaultProposalThresholds + (ProposalId 5) + def + def + ) MintGATs mintGATs , validatorSucceedsWith "mutate governor state" (governorValidator Shared.governor) - (GovernorDatum Shared.defaultProposalThresholds (ProposalId 5)) + ( GovernorDatum + Shared.defaultProposalThresholds + (ProposalId 5) + def + def + ) MutateGovernor mutateState ] diff --git a/agora-test/Spec/Proposal.hs b/agora-test/Spec/Proposal.hs index a78d693..c381126 100644 --- a/agora-test/Spec/Proposal.hs +++ b/agora-test/Spec/Proposal.hs @@ -31,12 +31,14 @@ import Agora.Proposal.Scripts ( proposalPolicy, proposalValidator, ) +import Agora.Proposal.Time (ProposalStartingTime (ProposalStartingTime)) import Agora.Stake ( ProposalLock (ProposalLock), StakeDatum (StakeDatum), StakeRedeemer (PermitVote, WitnessStake), ) import Agora.Stake.Scripts (stakeValidator) +import Data.Default.Class (Default (def)) import Plutarch.SafeMoney (Tagged (Tagged)) import Plutus.V1.Ledger.Api (ScriptContext (..), ScriptPurpose (..)) import PlutusTx.AssocMap qualified as AssocMap @@ -82,8 +84,8 @@ tests = [ (ResultTag 0, AssocMap.empty) , (ResultTag 1, AssocMap.empty) ] - , timingConfig = Shared.proposalTimingConfig - , startingTime = Shared.tmpProposalStartingTime + , timingConfig = def + , startingTime = ProposalStartingTime 0 } ) (Cosign [signer2]) @@ -117,8 +119,8 @@ tests = , (ResultTag 1, 4242) ] ) - , timingConfig = Shared.proposalTimingConfig - , startingTime = Shared.tmpProposalStartingTime + , timingConfig = def + , startingTime = ProposalStartingTime 0 } ) (Vote (ResultTag 0)) diff --git a/agora.cabal b/agora.cabal index 9014c21..256e025 100644 --- a/agora.cabal +++ b/agora.cabal @@ -114,6 +114,7 @@ common test-deps , agora , apropos , apropos-tx + , data-default-class , mtl , QuickCheck , quickcheck-instances @@ -141,22 +142,20 @@ library Agora.Proposal.Time Agora.Record Agora.SafeMoney + Agora.ScriptInfo Agora.Stake Agora.Stake.Scripts Agora.Treasury Agora.Utils Agora.Utils.Value - Agora.ScriptInfo - other-modules: - Agora.Aeson.Orphans + other-modules: Agora.Aeson.Orphans hs-source-dirs: agora library pprelude default-language: Haskell2010 exposed-modules: PPrelude hs-source-dirs: agora - build-depends: , base , plutarch @@ -176,8 +175,8 @@ library agora-sample Sample.Shared Sample.Stake Sample.Treasury - hs-source-dirs: agora-sample + hs-source-dirs: agora-sample build-depends: agora-testlib test-suite agora-test @@ -214,8 +213,7 @@ executable agora-scripts import: lang, deps, exe-opts main-is: Scripts.hs hs-source-dirs: agora-scripts - other-modules: - Options + other-modules: Options build-depends: , agora , optparse-applicative diff --git a/agora/Agora/Governor.hs b/agora/Agora/Governor.hs index 4f64a76..a2d5940 100644 --- a/agora/Agora/Governor.hs +++ b/agora/Agora/Governor.hs @@ -37,6 +37,12 @@ import Agora.Proposal ( ProposalId (ProposalId), ProposalThresholds, ) +import Agora.Proposal.Time ( + MaxTimeRangeWidth, + PMaxTimeRangeWidth, + PProposalTimingConfig, + ProposalTimingConfig, + ) import Agora.SafeMoney (GTTag) import Agora.Utils (tclet) @@ -66,6 +72,11 @@ data GovernorDatum = GovernorDatum -- ^ Gets copied over upon creation of a 'Agora.Proposal.ProposalDatum'. , nextProposalId :: ProposalId -- ^ What tag the next proposal will get upon creating. + , proposalTimings :: ProposalTimingConfig + -- ^ The timing configuration for proposals. + -- Will get copied over upon the creation of proposals. + , createProposalTimeRangeMaxWidth :: MaxTimeRangeWidth + -- ^ The maximum valid duration of a transaction that creats a proposal. } deriving stock (Show, GHC.Generic) @@ -118,6 +129,8 @@ newtype PGovernorDatum (s :: S) = PGovernorDatum ( PDataRecord '[ "proposalThresholds" ':= PProposalThresholds , "nextProposalId" ':= PProposalId + , "proposalTimings" ':= PProposalTimingConfig + , "createProposalTimeRangeMaxWidth" ':= PMaxTimeRangeWidth ] ) } diff --git a/agora/Agora/Governor/Scripts.hs b/agora/Agora/Governor/Scripts.hs index 0b41352..fc4987d 100644 --- a/agora/Agora/Governor/Scripts.hs +++ b/agora/Agora/Governor/Scripts.hs @@ -51,12 +51,14 @@ import Agora.Proposal ( PResultTag, Proposal (..), ProposalStatus (Draft, Locked), + pemptyVotesFor, proposalDatumValid, ) import Agora.Proposal.Scripts ( proposalPolicy, proposalValidator, ) +import Agora.Proposal.Time (createProposalStartingTime) import Agora.Record import Agora.SafeMoney (GTTag) import Agora.Stake ( @@ -126,7 +128,6 @@ import Plutarch.TryFrom (ptryFrom) -------------------------------------------------------------------------------- -import Agora.Proposal.Time (ProposalStartingTime (..), ProposalTimingConfig (..)) import Plutus.V1.Ledger.Api ( CurrencySymbol (..), MintingPolicy, @@ -172,7 +173,7 @@ governorPolicy gov = let ownAssetClass = passetClass # ownSymbol # pconstant "" txInfo = pfromData $ pfield @"txInfo" # ctx' - txInfoF <- tcont $ pletFields @'["mint", "inputs", "outputs", "datums"] txInfo + txInfoF <- tcont $ pletFields @'["mint", "inputs", "outputs", "datums", "validRange"] txInfo tcassert "Referenced utxo should be spent" $ pisUTXOSpent # oref # txInfoF.inputs @@ -288,7 +289,7 @@ governorValidator gov = ctxF <- tcont $ pletFields @'["txInfo", "purpose"] ctx' txInfo' <- tclet $ pfromData $ ctxF.txInfo - txInfoF <- tcont $ pletFields @'["mint", "inputs", "outputs", "datums", "signatories"] txInfo' + txInfoF <- tcont $ pletFields @'["mint", "inputs", "outputs", "datums", "signatories", "validRange"] txInfo' PSpending (pfromData . (pfield @"_0" #) -> ownInputRef) <- tcmatch $ pfromData ctxF.purpose @@ -300,7 +301,15 @@ governorValidator gov = let ownAddress = pfromData $ ownInputF.address (pfromData -> (oldGovernorDatum :: Term _ PGovernorDatum), _) <- tcont $ ptryFrom datum' - oldGovernorDatumF <- tcont $ pletFields @'["proposalThresholds", "nextProposalId"] oldGovernorDatum + oldGovernorDatumF <- + tcont $ + pletFields + @'[ "proposalThresholds" + , "nextProposalId" + , "proposalTimings" + , "createProposalTimeRangeMaxWidth" + ] + oldGovernorDatum -- Check that GST will be returned to the governor. let ownInputGSTAmount = psymbolValueOf # pgstSymbol # ownInputF.value @@ -337,6 +346,9 @@ governorValidator gov = PGovernorDatum ( #proposalThresholds .= oldGovernorDatumF.proposalThresholds .& #nextProposalId .= pdata expectedNextProposalId + .& #proposalTimings .= oldGovernorDatumF.proposalTimings + .& #createProposalTimeRangeMaxWidth + .= oldGovernorDatumF.createProposalTimeRangeMaxWidth ) tcassert "Unexpected governor state datum" $ newGovernorDatum #== expectedNewDatum @@ -402,9 +414,6 @@ governorValidator gov = outputDatumHash <- tclet $ pfield @"datumHash" #$ phead # outputsToProposalValidatorWithStateToken - tcassert "The utxo paid to the proposal validator must have datum" $ - pisDJust # outputDatumHash - proposalOutputDatum' <- tclet $ mustFindDatum' @PProposalDatum @@ -417,23 +426,34 @@ governorValidator gov = proposalOutputDatum <- tcont $ pletFields - @'["proposalId", "status", "cosigners", "thresholds", "votes"] + @'["effects", "cosigners", "proposalId", "votes"] proposalOutputDatum' - -- Id and thresholds should be copied from the old governor state datum. - tcassert "Invalid proposal id in proposal datum" $ - proposalOutputDatum.proposalId #== oldGovernorDatumF.nextProposalId - - tcassert "Invalid thresholds in proposal datum" $ - proposalOutputDatum.thresholds #== oldGovernorDatumF.proposalThresholds - - -- The proposal at this point should be in draft state. - tcassert "Proposal state should be draft" $ - proposalOutputDatum.status #== pconstantData Draft - tcassert "Proposal should have only one cosigner" $ plength # pfromData proposalOutputDatum.cosigners #== 1 + let -- Votes should be empty at this point + expectedVotes = pemptyVotesFor # pfromData proposalOutputDatum.effects + expectedStartingTime = + createProposalStartingTime + # oldGovernorDatumF.createProposalTimeRangeMaxWidth + # txInfoF.validRange + -- Id, thresholds and timings should be copied from the old governor state datum. + expectedProposalOut = + mkRecordConstr + PProposalDatum + ( #proposalId .= oldGovernorDatumF.nextProposalId + .& #effects .= proposalOutputDatum.effects + .& #status .= pconstantData Draft + .& #cosigners .= proposalOutputDatum.cosigners + .& #thresholds .= oldGovernorDatumF.proposalThresholds + .& #votes .= pdata expectedVotes + .& #timingConfig .= oldGovernorDatumF.proposalTimings + .& #startingTime .= pdata expectedStartingTime + ) + + tcassert "Datum correct" $ expectedProposalOut #== proposalOutputDatum' + let cosigner = phead # pfromData proposalOutputDatum.cosigners tcassert "Cosigner should be the stake owner" $ @@ -560,7 +580,7 @@ governorValidator gov = proposalInputDatumF <- tcont $ - pletFields @'["proposalId", "effects", "status", "cosigners", "thresholds", "votes"] + pletFields @'["proposalId", "effects", "status", "cosigners", "thresholds", "votes", "timingConfig", "startingTime"] proposalInputDatum -- Check that the proposal state is advanced so that a proposal cannot be executed twice. @@ -577,10 +597,8 @@ governorValidator gov = .& #cosigners .= proposalInputDatumF.cosigners .& #thresholds .= proposalInputDatumF.thresholds .& #votes .= proposalInputDatumF.votes - -- FIXME: copy from the governor datum - .& #timingConfig .= pdata (pconstant tmpTimingConfig) - -- FIXME: calculate from 'txInfoValidRange' - .& #startingTime .= pdata (pconstant tmpProposalStartingTime) + .& #timingConfig .= proposalInputDatumF.timingConfig + .& #startingTime .= proposalInputDatumF.startingTime ) tcassert "Unexpected output proposal datum" $ @@ -732,20 +750,6 @@ governorValidator gov = let sym = governorSTSymbolFromGovernor gov in phoistAcyclic $ pconstant sym - -- TODO: remove this. This is temperary. - tmpTimingConfig :: ProposalTimingConfig - tmpTimingConfig = - ProposalTimingConfig - { draftTime = 50 - , votingTime = 1000 - , lockingTime = 2000 - , executingTime = 3000 - } - - -- TODO: remove this. - tmpProposalStartingTime :: ProposalStartingTime - tmpProposalStartingTime = ProposalStartingTime 0 - -------------------------------------------------------------------------------- -- | Get the 'CurrencySymbol' of GST. diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index 0da7627..b120216 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -30,6 +30,7 @@ module Agora.Proposal ( -- * Plutarch helpers proposalDatumValid, + pemptyVotesFor, ) where import GHC.Generics qualified as GHC @@ -47,7 +48,7 @@ import PlutusTx.AssocMap qualified as AssocMap import Agora.Proposal.Time (PProposalStartingTime, PProposalTimingConfig, ProposalStartingTime, ProposalTimingConfig) import Agora.SafeMoney (GTTag) -import Agora.Utils (pkeysEqual, pnotNull) +import Agora.Utils (pkeysEqual, pmapMap, pnotNull) import Control.Applicative (Const) import Control.Arrow (first) import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields, PIsDataReprInstances (..)) @@ -348,6 +349,16 @@ deriving via instance (PConstantDecl ProposalVotes) +-- Plutarch-level version of 'emptyVotesFor'. +pemptyVotesFor :: forall s a. (PIsData a) => Term s (PMap PResultTag a :--> PProposalVotes) +pemptyVotesFor = + phoistAcyclic $ + plam + ( \m -> + pcon $ + PProposalVotes $ pmapMap # plam (const $ pconstant 0) # m + ) + -- | Plutarch-level version of 'ProposalDatum'. newtype PProposalDatum (s :: S) = PProposalDatum { getProposalDatum :: diff --git a/agora/Agora/Proposal/Time.hs b/agora/Agora/Proposal/Time.hs index 54fed1a..e8d11a0 100644 --- a/agora/Agora/Proposal/Time.hs +++ b/agora/Agora/Proposal/Time.hs @@ -10,16 +10,18 @@ Time functions for proposal phases. -} module Agora.Proposal.Time ( -- * Haskell-land - ProposalTime (..), ProposalTimingConfig (..), ProposalStartingTime (..), + MaxTimeRangeWidth (..), -- * Plutarch-land PProposalTime (..), PProposalTimingConfig (..), PProposalStartingTime (..), + PMaxTimeRangeWidth (..), -- * Compute periods given config and starting time. + createProposalStartingTime, currentProposalTime, isDraftPeriod, isVotingPeriod, @@ -27,10 +29,9 @@ module Agora.Proposal.Time ( isExecutionPeriod, ) where -import Agora.Record (mkRecordConstr, (.&), (.=)) -import Agora.Utils (tcmatch) +import Agora.Utils (tcassert, tcmatch) import GHC.Generics qualified as GHC -import Generics.SOP (Generic, I (I)) +import Generics.SOP (Generic, HasDatatypeInfo, I (I)) import Plutarch.Api.V1 ( PExtended (PFinite), PInterval (PInterval), @@ -39,7 +40,11 @@ import Plutarch.Api.V1 ( PPOSIXTimeRange, PUpperBound (PUpperBound), ) -import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields, PIsDataReprInstances (..)) +import Plutarch.DataRepr ( + DerivePConstantViaData (..), + PDataFields, + PIsDataReprInstances (..), + ) import Plutarch.Lift ( DerivePConstantViaNewtype (..), PConstantDecl, @@ -53,35 +58,6 @@ import Prelude hiding ((+)) -------------------------------------------------------------------------------- -{- | == Establishing timing in Proposal interactions. - - In Plutus, it's impossible to determine time exactly. It's also impossible - to get a single point in time, yet often we need to check - various constraints on time. - - For the purposes of proposals, there's a single most important feature: - The ability to determine if we can perform an action. In order to correctly - determine if we are able to perform certain actions, we need to know what - time it roughly is, compared to when the proposal was created. - - 'ProposalTime' represents "the time according to the proposal". - Its representation is opaque, and doesn't matter. - - Various functions work simply on 'ProposalTime' and 'ProposalTimingConfig'. - In particular, 'currentProposalTime' is useful for extracting the time - from the 'Plutus.V1.Ledger.Api.txInfoValidPeriod' field - of 'Plutus.V1.Ledger.Api.TxInfo'. - - We avoid 'PPOSIXTimeRange' where we can in order to save on operations. --} -data ProposalTime = ProposalTime - { lowerBound :: POSIXTime - , upperBound :: POSIXTime - } - deriving stock (Eq, Show, GHC.Generic) - -PlutusTx.makeIsDataIndexed ''ProposalTime [('ProposalTime, 0)] - -- | Represents the starting time of the proposal. newtype ProposalStartingTime = ProposalStartingTime { getProposalStartingTime :: POSIXTime @@ -107,32 +83,40 @@ data ProposalTimingConfig = ProposalTimingConfig PlutusTx.makeIsDataIndexed ''ProposalTimingConfig [('ProposalTimingConfig, 0)] +-- | Represents the maximum width of a 'POSIXTimeRange'. +newtype MaxTimeRangeWidth = MaxTimeRangeWidth {getMaxWidth :: POSIXTime} + deriving stock (Eq, Show, Ord, GHC.Generic) + deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) + -------------------------------------------------------------------------------- --- | Plutarch-level version of 'ProposalTime'. -newtype PProposalTime (s :: S) - = PProposalTime - ( Term - s - ( PDataRecord - '[ "lowerBound" ':= PPOSIXTime - , "upperBound" ':= PPOSIXTime - ] - ) - ) - deriving stock (GHC.Generic) - deriving anyclass (Generic) - deriving anyclass (PIsDataRepr) - deriving - (PlutusType, PIsData, PDataFields) - via (PIsDataReprInstances PProposalTime) +{- | == Establishing timing in Proposal interactions. -instance PUnsafeLiftDecl PProposalTime where - type PLifted PProposalTime = ProposalTime -deriving via - (DerivePConstantViaData ProposalTime PProposalTime) - instance - (PConstantDecl ProposalTime) + In Plutus, it's impossible to determine time exactly. It's also impossible + to get a single point in time, yet often we need to check + various constraints on time. + + For the purposes of proposals, there's a single most important feature: + The ability to determine if we can perform an action. In order to correctly + determine if we are able to perform certain actions, we need to know what + time it roughly is, compared to when the proposal was created. + + 'ProposalTime' represents "the time according to the proposal". + Its representation is opaque, and doesn't matter. + + Various functions work simply on 'ProposalTime' and 'ProposalTimingConfig'. + In particular, 'currentProposalTime' is useful for extracting the time + from the 'Plutus.V1.Ledger.Api.txInfoValidPeriod' field + of 'Plutus.V1.Ledger.Api.TxInfo'. + + We avoid 'PPOSIXTimeRange' where we can in order to save on operations. +-} +data PProposalTime (s :: S) = PProposalTime + { lowerBound :: Term s PPOSIXTime + , upperBound :: Term s PPOSIXTime + } + deriving stock (GHC.Generic) + deriving anyclass (Generic, PlutusType, HasDatatypeInfo, PEq) -- | Plutarch-level version of 'ProposalStartingTime'. newtype PProposalStartingTime (s :: S) = PProposalStartingTime (Term s PPOSIXTime) @@ -172,12 +156,45 @@ deriving via instance (PConstantDecl ProposalTimingConfig) +-- | Plutarch-level version of 'MaxTimeRangeWidth'. +newtype PMaxTimeRangeWidth (s :: S) + = PMaxTimeRangeWidth (Term s PPOSIXTime) + deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PMaxTimeRangeWidth PPOSIXTime) + +instance PUnsafeLiftDecl PMaxTimeRangeWidth where type PLifted PMaxTimeRangeWidth = MaxTimeRangeWidth +deriving via + (DerivePConstantViaNewtype MaxTimeRangeWidth PMaxTimeRangeWidth PPOSIXTime) + instance + (PConstantDecl MaxTimeRangeWidth) + -------------------------------------------------------------------------------- -- FIXME: Orphan instance, move this to plutarch-extra. instance AdditiveSemigroup (Term s PPOSIXTime) where (punsafeCoerce @_ @_ @PInteger -> x) + (punsafeCoerce @_ @_ @PInteger -> y) = punsafeCoerce $ x + y +{- | Get the starting time of a proposal, from the 'Plutus.V1.Ledger.Api.txInfoValidPeriod' field. + 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. +-} +createProposalStartingTime :: forall (s :: S). Term s (PMaxTimeRangeWidth :--> PPOSIXTimeRange :--> PProposalStartingTime) +createProposalStartingTime = phoistAcyclic $ + plam $ \(pto -> maxDuration) iv -> unTermCont $ do + currentTimeF <- tcmatch $ currentProposalTime # iv + + -- Use the middle of the current time range as the starting time. + let duration = currentTimeF.upperBound - currentTimeF.lowerBound + + startingTime = + pdiv + # (currentTimeF.lowerBound + currentTimeF.upperBound) + # 2 + + tcassert "createProposalStartingTime: given time range should be tight enough" $ + duration #<= maxDuration + + pure $ pcon $ PProposalStartingTime startingTime + {- | Get the current proposal time, from the 'Plutus.V1.Ledger.Api.txInfoValidPeriod' field. If it's impossible to get a fully-bounded time, (e.g. either end of the 'PPOSIXTimeRange' is @@ -193,21 +210,23 @@ currentProposalTime = phoistAcyclic $ lbf <- tcont $ pletFields @'["_0", "_1"] lb ubf <- tcont $ pletFields @'["_0", "_1"] ub pure $ - mkRecordConstr PProposalTime $ - #lowerBound - .= pmatch - lbf._0 - ( \case - PFinite ((pfield @"_0" #) -> d) -> d - _ -> ptraceError "currentProposalTime: Can't get fully-bounded proposal time." - ) - .& #upperBound - .= pmatch - ubf._0 - ( \case - PFinite ((pfield @"_0" #) -> d) -> d - _ -> ptraceError "currentProposalTime: Can't get fully-bounded proposal time." - ) + pcon $ + PProposalTime + { lowerBound = + pmatch + lbf._0 + ( \case + PFinite ((pfield @"_0" #) -> d) -> d + _ -> ptraceError "currentProposalTime: Can't get fully-bounded proposal time." + ) + , upperBound = + pmatch + ubf._0 + ( \case + PFinite ((pfield @"_0" #) -> d) -> d + _ -> ptraceError "currentProposalTime: Can't get fully-bounded proposal time." + ) + } -- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive. proposalTimeWithin :: @@ -220,13 +239,12 @@ proposalTimeWithin :: ) proposalTimeWithin = phoistAcyclic $ plam $ \l h proposalTime' -> unTermCont $ do - PProposalTime proposalTime <- tcmatch proposalTime' - ptf <- tcont $ pletFields @'["lowerBound", "upperBound"] proposalTime + PProposalTime ut lt <- tcmatch proposalTime' pure $ foldr1 (#&&) - [ l #<= pfromData ptf.lowerBound - , pfromData ptf.upperBound #<= h + [ l #<= lt + , ut #<= h ] -- | True if the 'PProposalTime' is in the draft period. diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index 62ce8f3..a3faa17 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -41,6 +41,7 @@ module Agora.Utils ( pmsort, pnubSort, pupdate, + pmapMap, pmapMaybe, -- * Functions which should (probably) not be upstreamed @@ -322,6 +323,23 @@ pupdate = phoistAcyclic $ ) # ps +-- | / O(n) /. Map a function over all values in a 'PMap'. +pmapMap :: forall s k a b. (PIsData k, PIsData a, PIsData b) => Term s ((a :--> b) :--> PMap k a :--> PMap k b) +pmapMap = phoistAcyclic $ + plam $ \f (pto -> (ps :: Term _ (PBuiltinList _))) -> + pcon $ + PMap $ + pmap + # plam + ( \kv -> + let k = pfstBuiltin # kv + v = psndBuiltin # kv + + nv = pdata $ f # pfromData v + in ppairDataBuiltin # k # nv + ) + # ps + -- | Add two 'PValue's together. paddValue :: forall s. Term s (PValue :--> PValue :--> PValue) paddValue = phoistAcyclic $