correctly handle proposal time

agora-specs/Sample/Proposal/Unlock.hs

@@ -339,15 +339,19 @@ unlock ps = builder
 
     ---
 
+    ProposalStartingTime s = defStartingTime
+
     time = case ps.transactionParameters.timeRange of
       WhileVoting ->
-        closedBoundedInterval
+        let lb = s + (def :: ProposalTimingConfig).draftTime
-          ((def :: ProposalTimingConfig).draftTime + 1)
+            ub = lb + (def :: ProposalTimingConfig).votingTime
-          ((def :: ProposalTimingConfig).votingTime - 1)
+         in closedBoundedInterval (lb + 1) (ub - 1)
       AfterVoting ->
-        closedBoundedInterval
+        let lb =
-          ((def :: ProposalTimingConfig).votingTime + 1)
+              s + (def :: ProposalTimingConfig).draftTime
-          ((def :: ProposalTimingConfig).lockingTime - 1)
+                + (def :: ProposalTimingConfig).votingTime
+            ub = lb + (def :: ProposalTimingConfig).lockingTime
+         in closedBoundedInterval (lb + 1) (ub - 1)
 
     sig = case ps.transactionParameters.signedBy of
       Unknown -> defUnknown

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,
+  pgetRelation,
-  isExecutionPeriod,
+  pisWithin,
-  isLockingPeriod,
-  isVotingPeriod,
  )
 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
+              pisWithin # getTimingRelation PVotingPeriod
-                # proposalInputDatumF.startingTime
-                #$ passertPJust
-                # "Should be able to get current time"
-                # currentTime
 
             -- 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
+                  pisWithin # getTimingRelation PVotingPeriod
-                    # proposalInputDatumF.startingTime
-                    # currentTime'
 
                 -- 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 (getTimingRelation PDraftingPeriod) >>= \case
-
+                      PWithin -> do
-                    pmatchC notTooLate >>= \case
-                      PTrue -> 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
+                  pmatchC (getTimingRelation PLockingPeriod) >>= \case
-                      notTooEarly = pnot # inVotingPeriod
+                    PWithin -> do
-
-                  pguardC "Cannot advance ahead of time" notTooEarly
-
-                  pmatchC notTooLate >>= \case
-                    PTrue -> 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
+                    pmatch
-                      notTooLate
+                      (getTimingRelation PExecutingPeriod)
-                      -- Not too late: GST should moved
+                      ( \case
-                      pidentity
+                          PWithin -> pidentity
-                      -- Not too late: GST should not moved
+                          PAfter -> pnot
-                      pnot
+                      )
                       # gstMoved
 
                   pure $ popaque $ pconstant ()

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 $
+pgetRelation = phoistAcyclic $
-  plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
+  plam $ \config startingTime currentTime period -> unTermCont $ do
-    pisCurrentTimeWithin # s # (s + (pfield @"draftTime" # config))
+    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
+    dub <- pletC $ s + configF.draftTime
--}
+    vub <- pletC $ dub + configF.votingTime
-isVotingPeriod ::
+    lub <- pletC $ vub + configF.lockingTime
-  forall (s :: S).
+    eub <- pletC $ lub + configF.executingTime
-  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)
 
-{- | 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
+    pure $
--}
+      pif (plb #<= lb #&& ub #<= pub) (pcon PWithin) $
-isLockingPeriod ::
+        pif (pub #< lb) (pcon PAfter) $
-  forall (s :: S).
+          ptraceError "pgetRelation: too early or invalid current time"
-  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)