correctly handle proposal time

2022-10-26 21:15:20 +08:00 · 2022-10-26 21:15:20 +08:00 · b19faa7cfe
commit b19faa7cfe
parent 4dbccbc996
3 changed files with 141 additions and 131 deletions
--- a/agora-specs/Sample/Proposal/Unlock.hs
+++ b/agora-specs/Sample/Proposal/Unlock.hs
@ -339,15 +339,19 @@ unlock ps = builder

    ---

+    ProposalStartingTime s = defStartingTime
+
    time = case ps.transactionParameters.timeRange of
      WhileVoting ->
-        closedBoundedInterval
-          ((def :: ProposalTimingConfig).draftTime + 1)
-          ((def :: ProposalTimingConfig).votingTime - 1)
+        let lb = s + (def :: ProposalTimingConfig).draftTime
+            ub = lb + (def :: ProposalTimingConfig).votingTime
+         in closedBoundedInterval (lb + 1) (ub - 1)
      AfterVoting ->
-        closedBoundedInterval
-          ((def :: ProposalTimingConfig).votingTime + 1)
-          ((def :: ProposalTimingConfig).lockingTime - 1)
+        let lb =
+              s + (def :: ProposalTimingConfig).draftTime
+                + (def :: ProposalTimingConfig).votingTime
+            ub = lb + (def :: ProposalTimingConfig).lockingTime
+         in closedBoundedInterval (lb + 1) (ub - 1)

    sig = case ps.transactionParameters.signedBy of
      Unknown -> defUnknown
--- a/agora/Agora/Proposal/Scripts.hs
+++ b/agora/Agora/Proposal/Scripts.hs
@ -20,11 +20,11 @@ import Agora.Proposal (
  pwinner',
 )
 import Agora.Proposal.Time (
+  PPeriod (PDraftingPeriod, PExecutingPeriod, PLockingPeriod, PVotingPeriod),
+  PTimingRelation (PAfter, PWithin),
  currentProposalTime,
-  isDraftPeriod,
-  isExecutionPeriod,
-  isLockingPeriod,
-  isVotingPeriod,
+  pgetRelation,
+  pisWithin,
 )
 import Agora.Stake (
  PStakeDatum,
@ -232,8 +232,6 @@ proposalValidator =
          ]
        txInfo

-    currentTime <- pletC $ currentProposalTime # txInfoF.validRange
-
    ----------------------------------------------------------------------------

    PSpending ((pfield @"_0" #) -> propsalInputRef) <-
@ -292,6 +290,20 @@ proposalValidator =

    --------------------------------------------------------------------------

+    getTimingRelation' <-
+      pletC $
+        let currentTime =
+              passertPJust # "Current time should be resolved"
+                #$ currentProposalTime # txInfoF.validRange
+         in pgetRelation
+              # proposalInputDatumF.timingConfig
+              # proposalInputDatumF.startingTime
+              # currentTime
+
+    let getTimingRelation = (getTimingRelation' #) . pcon
+
+    --------------------------------------------------------------------------
+
    -- Handle stake inputs/outputs.

    -- Reslove stake datum if the given UTxO is a stake UTxO.
@ -473,11 +485,7 @@ proposalValidator =
              currentStatus #== pconstant VotingReady

            pguardC "Proposal time should be wthin the voting period" $
-              isVotingPeriod # proposalInputDatumF.timingConfig
-                # proposalInputDatumF.startingTime
-                #$ passertPJust
-                # "Should be able to get current time"
-                # currentTime
+              pisWithin # getTimingRelation PVotingPeriod

            -- Ensure the transaction is voting to a valid 'ResultTag'(outcome).
            PProposalVotes voteMap <- pmatchC proposalInputDatumF.votes
@ -557,15 +565,8 @@ proposalValidator =
                    # proposalInputDatumF.votes
                    # sctxF.inputStakes

-                currentTime' =
-                  passertPJust
-                    # "Should be able to get current time"
-                    # currentTime
-
                inVotingPeriod =
-                  isVotingPeriod # proposalInputDatumF.timingConfig
-                    # proposalInputDatumF.startingTime
-                    # currentTime'
+                  pisWithin # getTimingRelation PVotingPeriod

                -- The votes can only change when the proposal still allows voting.
                shouldUpdateVotes =
@ -599,24 +600,6 @@ proposalValidator =
          ----------------------------------------------------------------------

          PAdvanceProposal _ -> unTermCont $ do
-            currentTime' <-
-              pletC $
-                passertPJust
-                  # "Should be able to get current time"
-                  # currentTime
-
-            applyIs <- pletC $
-              plam $ \f ->
-                f
-                  # proposalInputDatumF.timingConfig
-                  # proposalInputDatumF.startingTime
-                  # currentTime'
-            let inDraftPeriod = applyIs # isDraftPeriod
-                inVotingPeriod = applyIs # isVotingPeriod
-                inExecutionPeriod = applyIs # isExecutionPeriod
-
-            inLockedPeriod <- pletC $ applyIs # isLockingPeriod
-
            proposalOutputStatus <-
              pletC $
                pfromData $
@ -641,10 +624,8 @@ proposalValidator =
              pmatch currentStatus $ \case
                PDraft ->
                  witnessStakes $ \sctxF -> do
-                    let notTooLate = inDraftPeriod
-
-                    pmatchC notTooLate >>= \case
-                      PTrue -> do
+                    pmatchC (getTimingRelation PDraftingPeriod) >>= \case
+                      PWithin -> do
                        pguardC "More cosigns than minimum amount" $
                          punsafeCoerce (pfromData thresholdsF.toVoting) #<= sctxF.totalAmount

@ -658,20 +639,15 @@ proposalValidator =
                        pguardC "Proposal status set to VotingReady" $
                          proposalOutputStatus #== pconstant VotingReady
                      -- Too late: failed proposal, status set to 'Finished'.
-                      PFalse ->
+                      PAfter ->
                        pguardC "Proposal should fail: not on time" $
                          proposalOutputStatus #== pconstant Finished

                ----------------------------------------------------------------

                PVotingReady -> unTermCont $ do
-                  let notTooLate = inLockedPeriod
-                      notTooEarly = pnot # inVotingPeriod
-
-                  pguardC "Cannot advance ahead of time" notTooEarly
-
-                  pmatchC notTooLate >>= \case
-                    PTrue -> do
+                  pmatchC (getTimingRelation PLockingPeriod) >>= \case
+                    PWithin -> do
                      -- 'VotingReady' -> 'Locked'
                      pguardC "Proposal status set to Locked" $
                        proposalOutputStatus #== pconstant Locked
@ -681,7 +657,7 @@ proposalValidator =
                          #$ punsafeCoerce
                          $ pfromData thresholdsF.execute
                    -- Too late: failed proposal, status set to 'Finished'.
-                    PFalse ->
+                    PAfter ->
                      pguardC "Proposal should fail: not on time" $
                        proposalOutputStatus #== pconstant Finished

@ -690,11 +666,6 @@ proposalValidator =
                ----------------------------------------------------------------

                PLocked -> unTermCont $ do
-                  let notTooLate = inExecutionPeriod
-                      notTooEarly = pnot # inLockedPeriod
-
-                  pguardC "Not too early" notTooEarly
-
                  pguardC "Proposal status set to Finished" $
                    proposalOutputStatus #== pconstant Finished

@ -710,12 +681,12 @@ proposalValidator =
                          # pfromData txInfoF.inputs

                  pguardC "GST not moved if too late, moved otherwise" $
-                    pif
-                      notTooLate
-                      -- Not too late: GST should moved
-                      pidentity
-                      -- Not too late: GST should not moved
-                      pnot
+                    pmatch
+                      (getTimingRelation PExecutingPeriod)
+                      ( \case
+                          PWithin -> pidentity
+                          PAfter -> pnot
+                      )
                      # gstMoved

                  pure $ popaque $ pconstant ()
--- a/agora/Agora/Proposal/Time.hs
+++ b/agora/Agora/Proposal/Time.hs
@ -18,20 +18,21 @@ module Agora.Proposal.Time (
  PProposalTimingConfig (..),
  PProposalStartingTime (..),
  PMaxTimeRangeWidth (..),
+  PTimingRelation (..),
+  PPeriod (..),

  -- * Compute periods given config and starting time.
  validateProposalStartingTime,
  currentProposalTime,
-  isDraftPeriod,
-  isVotingPeriod,
-  isLockingPeriod,
-  isExecutionPeriod,
  pisProposalTimingConfigValid,
  pisMaxTimeRangeWidthValid,
+  pgetRelation,
+  pisWithin,
 ) where

 import Agora.Utils (pcurrentTimeDuration)
 import Control.Composition ((.*))
+import Data.Functor ((<&>))
 import Plutarch.Api.V1 (
  PExtended (PFinite),
  PInterval (PInterval),
@ -46,11 +47,11 @@ import Plutarch.DataRepr (
 )
 import Plutarch.Extra.Applicative (PApply (pliftA2))
 import Plutarch.Extra.Field (pletAll, pletAllC)
+import Plutarch.Extra.IsData (PlutusTypeEnumData)
 import Plutarch.Extra.Maybe (pjust, pmaybe, pnothing)
-import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pmatchC)
+import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pletC, pmatchC)
 import Plutarch.Extra.Time (
  PCurrentTime (PCurrentTime),
-  pisCurrentTimeWithin,
  pisWithinCurrentTime,
 )
 import Plutarch.Lift (
@ -388,74 +389,108 @@ currentProposalTime = phoistAcyclic $
        mkTime = phoistAcyclic $ plam $ pcon .* PCurrentTime
    pure $ pliftA2 # mkTime # lowerBound # upperBound

-{- | True if the 'PProposalTime' is in the draft period.
+{- | Represent relation between current time and a given period.

-     @since 0.1.0
+     Note that the "before" relation isn't present due to the fact that
+     it's considered as an error in the proposal script.
+
+     @since 1.0.0
 -}
-isDraftPeriod ::
+data PTimingRelation (s :: S)
+  = PWithin
+  | PAfter
+  deriving stock
+    ( -- | @since 1.0.0
+      Generic
+    , -- | @since 1.0.0
+      Enum
+    , -- | @since 1.0.0
+      Bounded
+    )
+  deriving anyclass
+    ( -- | @since 1.0.0
+      PlutusType
+    )
+
+-- | @since 1.0.0
+instance DerivePlutusType PTimingRelation where
+  type DPTStrat _ = PlutusTypeEnumData
+
+{- | Return truw if a relation is 'PWithin'.
+
+     @since 1.0.0
+-}
+pisWithin :: forall (s :: S). Term s (PTimingRelation :--> PBool)
+pisWithin = phoistAcyclic $
+  plam $
+    flip pmatch $ \case
+      PWithin -> pconstant True
+      _ -> pconstant False
+
+{- | Represent a proposal period.
+
+     @since 1.0.0
+-}
+data PPeriod (s :: S)
+  = PDraftingPeriod
+  | PVotingPeriod
+  | PLockingPeriod
+  | PExecutingPeriod
+  deriving stock
+    ( -- | @since 1.0.0
+      Generic
+    , -- | @since 1.0.0
+      Enum
+    , -- | @since 1.0.0
+      Bounded
+    )
+  deriving anyclass
+    ( -- | @since 1.0.0
+      PlutusType
+    )
+
+-- | @since 1.0.0
+instance DerivePlutusType PPeriod where
+  type DPTStrat _ = PlutusTypeEnumData
+
+{- | Compute the relation between current time range and the given peroid,
+     providing the starting time and timing configuration of a proposal. If the
+     relation cannot be ddetermined, error out.
+
+     @since 1.0.0
+-}
+pgetRelation ::
  forall (s :: S).
  Term
    s
    ( PProposalTimingConfig
        :--> PProposalStartingTime
        :--> PProposalTime
-        :--> PBool
+        :--> PPeriod
+        :--> PTimingRelation
    )
-isDraftPeriod = phoistAcyclic $
-  plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
-    pisCurrentTimeWithin # s # (s + (pfield @"draftTime" # config))
+pgetRelation = phoistAcyclic $
+  plam $ \config startingTime currentTime period -> unTermCont $ do
+    configF <- pletAllC config

-{- | True if the 'PProposalTime' is in the voting period.
+    PProposalStartingTime s <- pmatchC startingTime
+    PCurrentTime lb ub <- pmatchC currentTime

-     @since 0.1.0
-}
-isVotingPeriod ::
-  forall (s :: S).
-  Term
-    s
-    ( PProposalTimingConfig
-        :--> PProposalStartingTime
-        :--> PProposalTime
-        :--> PBool
-    )
-isVotingPeriod = phoistAcyclic $
-  plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
-    pletFields @'["draftTime", "votingTime"] config $ \f ->
-      pisCurrentTimeWithin # s # (s + f.draftTime + f.votingTime)
+    dub <- pletC $ s + configF.draftTime
+    vub <- pletC $ dub + configF.votingTime
+    lub <- pletC $ vub + configF.lockingTime
+    eub <- pletC $ lub + configF.executingTime

-{- | True if the 'PProposalTime' is in the locking period.
+    (plb, pub) <-
+      pmatchC period
+        <&> ( \case
+                PDraftingPeriod -> (s, dub)
+                PVotingPeriod -> (dub, vub)
+                PLockingPeriod -> (vub, lub)
+                PExecutingPeriod -> (lub, eub)
+            )

-     @since 0.1.0
-}
-isLockingPeriod ::
-  forall (s :: S).
-  Term
-    s
-    ( PProposalTimingConfig
-        :--> PProposalStartingTime
-        :--> PProposalTime
-        :--> PBool
-    )
-isLockingPeriod = phoistAcyclic $
-  plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
-    pletFields @'["draftTime", "votingTime", "lockingTime"] config $ \f ->
-      pisCurrentTimeWithin # s # (s + f.draftTime + f.votingTime + f.lockingTime)
-
-{- | True if the 'PProposalTime' is in the execution period.
-
-     @since 0.1.0
-}
-isExecutionPeriod ::
-  forall (s :: S).
-  Term
-    s
-    ( PProposalTimingConfig
-        :--> PProposalStartingTime
-        :--> PProposalTime
-        :--> PBool
-    )
-isExecutionPeriod = phoistAcyclic $
-  plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
-    pletFields @'["draftTime", "votingTime", "lockingTime", "executingTime"] config $ \f ->
-      pisCurrentTimeWithin # s
-        # (s + f.draftTime + f.votingTime + f.lockingTime + f.executingTime)
+    pure $
+      pif (plb #<= lb #&& ub #<= pub) (pcon PWithin) $
+        pif (pub #< lb) (pcon PAfter) $
+          ptraceError "pgetRelation: too early or invalid current time"