diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index 5399e95..5252f0f 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -11,6 +11,7 @@ module Agora.Proposal ( -- * Haskell-land Proposal (..), ProposalDatum (..), + ProposalRedeemer (..), ProposalStatus (..), ProposalThresholds (..), ProposalVotes (..), @@ -19,6 +20,7 @@ module Agora.Proposal ( -- * Plutarch-land PProposalDatum (..), + PProposalRedeemer (..), PProposalStatus (..), PProposalThresholds (..), PProposalVotes (..), @@ -182,12 +184,12 @@ PlutusTx.makeIsDataIndexed ''ProposalDatum [('ProposalDatum, 0)] data ProposalRedeemer = -- | Cast one or more votes towards a particular 'ResultTag'. Vote ResultTag - | -- | Add one or more public keys to the cosignature list. Must be signed by - -- those cosigning. + | -- | Add one or more public keys to the cosignature list. + -- Must be signed by those cosigning. -- - -- This is particularly used in the 'Draft' 'ProposalStatus'. Where matching - -- 'Stake's can be called to advance the proposal, provided enough GT is shared - -- among them. + -- This is particularly used in the 'Draft' 'ProposalStatus', + -- where matching 'Stake's can be called to advance the proposal, + -- provided enough GT is shared among them. Cosign [PubKeyHash] | -- | Allow unlocking one or more stakes with votes towards particular 'ResultTag'. Unlock ResultTag @@ -195,19 +197,23 @@ data ProposalRedeemer -- -- 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'. -- 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'. -- 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. -- - -- @'Locked' -> 'Finished'@: + -- === @'Locked' -> 'Finished'@: + -- -- 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 -- to transition into 'Finished' state, because it has expired (and failed). AdvanceProposal @@ -221,10 +227,10 @@ PlutusTx.makeIsDataIndexed , ('AdvanceProposal, 3) ] -{- | Identifies a Proposal, issued upon creation of a proposal. - In practice, this number starts at zero, and increments by one - for each proposal. The 100th proposal will be @'ProposalId' 99@. - This counter lives in the 'Governor', see 'nextProposalId'. +{- | Identifies a Proposal, issued upon creation of a proposal. In practice, + this number starts at zero, and increments by one for each proposal. + The 100th proposal will be @'ProposalId' 99@. This counter lives + in the 'Agora.Governor.Governor', see 'Agora.Governor.nextProposalId'. -} newtype ProposalId = ProposalId {proposalTag :: Integer} deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) diff --git a/agora/Agora/Proposal/Time.hs b/agora/Agora/Proposal/Time.hs index 7245dd0..952b8dd 100644 --- a/agora/Agora/Proposal/Time.hs +++ b/agora/Agora/Proposal/Time.hs @@ -20,35 +20,53 @@ module Agora.Proposal.Time ( PProposalStartingTime (..), -- * Compute ranges given config and starting time. - proposalDraftRange, - - -- * Upstreamables - plowerBound, - pupperBound, - pstrictLowerBound, - pstrictUpperBound, + currentProposalTime, + isDraftRange, ) where import Agora.Record (build, (.&), (.=)) import GHC.Generics qualified as GHC 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.Monadic qualified as P import Plutarch.Numeric (AdditiveSemigroup ((+))) import Plutarch.Unsafe (punsafeCoerce) -import Plutus.V1.Ledger.Time (POSIXTime, POSIXTimeRange) +import Plutus.V1.Ledger.Time (POSIXTime) import PlutusTx qualified import Prelude hiding ((+)) -------------------------------------------------------------------------------- --- | Represents the current time, as far as the proposal is concerned. -newtype ProposalTime = ProposalTime - { getProposalTime :: POSIXTimeRange +{- | == Establishing timing in Proposal interactions. + + In Plutus, it's impossible to determine time exactly. It's also impossible + to get a single point in time, yet often we need to check + various constraints on time. + + For the purposes of proposals, there's a single most important feature: + The ability to determine if we can perform an action. In order to correctly + determine if we are able to perform certain actions, we need to know what + time it roughly is, compared to when the proposal 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) +PlutusTx.makeIsDataIndexed ''ProposalTime [('ProposalTime, 0)] + -- | Represents the starting time of the proposal. newtype ProposalStartingTime = ProposalStartingTime { getProposalStartingTime :: POSIXTime @@ -74,8 +92,22 @@ PlutusTx.makeIsDataIndexed ''ProposalTimingConfig [('ProposalTimingConfig, 0)] -------------------------------------------------------------------------------- -- | Plutarch-level version of 'ProposalTime'. -newtype PProposalTime (s :: S) = PProposalTime (Term s PPOSIXTime) - deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalTime PPOSIXTime) +newtype PProposalTime (s :: S) + = 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'. newtype PProposalStartingTime (s :: S) = PProposalStartingTime (Term s PPOSIXTime) @@ -103,58 +135,56 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig -------------------------------------------------------------------------------- --- -- Need to move these away from here -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. +-- FIXME: Orphan instance, move this to plutarch-extra. instance AdditiveSemigroup (Term s PPOSIXTime) where (punsafeCoerce @_ @_ @PInteger -> x) + (punsafeCoerce @_ @_ @PInteger -> y) = punsafeCoerce $ x + y --- | Compute the range of time during which cosigning is legal. -proposalDraftRange :: Term s (PPOSIXTime :--> PProposalTimingConfig :--> PPOSIXTimeRange) -proposalDraftRange = phoistAcyclic $ - plam $ \s config -> +-- | Get the current proposal time, from the 'txInfoValidRange' field. +currentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PProposalTime) +currentProposalTime = phoistAcyclic $ + 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 - ( PInterval $ + ( PProposalTime $ build $ - #from .= pdata (pstrictLowerBound # s) - .& #to .= pdata (pstrictUpperBound #$ s + pfield @"draftTime" # config) + #lowerBound + .= 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)