implement cooldown period for stake unlocking
This commit is contained in:
Hongrui Fang
parent
fadd6ca2da
commit
a462e6a3d3
6 changed files with 378 additions and 194 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue