lock field in Stake datum, singleAuthorityTokenBurned helper

agora-test/Spec/Sample/Stake.hs

@@ -95,7 +95,7 @@ stakeCreation :: ScriptContext
 stakeCreation =
   let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST
       datum :: Datum
-      datum = Datum (toBuiltinData $ StakeDatum 424242424242 signer)
+      datum = Datum (toBuiltinData $ StakeDatum 424242424242 signer [])
    in ScriptContext
         { scriptContextTxInfo =
             TxInfo
@@ -123,7 +123,7 @@ stakeCreation =
 stakeCreationWrongDatum :: ScriptContext
 stakeCreationWrongDatum =
   let datum :: Datum
-      datum = Datum (toBuiltinData $ StakeDatum 4242424242424242 signer) -- Too much GT
+      datum = Datum (toBuiltinData $ StakeDatum 4242424242424242 signer []) -- Too much GT
    in ScriptContext
         { scriptContextTxInfo = stakeCreation.scriptContextTxInfo {txInfoData = [("", datum)]}
         , scriptContextPurpose = Minting policySymbol
@@ -155,7 +155,7 @@ stakeDepositWithdraw :: DepositWithdrawExample -> ScriptContext
 stakeDepositWithdraw config =
   let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST
       stakeBefore :: StakeDatum
-      stakeBefore = StakeDatum config.startAmount signer
+      stakeBefore = StakeDatum config.startAmount signer []
 
       stakeAfter :: StakeDatum
       stakeAfter = stakeBefore {stakedAmount = stakeBefore.stakedAmount + config.delta}

agora-test/Spec/Stake.hs

@@ -52,19 +52,19 @@ tests =
       , validatorSucceedsWith
           "stakeDepositWithdraw deposit"
           (stakeValidator Stake.stake)
-          (toDatum $ StakeDatum 100_000 signer)
+          (toDatum $ StakeDatum 100_000 signer [])
           (toDatum $ DepositWithdraw 100_000)
           (Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = 100_000})
       , validatorSucceedsWith
           "stakeDepositWithdraw withdraw"
           (stakeValidator Stake.stake)
-          (toDatum $ StakeDatum 100_000 signer)
+          (toDatum $ StakeDatum 100_000 signer [])
           (toDatum $ DepositWithdraw $ negate 100_000)
           (Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 100_000})
       , validatorFailsWith
           "stakeDepositWithdraw negative GT"
           (stakeValidator Stake.stake)
-          (toDatum $ StakeDatum 100_000 signer)
+          (toDatum $ StakeDatum 100_000 signer [])
           (toDatum $ DepositWithdraw 1_000_000)
           (Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 1_000_000})
       ]

agora/Agora/AuthorityToken.hs

@@ -8,6 +8,7 @@ Tokens acting as redeemable proofs of DAO authority.
 module Agora.AuthorityToken (
   authorityTokenPolicy,
   authorityTokensValidIn,
+  singleAuthorityTokenBurned,
   AuthorityToken (..),
 ) where
 
@@ -32,7 +33,15 @@ import Prelude
 
 --------------------------------------------------------------------------------
 
-import Agora.Utils (allOutputs, passert, passetClassValueOf, passetClassValueOf', plookup)
+import Agora.Utils (
+  allInputs,
+  allOutputs,
+  passert,
+  passetClassValueOf,
+  passetClassValueOf',
+  plookup,
+  psymbolValueOf,
+ )
 
 --------------------------------------------------------------------------------
 
@@ -85,6 +94,27 @@ authorityTokensValidIn = phoistAcyclic $
         -- No GATs exist at this output!
         pconstant True
 
+-- | Assert that a single authority token has been burned.
+singleAuthorityTokenBurned ::
+  forall (s :: S).
+  Term s PCurrencySymbol ->
+  Term s (PAsData PTxInfo) ->
+  Term s PValue ->
+  Term s PBool
+singleAuthorityTokenBurned gatCs txInfo mint = P.do
+  let gatAmountMinted :: Term _ PInteger
+      gatAmountMinted = psymbolValueOf # gatCs # mint
+
+  foldr1
+    (#&&)
+    [ ptraceIfFalse "GAT not burned." $ gatAmountMinted #== -1
+    , ptraceIfFalse "All inputs only have valid GATs" $
+        allInputs @PUnit # pfromData txInfo #$ plam $ \txOut _value _address _datum ->
+          authorityTokensValidIn
+            # gatCs
+            # txOut
+    ]
+
 -- | Policy given 'AuthorityToken' params.
 authorityTokenPolicy ::
   AuthorityToken ->

agora/Agora/Effect.hs

@@ -7,19 +7,28 @@ Helpers for constructing effects.
 -}
 module Agora.Effect (makeEffect) where
 
-import Plutarch.Api.V1 (PScriptPurpose (PSpending), PTxInfo, PTxOutRef, PValidator)
+import Agora.AuthorityToken (singleAuthorityTokenBurned)
+import Agora.Utils (passert)
+import Plutarch.Api.V1 (PScriptPurpose (PSpending), PTxInfo, PTxOutRef, PValidator, PValue)
 import Plutarch.Internal (punsafeCoerce)
 import Plutarch.Monadic qualified as P
+import Plutus.V1.Ledger.Value (CurrencySymbol)
 
 --------------------------------------------------------------------------------
 
--- | Helper "template" for creating effect validator.
+{- | Helper "template" for creating effect validator.
+
+     In some situations, it may be the case that we need more control over how
+     an effect is implemented. In such situations, it's okay to not use this
+     helper.
+-}
 makeEffect ::
   forall (datum :: PType) (s :: S).
   PIsData datum =>
-  (Term s datum -> Term s PTxOutRef -> Term s PTxInfo -> Term s POpaque) ->
+  CurrencySymbol ->
+  (Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) ->
   Term s PValidator
-makeEffect f =
+makeEffect gatCs' f =
   plam $ \datum _redeemer ctx' -> P.do
     ctx <- pletFields @'["txInfo", "purpose"] ctx'
     txInfo' <- plet ctx.txInfo
@@ -30,7 +39,13 @@ makeEffect f =
     PSpending txOutRef <- pmatch $ pfromData ctx.purpose
     txOutRef' <- plet (pfield @"_0" # txOutRef)
 
-    -- TODO: Here, check that a *single* GAT is burned.
+    txInfo <- pletFields @'["mint"] txInfo'
+    let mint :: Term s PValue
+        mint = txInfo.mint
+
+    gatCs <- plet $ pconstant gatCs'
+
+    passert "singleAuthorityTokenBurned" $ singleAuthorityTokenBurned gatCs txInfo' mint
 
     f datum' txOutRef' txInfo'
 

agora/Agora/Proposal.hs

@@ -14,10 +14,15 @@ module Agora.Proposal (
   ProposalStatus (..),
   ProposalThresholds (..),
   ProposalVotes (..),
+  ProposalTag (..),
   ResultTag (..),
 
   -- * Plutarch-land
   PProposalDatum (..),
+  PProposalStatus (..),
+  PProposalThresholds (..),
+  PProposalVotes (..),
+  PProposalTag (..),
   PResultTag (..),
 ) where
 
@@ -85,6 +90,7 @@ data ProposalStatus
     --
     --   TODO: The owner of the proposal may choose to reclaim their proposal.
     Finished
+  deriving stock (Eq, Show, GHC.Generic)
 
 PlutusTx.makeIsDataIndexed ''ProposalStatus [('Draft, 0), ('VotingReady, 1), ('Finished, 2)]
 
@@ -101,6 +107,7 @@ data ProposalThresholds = ProposalThresholds
   -- ^ How much GT required to allow voting to happen.
   -- (i.e. to move into 'VotingReady')
   }
+  deriving stock (Eq, Show, GHC.Generic)
 
 PlutusTx.makeIsDataIndexed ''ProposalThresholds [('ProposalThresholds, 0)]
 
@@ -119,6 +126,7 @@ newtype ProposalVotes = ProposalVotes
   { getProposalVotes :: [(ResultTag, Integer)]
   }
   deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
+  deriving stock (Eq, Show, GHC.Generic)
 
 -- | Haskell-level datum for Proposal scripts.
 data ProposalDatum = ProposalDatum
@@ -136,9 +144,15 @@ data ProposalDatum = ProposalDatum
   , votes :: ProposalVotes
   -- ^ Vote tally on the proposal
   }
+  deriving stock (Eq, Show, GHC.Generic)
 
 PlutusTx.makeIsDataIndexed ''ProposalDatum [('ProposalDatum, 0)]
 
+-- | Identifies a Proposal, issued upon creation of a proposal.
+newtype ProposalTag = ProposalTag {proposalTag :: Integer}
+  deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
+  deriving stock (Eq, Show, GHC.Generic)
+
 -- | Parameters that identify the Proposal validator script.
 data Proposal = Proposal
 
@@ -149,6 +163,10 @@ data Proposal = Proposal
 newtype PResultTag (s :: S) = PResultTag (Term s PInteger)
   deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PResultTag PInteger)
 
+-- | Plutarch-level version of 'PProposalTag'.
+newtype PProposalTag (s :: S) = PProposalTag (Term s PInteger)
+  deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalTag PInteger)
+
 -- | Plutarch-level version of 'ProposalStatus'.
 data PProposalStatus (s :: S)
   = -- TODO: 'PProposalStatus' ought te be encoded as 'PInteger'.

agora/Agora/Stake.hs

@@ -12,6 +12,8 @@ module Agora.Stake (
   PStakeRedeemer (..),
   StakeDatum (..),
   StakeRedeemer (..),
+  ProposalLock (..),
+  PProposalLock (..),
   Stake (..),
   stakePolicy,
   stakeValidator,
@@ -43,15 +45,18 @@ import Plutarch.Api.V1 (
   mkMintingPolicy,
  )
 import Plutarch.DataRepr (
+  DerivePConstantViaData (..),
   PDataFields,
   PIsDataReprInstances (PIsDataReprInstances),
  )
 import Plutarch.Internal (punsafeCoerce)
+import Plutarch.Lift (PUnsafeLiftDecl (..))
 import Plutarch.Monadic qualified as P
 import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
 
 --------------------------------------------------------------------------------
 
+import Agora.Proposal (PProposalTag, PResultTag, ProposalTag (..), ResultTag (..))
 import Agora.SafeMoney (GTTag)
 import Agora.Utils (
   anyInput,
@@ -94,19 +99,48 @@ data StakeRedeemer
 
 PlutusTx.makeIsDataIndexed ''StakeRedeemer [('DepositWithdraw, 0), ('Destroy, 1)]
 
+data ProposalLock = ProposalLock
+  { vote :: ResultTag
+  -- ^ What was voted on. This allows retracting votes to
+  --   undo their vote.
+  , proposalTag :: ProposalTag
+  -- ^ Identifies the proposal.
+  }
+  deriving stock (Show, GHC.Generic)
+
+PlutusTx.makeIsDataIndexed ''ProposalLock [('ProposalLock, 0)]
+
 -- | Haskell-level datum for Stake scripts.
 data StakeDatum = StakeDatum
   { stakedAmount :: Tagged GTTag Integer
+  -- ^ Tracks the amount of governance token staked in the datum.
+  -- This also acts as the voting weight for 'Proposal's.
   , owner :: PubKeyHash
+  -- ^ The hash of the public key this stake belongs to.
+  --
+  -- TODO Support for MultiSig/Scripts is tracked here:
+  --      https://github.com/Liqwid-Labs/agora/issues/45
+  , lockedBy :: [ProposalLock]
+  -- ^ The proposal locks in place. This field must be empty
+  -- for the stake to be usable for deposits and withdrawals.
   }
   deriving stock (Show, GHC.Generic)
 
 PlutusTx.makeIsDataIndexed ''StakeDatum [('StakeDatum, 0)]
 
+--------------------------------------------------------------------------------
+
 -- | Plutarch-level datum for Stake scripts.
 newtype PStakeDatum (s :: S) = PStakeDatum
   { getStakeDatum ::
-    Term s (PDataRecord '["stakedAmount" ':= PDiscrete GTTag, "owner" ':= PPubKeyHash])
+    Term
+      s
+      ( PDataRecord
+          '[ "stakedAmount" ':= PDiscrete GTTag
+           , "owner" ':= PPubKeyHash
+           , "lockedBy" ':= PBuiltinList (PAsData PProposalLock)
+           ]
+      )
   }
   deriving stock (GHC.Generic)
   deriving anyclass (Generic)
@@ -115,6 +149,9 @@ newtype PStakeDatum (s :: S) = PStakeDatum
     (PlutusType, PIsData, PDataFields)
     via (PIsDataReprInstances PStakeDatum)
 
+instance PUnsafeLiftDecl PStakeDatum where type PLifted PStakeDatum = StakeDatum
+deriving via (DerivePConstantViaData StakeDatum PStakeDatum) instance (PConstant StakeDatum)
+
 -- | Plutarch-level redeemer for Stake scripts.
 data PStakeRedeemer (s :: S)
   = -- | Deposit or withdraw a discrete amount of the staked governance token.
@@ -128,6 +165,29 @@ data PStakeRedeemer (s :: S)
     (PlutusType, PIsData)
     via PIsDataReprInstances PStakeRedeemer
 
+instance PUnsafeLiftDecl PStakeRedeemer where type PLifted PStakeRedeemer = StakeRedeemer
+deriving via (DerivePConstantViaData StakeRedeemer PStakeRedeemer) instance (PConstant StakeRedeemer)
+
+newtype PProposalLock (s :: S) = PProposalLock
+  { getProposalLock ::
+    Term
+      s
+      ( PDataRecord
+          '[ "vote" ':= PResultTag
+           , "proposalTag" ':= PProposalTag
+           ]
+      )
+  }
+  deriving stock (GHC.Generic)
+  deriving anyclass (Generic)
+  deriving anyclass (PIsDataRepr)
+  deriving
+    (PlutusType, PIsData, PDataFields)
+    via (PIsDataReprInstances PProposalLock)
+
+instance PUnsafeLiftDecl PProposalLock where type PLifted PProposalLock = ProposalLock
+deriving via (DerivePConstantViaData ProposalLock PProposalLock) instance (PConstant ProposalLock)
+
 --------------------------------------------------------------------------------
 {- What this Policy does
 
@@ -338,6 +398,8 @@ stakeValidator stake =
 -- | Check whether a Stake is locked. If it is locked, various actions are unavailable.
 stakeLocked :: forall (s :: S). Term s (PStakeDatum :--> PBool)
 stakeLocked = phoistAcyclic $
-  plam $ \_stakeDatum ->
+  plam $ \stakeDatum ->
-    -- TODO: when we extend this to support proposals, this will need to do something
+    let locks :: Term _ (PBuiltinList (PAsData PProposalLock))
-    pcon PFalse
+        locks = pfield @"lockedBy" # stakeDatum
+     in -- 'pnotNull' ?
+        pelimList (\_ _ -> pcon PTrue) (pcon PFalse) locks

agora/Agora/Treasury.hs

@@ -21,8 +21,8 @@ import Plutus.V1.Ledger.Value (CurrencySymbol)
 
 --------------------------------------------------------------------------------
 
-import Agora.AuthorityToken (authorityTokensValidIn)
+import Agora.AuthorityToken (singleAuthorityTokenBurned)
-import Agora.Utils (allInputs, passert, psymbolValueOf)
+import Agora.Utils (passert)
 
 {- | Validator ensuring that transactions consuming the treasury
      do so in a valid manner.
@@ -37,7 +37,7 @@ treasuryV ::
         :--> PAsData PScriptContext
         :--> PUnit
     )
-treasuryV cs = plam $ \_d r ctx' -> P.do
+treasuryV gatCs' = plam $ \_d r ctx' -> P.do
   -- plet required fields from script context.
   ctx <- pletFields @["txInfo", "purpose"] ctx'
 
@@ -52,16 +52,10 @@ treasuryV cs = plam $ \_d r ctx' -> P.do
   txInfo <- pletFields @'["mint"] txInfo'
   let mint :: Term s PValue
       mint = txInfo.mint
-      gatAmountMinted :: Term s PInteger
-      gatAmountMinted = psymbolValueOf # pconstant cs # mint
 
-  passert "GAT not burned." $ gatAmountMinted #== -1
+  gatCs <- plet $ pconstant gatCs'
 
-  passert "All inputs only have valid GATs" $
+  passert "singleAuthorityTokenBurned" $ singleAuthorityTokenBurned gatCs txInfo' mint
-    allInputs @PUnit # pfromData ctx.txInfo #$ plam $ \txOut _value _address _datum ->
-      authorityTokensValidIn
-        # pconstant cs
-        # txOut
 
   pconstant ()