witnessing stakes in reference inputs

agora/Agora/Proposal.hs

@@ -9,8 +9,7 @@ Proposal scripts encoding effects that operate on the system.
 -}
 module Agora.Proposal (
   -- * Haskell-land
-
+  ProposalEffectMetadata (..),
-  -- Proposal (..),
   ProposalEffectGroup,
   ProposalDatum (..),
   ProposalRedeemer (..),
@@ -22,6 +21,7 @@ module Agora.Proposal (
   emptyVotesFor,
 
   -- * Plutarch-land
+  PProposalEffectMetadata (..),
   PProposalEffectGroup,
   PProposalDatum (..),
   PProposalRedeemer (..),

agora/Agora/Proposal/Scripts.hs

@@ -39,32 +39,41 @@ import Agora.Stake (
   pisVoter,
  )
 import Agora.Utils (
+  plistEqualsBy,
   pltAsData,
  )
 import Plutarch.Api.V1 (PCredential)
 import Plutarch.Api.V1.AssocMap (plookup)
 import Plutarch.Api.V2 (
-  PDatumHash,
   PMintingPolicy,
   PScriptContext (PScriptContext),
   PScriptPurpose (PMinting, PSpending),
+  PTxInInfo,
   PTxInfo (PTxInfo),
   PTxOut,
   PValidator,
  )
 import Plutarch.Extra.AssetClass (passetClass, passetClassValueOf)
+import Plutarch.Extra.Category (PCategory (pidentity))
 import Plutarch.Extra.Comonad (pextract)
 import Plutarch.Extra.Field (pletAll, pletAllC)
-import Plutarch.Extra.List (pfirstJust, pisUniq', pmapMaybe, pmergeBy, pmsortBy)
+import Plutarch.Extra.Functor (pfmap)
+import Plutarch.Extra.List (pfirstJust, pisUniq', pmergeBy, pmsort)
 import Plutarch.Extra.Map (pupdate)
-import Plutarch.Extra.Maybe (passertPJust, pfromJust, pisJust, pjust, pnothing)
+import Plutarch.Extra.Maybe (
+  passertPJust,
+  pfromJust,
+  pfromMaybe,
+  pisJust,
+  pjust,
+  pnothing,
+ )
 import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
 import Plutarch.Extra.ScriptContext (
   pfindTxInByTxOutRef,
-  pfromDatumHash,
   pfromOutputDatum,
   pisTokenSpent,
-  ptryFindDatum,
+  ptryFromOutputDatum,
  )
 import Plutarch.Extra.TermCont (
   pguardC,
@@ -125,6 +134,33 @@ proposalPolicy (AssetClass (govCs, govTn)) =
 
     pure $ popaque (pconstant ())
 
+data PWitneseMultipleStakeContext (s :: S) = PWitneseMultipleStakeContext
+  { totalAmount :: Term s PInteger
+  , orderedOwners :: Term s (PList PCredential)
+  }
+  deriving stock (Generic)
+  deriving anyclass
+    ( PlutusType
+    )
+
+instance DerivePlutusType PWitneseMultipleStakeContext where
+  type DPTStrat _ = PlutusTypeScott
+
+data PSpendSingleStakeContext (s :: S) = PSpendSingleStakeContext
+  { inputStake :: Term s PStakeDatum
+  , outputStake :: Term s PStakeDatum
+  }
+  deriving stock (Generic)
+  deriving anyclass
+    ( PlutusType
+    )
+
+instance DerivePlutusType PSpendSingleStakeContext where
+  type DPTStrat _ = PlutusTypeScott
+
+pemptyWitneseMultipleStakeContext :: forall (s :: S). Term s PWitneseMultipleStakeContext
+pemptyWitneseMultipleStakeContext = pcon $ PWitneseMultipleStakeContext 0 pnil
+
 {- | The validator for Proposals.
 
      The documentation for various of the redeemers lives at 'Agora.Proposal.ProposalRedeemer'.
@@ -167,7 +203,8 @@ proposalValidator as maximumCosigners =
     PTxInfo txInfo' <- pmatchC txInfo
     txInfoF <-
       pletFieldsC
-        @'[ "inputs"
+        @'[ "referenceInputs"
+          , "inputs"
           , "outputs"
           , "mint"
           , "datums"
@@ -256,6 +293,8 @@ proposalValidator as maximumCosigners =
 
     onlyStatusChanged <-
       pletC $
+        -- Only the status of proposals is updated.
+
         -- Only the status of proposals is updated.
         proposalOut
           #== mkRecordConstr
@@ -274,141 +313,130 @@ proposalValidator as maximumCosigners =
 
     -- Find the stake inputs/outputs by SST.
 
-    let AssetClass (stakeSym, stakeTn) = stakeSTAssetClass as
+    getStakeDatum :: Term _ (PTxOut :--> PMaybe PStakeDatum) <-
-    stakeSTAssetClass <-
-      pletC $ passetClass # pconstant stakeSym # pconstant stakeTn
-
-    filterStakeDatumHash :: Term _ (PTxOut :--> PMaybe (PAsData PDatumHash)) <-
       pletC $
-        plam $ \txOut -> unTermCont $ do
+        plam $
-          txOutF <- pletFieldsC @'["value", "datum"] txOut
+          flip (pletFields @'["value", "datum"]) $ \txOutF ->
-          pure $
+            let AssetClass (stakeSym, _) = stakeSTAssetClass as
-            pif
-              (passetClassValueOf # txOutF.value # stakeSTAssetClass #== 1)
-              ( let datumHash = pfromDatumHash # txOutF.datum
-                 in pcon $ PJust $ pdata datumHash
-              )
-              (pcon PNothing)
 
-    stakeInputDatumHashes <-
+                isStakeUTxO =
-      pletC $
+                  psymbolValueOf
-        pmapMaybe @PBuiltinList
+                    # pconstant stakeSym
-          # plam ((filterStakeDatumHash #) . (pfield @"resolved" #))
+                    # txOutF.value
-          # txInfoF.inputs
+                    #== 1
 
-    stakeOutputDatumHashes <-
+                stake =
-      pletC $
+                  pfromData $
-        pmapMaybe @PBuiltinList
+                    pfromJust
-          # filterStakeDatumHash
+                      -- Use inline datum to avoid extra map lookup.
-          # txInfoF.outputs
+                      #$ ptryFromOutputDatum @(PAsData PStakeDatum)
+                      # txOutF.datum
+                      # txInfoF.datums
+             in pif isStakeUTxO (pjust # stake) pnothing
 
-    stakeInputNum <- pletC $ plength # stakeInputDatumHashes
+    witnessStakes' ::
-
-    pguardC "Every stake input should have a correspoding output" $
-      stakeInputNum #== plength # stakeOutputDatumHashes
-
-    ----------------------------------------------------------------------------
-
-    withMultipleStakes' ::
       Term
-        _
+        s
-        ( ( PInteger
+        ( (PWitneseMultipleStakeContext :--> PUnit) :--> PUnit
-              :--> PBuiltinList (PAsData PCredential)
-              :--> PUnit
-          )
-            :--> PUnit
         ) <-
       pletC $
-        plam $ \validationLogic -> unTermCont $ do
+        let updateCtx = plam $ \ctx' stake -> unTermCont $ do
-          -- The following code ensures that all the stake datums are not
+              ctxF <- pmatchC ctx'
-          --   changed.
-          --
-          -- TODO: This is quite inefficient (O(nlogn)) but for now we don't
-          --   have a nice way to check this. In plutus v2 we'll have map of
-          --   (Script -> Redeemer) in ScriptContext, which should be the
-          --   straight up solution.
-          let sortDatumHashes = phoistAcyclic $ pmsortBy # pltAsData
 
-              sortedStakeInputDatumHashes =
+              stakeF <-
-                sortDatumHashes # stakeInputDatumHashes
+                pletFieldsC @'["stakedAmount", "owner"] $
+                  pto stake
 
-              sortedStakeOutputDatumHashes =
+              pure $
-                sortDatumHashes # stakeOutputDatumHashes
+                pcon $
+                  PWitneseMultipleStakeContext
+                    { totalAmount =
+                        ctxF.totalAmount
+                          + punsafeCoerce
+                            (pfromData stakeF.stakedAmount)
+                    , orderedOwners =
+                        pcons # stakeF.owner
+                          # ctxF.orderedOwners
+                    }
 
-          pguardC "All stake datum are unchanged" $
+            f :: Term _ (_ :--> PTxInInfo :--> _)
-            plistEquals
+            f = plam $ \ctx' ((pfield @"resolved" #) -> txOut) ->
-              # sortedStakeInputDatumHashes
+              pfromMaybe # ctx'
-              # sortedStakeOutputDatumHashes
+                #$ (pfmap # (updateCtx # ctx') #$ getStakeDatum # txOut)
 
-          PPair totalStakedAmount stakeOwners <-
+            sortOwners = plam $
-            pmatchC $
+              flip pmatch $ \ctxF ->
-              pfoldl
+                pcon $
-                # plam
+                  PWitneseMultipleStakeContext
-                  ( \l dh -> unTermCont $ do
+                    { totalAmount = ctxF.totalAmount
-                      let stake =
+                    , orderedOwners = pmsort # ctxF.orderedOwners
-                            pfromData $
+                    }
-                              pfromJust
-                                #$ ptryFindDatum @(PAsData PStakeDatum)
-                                # pfromData dh
-                                # txInfoF.datums
 
-                      stakeF <- pletFieldsC @'["stakedAmount", "owner"] $ pto stake
+            ctx =
+              sortOwners
+                #$ pfoldl
+                # f
+                # pemptyWitneseMultipleStakeContext
+                # txInfoF.referenceInputs
+         in plam (# ctx)
 
-                      PPair amount owners <- pmatchC l
+    let witnessStakes ::
+          ( PWitneseMultipleStakeContext _ ->
+            TermCont _ ()
+          ) ->
+          Term _ POpaque
+        witnessStakes c = popaque $
+          witnessStakes' #$ plam $ \sctxF ->
+            unTermCont $ pmatchC sctxF >>= c >> pure (pconstant ())
 
-                      let newAmount = amount + punsafeCoerce (pfromData stakeF.stakedAmount)
+    spendSingleStake' ::
-                          updatedOwners = pcons # stakeF.owner # owners
-
-                      pure $ pcon $ PPair newAmount updatedOwners
-                  )
-                # pcon (PPair (0 :: Term _ PInteger) (pnil @PBuiltinList))
-                # stakeInputDatumHashes
-
-          sortedStakeOwners <- pletC $ pmsortBy # pltAsData # stakeOwners
-
-          pure $ validationLogic # totalStakedAmount # sortedStakeOwners
-
-    withSingleStake' ::
       Term
-        _
+        s
-        ( ( PStakeDatum :--> PStakeDatum :--> PBool :--> PUnit
+        ((PSpendSingleStakeContext :--> PUnit) :--> PUnit) <-
-          )
+      pletC $
-            :--> PUnit
+        let singleInput ::
-        ) <- pletC $
+              Term
-      plam $ \validationLogic -> unTermCont $ do
+                _
-        pguardC "Can only deal with one stake" $
+                ( PMaybe PStakeDatum
-          stakeInputNum #== 1
+                    :--> PTxInInfo
+                    :--> PMaybe PStakeDatum
+                )
+            singleInput = plam $ \l ((pfield @"resolved" #) -> txOut) ->
+              unTermCont $ do
+                lF <- pmatchC l
+                t <- pletC $ getStakeDatum # txOut
+                tF <- pmatchC l
 
-        stakeInputHash <- pletC $ pfromData $ phead # stakeInputDatumHashes
+                pure $ case (lF, tF) of
-        stakeOutputHash <- pletC $ pfromData $ phead # stakeOutputDatumHashes
+                  (PJust _, PJust _) ->
+                    ptraceError "Can only deal with one stake"
+                  (PNothing, _) -> t
+                  (_, PNothing) -> l
 
-        stakeIn :: Term _ PStakeDatum <-
+            stakeInput =
-          pletC $ pfromData $ pfromJust #$ ptryFindDatum # stakeInputHash # txInfoF.datums
+              passertPJust # "Stake input not found"
+                #$ pfoldl # singleInput # pnothing # txInfoF.inputs
 
-        stakeOut :: Term _ PStakeDatum <-
+            stakeOutput =
-          pletC $ pfromData $ pfromJust #$ ptryFindDatum # stakeOutputHash # txInfoF.datums
+              pfromJust
+                #$ pfirstJust # getStakeDatum # txInfoF.outputs
 
-        stakeUnchanged <- pletC $ stakeInputHash #== stakeOutputHash
+            ctx = pcon $ PSpendSingleStakeContext stakeInput stakeOutput
+         in plam (# ctx)
 
-        pure $ validationLogic # stakeIn # stakeOut # stakeUnchanged
+    let spendSingleStake ::
-
+          ( PSpendSingleStakeContext _ ->
-    let withMultipleStakes val =
+            TermCont _ ()
-          withMultipleStakes'
+          ) ->
-            #$ plam
+          Term _ POpaque
-            $ \totalStakedAmount sortedStakeOwner ->
+        spendSingleStake c = popaque $
-              unTermCont $
+          spendSingleStake' #$ plam $ \sctx ->
-                val totalStakedAmount sortedStakeOwner
+            unTermCont $ pmatchC sctx >>= c >> pure (pconstant ())
-
-        withSingleStake val =
-          withSingleStake' #$ plam $ \stakeIn stakeOut stakeUnchange -> unTermCont $ do
-            stakeInF <- pletAllC $ pto stakeIn
-
-            val stakeInF stakeOut stakeUnchange
 
     pure $
       popaque $
         pmatch proposalRedeemer $ \case
-          PCosign r -> withMultipleStakes $ \_ sortedStakeOwners -> do
+          PCosign r -> witnessStakes $ \sctxF -> do
             pguardC "Should be in draft state" $
               currentStatus #== pconstant Draft
 
@@ -430,7 +458,10 @@ proposalValidator as maximumCosigners =
               pisUniq' # updatedSigs
 
             pguardC "All new cosigners are witnessed by their Stake datums" $
-              plistEquals # sortedStakeOwners # newSigs
+              plistEqualsBy
+                # plam (\x (pfromData -> y) -> x #== y)
+                # sctxF.orderedOwners
+                # newSigs
 
             let expectedDatum =
                   mkRecordConstr
@@ -448,11 +479,11 @@ proposalValidator as maximumCosigners =
             pguardC "Signatures are correctly added to cosignature list" $
               proposalOut #== expectedDatum
 
-            pure $ pconstant ()
-
           ----------------------------------------------------------------------
 
-          PVote r -> withSingleStake $ \stakeInF stakeOut _ -> do
+          PVote r -> spendSingleStake $ \sctxF -> do
+            stakeInF <- pletAllC $ pto sctxF.inputStake
+
             pguardC "Input proposal must be in VotingReady state" $
               currentStatus #== pconstant VotingReady
 
@@ -471,7 +502,7 @@ proposalValidator as maximumCosigners =
 
             -- Ensure that no lock with the current proposal id has been put on the stake.
             pguardC "Same stake shouldn't vote on the same proposal twice" $
-              pnot #$ pisVoter #$ pgetStakeRole # proposalF.proposalId # pfromData stakeInF.lockedBy
+              pnot #$ pisVoter #$ pgetStakeRole # proposalF.proposalId # stakeInF.lockedBy
 
             let -- The amount of new votes should be the 'stakedAmount'.
                 -- Update the vote counter of the proposal, and leave other stuff as is.
@@ -525,13 +556,13 @@ proposalValidator as maximumCosigners =
                         .& #lockedBy .= pdata expectedProposalLocks
                     )
 
-            pguardC "Output stake should be locked by the proposal" $ expectedStakeOut #== stakeOut
+            pguardC "Output stake should be locked by the proposal" $ expectedStakeOut #== sctxF.outputStake
-
-            pure $ pconstant ()
 
           ----------------------------------------------------------------------
 
-          PUnlock _ -> withSingleStake $ \stakeInF stakeOut _ -> do
+          PUnlock _ -> spendSingleStake $ \sctxF -> do
+            stakeInF <- pletAllC $ pto sctxF.inputStake
+
             stakeRole <- pletC $ pgetStakeRole # proposalF.proposalId # stakeInF.lockedBy
 
             pguardC "Stake input should be relevant" $
@@ -592,7 +623,7 @@ proposalValidator as maximumCosigners =
                 $ ptraceIfFalse "Proposal unchanged" proposalUnchanged
 
             -- At last, we ensure that all locks belong to this proposal will be removed.
-            stakeOutputLocks <- pletC $ pfield @"lockedBy" # pto stakeOut
+            stakeOutputLocks <- pletC $ pfield @"lockedBy" # pto sctxF.outputStake
 
             let templateStakeOut =
                   mkRecordConstr
@@ -604,102 +635,99 @@ proposalValidator as maximumCosigners =
                     )
 
             pguardC "Only locks updated in the output stake" $
-              templateStakeOut #== stakeOut
+              templateStakeOut #== sctxF.outputStake
 
             pguardC "All relevant locks removed from the stake" $
               validateOutputLocks # stakeOutputLocks
 
-            pure $ pconstant ()
-
           ----------------------------------------------------------------------
 
           PAdvanceProposal _ -> unTermCont $ do
             currentTime' <- pletC $ pfromJust # currentTime
+
             let inDraftPeriod = isDraftPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime'
                 inVotingPeriod = isVotingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime'
                 inExecutionPeriod = isExecutionPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime'
+
             inLockedPeriod <- pletC $ isLockingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime'
+
             pguardC "Only status changes in the output proposal" onlyStatusChanged
-            let gstSymbol = pconstant $ governorSTSymbol as
-            gstMoved <-
-              pletC $
-                pany
-                  # plam
-                    ( \( (pfield @"value" #)
-                          . (pfield @"resolved" #) ->
-                          value
-                        ) ->
-                          psymbolValueOf # gstSymbol # value #== 1
-                    )
-                  # pfromData txInfoF.inputs
-            let toFailedState = unTermCont $ do
-                  -- -> 'Finished'
-                  pguardC "Proposal should fail: not on time" $
-                    proposalOutStatus #== pconstant Finished
 
-                  pguardC "GST not moved" $ pnot # gstMoved
-
-                  pure $ pconstant ()
             pure $
               pmatch currentStatus $ \case
                 PDraft ->
-                  withMultipleStakes $ \totalStakedAmount sortedStakeOwners ->
+                  witnessStakes $ \sctxF -> do
-                    pmatchC inDraftPeriod >>= \case
+                    let notTooLate = inDraftPeriod
+
+                    pmatchC notTooLate >>= \case
                       PTrue -> do
                         pguardC "More cosigns than minimum amount" $
-                          punsafeCoerce (pfromData thresholdsF.vote) #< totalStakedAmount
+                          punsafeCoerce (pfromData thresholdsF.vote) #< sctxF.totalAmount
 
                         pguardC "All new cosigners are witnessed by their Stake datums" $
-                          plistEquals # sortedStakeOwners # proposalF.cosigners
+                          plistEqualsBy
+                            # plam (\x (pfromData -> y) -> x #== y)
+                            # sctxF.orderedOwners
+                            # proposalF.cosigners
 
                         -- 'Draft' -> 'VotingReady'
                         pguardC "Proposal status set to VotingReady" $
                           proposalOutStatus #== pconstant VotingReady
-
+                      -- Too late: failed proposal, status set to 'Finished'.
-                        pure $ pconstant ()
+                      PFalse ->
-                      PFalse -> do
+                        pguardC "Proposal should fail: not on time" $
-                        pguardC "Advance to failed state" $ proposalOutStatus #== pconstant Finished
+                          proposalOutStatus #== pconstant Finished
-
-                        pure $ pconstant ()
                 PVotingReady -> unTermCont $ do
                   let notTooLate = inLockedPeriod
                       notTooEarly = pnot # inVotingPeriod
+
                   pguardC "Cannot advance ahead of time" notTooEarly
-                  -- FIXME: This should be checked by Stake, as opposed to here.
-                  pguardC "No stakes must be present" $ stakeInputNum #== 0
-                  pure $
-                    pif
-                      notTooLate
-                      ( unTermCont $ do
-                          -- 'VotingReady' -> 'Locked'
-                          pguardC "Proposal status set to Locked" $
-                            proposalOutStatus #== pconstant Locked
 
-                          pguardC "Winner outcome not found" $
+                  pmatchC notTooLate >>= \case
-                            pisJust #$ pwinner' # proposalF.votes
+                    PTrue -> do
-                              #$ punsafeCoerce
+                      -- 'VotingReady' -> 'Locked'
-                              $ pfromData thresholdsF.execute
+                      pguardC "Proposal status set to Locked" $
+                        proposalOutStatus #== pconstant Locked
 
-                          pure $ pconstant ()
+                      pguardC "Winner outcome not found" $
-                      )
+                        pisJust #$ pwinner' # proposalF.votes
-                      -- Too late: failed proposal, status set to 'Finished'.
+                          #$ punsafeCoerce
-                      toFailedState
+                          $ pfromData thresholdsF.execute
+                    -- Too late: failed proposal, status set to 'Finished'.
+                    PFalse ->
+                      pguardC "Proposal should fail: not on time" $
+                        proposalOutStatus #== pconstant Finished
+
+                  pure $ popaque $ pconstant ()
                 PLocked -> unTermCont $ do
                   let notTooLate = inExecutionPeriod
                       notTooEarly = pnot # inLockedPeriod
+
                   pguardC "Not too early" notTooEarly
-                  pguardC "No stakes must be present" $ stakeInputNum #== 0
+
-                  pure $
+                  pguardC "Proposal status set to Finished" $
+                    proposalOutStatus #== pconstant Finished
+
+                  let gstSymbol = pconstant $ governorSTSymbol as
+                      gstMoved =
+                        pany
+                          # plam
+                            ( \( (pfield @"value" #)
+                                  . (pfield @"resolved" #) ->
+                                  value
+                                ) ->
+                                  psymbolValueOf # gstSymbol # value #== 1
+                            )
+                          # pfromData txInfoF.inputs
+
+                  pguardC "GST not moved if too late, moved otherwise" $
                     pif
                       notTooLate
-                      ( unTermCont $ do
+                      -- Not too late: GST should moved
-                          -- 'Locked' -> 'Finished'
+                      pidentity
-                          pguardC "Proposal status set to Finished" $
+                      -- Not too late: GST should not moved
-                            proposalOutStatus #== pconstant Finished
+                      pnot
+                      # gstMoved
 
-                          pguardC "GST moved" gstMoved
+                  pure $ popaque $ pconstant ()
-
-                          pure $ pconstant ()
-                      )
-                      toFailedState
                 PFinished -> ptraceError "Finished proposals cannot be advanced"

agora/Agora/Stake.hs

@@ -143,9 +143,6 @@ data StakeRedeemer
     --   always allowed to have votes retracted and won't affect the Proposal datum,
     --   allowing 'Stake's to be unlocked.
     RetractVotes
-  | -- | The owner can consume stake if nothing is changed about it.
-    --   If the proposal token moves, this is equivalent to the owner consuming it.
-    WitnessStake
   | -- | The owner can delegate the stake to another user, allowing the
     --    delegate to vote on prooposals with the stake.
     DelegateTo Credential
@@ -164,9 +161,8 @@ PlutusTx.makeIsDataIndexed
   , ('Destroy, 1)
   , ('PermitVote, 2)
   , ('RetractVotes, 3)
-  , ('WitnessStake, 4)
+  , ('DelegateTo, 4)
-  , ('DelegateTo, 5)
+  , ('ClearDelegate, 5)
-  , ('ClearDelegate, 6)
   ]
 
 {- | Haskell-level datum for Stake scripts.
@@ -264,7 +260,6 @@ data PStakeRedeemer (s :: S)
     PDestroy (Term s (PDataRecord '[]))
   | PPermitVote (Term s (PDataRecord '[]))
   | PRetractVotes (Term s (PDataRecord '[]))
-  | PWitnessStake (Term s (PDataRecord '[]))
   | PDelegateTo (Term s (PDataRecord '["pkh" ':= PCredential]))
   | PClearDelegate (Term s (PDataRecord '[]))
   deriving stock

agora/Agora/Stake/Scripts.hs

@@ -8,6 +8,7 @@ Plutus Scripts for Stakes.
 module Agora.Stake.Scripts (stakePolicy, stakeValidator) where
 
 import Agora.Credential (authorizationContext, pauthorizedBy)
+import Agora.Proposal (PProposalRedeemer (PUnlock, PVote))
 import Agora.SafeMoney (GTTag)
 import Agora.Scripts (AgoraScripts, proposalSTAssetClass, stakeSTSymbol)
 import Agora.Stake (
@@ -15,22 +16,22 @@ import Agora.Stake (
   PStakeRedeemer (..),
   pstakeLocked,
  )
-import Data.Function (on)
 import Data.Tagged (Tagged, untag)
 import Plutarch.Api.V1 (
   PCredential (PPubKeyCredential, PScriptCredential),
   PTokenName,
   PValue,
  )
+import Plutarch.Api.V1.AssocMap (plookup)
 import Plutarch.Api.V2 (
   AmountGuarantees (Positive),
   KeyGuarantees (Sorted),
-  PDatumHash,
   PMaybeData,
   PMintingPolicy,
   PScriptPurpose (PMinting, PSpending),
+  PTxInInfo,
   PTxInfo,
-  PTxOut,
+  PTxOutRef,
   PValidator,
  )
 import Plutarch.Extra.AssetClass (
@@ -38,23 +39,40 @@ import Plutarch.Extra.AssetClass (
   passetClassValueOf,
   pvalueOf,
  )
+import Plutarch.Extra.Bind (PBind ((#>>=)))
 import Plutarch.Extra.Field (pletAllC)
-import Plutarch.Extra.List (pmapMaybe, pmsortBy)
+import Plutarch.Extra.Functor (PFunctor (pfmap))
-import Plutarch.Extra.Maybe (passertPJust, pdjust, pdnothing, pmaybeData)
+import Plutarch.Extra.List (pfirstJust)
+import Plutarch.Extra.Maybe (
+  passertPJust,
+  pdjust,
+  pdnothing,
+  pjust,
+  pmaybeData,
+  pnothing,
+ )
 import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
 import Plutarch.Extra.ScriptContext (
   pfindTxInByTxOutRef,
-  pfromDatumHash,
   pfromOutputDatum,
   pvalueSpent,
  )
-import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC)
+import Plutarch.Extra.TermCont (
+  pguardC,
+  pletC,
+  pletFieldsC,
+  pmatchC,
+  ptryFromC,
+ )
 import Plutarch.Extra.Value (
   pgeqByClass',
   pgeqBySymbol,
   psymbolValueOf,
  )
-import Plutarch.Numeric.Additive (AdditiveMonoid (zero), AdditiveSemigroup ((+)))
+import Plutarch.Numeric.Additive (
+  AdditiveMonoid (zero),
+  AdditiveSemigroup ((+)),
+ )
 import Plutarch.SafeMoney (
   pdiscreteValue',
   pvalueDiscrete',
@@ -264,6 +282,7 @@ stakeValidator as gtClassRef =
           , "outputs"
           , "signatories"
           , "datums"
+          , "redeemers"
           ]
         txInfo
 
@@ -321,9 +340,33 @@ stakeValidator as gtClassRef =
         _ -> unTermCont $ do
           let AssetClass (propCs, propTn) = proposalSTAssetClass as
               proposalSTClass = passetClass # pconstant propCs # pconstant propTn
-              spentProposalST = passetClassValueOf # valueSpent # proposalSTClass
 
-          proposalTokenMoved <- pletC $ 1 #<= spentProposalST
+          proposalRedeemer <-
+            pletC $
+              let convertRedeemer = plam $ \(pto -> dt) ->
+                    ptryFrom @PProposalRedeemer dt fst
+
+                  findRedeemer = plam $ \ref ->
+                    plookup
+                      # pcon
+                        ( PSpending $
+                            pdcons @_0
+                              # pdata ref
+                              # pdnil
+                        )
+                      # txInfoF.redeemers
+
+                  f :: Term _ (PTxInInfo :--> PMaybe PTxOutRef)
+                  f = plam $ \inInfo ->
+                    let value = pfield @"value" #$ pfield @"resolved" # inInfo
+                        ref = pfield @"outRef" # inInfo
+                     in pif
+                          (passetClassValueOf # value # proposalSTClass #== 1)
+                          (pjust # ref)
+                          pnothing
+
+                  proposalRef = pfirstJust # f # txInfoF.inputs
+               in pfmap # convertRedeemer #$ proposalRef #>>= findRedeemer
 
           -- Filter out own outputs using own address and ST.
           ownOutputs <-
@@ -339,52 +382,6 @@ stakeValidator as gtClassRef =
                   )
                 # pfromData txInfoF.outputs
 
-          let witnessStake = unTermCont $ do
-                pguardC "Either owner signs the transaction or proposal token moved" $
-                  ownerSignsTransaction #|| proposalTokenMoved
-
-                -- FIXME: remove this once we have reference input.
-                --
-                -- Our goal here is to allow multiple input stakes, and also ensure that every the input stakes has a
-                --   corresponding output stake, which carries the same value and the same datum as the input stake.
-                --
-                -- Validation strategy I have tried/considered so far:
-                -- 1. Check that the number of input stakes equals to the number of output stakes, and verify
-                --     that there's an output stake with the exact same value and datum hash as the stake being
-                --     validated , However this approach has a fatal vulnerability: let's say we have two totally
-                --     identical stakes, a malicious user can comsume these two stakes and remove GTs from one of them.
-                -- 2. Perform the same checks as the last approch does, while also checking that every output stake is
-                --     valid(stakedAmount == actual value). However this requires that all the output stake datum are
-                --     included in the transaction, and we have to find and go through them one by one to access the
-                --      'stakedAmount' fields, meaning that computationally this approach is *very* expensive.
-                -- 3. The one implemented below. Find all the continuous input/output, sort them by 'datumHash', and
-                --     ensure that the two sorted lists are equal.
-                let ownInputs =
-                      pmapMaybe
-                        # plam
-                          ( \input -> plet (pfield @"resolved" # input) $ \resolvedInput ->
-                              let value = pfield @"value" # resolvedInput
-                               in pif
-                                    (psymbolValueOf # stCurrencySymbol # value #== 1)
-                                    (pcon $ PJust resolvedInput)
-                                    (pcon PNothing)
-                          )
-                        # pfromData txInfoF.inputs
-
-                    sortTxOuts :: Term _ (PBuiltinList PTxOut :--> PBuiltinList PTxOut)
-                    sortTxOuts = phoistAcyclic $ plam (pmsortBy # plam ((#<) `on` (getDatumHash #)) #)
-                      where
-                        getDatumHash :: Term _ (PTxOut :--> PDatumHash)
-                        getDatumHash = phoistAcyclic $ plam ((pfromDatumHash #) . (pfield @"datum" #))
-
-                    sortedOwnInputs = sortTxOuts # ownInputs
-                    sortedOwnOutputs = sortTxOuts # ownOutputs
-
-                pguardC "Every stake inputs has a corresponding unchanged output" $
-                  plistEquals # sortedOwnInputs # sortedOwnOutputs
-
-                pure $ popaque $ pconstant ()
-
           ----------------------------------------------------------------------
 
           withSingleStake' ::
@@ -479,7 +476,17 @@ stakeValidator as gtClassRef =
 
                 -- This puts trust into the Proposal. The Proposal must necessarily check
                 -- that this is not abused.
-                pguardC "Proposal ST spent" proposalTokenMoved
+
+                pguardC "Proposal ST spent" $
+                  pmatch proposalRedeemer $ \case
+                    PJust redeemer -> pmatch redeemer $ \case
+                      PUnlock _ -> pconstant True
+                      _ ->
+                        ptrace "Expected PUnlock, but got other" $
+                          pconstant False
+                    PNothing ->
+                      ptrace "Proposal redeemer not found" $
+                        pconstant False
 
                 pguardC "A UTXO must exist with the correct output" $
                   let valueCorrect = ctx.ownOutputValueUnchanged
@@ -503,7 +510,16 @@ stakeValidator as gtClassRef =
                 -- This puts trust into the Proposal. The Proposal must necessarily check
                 -- that this is not abused.
                 pguardC "Proposal ST spent or minted" $
-                  proposalTokenMoved #|| proposalTokenMinted
+                  pmatch
+                    proposalRedeemer
+                    ( \case
+                        PJust proposalRedeemer' ->
+                          pmatch proposalRedeemer' $ \case
+                            PVote _ -> pconstant True
+                            _ -> ptrace "Expected PVote" $ pconstant False
+                        _ -> proposalTokenMinted
+                    )
+
                 pguardC "A UTXO must exist with the correct output" $
                   let correctOutputDatum = ctx.onlyLocksUpdated
                       valueCorrect = ctx.ownOutputValueUnchanged
@@ -579,7 +595,4 @@ stakeValidator as gtClassRef =
 
               ------------------------------------------------------------------
 
-              PWitnessStake _ -> witnessStake
-              ------------------------------------------------------------------
-
               _ -> ptraceError "unreachable"

agora/Agora/Utils.hs

@@ -18,10 +18,15 @@ module Agora.Utils (
   pvalidatorHashToTokenName,
   pscriptHashToTokenName,
   scriptHashToTokenName,
+  plistEqualsBy,
+  pstringIntercalate,
+  punwords,
 ) where
 
 import Plutarch.Api.V1 (PTokenName, PValidatorHash)
 import Plutarch.Api.V2 (PScriptHash)
+import Plutarch.Extra.TermCont (pmatchC)
+import Plutarch.List (puncons)
 import Plutarch.Unsafe (punsafeCoerce)
 import PlutusLedgerApi.V2 (
   Address (Address),
@@ -128,3 +133,45 @@ newtype CompiledMintingPolicy (redeemer :: Type) = CompiledMintingPolicy
 newtype CompiledEffect (datum :: Type) = CompiledEffect
   { getCompiledEffect :: Validator
   }
+
+-- | @since 1.0.0
+plistEqualsBy ::
+  forall
+    (list1 :: PType -> PType)
+    (list2 :: PType -> PType)
+    (a :: PType)
+    (b :: PType)
+    (s :: S).
+  (PIsListLike list1 a, PIsListLike list2 b) =>
+  Term s ((a :--> b :--> PBool) :--> list1 a :--> (list2 b :--> PBool))
+plistEqualsBy = phoistAcyclic $ pfix # go
+  where
+    go = plam $ \self eq l1 l2 -> unTermCont $ do
+      l1' <- pmatchC $ puncons # l1
+      l2' <- pmatchC $ puncons # l2
+
+      case (l1', l2') of
+        (PJust l1'', PJust l2'') -> do
+          (PPair h1 t1) <- pmatchC l1''
+          (PPair h2 t2) <- pmatchC l2''
+
+          pure $ eq # h1 # h2 #&& self # eq # t1 # t2
+        (PNothing, PNothing) -> pure $ pconstant True
+        _ -> pure $ pconstant False
+
+-- | @since 1.0.0
+pstringIntercalate ::
+  forall (s :: S).
+  Term s PString ->
+  [Term s PString] ->
+  Term s PString
+pstringIntercalate _ [x] = x
+pstringIntercalate i (x : xs) = x <> i <> pstringIntercalate i xs
+pstringIntercalate _ _ = ""
+
+-- | @since 1.0.0
+punwords ::
+  forall (s :: S).
+  [Term s PString] ->
+  Term s PString
+punwords = pstringIntercalate " "