move Proposal impl. to Agora.Proposal.Scripts to avoid cyclic deps

agora.cabal

@@ -129,6 +129,7 @@ library
     Agora.Governor
     Agora.MultiSig
     Agora.Proposal
+    Agora.Proposal.Scripts
     Agora.Proposal.Time
     Agora.Record
     Agora.SafeMoney

agora/Agora/Effect/NoOp.hs

@@ -10,7 +10,6 @@ module Agora.Effect.NoOp (noOpValidator, PNoOp) where
 import Control.Applicative (Const)
 
 import Agora.Effect (makeEffect)
-import Plutarch (popaque)
 import Plutarch.Api.V1 (PValidator)
 import Plutarch.TryFrom (PTryFrom (..))
 import Plutus.V1.Ledger.Value (CurrencySymbol)

agora/Agora/Effect/TreasuryWithdrawal.hs

@@ -19,7 +19,6 @@ import Generics.SOP (Generic, I (I))
 
 import Agora.Effect (makeEffect)
 import Agora.Utils (findTxOutByTxOutRef, paddValue, passert)
-import Plutarch (popaque)
 import Plutarch.Api.V1 (
   PCredential (..),
   PTuple,
@@ -34,7 +33,7 @@ import Plutarch.DataRepr (
   PDataFields,
   PIsDataReprInstances (..),
  )
-import Plutarch.Lift (PUnsafeLiftDecl (..))
+import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
 import Plutarch.Monadic qualified as P
 import Plutarch.TryFrom (PTryFrom (..))
 import Plutus.V1.Ledger.Credential (Credential)
@@ -69,10 +68,11 @@ newtype PTreasuryWithdrawalDatum (s :: S)
 
 instance PUnsafeLiftDecl PTreasuryWithdrawalDatum where
   type PLifted PTreasuryWithdrawalDatum = TreasuryWithdrawalDatum
+
 deriving via
   (DerivePConstantViaData TreasuryWithdrawalDatum PTreasuryWithdrawalDatum)
   instance
-    (PConstant TreasuryWithdrawalDatum)
+    (PConstantDecl TreasuryWithdrawalDatum)
 
 instance PTryFrom PData PTreasuryWithdrawalDatum where
   type PTryFromExcess PData PTreasuryWithdrawalDatum = Const ()
@@ -99,7 +99,7 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
   \_cs (datum' :: Term _ PTreasuryWithdrawalDatum) txOutRef' txInfo' -> P.do
     datum <- pletFields @'["receivers", "treasuries"] datum'
     txInfo <- pletFields @'["outputs", "inputs"] txInfo'
-    PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef' # pfromData txInfo'
+    PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef' # pfromData txInfo.inputs
     effInput <- pletFields @'["address", "value"] $ txOut
     outputValues <-
       plet $

agora/Agora/Proposal.hs

@@ -26,11 +26,6 @@ module Agora.Proposal (
   PProposalVotes (..),
   PProposalId (..),
   PResultTag (..),
-
-  -- * Scripts
-  proposalValidator,
-  proposalPolicy,
-  proposalDatumValid,
 ) where
 
 import GHC.Generics qualified as GHC
@@ -38,47 +33,26 @@ import Generics.SOP (Generic, I (I))
 import Plutarch.Api.V1 (
   PDatumHash,
   PMap,
-  PMintingPolicy,
   PPubKeyHash,
-  PScriptContext (PScriptContext),
-  PScriptPurpose (PMinting, PSpending),
-  PTxInfo (PTxInfo),
-  PValidator,
   PValidatorHash,
-  mintingPolicySymbol,
-  mkMintingPolicy,
  )
-import Plutarch.DataRepr (
-  DerivePConstantViaData (..),
-  PDataFields,
-  PIsDataReprInstances (PIsDataReprInstances),
- )
-import Plutus.V1.Ledger.Api (DatumHash, PubKeyHash, ValidatorHash)
 import PlutusTx qualified
 import PlutusTx.AssocMap qualified as AssocMap
 
 --------------------------------------------------------------------------------
-import Agora.Record (mkRecordConstr, (.&), (.=))
 import Agora.SafeMoney (GTTag)
-import Agora.Utils (
-  anyOutput,
-  findTxOutByTxOutRef,
-  passert,
-  pnotNull,
-  psymbolValueOf,
-  ptokenSpent,
-  ptxSignedBy,
-  pvalueSpent,
- )
 import Control.Arrow (first)
-import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
-import Plutarch.Builtin (PBuiltinMap)
-import Plutarch.Lift (DerivePConstantViaNewtype (..), PConstantDecl, PUnsafeLiftDecl (..))
-import Plutarch.Monadic qualified as P
+import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields, PIsDataReprInstances (..))
+import Plutarch.Lift (
+  DerivePConstantViaNewtype (..),
+  PConstantDecl,
+  PUnsafeLiftDecl (..),
+ )
 import Plutarch.SafeMoney (PDiscrete, Tagged)
 import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom'))
 import Plutarch.Unsafe (punsafeCoerce)
-import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
+import Plutus.V1.Ledger.Api (DatumHash, PubKeyHash, ValidatorHash)
+import Plutus.V1.Ledger.Value (AssetClass)
 
 --------------------------------------------------------------------------------
 -- Haskell-land
@@ -395,161 +369,3 @@ data PProposalRedeemer (s :: S)
 
 instance PUnsafeLiftDecl PProposalRedeemer where type PLifted PProposalRedeemer = ProposalRedeemer
 deriving via (DerivePConstantViaData ProposalRedeemer PProposalRedeemer) instance (PConstantDecl ProposalRedeemer)
-
---------------------------------------------------------------------------------
-
-{- | Policy for Proposals.
-   This needs to perform two checks:
-     - Governor is happy with mint.
-     - Exactly 1 token is minted.
-
-   NOTE: The governor needs to check that the datum is correct
-         and sent to the right address.
--}
-proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy
-proposalPolicy proposal =
-  plam $ \_redeemer ctx' -> P.do
-    PScriptContext ctx' <- pmatch ctx'
-    ctx <- pletFields @'["txInfo", "purpose"] ctx'
-    PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo
-    txInfo <- pletFields @'["inputs", "mint"] txInfo'
-    PMinting _ownSymbol <- pmatch $ pfromData ctx.purpose
-
-    let inputs = txInfo.inputs
-        mintedValue = pfromData txInfo.mint
-        AssetClass (govCs, govTn) = proposal.governorSTAssetClass
-
-    PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose
-    let mintedProposalST = passetClassValueOf # mintedValue # (passetClass # (pfield @"_0" # ownSymbol') # pconstant "")
-
-    passert "Governance state-thread token must move" $
-      ptokenSpent
-        # (passetClass # pconstant govCs # pconstant govTn)
-        # inputs
-
-    passert "Minted exactly one proposal ST" $
-      mintedProposalST #== 1
-
-    popaque (pconstant ())
-
--- | Validator for Proposals.
-proposalValidator :: Proposal -> ClosedTerm PValidator
-proposalValidator proposal =
-  plam $ \datum redeemer ctx' -> P.do
-    PScriptContext ctx' <- pmatch ctx'
-    ctx <- pletFields @'["txInfo", "purpose"] ctx'
-    txInfo <- plet $ pfromData ctx.txInfo
-    PTxInfo txInfo' <- pmatch txInfo
-    txInfoF <- pletFields @'["inputs", "mint"] txInfo'
-    PSpending ((pfield @"_0" #) -> txOutRef) <- pmatch $ pfromData ctx.purpose
-
-    PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs
-    txOutF <- pletFields @'["address", "value"] $ txOut
-
-    let proposalDatum :: Term _ PProposalDatum
-        proposalDatum = pfromData $ punsafeCoerce datum
-        proposalRedeemer :: Term _ PProposalRedeemer
-        proposalRedeemer = pfromData $ punsafeCoerce redeemer
-
-    proposalF <-
-      pletFields
-        @'[ "proposalId"
-          , "effects"
-          , "status"
-          , "cosigners"
-          , "thresholds"
-          , "votes"
-          ]
-        proposalDatum
-
-    ownAddress <- plet $ txOutF.address
-
-    stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (proposalPolicy proposal)
-    valueSpent <- plet $ pvalueSpent # txInfoF.inputs
-    spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ valueSpent
-    let AssetClass (stakeSym, stakeTn) = proposal.stakeSTAssetClass
-    spentStakeST <- plet $ passetClassValueOf # valueSpent # (passetClass # pconstant stakeSym # pconstant stakeTn)
-
-    pmatch proposalRedeemer $ \case
-      PVote _r -> P.do
-        passert "ST at inputs must be 1" $
-          spentST #== 1
-
-        popaque (pconstant ())
-      --------------------------------------------------------------------------
-      PCosign r -> P.do
-        newSigs <- plet $ pfield @"newCosigners" # r
-
-        passert "ST at inputs must be 1" $
-          spentST #== 1
-
-        passert "Signed by all new cosigners" $
-          pall # plam (\sig -> ptxSignedBy # ctx.txInfo # sig) # newSigs
-
-        passert "As many new cosigners as Stake datums" $
-          spentStakeST #== plength # newSigs
-
-        passert "Signatures are correctly added to cosignature list" $
-          anyOutput @PProposalDatum # ctx.txInfo
-            #$ plam
-            $ \newValue address newProposalDatum -> P.do
-              -- This is a little sad. Can we do better by
-              -- building a new ProposalDatum and then comparing?
-              let correctDatum =
-                    pdata newProposalDatum
-                      #== pdata
-                        ( mkRecordConstr
-                            PProposalDatum
-                            ( #proposalId .= proposalF.proposalId
-                                .& #effects .= proposalF.effects
-                                .& #status .= proposalF.status
-                                .& #cosigners .= pdata (pconcat # newSigs # proposalF.cosigners)
-                                .& #thresholds .= proposalF.thresholds
-                                .& #votes .= proposalF.votes
-                            )
-                        )
-
-              foldr1
-                (#&&)
-                [ pcon PTrue
-                , 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
-                ]
-
-        popaque (pconstant ())
-      --------------------------------------------------------------------------
-      PUnlock _r -> P.do
-        passert "ST at inputs must be 1" $
-          spentST #== 1
-
-        popaque (pconstant ())
-      --------------------------------------------------------------------------
-      PAdvanceProposal _r -> P.do
-        passert "ST at inputs must be 1" $
-          spentST #== 1
-
-        popaque (pconstant ())
-
-{- | Check for various invariants a proposal must uphold.
-     This can be used to check both upopn creation and
-     upon any following state transitions in the proposal.
--}
-proposalDatumValid :: Term s (PProposalDatum :--> PBool)
-proposalDatumValid =
-  phoistAcyclic $
-    plam $ \datum' -> P.do
-      datum <- pletFields @'["effects", "cosigners"] $ datum'
-
-      let effects :: Term _ (PBuiltinMap PResultTag (PBuiltinMap PValidatorHash PDatumHash))
-          effects = punsafeCoerce datum.effects
-
-          atLeastOneNegativeResult :: Term _ PBool
-          atLeastOneNegativeResult =
-            pany # plam (\pair -> pnull #$ pfromData $ psndBuiltin # pair) # effects
-
-      foldr1
-        (#&&)
-        [ ptraceIfFalse "Proposal has at least one ResultTag has no effects" atLeastOneNegativeResult
-        , ptraceIfFalse "Proposal has at least one cosigner" $ pnotNull # pfromData datum.cosigners
-        ]

agora/Agora/Proposal/Scripts.hs

@@ -0,0 +1,227 @@
+module Agora.Proposal.Scripts (
+  proposalValidator,
+  proposalPolicy,
+  proposalDatumValid,
+) where
+
+import Agora.Proposal
+import Agora.Record (mkRecordConstr, (.&), (.=))
+import Agora.Stake (PStakeDatum)
+import Agora.Utils (
+  anyOutput,
+  findTxOutByTxOutRef,
+  passert,
+  pfindDatum',
+  pnotNull,
+  psymbolValueOf,
+  ptokenSpent,
+  ptxSignedBy,
+  pvalueSpent,
+ )
+import Plutarch.Api.V1 (
+  PDatumHash,
+  PMaybeData (PDJust, PDNothing),
+  PMintingPolicy,
+  PPubKeyHash,
+  PScriptContext (PScriptContext),
+  PScriptPurpose (PMinting, PSpending),
+  PTxInInfo (PTxInInfo),
+  PTxInfo (PTxInfo),
+  PTxOut (PTxOut),
+  PValidator,
+  PValidatorHash,
+  mintingPolicySymbol,
+  mkMintingPolicy,
+ )
+import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
+import Plutarch.Builtin (PBuiltinMap)
+import Plutarch.Monadic qualified as P
+import Plutarch.Unsafe (punsafeCoerce)
+import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
+
+{- | Policy for Proposals.
+   This needs to perform two checks:
+     - Governor is happy with mint.
+     - Exactly 1 token is minted.
+
+   NOTE: The governor needs to check that the datum is correct
+         and sent to the right address.
+-}
+proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy
+proposalPolicy proposal =
+  plam $ \_redeemer ctx' -> P.do
+    PScriptContext ctx' <- pmatch ctx'
+    ctx <- pletFields @'["txInfo", "purpose"] ctx'
+    PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo
+    txInfo <- pletFields @'["inputs", "mint"] txInfo'
+    PMinting _ownSymbol <- pmatch $ pfromData ctx.purpose
+
+    let inputs = txInfo.inputs
+        mintedValue = pfromData txInfo.mint
+        AssetClass (govCs, govTn) = proposal.governorSTAssetClass
+
+    PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose
+    let mintedProposalST = passetClassValueOf # mintedValue # (passetClass # (pfield @"_0" # ownSymbol') # pconstant "")
+
+    passert "Governance state-thread token must move" $
+      ptokenSpent
+        # (passetClass # pconstant govCs # pconstant govTn)
+        # inputs
+
+    passert "Minted exactly one proposal ST" $
+      mintedProposalST #== 1
+
+    popaque (pconstant ())
+
+-- | Validator for Proposals.
+proposalValidator :: Proposal -> ClosedTerm PValidator
+proposalValidator proposal =
+  plam $ \datum redeemer ctx' -> P.do
+    PScriptContext ctx' <- pmatch ctx'
+    ctx <- pletFields @'["txInfo", "purpose"] ctx'
+    txInfo <- plet $ pfromData ctx.txInfo
+    PTxInfo txInfo' <- pmatch txInfo
+    txInfoF <- pletFields @'["inputs", "mint"] txInfo'
+    PSpending ((pfield @"_0" #) -> txOutRef) <- pmatch $ pfromData ctx.purpose
+
+    PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs
+    txOutF <- pletFields @'["address", "value"] $ txOut
+
+    let proposalDatum :: Term _ PProposalDatum
+        proposalDatum = pfromData $ punsafeCoerce datum
+        proposalRedeemer :: Term _ PProposalRedeemer
+        proposalRedeemer = pfromData $ punsafeCoerce redeemer
+
+    proposalF <-
+      pletFields
+        @'[ "proposalId"
+          , "effects"
+          , "status"
+          , "cosigners"
+          , "thresholds"
+          , "votes"
+          ]
+        proposalDatum
+
+    ownAddress <- plet $ txOutF.address
+
+    stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (proposalPolicy proposal)
+    valueSpent <- plet $ pvalueSpent # txInfoF.inputs
+    spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ valueSpent
+    let AssetClass (stakeSym, stakeTn) = proposal.stakeSTAssetClass
+    stakeSTAssetClass <- plet $ passetClass # pconstant stakeSym # pconstant stakeTn
+    spentStakeST <- plet $ passetClassValueOf # valueSpent # stakeSTAssetClass
+
+    pmatch proposalRedeemer $ \case
+      PVote _r -> P.do
+        passert "ST at inputs must be 1" $
+          spentST #== 1
+
+        popaque (pconstant ())
+      --------------------------------------------------------------------------
+      PCosign r -> P.do
+        newSigs <- plet $ pfield @"newCosigners" # r
+
+        passert "ST at inputs must be 1" $
+          spentST #== 1
+
+        passert "Signed by all new cosigners" $
+          pall # plam (\sig -> ptxSignedBy # ctx.txInfo # sig) # newSigs
+
+        passert "As many new cosigners as Stake datums" $
+          spentStakeST #== plength # newSigs
+
+        let stakeDatumOwnedBy :: Term _ (PPubKeyHash :--> PStakeDatum :--> PBool)
+            stakeDatumOwnedBy =
+              phoistAcyclic $
+                plam $ \pk stakeDatum -> P.do
+                  stakeDatumF <- pletFields @'["owner"] $ pto stakeDatum
+                  stakeDatumF.owner #== pdata pk
+
+        -- Does the input have a `Stake` owned by a particular PK?
+        let isInputStakeOwnedBy :: Term _ (PAsData PPubKeyHash :--> PAsData PTxInInfo :--> PBool)
+            isInputStakeOwnedBy =
+              plam $ \ss txInInfo' -> P.do
+                PTxInInfo ((pfield @"resolved" #) -> txOut) <- pmatch $ pfromData txInInfo'
+                PTxOut txOut' <- pmatch txOut
+                txOutF <- pletFields @'["value", "datumHash"] txOut'
+                outStakeST <- plet $ passetClassValueOf # txOutF.value # stakeSTAssetClass
+                pmatch txOutF.datumHash $ \case
+                  PDNothing _ -> pcon PFalse
+                  PDJust ((pfield @"_0" #) -> datumHash) ->
+                    pif
+                      (outStakeST #== 1)
+                      -- TODO: use 'ptryFindDatum' instead in the future
+                      ( pmatch (pfindDatum' # datumHash # txInfo) $ \case
+                          PNothing -> pcon PFalse
+                          PJust v -> stakeDatumOwnedBy # pfromData ss # pfromData v
+                      )
+                      (pcon PFalse)
+
+        passert "All new cosigners are witnessed by their Stake datums" $
+          pall
+            # plam (\sig -> pany # (isInputStakeOwnedBy # sig) # txInfoF.inputs)
+            # newSigs
+
+        passert "Signatures are correctly added to cosignature list" $
+          anyOutput @PProposalDatum # ctx.txInfo
+            #$ plam
+            $ \newValue address newProposalDatum -> P.do
+              let correctDatum =
+                    pdata newProposalDatum
+                      #== pdata
+                        ( mkRecordConstr
+                            PProposalDatum
+                            ( #proposalId .= proposalF.proposalId
+                                .& #effects .= proposalF.effects
+                                .& #status .= proposalF.status
+                                .& #cosigners .= pdata (pconcat # newSigs # proposalF.cosigners)
+                                .& #thresholds .= proposalF.thresholds
+                                .& #votes .= proposalF.votes
+                            )
+                        )
+
+              foldr1
+                (#&&)
+                [ pcon PTrue
+                , 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
+                ]
+
+        popaque (pconstant ())
+      --------------------------------------------------------------------------
+      PUnlock _r -> P.do
+        passert "ST at inputs must be 1" $
+          spentST #== 1
+
+        popaque (pconstant ())
+      --------------------------------------------------------------------------
+      PAdvanceProposal _r -> P.do
+        passert "ST at inputs must be 1" $
+          spentST #== 1
+
+        popaque (pconstant ())
+
+{- | Check for various invariants a proposal must uphold.
+     This can be used to check both upopn creation and
+     upon any following state transitions in the proposal.
+-}
+proposalDatumValid :: Term s (PProposalDatum :--> PBool)
+proposalDatumValid =
+  phoistAcyclic $
+    plam $ \datum' -> P.do
+      datum <- pletFields @'["effects", "cosigners"] $ datum'
+
+      let effects :: Term _ (PBuiltinMap PResultTag (PBuiltinMap PValidatorHash PDatumHash))
+          effects = punsafeCoerce datum.effects
+
+          atLeastOneNegativeResult :: Term _ PBool
+          atLeastOneNegativeResult =
+            pany # plam (\pair -> pnull #$ pfromData $ psndBuiltin # pair) # effects
+
+      foldr1
+        (#&&)
+        [ ptraceIfFalse "Proposal has at least one ResultTag has no effects" atLeastOneNegativeResult
+        , ptraceIfFalse "Proposal has at least one cosigner" $ pnotNull # pfromData datum.cosigners
+        ]

agora/Agora/Utils.hs

@@ -11,6 +11,7 @@ module Agora.Utils (
   pfind',
   pfindDatum,
   pfindDatum',
+  ptryFindDatum,
   pvalueSpent,
   ptxSignedBy,
   paddValue,
@@ -67,6 +68,7 @@ import Plutarch.Api.V1.Value (PValue (PValue))
 import Plutarch.Builtin (ppairDataBuiltin)
 import Plutarch.Internal (punsafeCoerce)
 import Plutarch.Monadic qualified as P
+import Plutarch.TryFrom (PTryFrom, ptryFrom)
 
 --------------------------------------------------------------------------------
 -- Validator-level utility functions
@@ -82,6 +84,17 @@ pfindDatum = phoistAcyclic $
     PTxInfo txInfo' <- pmatch txInfo''
     plookupTuple # datumHash #$ pfield @"datums" # txInfo'
 
+-- | Find a datum with the given hash, and `ptryFrom` it.
+ptryFindDatum :: PTryFrom PData a => Term s (PDatumHash :--> PTxInfo :--> PMaybe a)
+ptryFindDatum = phoistAcyclic $
+  plam $ \datumHash txInfo'' -> P.do
+    PTxInfo txInfo' <- pmatch txInfo''
+    pmatch (plookupTuple # datumHash #$ pfield @"datums" # txInfo') $ \case
+      PNothing -> pcon PNothing
+      PJust datum -> P.do
+        (datum', _) <- ptryFrom $ pto datum
+        pcon (PJust datum')
+
 {- | Find a datum with the given hash.
 NOTE: this is unsafe in the sense that, if the data layout is wrong, this is UB.
 -}