add sample test && fix broken tests

agora-sample/Sample/Proposal.hs

@@ -11,6 +11,7 @@ module Sample.Proposal (
   cosignProposal,
   proposalRef,
   stakeRef,
+  voteOnProposal,
 ) where
 
 --------------------------------------------------------------------------------
@@ -21,6 +22,7 @@ import Plutus.V1.Ledger.Api (
   Address (Address),
   Credential (ScriptCredential),
   Datum (Datum),
+  POSIXTimeRange,
   PubKeyHash,
   ScriptContext (..),
   ScriptPurpose (..),
@@ -43,14 +45,16 @@ import Agora.Proposal (
   ProposalDatum (..),
   ProposalId (..),
   ProposalStatus (..),
+  ProposalVotes (..),
   ResultTag (..),
   emptyVotesFor,
  )
-import Agora.Stake (Stake (..), StakeDatum (StakeDatum))
+import Agora.Proposal.Time (ProposalTimingConfig (..))
+import Agora.Stake (ProposalLock (ProposalLock), Stake (..), StakeDatum (..))
 import Plutarch.SafeMoney (Tagged (Tagged), untag)
 import PlutusTx.AssocMap qualified as AssocMap
 import Sample.Shared
-import Test.Util (datumPair, toDatumHash)
+import Test.Util (closedBoundedInterval, datumPair, toDatumHash, updateMap)
 
 --------------------------------------------------------------------------------
 
@@ -176,6 +180,11 @@ cosignProposal newSigners =
       stakeDatum = StakeDatum (Tagged 50_000_000) signer2 []
       proposalAfter :: ProposalDatum
       proposalAfter = proposalBefore {cosigners = newSigners <> proposalBefore.cosigners}
+      validTimeRange :: POSIXTimeRange
+      validTimeRange =
+        closedBoundedInterval
+          10
+          (proposalTimingConfig.draftTime - 10)
    in TxInfo
         { txInfoInputs =
             [ TxInInfo
@@ -227,7 +236,7 @@ cosignProposal newSigners =
         , txInfoMint = st
         , txInfoDCert = []
         , txInfoWdrl = []
-        , txInfoValidRange = Interval.always
+        , txInfoValidRange = validTimeRange
         , txInfoSignatories = newSigners
         , txInfoData =
             [ datumPair . Datum $ toBuiltinData proposalBefore
@@ -236,3 +245,145 @@ cosignProposal newSigners =
             ]
         , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
         }
+
+{- | A valid transaction of voting on a propsal.
+
+  -- TODO: docs
+-}
+voteOnProposal :: ResultTag -> Integer -> TxInfo
+voteOnProposal voteFor voteCount =
+  let pst = Value.singleton proposalPolicySymbol "" 1
+      sst = Value.assetClassValue stakeAssetClass 1
+
+      ---
+
+      stakeOwner = signer
+
+      ---
+
+      effects =
+        AssocMap.fromList
+          [ (ResultTag 0, AssocMap.empty)
+          , (ResultTag 1, AssocMap.empty)
+          ]
+
+      ---
+
+      initialVotes :: AssocMap.Map ResultTag Integer
+      initialVotes =
+        AssocMap.fromList
+          [ (ResultTag 0, 42)
+          , (ResultTag 1, 4242)
+          ]
+
+      ---
+
+      proposalInputDatum' :: ProposalDatum
+      proposalInputDatum' =
+        ProposalDatum
+          { proposalId = ProposalId 42
+          , effects = effects
+          , status = VotingReady
+          , cosigners = [stakeOwner]
+          , thresholds = defaultProposalThresholds
+          , votes = ProposalVotes initialVotes
+          , timingConfig = proposalTimingConfig
+          , startingTime = tmpProposalStartingTime
+          }
+      proposalInputDatum :: Datum
+      proposalInputDatum = Datum $ toBuiltinData proposalInputDatum'
+      proposalInput :: TxOut
+      proposalInput =
+        TxOut
+          { txOutAddress = proposalValidatorAddress
+          , txOutValue = pst
+          , txOutDatumHash = Just $ toDatumHash proposalInputDatum
+          }
+
+      ---
+
+      existingLocks :: [ProposalLock]
+      existingLocks =
+        [ ProposalLock (ResultTag 0) (ProposalId 0)
+        , ProposalLock (ResultTag 2) (ProposalId 1)
+        ]
+
+      ---
+
+      stakeInputDatum' :: StakeDatum
+      stakeInputDatum' =
+        StakeDatum
+          { stakedAmount = Tagged voteCount
+          , owner = stakeOwner
+          , lockedBy = existingLocks
+          }
+      stakeInputDatum :: Datum
+      stakeInputDatum = Datum $ toBuiltinData stakeInputDatum'
+      stakeInput :: TxOut
+      stakeInput =
+        TxOut
+          { txOutAddress = stakeAddress
+          , txOutValue = sst <> Value.assetClassValue (untag stake.gtClassRef) voteCount
+          , txOutDatumHash = Just $ toDatumHash stakeInputDatum
+          }
+
+      ---
+
+      updatedVotes :: AssocMap.Map ResultTag Integer
+      updatedVotes = updateMap (Just . (+ voteCount)) voteFor initialVotes
+
+      ---
+
+      proposalOutputDatum' :: ProposalDatum
+      proposalOutputDatum' =
+        proposalInputDatum'
+          { votes = ProposalVotes updatedVotes
+          }
+      proposalOutputDatum :: Datum
+      proposalOutputDatum = Datum $ toBuiltinData proposalOutputDatum'
+      proposalOutput :: TxOut
+      proposalOutput =
+        proposalInput
+          { txOutDatumHash = Just $ toDatumHash proposalOutputDatum
+          }
+
+      ---
+
+      -- Off-chain code should do exactly like this: prepend new lock to the list.
+      updatedLocks :: [ProposalLock]
+      updatedLocks = ProposalLock voteFor proposalInputDatum'.proposalId : existingLocks
+
+      ---
+
+      stakeOutputDatum' :: StakeDatum
+      stakeOutputDatum' =
+        stakeInputDatum'
+          { lockedBy = updatedLocks
+          }
+      stakeOutputDatum :: Datum
+      stakeOutputDatum = Datum $ toBuiltinData stakeOutputDatum'
+      stakeOutput :: TxOut
+      stakeOutput =
+        stakeInput
+          { txOutDatumHash = Just $ toDatumHash stakeOutputDatum
+          }
+
+      ---
+
+      validTimeRange =
+        closedBoundedInterval (proposalTimingConfig.draftTime + 1) (proposalTimingConfig.votingTime - 1)
+   in TxInfo
+        { txInfoInputs =
+            [ TxInInfo proposalRef proposalInput
+            , TxInInfo stakeRef stakeInput
+            ]
+        , txInfoOutputs = [proposalOutput, stakeOutput]
+        , txInfoFee = Value.singleton "" "" 2
+        , txInfoMint = mempty
+        , txInfoDCert = []
+        , txInfoWdrl = []
+        , txInfoValidRange = validTimeRange
+        , txInfoSignatories = [stakeOwner]
+        , txInfoData = datumPair <$> [proposalInputDatum, proposalOutputDatum, stakeInputDatum, stakeOutputDatum]
+        , txInfoId = "827598fb2d69a896bbd9e645bb14c307df907f422b39eecbe4d6329bc30b428c"
+        }

agora-sample/Sample/Shared.hs

@@ -193,7 +193,7 @@ authorityTokenSymbol = authorityTokenSymbolFromGovernor governor
 proposalTimingConfig :: ProposalTimingConfig
 proposalTimingConfig =
   ProposalTimingConfig
-    { draftTime = 0
+    { draftTime = 50
     , votingTime = 1000
     , lockingTime = 2000
     , executingTime = 3000

agora-test/Spec/Proposal.hs

@@ -15,8 +15,9 @@ import Agora.Proposal (
   Proposal (..),
   ProposalDatum (..),
   ProposalId (ProposalId),
-  ProposalRedeemer (Cosign),
+  ProposalRedeemer (Cosign, Vote),
-  ProposalStatus (Draft),
+  ProposalStatus (Draft, VotingReady),
+  ProposalVotes (ProposalVotes),
   ResultTag (ResultTag),
   cosigners,
   effects,
@@ -30,7 +31,11 @@ import Agora.Proposal.Scripts (
   proposalPolicy,
   proposalValidator,
  )
-import Agora.Stake (StakeDatum (StakeDatum), StakeRedeemer (WitnessStake))
+import Agora.Stake (
+  ProposalLock (ProposalLock),
+  StakeDatum (StakeDatum),
+  StakeRedeemer (PermitVote, WitnessStake),
+ )
 import Agora.Stake.Scripts (stakeValidator)
 import Plutarch.SafeMoney (Tagged (Tagged))
 import Plutus.V1.Ledger.Api (ScriptContext (..), ScriptPurpose (..))
@@ -90,5 +95,46 @@ tests =
               WitnessStake
               (ScriptContext (Proposal.cosignProposal [signer2]) (Spending Proposal.stakeRef))
           ]
+      , testGroup
+          "voting"
+          [ validatorSucceedsWith
+              "proposal"
+              (proposalValidator Shared.proposal)
+              ( ProposalDatum
+                  { proposalId = ProposalId 42
+                  , effects =
+                      AssocMap.fromList
+                        [ (ResultTag 0, AssocMap.empty)
+                        , (ResultTag 1, AssocMap.empty)
+                        ]
+                  , status = VotingReady
+                  , cosigners = [signer]
+                  , thresholds = Shared.defaultProposalThresholds
+                  , votes =
+                      ProposalVotes
+                        ( AssocMap.fromList
+                            [ (ResultTag 0, 42)
+                            , (ResultTag 1, 4242)
+                            ]
+                        )
+                  , timingConfig = Shared.proposalTimingConfig
+                  , startingTime = Shared.tmpProposalStartingTime
+                  }
+              )
+              (Vote (ResultTag 0))
+              (ScriptContext (Proposal.voteOnProposal (ResultTag 0) 27) (Spending Proposal.proposalRef))
+          , validatorSucceedsWith
+              "stake"
+              (stakeValidator Shared.stake)
+              ( StakeDatum
+                  (Tagged 27)
+                  signer
+                  [ ProposalLock (ResultTag 0) (ProposalId 0)
+                  , ProposalLock (ResultTag 2) (ProposalId 1)
+                  ]
+              )
+              (PermitVote $ ProposalLock (ResultTag 0) (ProposalId 42))
+              (ScriptContext (Proposal.voteOnProposal (ResultTag 0) 27) (Spending Proposal.stakeRef))
+          ]
       ]
   ]

agora-testlib/Test/Util.hs

@@ -38,6 +38,8 @@ module Test.Util (
   toDatum,
   toDatumHash,
   datumPair,
+  closedBoundedInterval,
+  updateMap,
 ) where
 
 --------------------------------------------------------------------------------
@@ -62,9 +64,12 @@ import Plutarch.Crypto (pblake2b_256)
 import Plutarch.Evaluate (evalScript)
 import Plutarch.Lift (PUnsafeLiftDecl (PLifted))
 import Plutus.V1.Ledger.Contexts (ScriptContext)
+import Plutus.V1.Ledger.Interval as PlutusTx
 import Plutus.V1.Ledger.Scripts (Datum (Datum), DatumHash (DatumHash), Script)
+import PlutusTx.AssocMap qualified as AssocMap
 import PlutusTx.Builtins qualified as PlutusTx
 import PlutusTx.IsData qualified as PlutusTx
+import PlutusTx.Ord qualified as PlutusTx
 
 --------------------------------------------------------------------------------
 
@@ -231,3 +236,20 @@ toDatumHash datum =
       plift $
         pblake2b_256
           # pconstant (ByteString.Lazy.toStrict $ serialise $ PlutusTx.toData datum)
+
+--------------------------------------------------------------------------------
+
+-- | Create a closed bounded `Interval`.
+closedBoundedInterval :: PlutusTx.Ord a => a -> a -> PlutusTx.Interval a
+closedBoundedInterval from to = PlutusTx.intersection (PlutusTx.from from) (PlutusTx.to to)
+
+--------------------------------------------------------------------------------
+
+updateMap :: Eq k => (v -> Maybe v) -> k -> AssocMap.Map k v -> AssocMap.Map k v
+updateMap f k =
+  AssocMap.mapMaybeWithKey
+    ( \k' v ->
+        if k' == k
+          then f v
+          else Just v
+    )

agora/Agora/Governor/Scripts.hs

@@ -736,7 +736,7 @@ governorValidator gov =
     tmpTimingConfig :: ProposalTimingConfig
     tmpTimingConfig =
       ProposalTimingConfig
-        { draftTime = 0
+        { draftTime = 50
         , votingTime = 1000
         , lockingTime = 2000
         , executingTime = 3000

agora/Agora/Proposal/Scripts.hs

@@ -230,24 +230,18 @@ proposalValidator proposal =
 
           -- TODO: maybe we can move this outside of the pmatch block.
           -- Filter out own output with own address and PST.
-          ownOutput <-
+          let ownOutput =
-            tclet $
+                mustBePJust # "Own output not found" #$ pfind
-              mustBePJust # "Own output not found" #$ pfind
+                  # plam
-                # plam
+                    ( \input -> unTermCont $ do
-                  ( \input -> unTermCont $ do
+                        inputF <- tcont $ pletFields @'["address", "value"] input
-                      inputF <- tcont $ pletFields @'["address", "value"] input
+                        pure $
-                      pure $
+                          inputF.address #== ownAddress
-                        inputF.address #== ownAddress
+                            #&& psymbolValueOf # stCurrencySymbol # inputF.value #== 1
-                          #&& psymbolValueOf # stCurrencySymbol # inputF.value #== 1
+                    )
-                  )
+                  # pfromData txInfoF.outputs
-                # pfromData txInfoF.outputs
 
-          ownOutputF <- tcont $ pletFields @'["datumHash", "value"] ownOutput
+              proposalOut :: Term _ PProposalDatum
-
-          -- TODO: is this really necessary?
-          tcassert "Own output value should be correct" $ ownOutputF.value #== pdata txOutF.value
-
-          let proposalOut :: Term _ PProposalDatum
               proposalOut = mustFindDatum' # (pfield @"datumHash" # ownOutput) # txInfoF.datums
 
           let -- Update the vote counter of the proposal, and leave other stuff as is.