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

add 'isDraftRange' checking function.

Browse source
This commit is contained in:
Emily Martins 2022-04-18 13:52:01 +02:00
parent 0ba8a58cb7
commit 76911ed5d6
2 changed files with 113 additions and 77 deletions
Download patch file Download diff file Expand all files Collapse all files

32
agora/Agora/Proposal.hs
View file

@ -11,6 +11,7 @@ module Agora.Proposal (
-- * Haskell-land -- * Haskell-land
Proposal (..), Proposal (..),
ProposalDatum (..), ProposalDatum (..),
ProposalRedeemer (..),
ProposalStatus (..), ProposalStatus (..),
ProposalThresholds (..), ProposalThresholds (..),
ProposalVotes (..), ProposalVotes (..),
@ -19,6 +20,7 @@ module Agora.Proposal (
-- * Plutarch-land -- * Plutarch-land
PProposalDatum (..), PProposalDatum (..),
PProposalRedeemer (..),
PProposalStatus (..), PProposalStatus (..),
PProposalThresholds (..), PProposalThresholds (..),
PProposalVotes (..), PProposalVotes (..),
@ -182,12 +184,12 @@ PlutusTx.makeIsDataIndexed ''ProposalDatum [('ProposalDatum, 0)]
data ProposalRedeemer data ProposalRedeemer
= -- | Cast one or more votes towards a particular 'ResultTag'. = -- | Cast one or more votes towards a particular 'ResultTag'.
Vote ResultTag Vote ResultTag
| -- | Add one or more public keys to the cosignature list. Must be signed by | -- | Add one or more public keys to the cosignature list.
-- those cosigning. -- Must be signed by those cosigning.
-- --
-- This is particularly used in the 'Draft' 'ProposalStatus'. Where matching -- This is particularly used in the 'Draft' 'ProposalStatus',
-- 'Stake's can be called to advance the proposal, provided enough GT is shared -- where matching 'Stake's can be called to advance the proposal,
-- among them. -- provided enough GT is shared among them.
Cosign [PubKeyHash] Cosign [PubKeyHash]
| -- | Allow unlocking one or more stakes with votes towards particular 'ResultTag'. | -- | Allow unlocking one or more stakes with votes towards particular 'ResultTag'.
Unlock ResultTag Unlock ResultTag
@ -195,19 +197,23 @@ data ProposalRedeemer
-- --
-- These are roughly the checks for each possible transition: -- These are roughly the checks for each possible transition:
-- --
-- @'Draft' -> 'VotingReady'@: -- === @'Draft' -> 'VotingReady'@:
--
-- 1. The sum of all of the cosigner's GT is larger than the 'vote' field of 'ProposalThresholds'. -- 1. The sum of all of the cosigner's GT is larger than the 'vote' field of 'ProposalThresholds'.
-- 2. The proposal hasn't been alive for longer than the review time. -- 2. The proposal hasn't been alive for longer than the review time.
-- --
-- @'VotingReady' -> 'Locked'@: -- === @'VotingReady' -> 'Locked'@:
--
-- 1. The sum of all votes is larger than 'countVoting'. -- 1. The sum of all votes is larger than 'countVoting'.
-- 2. The winning 'ResultTag' has more votes than all other 'ResultTag's. -- 2. The winning 'ResultTag' has more votes than all other 'ResultTag's.
-- 3. The proposal hasn't been alive for longer than the voting time. -- 3. The proposal hasn't been alive for longer than the voting time.
-- --
-- @'Locked' -> 'Finished'@: -- === @'Locked' -> 'Finished'@:
--
-- Always valid provided the conditions for the transition are met. -- Always valid provided the conditions for the transition are met.
-- --
-- @* -> 'Finished'@: -- === @* -> 'Finished'@:
--
-- If the proposal has run out of time for the current 'ProposalStatus', it will always be possible -- If the proposal has run out of time for the current 'ProposalStatus', it will always be possible
-- to transition into 'Finished' state, because it has expired (and failed). -- to transition into 'Finished' state, because it has expired (and failed).
AdvanceProposal AdvanceProposal
@ -221,10 +227,10 @@ PlutusTx.makeIsDataIndexed
, ('AdvanceProposal, 3) , ('AdvanceProposal, 3)
] ]
{- | Identifies a Proposal, issued upon creation of a proposal. {- | Identifies a Proposal, issued upon creation of a proposal. In practice,
In practice, this number starts at zero, and increments by one this number starts at zero, and increments by one for each proposal.
for each proposal. The 100th proposal will be @'ProposalId' 99@. The 100th proposal will be @'ProposalId' 99@. This counter lives
This counter lives in the 'Governor', see 'nextProposalId'. in the 'Agora.Governor.Governor', see 'Agora.Governor.nextProposalId'.
-} -}
newtype ProposalId = ProposalId {proposalTag :: Integer} newtype ProposalId = ProposalId {proposalTag :: Integer}
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)

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

@ -20,35 +20,53 @@ module Agora.Proposal.Time (
PProposalStartingTime (..), PProposalStartingTime (..),
-- * Compute ranges given config and starting time. -- * Compute ranges given config and starting time.
proposalDraftRange, currentProposalTime,
isDraftRange,
-- * Upstreamables
plowerBound,
pupperBound,
pstrictLowerBound,
pstrictUpperBound,
) where ) where
import Agora.Record (build, (.&), (.=)) import Agora.Record (build, (.&), (.=))
import GHC.Generics qualified as GHC import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I)) import Generics.SOP (Generic, I (I))
import Plutarch.Api.V1 (PExtended (PFinite), PInterval (PInterval), PLowerBound (PLowerBound), PPOSIXTime, PPOSIXTimeRange, PUpperBound (PUpperBound)) import Plutarch.Api.V1 (PExtended (PFinite), PInterval (PInterval), PLowerBound (PLowerBound), PMaybeData (PDJust, PDNothing), PPOSIXTime, PPOSIXTimeRange, PUpperBound (PUpperBound))
import Plutarch.DataRepr (PDataFields, PIsDataReprInstances (..)) import Plutarch.DataRepr (PDataFields, PIsDataReprInstances (..))
import Plutarch.Monadic qualified as P
import Plutarch.Numeric (AdditiveSemigroup ((+))) import Plutarch.Numeric (AdditiveSemigroup ((+)))
import Plutarch.Unsafe (punsafeCoerce) import Plutarch.Unsafe (punsafeCoerce)
import Plutus.V1.Ledger.Time (POSIXTime, POSIXTimeRange) import Plutus.V1.Ledger.Time (POSIXTime)
import PlutusTx qualified import PlutusTx qualified
import Prelude hiding ((+)) import Prelude hiding ((+))
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Represents the current time, as far as the proposal is concerned. {- | == Establishing timing in Proposal interactions.
newtype ProposalTime = ProposalTime
{ getProposalTime :: POSIXTimeRange 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 got 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.txInfoValidRange' field
of 'Plutus.V1.Ledger.Api.TxInfo'.
We avoid 'PPOSIXTimeRange' where we can in order to save on operations.
-}
data ProposalTime = ProposalTime
{ lowerBound :: Maybe POSIXTime
, upperBound :: Maybe POSIXTime
} }
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
deriving stock (Eq, Show, GHC.Generic) deriving stock (Eq, Show, GHC.Generic)
PlutusTx.makeIsDataIndexed ''ProposalTime [('ProposalTime, 0)]
-- | Represents the starting time of the proposal. -- | Represents the starting time of the proposal.
newtype ProposalStartingTime = ProposalStartingTime newtype ProposalStartingTime = ProposalStartingTime
{ getProposalStartingTime :: POSIXTime { getProposalStartingTime :: POSIXTime
@ -74,8 +92,22 @@ PlutusTx.makeIsDataIndexed ''ProposalTimingConfig [('ProposalTimingConfig, 0)]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Plutarch-level version of 'ProposalTime'. -- | Plutarch-level version of 'ProposalTime'.
newtype PProposalTime (s :: S) = PProposalTime (Term s PPOSIXTime) newtype PProposalTime (s :: S)
deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalTime PPOSIXTime) = PProposalTime
( Term
s
( PDataRecord
'[ "lowerBound" ':= PMaybeData PPOSIXTime
, "upperBound" ':= PMaybeData PPOSIXTime
]
)
)
deriving stock (GHC.Generic)
deriving anyclass (Generic)
deriving anyclass (PIsDataRepr)
deriving
(PlutusType, PIsData, PDataFields)
via (PIsDataReprInstances PProposalTime)
-- | Plutarch-level version of 'ProposalStartingTime'. -- | Plutarch-level version of 'ProposalStartingTime'.
newtype PProposalStartingTime (s :: S) = PProposalStartingTime (Term s PPOSIXTime) newtype PProposalStartingTime (s :: S) = PProposalStartingTime (Term s PPOSIXTime)
@ -103,58 +135,56 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- -- Need to move these away from here -- FIXME: Orphan instance, move this to plutarch-extra.
pstrictLowerBound :: PIsData a => Term s (a :--> PLowerBound a)
pstrictLowerBound = phoistAcyclic $
plam $ \a ->
pcon
( PLowerBound $
build $
#_0 .= pdata (pcon (PFinite $ build $ #_0 .= pdata a))
.& #_1 .= pdata (pcon PFalse)
)
pstrictUpperBound :: PIsData a => Term s (a :--> PUpperBound a)
pstrictUpperBound = phoistAcyclic $
plam $ \a ->
pcon
( PUpperBound $
build $
#_0 .= pdata (pcon (PFinite $ build $ #_0 .= pdata a))
.& #_1 .= pdata (pcon PFalse)
)
plowerBound :: PIsData a => Term s (a :--> PLowerBound a)
plowerBound = phoistAcyclic $
plam $ \a ->
pcon
( PLowerBound $
build $
#_0 .= pdata (pcon (PFinite $ build $ #_0 .= pdata a))
.& #_1 .= pdata (pcon PTrue)
)
pupperBound :: PIsData a => Term s (a :--> PUpperBound a)
pupperBound = phoistAcyclic $
plam $ \a ->
pcon
( PUpperBound $
build $
#_0 .= pdata (pcon (PFinite $ build $ #_0 .= pdata a))
.& #_1 .= pdata (pcon PTrue)
)
-- Move this to plutarch-extra.
instance AdditiveSemigroup (Term s PPOSIXTime) where instance AdditiveSemigroup (Term s PPOSIXTime) where
(punsafeCoerce @_ @_ @PInteger -> x) + (punsafeCoerce @_ @_ @PInteger -> y) = punsafeCoerce $ x + y (punsafeCoerce @_ @_ @PInteger -> x) + (punsafeCoerce @_ @_ @PInteger -> y) = punsafeCoerce $ x + y
-- | Compute the range of time during which cosigning is legal. -- | Get the current proposal time, from the 'txInfoValidRange' field.
proposalDraftRange :: Term s (PPOSIXTime :--> PProposalTimingConfig :--> PPOSIXTimeRange) currentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PProposalTime)
proposalDraftRange = phoistAcyclic $ currentProposalTime = phoistAcyclic $
plam $ \s config -> plam $ \iv -> P.do
PInterval iv' <- pmatch iv
ivf <- pletFields @'["from", "to"] iv'
PLowerBound lb <- pmatch ivf.from
PUpperBound ub <- pmatch ivf.to
lbf <- pletFields @'["_0", "_1"] lb
ubf <- pletFields @'["_0", "_1"] ub
pcon pcon
( PInterval $ ( PProposalTime $
build $ build $
#from .= pdata (pstrictLowerBound # s) #lowerBound
.& #to .= pdata (pstrictUpperBound #$ s + pfield @"draftTime" # config) .= pdata
( pmatch lbf._0 $
\case
PFinite d -> pcon (PDJust d)
_ -> pcon (PDNothing pdnil)
)
.& #upperBound
.= pdata
( pmatch ubf._0 $ \case
PFinite d -> pcon (PDJust d)
_ -> pcon (PDNothing pdnil)
)
) )
-- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive.
proposalTimeWithin :: Term s (PPOSIXTime :--> PPOSIXTime :--> PProposalTime :--> PBool)
proposalTimeWithin = phoistAcyclic $
plam $ \l h proposalTime' -> P.do
PProposalTime proposalTime <- pmatch proposalTime'
ptf <- pletFields @'["lowerBound", "upperBound"] proposalTime
foldr1
(#&&)
[ pmatch ptf.lowerBound $ \case
PDJust lb -> l #<= pfromData (pfield @"_0" # lb)
_ -> pcon PFalse
, pmatch ptf.upperBound $ \case
PDJust lb -> pfromData (pfield @"_0" # lb) #<= h
_ -> pcon PFalse
]
-- | True if the 'PProposalTime' is in the draft period.
isDraftRange :: forall (s :: S). Term s (PProposalTimingConfig :--> PProposalStartingTime :--> PProposalTime :--> PBool)
isDraftRange = phoistAcyclic $
plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
proposalTimeWithin # s # (s + pfield @"draftTime" # config)