prevent ambiguous stake inputs while creating proposals

agora/Agora/Stake/Redeemers.hs

@@ -48,7 +48,7 @@ import Agora.Stake (
   ),
   pstakeLocked,
  )
-import Agora.Utils (pdeleteBy, pfromSingleton)
+import Agora.Utils (pdeleteBy, pfromSingleton, pisSingleton)
 import Plutarch.Api.V1.Address (PCredential)
 import Plutarch.Api.V2 (PMaybeData)
 import Plutarch.Extra.Field (pletAll, pletAllC)
@@ -149,7 +149,7 @@ pvoteHelper ::
   forall (s :: S).
   Term
     s
-    ( ( PProposalContext
+    ( ( PStakeRedeemerHandlerContext
           :--> PBuiltinList (PAsData PProposalLock)
           :--> PBuiltinList (PAsData PProposalLock)
       )
@@ -157,8 +157,6 @@ pvoteHelper ::
     )
 pvoteHelper = phoistAcyclic $
   plam $ \valProposalCtx ctx -> unTermCont $ do
-    ctxF <- pmatchC ctx
-
     pguardC "Owner or delegate signs this transaction" $
       pisSignedBy # pconstant True # ctx
 
@@ -166,7 +164,7 @@ pvoteHelper = phoistAcyclic $
     -- that this is not abused.
 
     pguardC "Correct outputs" $
-      ponlyLocksUpdated # (valProposalCtx # ctxF.proposalContext) # ctx
+      ponlyLocksUpdated # (valProposalCtx # ctx) # ctx
 
     pure $ pconstant ()
 
@@ -189,27 +187,35 @@ paddNewLock = phoistAcyclic $
      @since 1.0.0
 -}
 ppermitVote :: forall (s :: S). Term s PStakeRedeemerHandler
-ppermitVote = pvoteHelper #$ phoistAcyclic $
+ppermitVote = phoistAcyclic $
-  plam $
+  pvoteHelper #$ phoistAcyclic $
-    flip pmatch $ \case
+    plam $ \ctx -> unTermCont $ do
-      PSpendProposal pid _ r -> pmatch r $ \case
+      ctxF <- pmatchC ctx
-        PVote ((pfromData . (pfield @"resultTag" #)) -> voteFor) ->
+
-          let newLock =
+      let withOnlyOneStakeInput =
-                mkRecordConstr
+            plam $ \lock -> unTermCont $ do
-                  PVoted
+              pguardC "Only one stake input allowed" $
-                  ( #votedOn .= pdata pid
+                pisSingleton # ctxF.stakeInputDatums
-                      .& #votedFor .= pdata voteFor
+
-                  )
+              pure lock
-           in paddNewLock # newLock
+
-        _ -> ptraceError "Expected Vote"
+      pure $
-      PNewProposal pid ->
+        paddNewLock #$ pmatch ctxF.proposalContext $ \case
-        let newLock =
+          PSpendProposal pid _ r -> pmatch r $ \case
+            PVote ((pfromData . (pfield @"resultTag" #)) -> voteFor) ->
               mkRecordConstr
+                PVoted
+                ( #votedOn .= pdata pid
+                    .& #votedFor .= pdata voteFor
+                )
+            _ -> ptraceError "Expected Vote"
+          PNewProposal pid ->
+            withOnlyOneStakeInput
+              #$ mkRecordConstr
                 PCreated
                 ( #created .= pdata pid
                 )
-         in paddNewLock # newLock
+          _ -> ptraceError "Expected proposal"
-      _ -> ptraceError "Expected proposal"
 
 {- | Remove stake locks with the proposal id given the list of existing locks.
      The first parameter controls whether to revmove creator locks or not.
@@ -237,16 +243,18 @@ premoveLocks = phoistAcyclic $
      @since 1.0.0
 -}
 pretractVote :: forall (s :: S). Term s PStakeRedeemerHandler
-pretractVote = pvoteHelper #$ phoistAcyclic $
+pretractVote = phoistAcyclic $
-  plam $
+  pvoteHelper #$ phoistAcyclic $
-    flip pmatch $ \case
+    plam $
-      PSpendProposal pid s r -> pmatch r $ \case
+      flip pmatch $ \ctxF ->
-        PUnlock _ ->
+        pmatch ctxF.proposalContext $ \case
-          let allowRemovingCreatorLock =
+          PSpendProposal pid s r -> pmatch r $ \case
-                s #== pconstant Finished
+            PUnlock _ ->
-           in premoveLocks # pid # allowRemovingCreatorLock
+              let allowRemovingCreatorLock =
-        _ -> ptraceError "Expected unlock"
+                    s #== pconstant Finished
-      _ -> ptraceError "Expected spending proposal"
+               in premoveLocks # pid # allowRemovingCreatorLock
+            _ -> ptraceError "Expected unlock"
+          _ -> ptraceError "Expected spending proposal"
 
 -- | Validation logic shared by 'pdelegateTo' and 'pclearDelegate'.
 pdelegateHelper ::