add checks to cosign

agora-test/Spec/Proposal.hs

@@ -13,9 +13,26 @@ module Spec.Proposal (tests) where
 
 --------------------------------------------------------------------------------
 
-import Agora.Proposal (proposalPolicy)
+import Agora.Proposal (
+  ProposalDatum (ProposalDatum),
+  ProposalId (ProposalId),
+  ProposalRedeemer (Cosign),
+  ProposalStatus (Draft),
+  ProposalVotes (ProposalVotes),
+  ResultTag (ResultTag),
+  cosigners,
+  effects,
+  proposalId,
+  proposalPolicy,
+  proposalValidator,
+  status,
+  thresholds,
+  votes,
+ )
+import PlutusTx.AssocMap qualified as AssocMap
+import Spec.Sample.Proposal (propThresholds, signer, signer2)
 import Spec.Sample.Proposal qualified as Proposal
-import Spec.Util (policySucceedsWith)
+import Spec.Util (policySucceedsWith, validatorSucceedsWith)
 import Test.Tasty (TestTree, testGroup)
 
 --------------------------------------------------------------------------------
@@ -35,4 +52,25 @@ tests =
           ()
           Proposal.proposalCreation
       ]
+  , testGroup
+      "validator"
+      [ validatorSucceedsWith
+          "stakeCreation"
+          (proposalValidator Proposal.proposal)
+          ( ProposalDatum
+              { proposalId = ProposalId 0
+              , effects =
+                  AssocMap.fromList
+                    [ (ResultTag 0, [])
+                    , (ResultTag 1, [])
+                    ]
+              , status = Draft
+              , cosigners = [signer]
+              , thresholds = propThresholds
+              , votes = ProposalVotes AssocMap.empty
+              }
+          )
+          (Cosign [signer2])
+          (Proposal.cosignProposal [signer2])
+      ]
   ]

agora-test/Spec/Sample/Proposal.hs

@@ -7,13 +7,15 @@ This module tests primarily the happy path for Proposal interactions
 -}
 module Spec.Sample.Proposal (
   proposal,
-  policy,
+  propPolicy,
-  policySymbol,
+  propPolicySymbol,
-  validatorHashTN,
+  propThresholds,
   signer,
+  signer2,
 
   -- * Script contexts
   proposalCreation,
+  cosignProposal,
 ) where
 
 --------------------------------------------------------------------------------
@@ -37,11 +39,9 @@ import Plutus.V1.Ledger.Api (
   TxInfo (..),
   TxOut (TxOut, txOutAddress, txOutDatumHash, txOutValue),
   TxOutRef (TxOutRef),
-  ValidatorHash (ValidatorHash),
  )
 import Plutus.V1.Ledger.Interval qualified as Interval
-import Plutus.V1.Ledger.Scripts (Validator)
+import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash)
-import Plutus.V1.Ledger.Value (AssetClass (AssetClass), TokenName (TokenName))
 import Plutus.V1.Ledger.Value qualified as Value
 
 --------------------------------------------------------------------------------
@@ -52,13 +52,35 @@ import Agora.Governor (
   governorPolicy,
   governorValidator,
  )
-import Agora.Proposal
+import Agora.Proposal (
+  Proposal (..),
+  ProposalDatum (..),
+  ProposalId (..),
+  ProposalStatus (..),
+  ProposalThresholds (..),
+  ProposalVotes (..),
+  ResultTag (..),
+  proposalPolicy,
+  proposalValidator,
+ )
+import Agora.Stake (Stake (..), stakePolicy)
 import Plutarch.SafeMoney
+import Plutus.V1.Ledger.Address (scriptHashAddress)
 import PlutusTx.AssocMap qualified as AssocMap
 import Spec.Util (datumPair, toDatumHash)
 
 --------------------------------------------------------------------------------
 
+stake :: Stake
+stake =
+  Stake
+    { gtClassRef = Tagged $ Value.assetClass govSymbol ""
+    , proposalSTClass = Value.assetClass propPolicySymbol ""
+    }
+
+stakeSymbol :: CurrencySymbol
+stakeSymbol = mintingPolicySymbol $ mkMintingPolicy $ stakePolicy stake.gtClassRef
+
 governor :: Governor
 governor = Governor
 
@@ -76,30 +98,35 @@ proposal =
   Proposal
     { governorSTAssetClass =
         -- TODO: if we had a governor here
-        AssetClass
+        Value.assetClass govSymbol ""
-          ( govSymbol
+    , stakeSTAssetClass =
-          , ""
+        Value.assetClass stakeSymbol ""
-          )
     }
 
 -- | 'Proposal' policy instance.
-policy :: MintingPolicy
+propPolicy :: MintingPolicy
-policy = mkMintingPolicy (proposalPolicy proposal)
+propPolicy = mkMintingPolicy (proposalPolicy proposal)
 
-policySymbol :: CurrencySymbol
+propPolicySymbol :: CurrencySymbol
-policySymbol = mintingPolicySymbol policy
+propPolicySymbol = mintingPolicySymbol propPolicy
 
 -- | A sample 'PubKeyHash'.
 signer :: PubKeyHash
 signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
 
--- | 'Proposal' validator instance.
+-- | Another sample 'PubKeyHash'.
-validator :: Validator
+signer2 :: PubKeyHash
-validator = mkValidator (proposalValidator proposal)
+signer2 = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be74012141420192"
 
--- | 'TokenName' that represents the hash of the 'Proposal' validator.
+-- | 'Proposal' validator instance.
-validatorHashTN :: TokenName
+propValidator :: Validator
-validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh
+propValidator = mkValidator (proposalValidator proposal)
+
+propValidatorHash :: ValidatorHash
+propValidatorHash = validatorHash propValidator
+
+propValidatorAddress :: Address
+propValidatorAddress = scriptHashAddress propValidatorHash
 
 propThresholds :: ProposalThresholds
 propThresholds =
@@ -112,7 +139,7 @@ propThresholds =
 -- | This script context should be a valid transaction.
 proposalCreation :: ScriptContext
 proposalCreation =
-  let st = Value.singleton policySymbol "" 1 -- Proposal ST
+  let st = Value.singleton propPolicySymbol "" 1 -- Proposal ST
       proposalDatum :: Datum
       proposalDatum =
         Datum
@@ -163,7 +190,7 @@ proposalCreation =
                   ]
               , txInfoOutputs =
                   [ TxOut
-                      { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
+                      { txOutAddress = Address (ScriptCredential $ validatorHash propValidator) Nothing
                       , txOutValue =
                           mconcat
                             [ st
@@ -194,5 +221,68 @@ proposalCreation =
                   ]
               , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
               }
-        , scriptContextPurpose = Minting policySymbol
+        , scriptContextPurpose = Minting propPolicySymbol
+        }
+
+-- | This script context should be a valid transaction.
+cosignProposal :: [PubKeyHash] -> ScriptContext
+cosignProposal newSigners =
+  let st = Value.singleton propPolicySymbol "" 1 -- Proposal ST
+      proposalBefore :: ProposalDatum
+      proposalBefore =
+        ProposalDatum
+          { proposalId = ProposalId 0
+          , effects =
+              AssocMap.fromList
+                [ (ResultTag 0, [])
+                , (ResultTag 1, [])
+                ]
+          , status = Draft
+          , cosigners = [signer]
+          , thresholds = propThresholds
+          , votes = ProposalVotes AssocMap.empty
+          }
+      proposalAfter :: ProposalDatum
+      proposalAfter = proposalBefore {cosigners = newSigners <> proposalBefore.cosigners}
+      proposalRef = (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
+   in ScriptContext
+        { scriptContextTxInfo =
+            TxInfo
+              { txInfoInputs =
+                  [ TxInInfo
+                      proposalRef
+                      TxOut
+                        { txOutAddress = propValidatorAddress
+                        , txOutValue =
+                            mconcat
+                              [ st
+                              , Value.singleton "" "" 10_000_000
+                              ]
+                        , txOutDatumHash = Just (toDatumHash proposalBefore)
+                        }
+                  ]
+              , txInfoOutputs =
+                  [ TxOut
+                      { txOutAddress = Address (ScriptCredential $ validatorHash propValidator) Nothing
+                      , txOutValue =
+                          mconcat
+                            [ st
+                            , Value.singleton "" "" 10_000_000
+                            ]
+                      , txOutDatumHash = Just (toDatumHash . Datum $ toBuiltinData proposalAfter)
+                      }
+                  ]
+              , txInfoFee = Value.singleton "" "" 2
+              , txInfoMint = st
+              , txInfoDCert = []
+              , txInfoWdrl = []
+              , txInfoValidRange = Interval.always
+              , txInfoSignatories = newSigners
+              , txInfoData =
+                  [ datumPair . Datum $ toBuiltinData proposalBefore
+                  , datumPair . Datum $ toBuiltinData proposalAfter
+                  ]
+              , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
+              }
+        , scriptContextPurpose = Spending proposalRef
         }

agora-test/Spec/Sample/Stake.hs

@@ -69,11 +69,12 @@ stake =
               , "LQ"
               )
           )
+    , proposalSTClass = AssetClass ("", "")
     }
 
 -- | 'Stake' policy instance.
 policy :: MintingPolicy
-policy = mkMintingPolicy (stakePolicy stake)
+policy = mkMintingPolicy (stakePolicy stake.gtClassRef)
 
 policySymbol :: CurrencySymbol
 policySymbol = mintingPolicySymbol policy

agora-test/Spec/Stake.hs

@@ -19,7 +19,7 @@ import Test.Tasty (TestTree, testGroup)
 
 --------------------------------------------------------------------------------
 
-import Agora.Stake (StakeDatum (StakeDatum), StakeRedeemer (DepositWithdraw), stakePolicy, stakeValidator)
+import Agora.Stake (Stake (..), StakeDatum (StakeDatum), StakeRedeemer (DepositWithdraw), stakePolicy, stakeValidator)
 
 --------------------------------------------------------------------------------
 
@@ -36,17 +36,17 @@ tests =
       "policy"
       [ policySucceedsWith
           "stakeCreation"
-          (stakePolicy Stake.stake)
+          (stakePolicy Stake.stake.gtClassRef)
           ()
           Stake.stakeCreation
       , policyFailsWith
           "stakeCreationWrongDatum"
-          (stakePolicy Stake.stake)
+          (stakePolicy Stake.stake.gtClassRef)
           ()
           Stake.stakeCreationWrongDatum
       , policyFailsWith
           "stakeCreationUnsigned"
-          (stakePolicy Stake.stake)
+          (stakePolicy Stake.stake.gtClassRef)
           ()
           Stake.stakeCreationUnsigned
       ]

agora/Agora/Proposal.hs

@@ -249,8 +249,9 @@ PlutusTx.makeIsDataIndexed
   ]
 
 -- | Parameters that identify the Proposal validator script.
-newtype Proposal = Proposal
+data Proposal = Proposal
   { governorSTAssetClass :: AssetClass
+  , stakeSTAssetClass :: AssetClass
   }
   deriving stock (Show, Eq)
 
@@ -442,14 +443,23 @@ proposalValidator proposal =
     PSpending ((pfield @"_0" #) -> txOutRef) <- pmatch $ pfromData ctx.purpose
 
     PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs
-    txOutF <- pletFields @'["address"] $ txOut
+    txOutF <- pletFields @'["address", "value"] $ txOut
 
     let proposalDatum :: Term _ PProposalDatum
         proposalDatum = pfromData $ punsafeCoerce datum
         proposalRedeemer :: Term _ PProposalRedeemer
         proposalRedeemer = pfromData $ punsafeCoerce redeemer
 
-    proposalF <- pletFields @'["cosigners"] proposalDatum
+    proposalF <-
+      pletFields
+        @'[ "id"
+          , "effects"
+          , "status"
+          , "cosigners"
+          , "thresholds"
+          , "votes"
+          ]
+        proposalDatum
 
     ownAddress <- plet $ txOutF.address
 
@@ -475,18 +485,35 @@ proposalValidator proposal =
         passert "Signatures are correctly added to cosignature list" $
           anyOutput @PProposalDatum # ctx.txInfo
             #$ plam
-            $ \_value address newProposalDatum -> P.do
+            $ \newValue address newProposalDatum -> P.do
-              newProposalF <- pletFields @'["cosigners"] newProposalDatum
+              newProposalF <-
+                pletFields
+                  @'[ "id"
+                    , "effects"
+                    , "status"
+                    , "cosigners"
+                    , "thresholds"
+                    , "votes"
+                    ]
+                  newProposalDatum
 
+              -- This is a little sad. Can we do better by
+              -- building a new ProposalDatum and then comparing?
               let correctDatum =
                     foldr1
                       (#&&)
-                      [ newProposalF.cosigners #== proposalF.cosigners
+                      [ newProposalF.cosigners #== pconcat # newSigs # proposalF.cosigners
+                      , newProposalF.id #== proposalF.id
+                      , newProposalF.effects #== proposalF.effects
+                      , newProposalF.status #== proposalF.status
+                      , newProposalF.thresholds #== proposalF.thresholds
+                      , newProposalF.votes #== proposalF.votes
                       ]
 
               foldr1
                 (#&&)
                 [ ptraceIfFalse "Datum must be correct" $ correctDatum
+                , ptraceIfFalse "Value should be correct" $ pdata txOutF.value #== pdata newValue
                 , ptraceIfFalse "Must be sent to Proposal's address" $ ownAddress #== pdata address
                 ]
 

agora/Agora/Stake.hs

@@ -70,9 +70,11 @@ import Agora.Utils (
   pnotNull,
   psingletonValue,
   psymbolValueOf,
+  ptokenSpent,
   ptxSignedBy,
   pvalueSpent,
  )
+import Plutarch.Api.V1.Extra (passetClass)
 import Plutarch.Numeric
 import Plutarch.SafeMoney (
   PDiscrete,
@@ -85,9 +87,10 @@ import Plutarch.TryFrom (PTryFrom, ptryFrom)
 --------------------------------------------------------------------------------
 
 -- | Parameters for creating Stake scripts.
-newtype Stake = Stake
+data Stake = Stake
   { gtClassRef :: Tagged GTTag AssetClass
   -- ^ Used when inlining the AssetClass of a 'PDiscrete' in the script code.
+  , proposalSTClass :: AssetClass
   }
 
 {- | A lock placed on a Stake datum in order to prevent
@@ -147,6 +150,9 @@ data StakeRedeemer
     --   always allowed to have votes retracted and won't affect the Proposal datum,
     --   allowing 'Stake's to be unlocked.
     RetractVotes [ProposalLock]
+  | -- | 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
   deriving stock (Show, GHC.Generic)
 
 PlutusTx.makeIsDataIndexed
@@ -155,6 +161,7 @@ PlutusTx.makeIsDataIndexed
   , ('Destroy, 1)
   , ('PermitVote, 2)
   , ('RetractVotes, 3)
+  , ('WitnessStake, 4)
   ]
 
 -- | Haskell-level datum for Stake scripts.
@@ -207,6 +214,7 @@ data PStakeRedeemer (s :: S)
     PDestroy (Term s (PDataRecord '[]))
   | PPermitVote (Term s (PDataRecord '["lock" ':= PProposalLock]))
   | PRetractVotes (Term s (PDataRecord '["locks" ':= PBuiltinList (PAsData PProposalLock)]))
+  | PWitnessStake (Term s (PDataRecord '[]))
   deriving stock (GHC.Generic)
   deriving anyclass (Generic)
   deriving anyclass (PIsDataRepr)
@@ -263,8 +271,8 @@ deriving via (DerivePConstantViaData ProposalLock PProposalLock) instance (PCons
 --------------------------------------------------------------------------------
 
 -- | Policy for Stake state threads.
-stakePolicy :: Stake -> ClosedTerm PMintingPolicy
+stakePolicy :: Tagged GTTag AssetClass -> ClosedTerm PMintingPolicy
-stakePolicy stake =
+stakePolicy gtClassRef =
   plam $ \_redeemer ctx' -> P.do
     ctx <- pletFields @'["txInfo", "purpose"] ctx'
     txInfo <- plet $ ctx.txInfo
@@ -325,7 +333,7 @@ stakePolicy stake =
                             # 1
                     let expectedValue =
                           paddValue
-                            # (pdiscreteValue' stake.gtClassRef # stakeDatum.stakedAmount)
+                            # (pdiscreteValue' gtClassRef # stakeDatum.stakedAmount)
                             # stValue
                     let ownerSignsTransaction =
                           ptxSignedBy
@@ -339,7 +347,7 @@ stakePolicy stake =
                           foldr1
                             (#&&)
                             [ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
-                            , pgeqByClass' (untag stake.gtClassRef)
+                            , pgeqByClass' (untag gtClassRef)
                                 # value
                                 # expectedValue
                             , pgeqByClass
@@ -381,7 +389,7 @@ stakeValidator stake =
     -- Whether the owner signs this transaction or not.
     ownerSignsTransaction <- plet $ ptxSignedBy # ctx.txInfo # stakeDatum.owner
 
-    stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake)
+    stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake.gtClassRef)
     mintedST <- plet $ psymbolValueOf # stCurrencySymbol # txInfoF.mint
     spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # txInfoF.inputs
 
@@ -414,6 +422,35 @@ stakeValidator stake =
         -- TODO: check proposal constraints
         popaque (pconstant ())
       --------------------------------------------------------------------------
+      PWitnessStake _ -> P.do
+        passert "ST at inputs must be 1" $
+          spentST #== 1
+
+        let AssetClass (propCs, propTn) = stake.proposalSTClass
+            propAssetClass = passetClass # pconstant propCs # pconstant propTn
+            proposalTokenMoved =
+              ptokenSpent
+                # propAssetClass
+                # txInfoF.inputs
+
+        passert
+          "Owner signs this transaction OR proposal token is spent"
+          (ownerSignsTransaction #|| proposalTokenMoved)
+
+        passert "A UTXO must exist with the correct output" $
+          anyOutput @PStakeDatum # txInfo
+            #$ plam
+            $ \value address newStakeDatum' -> P.do
+              let isScriptAddress = pdata address #== ownAddress
+              let correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
+              let valueCorrect = pdata continuingValue #== pdata value
+              foldr1
+                (#&&)
+                [ ptraceIfFalse "isScriptAddress" isScriptAddress
+                , ptraceIfFalse "correctOutputDatum" correctOutputDatum
+                , ptraceIfFalse "valueCorrect" valueCorrect
+                ]
+        popaque (pconstant ())
       PDepositWithdraw r -> P.do
         passert "ST at inputs must be 1" $
           spentST #== 1

agora/Agora/Utils.hs

@@ -287,7 +287,11 @@ pfindTxInByTxOutRef = phoistAcyclic $
 pnotNull :: forall list a. PIsListLike list a => Term _ (list a :--> PBool)
 pnotNull = phoistAcyclic $ plam $ pelimList (\_ _ -> pcon PTrue) (pcon PFalse)
 
--- | Check if a particular asset class has been spent in the input list.
+{- | Check if a particular asset class has been spent in the input list.
+
+     When using this as an authority check, you __MUST__ ensure the authority
+     knows how to ensure its end of the contract.
+-}
 ptokenSpent :: forall {s :: S}. Term s (PAssetClass :--> PBuiltinList (PAsData PTxInInfo) :--> PBool)
 ptokenSpent =
   plam $ \tokenClass inputs ->