From a462e6a3d36d71710ea98200048d0d475647f249 Mon Sep 17 00:00:00 2001 From: Hongrui Fang Date: Fri, 11 Nov 2022 17:59:41 +0800 Subject: [PATCH] implement cooldown period for stake unlocking --- agora/Agora/Governor/Scripts.hs | 4 +- agora/Agora/Proposal/Scripts.hs | 34 +++-- agora/Agora/Proposal/Time.hs | 118 ++++++++++++------ agora/Agora/Stake.hs | 212 ++++++++++++++++++++------------ agora/Agora/Stake/Redeemers.hs | 191 +++++++++++++++++++--------- agora/Agora/Stake/Scripts.hs | 13 +- 6 files changed, 378 insertions(+), 194 deletions(-) diff --git a/agora/Agora/Governor/Scripts.hs b/agora/Agora/Governor/Scripts.hs index f417e33..bbe92a0 100644 --- a/agora/Agora/Governor/Scripts.hs +++ b/agora/Agora/Governor/Scripts.hs @@ -35,7 +35,7 @@ import Agora.Proposal ( pneutralOption, pwinner, ) -import Agora.Proposal.Time (validateProposalStartingTime) +import Agora.Proposal.Time (pvalidateProposalStartingTime) import Agora.SafeMoney (AuthorityTokenTag, GovernorSTTag, ProposalSTTag, StakeSTTag) import Agora.Stake ( pnumCreatedProposals, @@ -453,7 +453,7 @@ governorValidator = , ptraceIfFalse "cosigners correct" $ plistEquals # pfromData proposalOutputDatumF.cosigners # expectedCosigners , ptraceIfFalse "starting time valid" $ - validateProposalStartingTime + pvalidateProposalStartingTime # governorInputDatumF.createProposalTimeRangeMaxWidth # txInfoF.validRange # proposalOutputDatumF.startingTime diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs index b9e0625..1d42121 100644 --- a/agora/Agora/Proposal/Scripts.hs +++ b/agora/Agora/Proposal/Scripts.hs @@ -23,9 +23,10 @@ import Agora.Proposal ( import Agora.Proposal.Time ( PPeriod (PDraftingPeriod, PExecutingPeriod, PLockingPeriod, PVotingPeriod), PTimingRelation (PAfter, PWithin), - currentProposalTime, + pcurrentProposalTime, pgetRelation, pisWithin, + psatisfyMaximumWidth, ) import Agora.SafeMoney (GovernorSTTag, ProposalSTTag, StakeSTTag) import Agora.Stake ( @@ -82,6 +83,7 @@ import "liqwid-plutarch-extra" Plutarch.Extra.TermCont ( pmatchC, ptryFromC, ) +import Plutarch.Extra.Time (PCurrentTime) import Plutarch.Extra.Traversable (pfoldMap) import Plutarch.Extra.Value (psymbolValueOf') import Plutarch.Unsafe (punsafeCoerce) @@ -306,17 +308,23 @@ proposalValidator = -------------------------------------------------------------------------- + currentTime <- pletC $ pcurrentProposalTime # txInfoF.validRange + + let withCurrentTime :: + forall (a :: PType). + Term _ (PCurrentTime :--> a) -> + Term _ a + withCurrentTime f = + pmatch currentTime $ \case + PJust currentTime -> f # currentTime + PNothing -> ptraceError "Unable to resolve current time" + getTimingRelation' <- pletC $ - let currentTime = - passertPJust - # "Current time should be resolved" - #$ currentProposalTime - # txInfoF.validRange - in pgetRelation - # proposalInputDatumF.timingConfig - # proposalInputDatumF.startingTime - # currentTime + withCurrentTime $ + pgetRelation + # proposalInputDatumF.timingConfig + # proposalInputDatumF.startingTime let getTimingRelation = (getTimingRelation' #) . pcon @@ -502,6 +510,12 @@ proposalValidator = pguardC "Proposal time should be wthin the voting period" $ pisWithin # getTimingRelation PVotingPeriod + pguardC "Width of time should meet maximum requirement" $ + withCurrentTime $ + psatisfyMaximumWidth + #$ pfield @"votingTimeRangeMaxWidth" + # proposalInputDatumF.timingConfig + -- Ensure the transaction is voting to a valid 'ResultTag'(outcome). PProposalVotes voteMap <- pmatchC proposalInputDatumF.votes voteFor <- pletC $ pfromData $ pfield @"resultTag" # r diff --git a/agora/Agora/Proposal/Time.hs b/agora/Agora/Proposal/Time.hs index 1eec301..505e6a7 100644 --- a/agora/Agora/Proposal/Time.hs +++ b/agora/Agora/Proposal/Time.hs @@ -22,15 +22,15 @@ module Agora.Proposal.Time ( PPeriod (..), -- * Compute periods given config and starting time. - validateProposalStartingTime, - currentProposalTime, + pvalidateProposalStartingTime, + pcurrentProposalTime, pisProposalTimingConfigValid, pisMaxTimeRangeWidthValid, pgetRelation, pisWithin, + psatisfyMaximumWidth, ) where -import Control.Composition ((.*)) import Data.Functor ((<&>)) import Plutarch.Api.V1 ( PExtended (PFinite), @@ -45,6 +45,7 @@ import Plutarch.DataRepr ( PDataFields, ) import Plutarch.Extra.Applicative (PApply (pliftA2)) +import Plutarch.Extra.Bool (passert) import Plutarch.Extra.Field (pletAll, pletAllC) import Plutarch.Extra.IsData (PlutusTypeEnumData) import Plutarch.Extra.Maybe (pjust, pmaybe, pnothing) @@ -59,6 +60,7 @@ import Plutarch.Lift ( PConstantDecl, PUnsafeLiftDecl (PLifted), ) +import Plutarch.Num (PNum) import PlutusLedgerApi.V1 (POSIXTime) import PlutusTx qualified @@ -88,33 +90,6 @@ newtype ProposalStartingTime = ProposalStartingTime PlutusTx.UnsafeFromData ) -{- | Configuration of proposal timings. - - See: https://liqwid.notion.site/Proposals-589853145a994057aa77f397079f75e4#d25ea378768d4c76b52dd4c1b6bc0fcd - - @since 0.1.0 --} -data ProposalTimingConfig = ProposalTimingConfig - { draftTime :: POSIXTime - -- ^ "D": the length of the draft period. - , votingTime :: POSIXTime - -- ^ "V": the length of the voting period. - , lockingTime :: POSIXTime - -- ^ "L": the length of the locking period. - , executingTime :: POSIXTime - -- ^ "E": the length of the execution period. - } - deriving stock - ( -- | @since 0.1.0 - Eq - , -- | @since 0.1.0 - Show - , -- | @since 0.1.0 - Generic - ) - -PlutusTx.makeIsDataIndexed 'ProposalTimingConfig [('ProposalTimingConfig, 0)] - -- | Represents the maximum width of a 'PlutusLedgerApi.V1.Time.POSIXTimeRange'. newtype MaxTimeRangeWidth = MaxTimeRangeWidth {getMaxWidth :: POSIXTime} deriving stock @@ -134,8 +109,41 @@ newtype MaxTimeRangeWidth = MaxTimeRangeWidth {getMaxWidth :: POSIXTime} PlutusTx.FromData , -- | @since 0.1.0 PlutusTx.UnsafeFromData + , -- | @since 1.0.0 + Num ) +{- | Configuration of proposal timings. + + See: https://liqwid.notion.site/Proposals-589853145a994057aa77f397079f75e4#d25ea378768d4c76b52dd4c1b6bc0fcd + + @since 0.1.0 +-} +data ProposalTimingConfig = ProposalTimingConfig + { draftTime :: POSIXTime + -- ^ "D": the length of the draft period. + , votingTime :: POSIXTime + -- ^ "V": the length of the voting period. + , lockingTime :: POSIXTime + -- ^ "L": the length of the locking period. + , executingTime :: POSIXTime + -- ^ "E": the length of the execution period. + , minStakeVotingTime :: POSIXTime + -- ^ Minimum time from creating a voting lock until it can be destroyed. + , votingTimeRangeMaxWidth :: MaxTimeRangeWidth + -- ^ The maximum width of transaction time range while voting. + } + deriving stock + ( -- | @since 0.1.0 + Eq + , -- | @since 0.1.0 + Show + , -- | @since 0.1.0 + Generic + ) + +PlutusTx.makeIsDataIndexed 'ProposalTimingConfig [('ProposalTimingConfig, 0)] + -------------------------------------------------------------------------------- {- | == Establishing timing in Proposal interactions. @@ -210,6 +218,8 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig , "votingTime" ':= PPOSIXTime , "lockingTime" ':= PPOSIXTime , "executingTime" ':= PPOSIXTime + , "minStakeVotingTime" ':= PPOSIXTime + , "votingTimeRangeMaxWidth" ':= PMaxTimeRangeWidth ] ) } @@ -264,6 +274,8 @@ newtype PMaxTimeRangeWidth (s :: S) POrd , -- | @since 0.2.1 PShow + , -- | @since 0.2.1 + PNum ) instance DerivePlutusType PMaxTimeRangeWidth where @@ -307,6 +319,8 @@ pisProposalTimingConfigValid = phoistAcyclic $ , confF.votingTime , confF.lockingTime , confF.executingTime + , confF.minStakeVotingTime + , pto confF.votingTimeRangeMaxWidth ] {- | Return true if the maximum time width is greater than 0. @@ -326,7 +340,7 @@ pisMaxTimeRangeWidthValid = @since 1.0.0 -} -validateProposalStartingTime :: +pvalidateProposalStartingTime :: forall (s :: S). Term s @@ -335,24 +349,23 @@ validateProposalStartingTime :: :--> PProposalStartingTime :--> PBool ) -validateProposalStartingTime = phoistAcyclic $ - plam $ \(pto -> maxDuration) iv (pto -> st) -> +pvalidateProposalStartingTime = phoistAcyclic $ + plam $ \maxWidth iv (pto -> st) -> pmaybe # pconstant False # plam ( \ct -> - let duration = pcurrentTimeDuration # ct - isTightEnough = + let isTightEnough = ptraceIfFalse "createProposalStartingTime: given time range should be tight enough" - $ duration #<= maxDuration + $ psatisfyMaximumWidth # maxWidth # ct isInCurrentTimeRange = ptraceIfFalse "createProposalStartingTime: starting time should be in current time range" $ pisWithinCurrentTime # st # ct in isTightEnough #&& isInCurrentTimeRange ) - # (currentProposalTime # iv) + # (pcurrentProposalTime # iv) {- | Get the current proposal time, given the 'PlutusLedgerApi.V1.txInfoValidPeriod' field. @@ -366,8 +379,8 @@ validateProposalStartingTime = phoistAcyclic $ @since 0.1.0 -} -currentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PMaybe PProposalTime) -currentProposalTime = phoistAcyclic $ +pcurrentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PMaybe PProposalTime) +pcurrentProposalTime = phoistAcyclic $ plam $ \iv -> unTermCont $ do PInterval iv' <- pmatchC iv ivf <- pletAllC iv' @@ -388,7 +401,13 @@ currentProposalTime = phoistAcyclic $ PFinite (pfromData . (pfield @"_0" #) -> d) -> pjust # d _ -> ptrace "currentProposalTime: time range should be bounded" pnothing - mkTime = phoistAcyclic $ plam $ pcon .* PCurrentTime + mkTime = phoistAcyclic $ + plam $ \lb ub -> + passert + "Upper bound bigger than lower bound" + (lb #< ub) + (pcon $ PCurrentTime lb ub) + pure $ pliftA2 # mkTime # lowerBound # upperBound {- | Represent relation between current time and a given period. @@ -496,3 +515,22 @@ pgetRelation = phoistAcyclic $ pif (plb #<= lb #&& ub #<= pub) (pcon PWithin) $ pif (pub #< lb) (pcon PAfter) $ ptraceError "pgetRelation: too early or invalid current time" + +{- | Return true if the width of given 'PProposalTime' is shorter than the + maximum. + + @since 1.0.0 +-} +psatisfyMaximumWidth :: + forall (s :: S). + Term + s + ( PMaxTimeRangeWidth + :--> PProposalTime + :--> PBool + ) +psatisfyMaximumWidth = phoistAcyclic $ + plam $ \maxWidth time -> + let width = pcurrentTimeDuration # time + max = pto maxWidth + in width #<= max diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index 19c232a..df2e3f7 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -12,11 +12,13 @@ module Agora.Stake ( -- * Haskell-land StakeDatum (..), StakeRedeemer (..), + ProposalAction (..), ProposalLock (..), -- * Plutarch-land PStakeDatum (..), PStakeRedeemer (..), + PProposalAction (..), PProposalLock (..), PStakeRole (..), @@ -42,17 +44,18 @@ module Agora.Stake ( ) where import Agora.Proposal ( + PProposalDatum, PProposalId, PProposalRedeemer, - PProposalStatus, PResultTag, ProposalId, ResultTag, ) +import Agora.Proposal.Time (PProposalTime) import Agora.SafeMoney (GTTag, StakeSTTag) import Data.Tagged (Tagged) import Generics.SOP qualified as SOP -import Plutarch.Api.V1 (PCredential) +import Plutarch.Api.V1 (PCredential, PPOSIXTime) import Plutarch.Api.V2 ( KeyGuarantees (Unsorted), PDatum, @@ -68,7 +71,6 @@ import Plutarch.DataRepr ( ) import Plutarch.Extra.Applicative (ppureIf) import Plutarch.Extra.AssetClass (PAssetClass) -import Plutarch.Extra.Field (pletAll) import Plutarch.Extra.IsData ( DerivePConstantViaDataList (DerivePConstantViaDataList), ProductIsData (ProductIsData), @@ -81,11 +83,48 @@ import Plutarch.Extra.Tagged (PTagged) import Plutarch.Extra.Traversable (pfoldMap) import Plutarch.Extra.Value (passetClassValueOfT) import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted)) -import PlutusLedgerApi.V2 (Credential) +import PlutusLedgerApi.V2 (Credential, POSIXTime) import PlutusTx qualified -------------------------------------------------------------------------------- +{- | The action that was performed on a particular proposal. + + @since 1.0.0 +-} +data ProposalAction + = -- | The stake was used to create a proposal. + -- + -- This kind of lock is placed upon the creation of a proposal, in order + -- to limit creation of proposals per stake. + -- + -- See also: https://github.com/Liqwid-Labs/agora/issues/68 + Created + | -- | The stake was used to vote on a proposal. + -- + -- This kind of lock is placed while voting on a proposal, in order to + -- prevent depositing and withdrawing when votes are in place. + Voted + ResultTag + -- ^ The option which was voted on. This allows votes to be retracted. + POSIXTime + -- ^ The upper bound of the transaction time range when the lock is created. + | -- | The stake was used to cosign a proposal.` + Cosigned + deriving stock + ( -- | @since 1.0.0 + Show + , -- | @since 1.0.0 + Generic + ) + +PlutusTx.makeIsDataIndexed + ''ProposalAction + [ ('Created, 0) + , ('Voted, 1) + , ('Cosigned, 2) + ] + {- | Locks that are stored in the stake datums for various purposes. NOTE: Due to retracting votes always being possible, @@ -111,45 +150,31 @@ import PlutusTx qualified └──────────────┘ └─────────────────┘ @ - @since 0.1.0 + @since 1.0.0 -} -data ProposalLock - = -- | The stake was used to create a proposal. - -- - -- This kind of lock is placed upon the creation of a proposal, in order - -- to limit creation of proposals per stake. - -- - -- See also: https://github.com/Liqwid-Labs/agora/issues/68 - -- - -- @since 0.2.0 - Created - ProposalId - -- ^ The identifier of the proposal. - | -- | The stake was used to vote on a proposal. - -- - -- This kind of lock is placed while voting on a proposal, in order to - -- prevent depositing and withdrawing when votes are in place. - -- - -- @since 0.2.0 - Voted - ProposalId - -- ^ The identifier of the proposal. - ResultTag - -- ^ The option which was voted on. This allows votes to be retracted. - | Cosigned ProposalId +data ProposalLock = ProposalLock + { proposalId :: ProposalId + -- ^ The identifier of the proposal. + , action :: ProposalAction + -- ^ The action that has been performed. + } deriving stock ( -- | @since 0.1.0 Show , -- | @since 0.1.0 Generic ) - -PlutusTx.makeIsDataIndexed - ''ProposalLock - [ ('Created, 0) - , ('Voted, 1) - , ('Cosigned, 2) - ] + deriving anyclass + ( -- | @since 0.1.0 + SOP.Generic + ) + deriving + ( -- | @since 0.1.0 + PlutusTx.ToData + , -- | @since 0.1.0 + PlutusTx.FromData + ) + via (ProductIsData ProposalLock) {- | Haskell-level redeemer for Stake scripts. @@ -267,6 +292,7 @@ newtype PStakeDatum (s :: S) = PStakeDatum PShow ) +-- | @since 1.0.0 instance DerivePlutusType PStakeDatum where type DPTStrat _ = PlutusTypeNewtype @@ -324,32 +350,65 @@ deriving via instance (PConstantDecl StakeRedeemer) -{- | Plutarch-level version of 'ProposalLock'. +{- | Plutarch-level version of 'ProposalAction'. - @since 0.2.0 + @since 1.0.0 -} -data PProposalLock (s :: S) - = PCreated - ( Term - s - ( PDataRecord - '["created" ':= PProposalId] - ) - ) +data PProposalAction (s :: S) + = PCreated (Term s (PDataRecord '[])) | PVoted ( Term s ( PDataRecord - '[ "votedOn" ':= PProposalId - , "votedFor" ':= PResultTag + '[ "votedFor" ':= PResultTag + , "createdAt" ':= PPOSIXTime ] ) ) - | PCosigned + | PCosigned (Term s (PDataRecord '[])) + deriving stock + ( -- | @since 1.0.0 + Generic + ) + deriving anyclass + ( -- | @since 1.0.0 + PlutusType + , -- | @since 1.0.0 + PIsData + , -- | @since 1.0.0 + PEq + , -- | @since 1.0.0 + PShow + ) + +-- | @since 1.0.0 +instance DerivePlutusType PProposalAction where + type DPTStrat _ = PlutusTypeData + +-- | @since 1.0.0 +instance PUnsafeLiftDecl PProposalAction where + type PLifted _ = ProposalAction + +-- | @since 1.0.0 +deriving via + (DerivePConstantViaData ProposalAction PProposalAction) + instance + (PConstantDecl ProposalAction) + +-- | @since 1.0.0 +instance PTryFrom PData PProposalAction + +{- | Plutarch-level version of 'ProposalLock'. + + @since 1.0.0 +-} +newtype PProposalLock (s :: S) + = PProposalLock ( Term s ( PDataRecord - '[ "cosigned" ':= PProposalId + '[ "proposalId" ':= PProposalId + , "action" ':= PProposalAction ] ) ) @@ -364,15 +423,15 @@ data PProposalLock (s :: S) PIsData , -- | @since 0.1.0 PEq + , -- | @since 1.0.0 + PDataFields , -- | @since 0.2.0 PShow ) +-- | @since 0.2.0 instance DerivePlutusType PProposalLock where - type DPTStrat _ = PlutusTypeData - --- | @since 0.1.0 -instance PTryFrom PData PProposalLock + type DPTStrat _ = PlutusTypeNewtype -- | @since 0.2.0 instance PTryFrom PData (PAsData PProposalLock) @@ -383,7 +442,7 @@ instance PUnsafeLiftDecl PProposalLock where -- | @since 0.1.0 deriving via - (DerivePConstantViaData ProposalLock PProposalLock) + (DerivePConstantViaDataList ProposalLock PProposalLock) instance (PConstantDecl ProposalLock) @@ -411,9 +470,11 @@ pnumCreatedProposals = pto $ pfoldMap # plam - ( \(pfromData -> lock) -> pmatch lock $ \case - PCreated _ -> pcon $ PSum 1 - _ -> mempty + ( \lock -> + let action = pfromData $ pfield @"action" # lock + in pmatch action $ \case + PCreated _ -> pcon $ PSum 1 + _ -> mempty ) # l @@ -524,9 +585,9 @@ instance DerivePlutusType PStakeRedeemerContext where data PProposalContext (s :: S) = -- | A proposal is spent. PSpendProposal - (Term s PProposalId) - (Term s PProposalStatus) + (Term s PProposalDatum) (Term s PProposalRedeemer) + (Term s PProposalTime) | -- | A new proposal is created. PNewProposal (Term s PProposalId) @@ -664,26 +725,17 @@ pgetStakeRoles :: ) pgetStakeRoles = phoistAcyclic $ plam $ \pid -> - pmapMaybe - # plam - ( flip - pmatch - ( \case - PCreated ((pfield @"created" #) -> pid') -> - ppureIf - # (pid' #== pid) - # pcon PCreator - PVoted r -> pletAll r $ \rF -> - ppureIf - # (rF.votedOn #== pid) - # pcon (PVoter rF.votedFor) - PCosigned ((pfield @"cosigned" #) -> pid') -> - ppureIf - # (pid' #== pid) - # pcon PCosigner - ) - . pfromData - ) + let getStakeRole = flip (pletFields @'["proposalId", "action"]) $ + \lockF -> + ppureIf + # (pid #== lockF.proposalId) + #$ pmatch lockF.action + $ \case + PCreated _ -> pcon PCreator + PVoted ((pfield @"votedFor" #) -> tag) -> + pcon $ PVoter tag + PCosigned _ -> pcon PCosigner + in pmapMaybe # plam (getStakeRole . pfromData) {- | Get the outcome that was voted for. diff --git a/agora/Agora/Stake/Redeemers.hs b/agora/Agora/Stake/Redeemers.hs index c0445f5..e71c7ed 100644 --- a/agora/Agora/Stake/Redeemers.hs +++ b/agora/Agora/Stake/Redeemers.hs @@ -19,13 +19,15 @@ import Agora.Proposal ( PProposalRedeemer (PCosign, PUnlockStake, PVote), ProposalStatus (Finished), ) +import Agora.Proposal.Time (PProposalTime) import Agora.Stake ( + PProposalAction (PCosigned, PCreated, PVoted), PProposalContext ( PNewProposal, PNoProposal, PSpendProposal ), - PProposalLock (PCosigned, PCreated, PVoted), + PProposalLock (PProposalLock), PSigContext (owner, signedBy), PSignedBy ( PSignedByDelegate, @@ -48,14 +50,20 @@ import Agora.Stake ( ), pstakeLocked, ) +import Data.Functor ((<&>)) import Plutarch.Api.V1.Address (PCredential) -import Plutarch.Api.V2 (PMaybeData) +import Plutarch.Api.V2 (PMaybeData, PPOSIXTime) import Plutarch.Extra.Bool (passert) import Plutarch.Extra.Field (pletAll, pletAllC) -import "liqwid-plutarch-extra" Plutarch.Extra.List (pisSingleton, ptryDeleteFirstBy, ptryFromSingleton) -import Plutarch.Extra.Maybe (pdjust, pdnothing, pmaybeData) +import "liqwid-plutarch-extra" Plutarch.Extra.List ( + pisSingleton, + ptryDeleteFirstBy, + ptryFromSingleton, + ) +import Plutarch.Extra.Maybe (pdjust, pdnothing, pjust, pmaybe, pmaybeData, pnothing) import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=)) -import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pmatchC) +import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC) +import Plutarch.Extra.Time (PCurrentTime (PCurrentTime)) -- | A wrapper which ensures that no proposal is presented in the transaction. pwithoutProposal :: @@ -203,32 +211,53 @@ ppermitVote = pvoteHelper #$ phoistAcyclic $ pure $ paddNewLock #$ pmatch ctxF.proposalContext $ \case - PSpendProposal pid _ r -> pmatch r $ \case - PVote ((pfromData . (pfield @"resultTag" #)) -> voteFor) -> - passert - "Owner or delegatee signs the transaction" - (pisSignedBy # pconstant True # ctx) - $ mkRecordConstr - PVoted - ( #votedOn - .= pdata pid - .& #votedFor - .= pdata voteFor + PSpendProposal proposal redeemer currentTime -> unTermCont $ do + mkLock <- pletC $ + plam $ \action -> + mkRecordConstr + PProposalLock + ( #proposalId + .= pfield @"proposalId" + # proposal + .& #action + .= pdata action ) - PCosign _ -> - withOnlyOneStakeInput - #$ mkRecordConstr - PCosigned - ( #cosigned .= pdata pid - ) - _ -> ptraceError "Expected Vote" - PNewProposal pid -> - withOnlyOneStakeInput - #$ mkRecordConstr - PCreated - ( #created .= pdata pid - ) - _ -> ptraceError "Expected proposal" + + pure $ + pmatch redeemer $ \case + PVote ((pfromData . (pfield @"resultTag" #)) -> voteFor) -> + unTermCont $ do + pguardC "Owner or delegatee signs the transaction" $ + pisSignedBy # pconstant True # ctx + + PCurrentTime _ upperBound <- pmatchC currentTime + + let action = + mkRecordConstr + PVoted + ( #votedFor + .= pdata voteFor + .& #createdAt + .= pdata upperBound + ) + + pure $ mkLock # action + PCosign _ -> + let action = pcon $ PCosigned pdnil + in withOnlyOneStakeInput #$ mkLock # action + _ -> ptraceError "Expected Vote or Cosign" + PNewProposal proposalId -> + let action = pcon $ PCreated pdnil + lock = + mkRecordConstr + PProposalLock + ( #proposalId + .= pdata proposalId + .& #action + .= pdata action + ) + in withOnlyOneStakeInput # lock + _ -> ptraceError "Expected a proposal to be spent or created" data PRemoveLocksMode (s :: S) = PRemoveVoterLockOnly | PRemoveAllLocks deriving stock (Generic) @@ -238,33 +267,59 @@ instance DerivePlutusType PRemoveLocksMode where type DPTStrat _ = PlutusTypeScott {- | Remove stake locks with the proposal id given the list of existing locks. - The first parameter controls whether to revmove creator locks or not. + The first parameter controls whether to revmove creator locks or not. If + one of the locks performed voting action, the unlock cooldown will be + checked if it's given. -} premoveLocks :: forall (s :: S). Term s ( PProposalId + :--> PMaybe PPOSIXTime + :--> PProposalTime :--> PRemoveLocksMode :--> PBuiltinList (PAsData PProposalLock) :--> PBuiltinList (PAsData PProposalLock) ) -premoveLocks = phoistAcyclic $ - plam $ \pid rl -> unTermCont $ do - shouldRemoveOtherLocks <- pletC $ - plam $ \pid' -> - pid' #== pid #&& rl #== pcon PRemoveAllLocks +premoveLocks = + phoistAcyclic $ + plam $ \proposalId unlockCooldown currentTime mode -> unTermCont $ do + shouldRemoveAllLocks <- pletC $ mode #== pcon PRemoveAllLocks - pure $ - pfilter - # plam - ( \(pfromData -> l) -> pnot #$ pmatch l $ \case - PCosigned ((pfield @"cosigned" #) -> pid') -> - shouldRemoveOtherLocks # pid' - PCreated ((pfield @"created" #) -> pid') -> - shouldRemoveOtherLocks # pid' - PVoted ((pfield @"votedOn" #) -> pid') -> pid' #== pid - ) + PCurrentTime lowerBound _ <- pmatchC currentTime + + let handleVoter + ( (pfield @"createdAt" #) -> + createdAt + ) = + let notInCooldown = + pmaybe + # pconstant True + # plam (\c -> createdAt + c #<= lowerBound) + # unlockCooldown + in foldl1 + (#||) + [ shouldRemoveAllLocks + , ptraceIfFalse "Stake lock in cooldown" notInCooldown + ] + + handleLock = + plam $ + flip + pletAll + ( \lockF -> + foldl1 + (#&&) + [ proposalId #== lockF.proposalId + , pmatch lockF.action $ \case + PVoted r -> handleVoter r + _ -> shouldRemoveAllLocks + ] + ) + . pfromData + + pure $ pfilter # handleLock {- | Default implementation of 'Agora.Stake.RetractVotes'. @@ -275,18 +330,38 @@ pretractVote = pvoteHelper #$ phoistAcyclic $ plam $ \ctx -> pmatch ctx $ \ctxF -> pmatch ctxF.proposalContext $ \case - PSpendProposal pid s r -> pmatch r $ \case - PUnlockStake _ -> - let mode = - pif - (s #== pconstant Finished) - (pcon PRemoveAllLocks) - (pcon PRemoveVoterLockOnly) - authorized = pisSignedBy # pconstant True # ctx - in passert - "Authorized by owner or delegatee" - authorized - $ premoveLocks # pid # mode + PSpendProposal proposal redeemer currentTime -> pmatch redeemer $ \case + PUnlockStake _ -> unTermCont $ do + proposalF <- + pletFieldsC + @'[ "proposalId" + , "status" + , "timingConfig" + ] + proposal + + (mode, unlockCooldown) <- + pmatchC (proposalF.status #== pconstant Finished) <&> \case + PTrue -> + ( pcon PRemoveAllLocks + , pnothing + ) + _ -> + ( pcon PRemoveVoterLockOnly + , pjust + #$ pfield @"minStakeVotingTime" + # proposalF.timingConfig + ) + + pguardC "Authorized by either opwner or delegatee" $ + pisSignedBy # pconstant True # ctx + + pure $ + premoveLocks + # proposalF.proposalId + # unlockCooldown + # currentTime + # mode _ -> ptraceError "Expected unlock" _ -> ptraceError "Expected spending proposal" diff --git a/agora/Agora/Stake/Scripts.hs b/agora/Agora/Stake/Scripts.hs index 24d407d..aaa6582 100644 --- a/agora/Agora/Stake/Scripts.hs +++ b/agora/Agora/Stake/Scripts.hs @@ -13,6 +13,7 @@ module Agora.Stake.Scripts ( import Agora.Credential (authorizationContext, pauthorizedBy) import Agora.Proposal (PProposalDatum, PProposalRedeemer) +import Agora.Proposal.Time (pcurrentProposalTime) import Agora.SafeMoney (GTTag, ProposalSTTag, StakeSTTag) import Agora.Stake ( PProposalContext ( @@ -256,6 +257,7 @@ mkStakeValidator impl sstSymbol pstClass gtClass = , "signatories" , "redeemers" , "datums" + , "validRange" ] txInfo @@ -482,10 +484,13 @@ mkStakeValidator impl sstSymbol pstClass gtClass = pfmap # plam ( \proposalDatum -> - let id = pfield @"proposalId" # proposalDatum - status = pfield @"status" # proposalDatum - redeemer = getProposalRedeemer # inInfoF.outRef - in pcon $ PSpendProposal id status redeemer + let redeemer = getProposalRedeemer # inInfoF.outRef + currentTime = + passertPJust + # "Should resolve proposal time" + #$ pcurrentProposalTime + # txInfoF.validRange + in pcon $ PSpendProposal proposalDatum redeemer currentTime ) #$ getProposalDatum # pfromData inInfoF.resolved