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

implement cooldown period for stake unlocking

Browse source
This commit is contained in:
Hongrui Fang 2022-11-11 17:59:41 +08:00
parent fadd6ca2da
commit a462e6a3d3
No known key found for this signature in database
GPG key ID: F10AB2CCE24113DD
6 changed files with 378 additions and 194 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -35,7 +35,7 @@ import Agora.Proposal (
pneutralOption, pneutralOption,
pwinner, pwinner,
) )
import Agora.Proposal.Time (validateProposalStartingTime) import Agora.Proposal.Time (pvalidateProposalStartingTime)
import Agora.SafeMoney (AuthorityTokenTag, GovernorSTTag, ProposalSTTag, StakeSTTag) import Agora.SafeMoney (AuthorityTokenTag, GovernorSTTag, ProposalSTTag, StakeSTTag)
import Agora.Stake ( import Agora.Stake (
pnumCreatedProposals, pnumCreatedProposals,
@ -453,7 +453,7 @@ governorValidator =
, ptraceIfFalse "cosigners correct" $ , ptraceIfFalse "cosigners correct" $
plistEquals # pfromData proposalOutputDatumF.cosigners # expectedCosigners plistEquals # pfromData proposalOutputDatumF.cosigners # expectedCosigners
, ptraceIfFalse "starting time valid" $ , ptraceIfFalse "starting time valid" $
validateProposalStartingTime pvalidateProposalStartingTime
# governorInputDatumF.createProposalTimeRangeMaxWidth # governorInputDatumF.createProposalTimeRangeMaxWidth
# txInfoF.validRange # txInfoF.validRange
# proposalOutputDatumF.startingTime # proposalOutputDatumF.startingTime

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

@ -23,9 +23,10 @@ import Agora.Proposal (
import Agora.Proposal.Time ( import Agora.Proposal.Time (
PPeriod (PDraftingPeriod, PExecutingPeriod, PLockingPeriod, PVotingPeriod), PPeriod (PDraftingPeriod, PExecutingPeriod, PLockingPeriod, PVotingPeriod),
PTimingRelation (PAfter, PWithin), PTimingRelation (PAfter, PWithin),
currentProposalTime, pcurrentProposalTime,
pgetRelation, pgetRelation,
pisWithin, pisWithin,
psatisfyMaximumWidth,
) )
import Agora.SafeMoney (GovernorSTTag, ProposalSTTag, StakeSTTag) import Agora.SafeMoney (GovernorSTTag, ProposalSTTag, StakeSTTag)
import Agora.Stake ( import Agora.Stake (
@ -82,6 +83,7 @@ import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
pmatchC, pmatchC,
ptryFromC, ptryFromC,
) )
import Plutarch.Extra.Time (PCurrentTime)
import Plutarch.Extra.Traversable (pfoldMap) import Plutarch.Extra.Traversable (pfoldMap)
import Plutarch.Extra.Value (psymbolValueOf') import Plutarch.Extra.Value (psymbolValueOf')
import Plutarch.Unsafe (punsafeCoerce) 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' <- getTimingRelation' <-
pletC $ pletC $
let currentTime = withCurrentTime $
passertPJust pgetRelation
# "Current time should be resolved" # proposalInputDatumF.timingConfig
#$ currentProposalTime # proposalInputDatumF.startingTime
# txInfoF.validRange
in pgetRelation
# proposalInputDatumF.timingConfig
# proposalInputDatumF.startingTime
# currentTime
let getTimingRelation = (getTimingRelation' #) . pcon let getTimingRelation = (getTimingRelation' #) . pcon
@ -502,6 +510,12 @@ proposalValidator =
pguardC "Proposal time should be wthin the voting period" $ pguardC "Proposal time should be wthin the voting period" $
pisWithin # getTimingRelation PVotingPeriod 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). -- Ensure the transaction is voting to a valid 'ResultTag'(outcome).
PProposalVotes voteMap <- pmatchC proposalInputDatumF.votes PProposalVotes voteMap <- pmatchC proposalInputDatumF.votes
voteFor <- pletC $ pfromData $ pfield @"resultTag" # r voteFor <- pletC $ pfromData $ pfield @"resultTag" # r

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

@ -22,15 +22,15 @@ module Agora.Proposal.Time (
PPeriod (..), PPeriod (..),
-- * Compute periods given config and starting time. -- * Compute periods given config and starting time.
validateProposalStartingTime, pvalidateProposalStartingTime,
currentProposalTime, pcurrentProposalTime,
pisProposalTimingConfigValid, pisProposalTimingConfigValid,
pisMaxTimeRangeWidthValid, pisMaxTimeRangeWidthValid,
pgetRelation, pgetRelation,
pisWithin, pisWithin,
psatisfyMaximumWidth,
) where ) where
import Control.Composition ((.*))
import Data.Functor ((<&>)) import Data.Functor ((<&>))
import Plutarch.Api.V1 ( import Plutarch.Api.V1 (
PExtended (PFinite), PExtended (PFinite),
@ -45,6 +45,7 @@ import Plutarch.DataRepr (
PDataFields, PDataFields,
) )
import Plutarch.Extra.Applicative (PApply (pliftA2)) import Plutarch.Extra.Applicative (PApply (pliftA2))
import Plutarch.Extra.Bool (passert)
import Plutarch.Extra.Field (pletAll, pletAllC) import Plutarch.Extra.Field (pletAll, pletAllC)
import Plutarch.Extra.IsData (PlutusTypeEnumData) import Plutarch.Extra.IsData (PlutusTypeEnumData)
import Plutarch.Extra.Maybe (pjust, pmaybe, pnothing) import Plutarch.Extra.Maybe (pjust, pmaybe, pnothing)
@ -59,6 +60,7 @@ import Plutarch.Lift (
PConstantDecl, PConstantDecl,
PUnsafeLiftDecl (PLifted), PUnsafeLiftDecl (PLifted),
) )
import Plutarch.Num (PNum)
import PlutusLedgerApi.V1 (POSIXTime) import PlutusLedgerApi.V1 (POSIXTime)
import PlutusTx qualified import PlutusTx qualified
@ -88,33 +90,6 @@ newtype ProposalStartingTime = ProposalStartingTime
PlutusTx.UnsafeFromData 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'. -- | Represents the maximum width of a 'PlutusLedgerApi.V1.Time.POSIXTimeRange'.
newtype MaxTimeRangeWidth = MaxTimeRangeWidth {getMaxWidth :: POSIXTime} newtype MaxTimeRangeWidth = MaxTimeRangeWidth {getMaxWidth :: POSIXTime}
deriving stock deriving stock
@ -134,8 +109,41 @@ newtype MaxTimeRangeWidth = MaxTimeRangeWidth {getMaxWidth :: POSIXTime}
PlutusTx.FromData PlutusTx.FromData
, -- | @since 0.1.0 , -- | @since 0.1.0
PlutusTx.UnsafeFromData 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. {- | == Establishing timing in Proposal interactions.
@ -210,6 +218,8 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
, "votingTime" ':= PPOSIXTime , "votingTime" ':= PPOSIXTime
, "lockingTime" ':= PPOSIXTime , "lockingTime" ':= PPOSIXTime
, "executingTime" ':= PPOSIXTime , "executingTime" ':= PPOSIXTime
, "minStakeVotingTime" ':= PPOSIXTime
, "votingTimeRangeMaxWidth" ':= PMaxTimeRangeWidth
] ]
) )
} }
@ -264,6 +274,8 @@ newtype PMaxTimeRangeWidth (s :: S)
POrd POrd
, -- | @since 0.2.1 , -- | @since 0.2.1
PShow PShow
, -- | @since 0.2.1
PNum
) )
instance DerivePlutusType PMaxTimeRangeWidth where instance DerivePlutusType PMaxTimeRangeWidth where
@ -307,6 +319,8 @@ pisProposalTimingConfigValid = phoistAcyclic $
, confF.votingTime , confF.votingTime
, confF.lockingTime , confF.lockingTime
, confF.executingTime , confF.executingTime
, confF.minStakeVotingTime
, pto confF.votingTimeRangeMaxWidth
] ]
{- | Return true if the maximum time width is greater than 0. {- | Return true if the maximum time width is greater than 0.
@ -326,7 +340,7 @@ pisMaxTimeRangeWidthValid =
@since 1.0.0 @since 1.0.0
-} -}
validateProposalStartingTime :: pvalidateProposalStartingTime ::
forall (s :: S). forall (s :: S).
Term Term
s s
@ -335,24 +349,23 @@ validateProposalStartingTime ::
:--> PProposalStartingTime :--> PProposalStartingTime
:--> PBool :--> PBool
) )
validateProposalStartingTime = phoistAcyclic $ pvalidateProposalStartingTime = phoistAcyclic $
plam $ \(pto -> maxDuration) iv (pto -> st) -> plam $ \maxWidth iv (pto -> st) ->
pmaybe pmaybe
# pconstant False # pconstant False
# plam # plam
( \ct -> ( \ct ->
let duration = pcurrentTimeDuration # ct let isTightEnough =
isTightEnough =
ptraceIfFalse ptraceIfFalse
"createProposalStartingTime: given time range should be tight enough" "createProposalStartingTime: given time range should be tight enough"
$ duration #<= maxDuration $ psatisfyMaximumWidth # maxWidth # ct
isInCurrentTimeRange = isInCurrentTimeRange =
ptraceIfFalse ptraceIfFalse
"createProposalStartingTime: starting time should be in current time range" "createProposalStartingTime: starting time should be in current time range"
$ pisWithinCurrentTime # st # ct $ pisWithinCurrentTime # st # ct
in isTightEnough #&& isInCurrentTimeRange in isTightEnough #&& isInCurrentTimeRange
) )
# (currentProposalTime # iv) # (pcurrentProposalTime # iv)
{- | Get the current proposal time, given the 'PlutusLedgerApi.V1.txInfoValidPeriod' field. {- | Get the current proposal time, given the 'PlutusLedgerApi.V1.txInfoValidPeriod' field.
@ -366,8 +379,8 @@ validateProposalStartingTime = phoistAcyclic $
@since 0.1.0 @since 0.1.0
-} -}
currentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PMaybe PProposalTime) pcurrentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PMaybe PProposalTime)
currentProposalTime = phoistAcyclic $ pcurrentProposalTime = phoistAcyclic $
plam $ \iv -> unTermCont $ do plam $ \iv -> unTermCont $ do
PInterval iv' <- pmatchC iv PInterval iv' <- pmatchC iv
ivf <- pletAllC iv' ivf <- pletAllC iv'
@ -388,7 +401,13 @@ currentProposalTime = phoistAcyclic $
PFinite (pfromData . (pfield @"_0" #) -> d) -> pjust # d PFinite (pfromData . (pfield @"_0" #) -> d) -> pjust # d
_ -> ptrace "currentProposalTime: time range should be bounded" pnothing _ -> 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 pure $ pliftA2 # mkTime # lowerBound # upperBound
{- | Represent relation between current time and a given period. {- | Represent relation between current time and a given period.
@ -496,3 +515,22 @@ pgetRelation = phoistAcyclic $
pif (plb #<= lb #&& ub #<= pub) (pcon PWithin) $ pif (plb #<= lb #&& ub #<= pub) (pcon PWithin) $
pif (pub #< lb) (pcon PAfter) $ pif (pub #< lb) (pcon PAfter) $
ptraceError "pgetRelation: too early or invalid current time" 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

212
agora/Agora/Stake.hs
View file

@ -12,11 +12,13 @@ module Agora.Stake (
-- * Haskell-land -- * Haskell-land
StakeDatum (..), StakeDatum (..),
StakeRedeemer (..), StakeRedeemer (..),
ProposalAction (..),
ProposalLock (..), ProposalLock (..),
-- * Plutarch-land -- * Plutarch-land
PStakeDatum (..), PStakeDatum (..),
PStakeRedeemer (..), PStakeRedeemer (..),
PProposalAction (..),
PProposalLock (..), PProposalLock (..),
PStakeRole (..), PStakeRole (..),
@ -42,17 +44,18 @@ module Agora.Stake (
) where ) where
import Agora.Proposal ( import Agora.Proposal (
PProposalDatum,
PProposalId, PProposalId,
PProposalRedeemer, PProposalRedeemer,
PProposalStatus,
PResultTag, PResultTag,
ProposalId, ProposalId,
ResultTag, ResultTag,
) )
import Agora.Proposal.Time (PProposalTime)
import Agora.SafeMoney (GTTag, StakeSTTag) import Agora.SafeMoney (GTTag, StakeSTTag)
import Data.Tagged (Tagged) import Data.Tagged (Tagged)
import Generics.SOP qualified as SOP import Generics.SOP qualified as SOP
import Plutarch.Api.V1 (PCredential) import Plutarch.Api.V1 (PCredential, PPOSIXTime)
import Plutarch.Api.V2 ( import Plutarch.Api.V2 (
KeyGuarantees (Unsorted), KeyGuarantees (Unsorted),
PDatum, PDatum,
@ -68,7 +71,6 @@ import Plutarch.DataRepr (
) )
import Plutarch.Extra.Applicative (ppureIf) import Plutarch.Extra.Applicative (ppureIf)
import Plutarch.Extra.AssetClass (PAssetClass) import Plutarch.Extra.AssetClass (PAssetClass)
import Plutarch.Extra.Field (pletAll)
import Plutarch.Extra.IsData ( import Plutarch.Extra.IsData (
DerivePConstantViaDataList (DerivePConstantViaDataList), DerivePConstantViaDataList (DerivePConstantViaDataList),
ProductIsData (ProductIsData), ProductIsData (ProductIsData),
@ -81,11 +83,48 @@ import Plutarch.Extra.Tagged (PTagged)
import Plutarch.Extra.Traversable (pfoldMap) import Plutarch.Extra.Traversable (pfoldMap)
import Plutarch.Extra.Value (passetClassValueOfT) import Plutarch.Extra.Value (passetClassValueOfT)
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted)) import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
import PlutusLedgerApi.V2 (Credential) import PlutusLedgerApi.V2 (Credential, POSIXTime)
import PlutusTx qualified 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. {- | Locks that are stored in the stake datums for various purposes.
NOTE: Due to retracting votes always being possible, 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 data ProposalLock = ProposalLock
= -- | The stake was used to create a proposal. { proposalId :: ProposalId
-- -- ^ The identifier of the proposal.
-- This kind of lock is placed upon the creation of a proposal, in order , action :: ProposalAction
-- to limit creation of proposals per stake. -- ^ The action that has been performed.
-- }
-- 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
deriving stock deriving stock
( -- | @since 0.1.0 ( -- | @since 0.1.0
Show Show
, -- | @since 0.1.0 , -- | @since 0.1.0
Generic Generic
) )
deriving anyclass
PlutusTx.makeIsDataIndexed ( -- | @since 0.1.0
''ProposalLock SOP.Generic
[ ('Created, 0) )
, ('Voted, 1) deriving
, ('Cosigned, 2) ( -- | @since 0.1.0
] PlutusTx.ToData
, -- | @since 0.1.0
PlutusTx.FromData
)
via (ProductIsData ProposalLock)
{- | Haskell-level redeemer for Stake scripts. {- | Haskell-level redeemer for Stake scripts.
@ -267,6 +292,7 @@ newtype PStakeDatum (s :: S) = PStakeDatum
PShow PShow
) )
-- | @since 1.0.0
instance DerivePlutusType PStakeDatum where instance DerivePlutusType PStakeDatum where
type DPTStrat _ = PlutusTypeNewtype type DPTStrat _ = PlutusTypeNewtype
@ -324,32 +350,65 @@ deriving via
instance instance
(PConstantDecl StakeRedeemer) (PConstantDecl StakeRedeemer)
{- | Plutarch-level version of 'ProposalLock'. {- | Plutarch-level version of 'ProposalAction'.
@since 0.2.0 @since 1.0.0
-} -}
data PProposalLock (s :: S) data PProposalAction (s :: S)
= PCreated = PCreated (Term s (PDataRecord '[]))
( Term
s
( PDataRecord
'["created" ':= PProposalId]
)
)
| PVoted | PVoted
( Term ( Term
s s
( PDataRecord ( 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 ( Term
s s
( PDataRecord ( PDataRecord
'[ "cosigned" ':= PProposalId '[ "proposalId" ':= PProposalId
, "action" ':= PProposalAction
] ]
) )
) )
@ -364,15 +423,15 @@ data PProposalLock (s :: S)
PIsData PIsData
, -- | @since 0.1.0 , -- | @since 0.1.0
PEq PEq
, -- | @since 1.0.0
PDataFields
, -- | @since 0.2.0 , -- | @since 0.2.0
PShow PShow
) )
-- | @since 0.2.0
instance DerivePlutusType PProposalLock where instance DerivePlutusType PProposalLock where
type DPTStrat _ = PlutusTypeData type DPTStrat _ = PlutusTypeNewtype
-- | @since 0.1.0
instance PTryFrom PData PProposalLock
-- | @since 0.2.0 -- | @since 0.2.0
instance PTryFrom PData (PAsData PProposalLock) instance PTryFrom PData (PAsData PProposalLock)
@ -383,7 +442,7 @@ instance PUnsafeLiftDecl PProposalLock where
-- | @since 0.1.0 -- | @since 0.1.0
deriving via deriving via
(DerivePConstantViaData ProposalLock PProposalLock) (DerivePConstantViaDataList ProposalLock PProposalLock)
instance instance
(PConstantDecl ProposalLock) (PConstantDecl ProposalLock)
@ -411,9 +470,11 @@ pnumCreatedProposals =
pto $ pto $
pfoldMap pfoldMap
# plam # plam
( \(pfromData -> lock) -> pmatch lock $ \case ( \lock ->
PCreated _ -> pcon $ PSum 1 let action = pfromData $ pfield @"action" # lock
_ -> mempty in pmatch action $ \case
PCreated _ -> pcon $ PSum 1
_ -> mempty
) )
# l # l
@ -524,9 +585,9 @@ instance DerivePlutusType PStakeRedeemerContext where
data PProposalContext (s :: S) data PProposalContext (s :: S)
= -- | A proposal is spent. = -- | A proposal is spent.
PSpendProposal PSpendProposal
(Term s PProposalId) (Term s PProposalDatum)
(Term s PProposalStatus)
(Term s PProposalRedeemer) (Term s PProposalRedeemer)
(Term s PProposalTime)
| -- | A new proposal is created. | -- | A new proposal is created.
PNewProposal PNewProposal
(Term s PProposalId) (Term s PProposalId)
@ -664,26 +725,17 @@ pgetStakeRoles ::
) )
pgetStakeRoles = phoistAcyclic $ pgetStakeRoles = phoistAcyclic $
plam $ \pid -> plam $ \pid ->
pmapMaybe let getStakeRole = flip (pletFields @'["proposalId", "action"]) $
# plam \lockF ->
( flip ppureIf
pmatch # (pid #== lockF.proposalId)
( \case #$ pmatch lockF.action
PCreated ((pfield @"created" #) -> pid') -> $ \case
ppureIf PCreated _ -> pcon PCreator
# (pid' #== pid) PVoted ((pfield @"votedFor" #) -> tag) ->
# pcon PCreator pcon $ PVoter tag
PVoted r -> pletAll r $ \rF -> PCosigned _ -> pcon PCosigner
ppureIf in pmapMaybe # plam (getStakeRole . pfromData)
# (rF.votedOn #== pid)
# pcon (PVoter rF.votedFor)
PCosigned ((pfield @"cosigned" #) -> pid') ->
ppureIf
# (pid' #== pid)
# pcon PCosigner
)
. pfromData
)
{- | Get the outcome that was voted for. {- | Get the outcome that was voted for.

191
agora/Agora/Stake/Redeemers.hs
View file

@ -19,13 +19,15 @@ import Agora.Proposal (
PProposalRedeemer (PCosign, PUnlockStake, PVote), PProposalRedeemer (PCosign, PUnlockStake, PVote),
ProposalStatus (Finished), ProposalStatus (Finished),
) )
import Agora.Proposal.Time (PProposalTime)
import Agora.Stake ( import Agora.Stake (
PProposalAction (PCosigned, PCreated, PVoted),
PProposalContext ( PProposalContext (
PNewProposal, PNewProposal,
PNoProposal, PNoProposal,
PSpendProposal PSpendProposal
), ),
PProposalLock (PCosigned, PCreated, PVoted), PProposalLock (PProposalLock),
PSigContext (owner, signedBy), PSigContext (owner, signedBy),
PSignedBy ( PSignedBy (
PSignedByDelegate, PSignedByDelegate,
@ -48,14 +50,20 @@ import Agora.Stake (
), ),
pstakeLocked, pstakeLocked,
) )
import Data.Functor ((<&>))
import Plutarch.Api.V1.Address (PCredential) 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.Bool (passert)
import Plutarch.Extra.Field (pletAll, pletAllC) import Plutarch.Extra.Field (pletAll, pletAllC)
import "liqwid-plutarch-extra" Plutarch.Extra.List (pisSingleton, ptryDeleteFirstBy, ptryFromSingleton) import "liqwid-plutarch-extra" Plutarch.Extra.List (
import Plutarch.Extra.Maybe (pdjust, pdnothing, pmaybeData) pisSingleton,
ptryDeleteFirstBy,
ptryFromSingleton,
)
import Plutarch.Extra.Maybe (pdjust, pdnothing, pjust, pmaybe, pmaybeData, pnothing)
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=)) 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. -- | A wrapper which ensures that no proposal is presented in the transaction.
pwithoutProposal :: pwithoutProposal ::
@ -203,32 +211,53 @@ ppermitVote = pvoteHelper #$ phoistAcyclic $
pure $ pure $
paddNewLock #$ pmatch ctxF.proposalContext $ \case paddNewLock #$ pmatch ctxF.proposalContext $ \case
PSpendProposal pid _ r -> pmatch r $ \case PSpendProposal proposal redeemer currentTime -> unTermCont $ do
PVote ((pfromData . (pfield @"resultTag" #)) -> voteFor) -> mkLock <- pletC $
passert plam $ \action ->
"Owner or delegatee signs the transaction" mkRecordConstr
(pisSignedBy # pconstant True # ctx) PProposalLock
$ mkRecordConstr ( #proposalId
PVoted .= pfield @"proposalId"
( #votedOn # proposal
.= pdata pid .& #action
.& #votedFor .= pdata action
.= pdata voteFor
) )
PCosign _ ->
withOnlyOneStakeInput pure $
#$ mkRecordConstr pmatch redeemer $ \case
PCosigned PVote ((pfromData . (pfield @"resultTag" #)) -> voteFor) ->
( #cosigned .= pdata pid unTermCont $ do
) pguardC "Owner or delegatee signs the transaction" $
_ -> ptraceError "Expected Vote" pisSignedBy # pconstant True # ctx
PNewProposal pid ->
withOnlyOneStakeInput PCurrentTime _ upperBound <- pmatchC currentTime
#$ mkRecordConstr
PCreated let action =
( #created .= pdata pid mkRecordConstr
) PVoted
_ -> ptraceError "Expected proposal" ( #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 data PRemoveLocksMode (s :: S) = PRemoveVoterLockOnly | PRemoveAllLocks
deriving stock (Generic) deriving stock (Generic)
@ -238,33 +267,59 @@ instance DerivePlutusType PRemoveLocksMode where
type DPTStrat _ = PlutusTypeScott type DPTStrat _ = PlutusTypeScott
{- | Remove stake locks with the proposal id given the list of existing locks. {- | 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 :: premoveLocks ::
forall (s :: S). forall (s :: S).
Term Term
s s
( PProposalId ( PProposalId
:--> PMaybe PPOSIXTime
:--> PProposalTime
:--> PRemoveLocksMode :--> PRemoveLocksMode
:--> PBuiltinList (PAsData PProposalLock) :--> PBuiltinList (PAsData PProposalLock)
:--> PBuiltinList (PAsData PProposalLock) :--> PBuiltinList (PAsData PProposalLock)
) )
premoveLocks = phoistAcyclic $ premoveLocks =
plam $ \pid rl -> unTermCont $ do phoistAcyclic $
shouldRemoveOtherLocks <- pletC $ plam $ \proposalId unlockCooldown currentTime mode -> unTermCont $ do
plam $ \pid' -> shouldRemoveAllLocks <- pletC $ mode #== pcon PRemoveAllLocks
pid' #== pid #&& rl #== pcon PRemoveAllLocks
pure $ PCurrentTime lowerBound _ <- pmatchC currentTime
pfilter
# plam let handleVoter
( \(pfromData -> l) -> pnot #$ pmatch l $ \case ( (pfield @"createdAt" #) ->
PCosigned ((pfield @"cosigned" #) -> pid') -> createdAt
shouldRemoveOtherLocks # pid' ) =
PCreated ((pfield @"created" #) -> pid') -> let notInCooldown =
shouldRemoveOtherLocks # pid' pmaybe
PVoted ((pfield @"votedOn" #) -> pid') -> pid' #== pid # 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'. {- | Default implementation of 'Agora.Stake.RetractVotes'.
@ -275,18 +330,38 @@ pretractVote = pvoteHelper #$ phoistAcyclic $
plam $ \ctx -> plam $ \ctx ->
pmatch ctx $ \ctxF -> pmatch ctx $ \ctxF ->
pmatch ctxF.proposalContext $ \case pmatch ctxF.proposalContext $ \case
PSpendProposal pid s r -> pmatch r $ \case PSpendProposal proposal redeemer currentTime -> pmatch redeemer $ \case
PUnlockStake _ -> PUnlockStake _ -> unTermCont $ do
let mode = proposalF <-
pif pletFieldsC
(s #== pconstant Finished) @'[ "proposalId"
(pcon PRemoveAllLocks) , "status"
(pcon PRemoveVoterLockOnly) , "timingConfig"
authorized = pisSignedBy # pconstant True # ctx ]
in passert proposal
"Authorized by owner or delegatee"
authorized (mode, unlockCooldown) <-
$ premoveLocks # pid # mode 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 unlock"
_ -> ptraceError "Expected spending proposal" _ -> ptraceError "Expected spending proposal"

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

@ -13,6 +13,7 @@ module Agora.Stake.Scripts (
import Agora.Credential (authorizationContext, pauthorizedBy) import Agora.Credential (authorizationContext, pauthorizedBy)
import Agora.Proposal (PProposalDatum, PProposalRedeemer) import Agora.Proposal (PProposalDatum, PProposalRedeemer)
import Agora.Proposal.Time (pcurrentProposalTime)
import Agora.SafeMoney (GTTag, ProposalSTTag, StakeSTTag) import Agora.SafeMoney (GTTag, ProposalSTTag, StakeSTTag)
import Agora.Stake ( import Agora.Stake (
PProposalContext ( PProposalContext (
@ -256,6 +257,7 @@ mkStakeValidator impl sstSymbol pstClass gtClass =
, "signatories" , "signatories"
, "redeemers" , "redeemers"
, "datums" , "datums"
, "validRange"
] ]
txInfo txInfo
@ -482,10 +484,13 @@ mkStakeValidator impl sstSymbol pstClass gtClass =
pfmap pfmap
# plam # plam
( \proposalDatum -> ( \proposalDatum ->
let id = pfield @"proposalId" # proposalDatum let redeemer = getProposalRedeemer # inInfoF.outRef
status = pfield @"status" # proposalDatum currentTime =
redeemer = getProposalRedeemer # inInfoF.outRef passertPJust
in pcon $ PSpendProposal id status redeemer # "Should resolve proposal time"
#$ pcurrentProposalTime
# txInfoF.validRange
in pcon $ PSpendProposal proposalDatum redeemer currentTime
) )
#$ getProposalDatum #$ getProposalDatum
# pfromData inInfoF.resolved # pfromData inInfoF.resolved