add mustBePJust and mustBePDJust util functions

agora/Agora/Governor.hs

@@ -45,7 +45,8 @@ import Agora.Proposal (
   PProposalId,
   PProposalStatus (PDraft),
   PProposalThresholds,
-  PResultTag,
+  PProposalVotes (PProposalVotes),
+  PResultTag (PResultTag),
   Proposal (..),
   ProposalId,
   ProposalThresholds,
@@ -58,14 +59,16 @@ import Agora.Utils (
   containsSingleCurrencySymbol,
   findOutputsToAddress,
   hasOnlyOneTokenOfCurrencySymbol,
+  mustBePDJust,
+  mustBePJust,
   mustFindDatum',
   passert,
   passetClassValueOf,
   passetClassValueOf',
+  pfindDatum,
   pfindTxInByTxOutRef,
   pisDJust,
   pisUxtoSpent,
-  plookup,
   pownCurrencySymbol,
   psymbolValueOf,
   scriptHashFromAddress,
@@ -102,6 +105,7 @@ import Plutarch.Unsafe (punsafeCoerce)
 --------------------------------------------------------------------------------
 
 import Plutarch.Builtin (PBuiltinMap, pforgetData)
+import Plutarch.Map.Extra (plookup, plookup')
 import Plutus.V1.Ledger.Api (
   Address (Address),
   Credential (ScriptCredential),
@@ -334,14 +338,14 @@ governorValidator params =
         passert "Invalid thresholds in proposal parameters" $
           proposalParams.thresholds #== oldParams.proposalThresholds
 
-        passert "Initial proposal votes should be zero" $
+        -- passert "Initial proposal votes should be empty" $
-          pnull #$ pto $ pto $ pfromData proposalParams.votes
+        --   pnull #$ pto $ pto $ pfromData proposalParams.votes
 
-        passert "Initial proposal status should be Draft" $ P.do
+        -- passert "Initial proposal status should be Draft" $ P.do
-          s <- pmatch $ proposalParams.status
+        --   s <- pmatch $ proposalParams.status
-          case s of
+        --   case s of
-            PDraft _ -> pconstant True
+        --     PDraft _ -> pconstant True
-            _ -> pconstant False
+        --     _ -> pconstant False
 
         passert "Proposal datum must be valid" $
           proposalDatumValid # proposalDatum'
@@ -377,20 +381,17 @@ governorValidator params =
 
         proposalDatum <- pletFields @'["id", "effects", "status", "cosigners", "thresholds", "votes"] proposalDatum'
 
-        let effects' :: Term _ (PBuiltinMap PResultTag (PBuiltinMap PValidatorHash PDatumHash))
+        PProposalVotes votes' <- pmatch $ pfromData proposalDatum.votes
-            effects' = punsafeCoerce proposalDatum.effects
+        votes <- plet votes'
 
-        effectMapList <-
+        let yesVotes = plookup' # pyesResultTag # votes
-          plet $
+            noVotes = plookup' # pnoResultTag # votes
-            pfoldr
+            -- TODO: check thresholds here
-              # ( plam $ \m l -> P.do
+            finalResultTag = pif (yesVotes #< noVotes) pnoResultTag pyesResultTag
-                    let theMap = pfromData $ psndBuiltin # m
-                    pconcat # theMap # l
-                )
-              # pcon PNil
-              # effects'
 
-        gatCount <- plet $ plength # effectMapList
+        effects <- plet $ plookup' # finalResultTag #$ proposalDatum.effects
+
+        gatCount <- plet $ plength #$ pto $ pto effects
 
         passert "Required amount of GATs should be minted" $
           psymbolValueOf # pProposalSym # txInfo.mint #== gatCount
@@ -405,34 +406,30 @@ governorValidator params =
                     0 #< psymbolValueOf # pGATSym # value
                 )
               #$ pfromData txInfo.outputs
-
         passert "Minted GAT amount should equal to amount of output GAT" $
           plength # outputsWithGAT #== gatCount
 
-        passert "All GAT must be properly tagged" $
-          pall
-            # ( plam $ \(pfromData -> outInfo) ->
-                  authorityTokensValidIn # pGATSym # outInfo
-              )
-            # outputsWithGAT
-
         popaque $
           pfoldr
-            # ( plam $ \(pfromData -> outputInfo') _ -> P.do
+            # ( plam $ \(pfromData -> output') _ -> P.do
-                  outputInfo <- pletFields @'["address", "datumHash"] $ outputInfo'
+                  output <- pletFields @'["address", "datumHash"] $ output'
-                  passert "GAT must be properly tagged" $ authorityTokensValidIn # pGATSym # outputInfo'
+
-                  passert "Output to the effect should have datum" $ pisDJust # outputInfo.datumHash
+                  let scriptHash =
-                  PDJust ((pfield @"_0" #) -> datumHash) <- pmatch outputInfo.datumHash
+                        mustBePJust # "GAT receiver is not a script"
-                  let scriptHash = scriptHashFromAddress' # outputInfo.address
+                          #$ scriptHashFromAddress # output.address
-                  expectedDatumHash' <- pmatch $ plookup # (pdata scriptHash) # effectMapList
+                      datumHash =
-                  case expectedDatumHash' of
+                        mustBePDJust # "Output to effect should have datum"
-                    PJust expectedDatumHash ->
+                          #$ output.datumHash
-                      passert "An unexpected datum hash is found sent to the effect" $
+ 
-                        datumHash #== expectedDatumHash
+                      expectedDatumHash =
-                    _ -> passert "A GAT is not sent to an effect" $ pconstant False
+                        mustBePJust # "Receiver is not in effect list"
-                  pconstant ()
+                          #$ plookup # scriptHash # effects
+
+                  passert "GAT must be tagged by the effect hash" $ authorityTokensValidIn # pGATSym # output'
+                  passert "Unexpected datum" $ datumHash #== expectedDatumHash
+                  (pconstant ())
               )
-            # pconstant ()
+            # (pconstant ())
             # outputsWithGAT
 
       -- TODO: check proposal votes and timing
@@ -476,13 +473,11 @@ governorValidator params =
     pGATSym :: Term s PCurrencySymbol
     pGATSym = phoistAcyclic $ pconstant $ authorityTokenSymbolFromGovernor params
 
-    scriptHashFromAddress' :: Term s (PAddress :--> PValidatorHash)
+    pyesResultTag :: Term s PResultTag
-    scriptHashFromAddress' = phoistAcyclic $
+    pyesResultTag = phoistAcyclic $ pcon $ PResultTag $ pconstant 1
-      plam $ \addr -> P.do
+
-        mh <- pmatch $ scriptHashFromAddress # addr
+    pnoResultTag :: Term s PResultTag
-        case mh of
+    pnoResultTag = phoistAcyclic $ pcon $ PResultTag $ pconstant 0
-          PJust vh -> vh
-          _ -> ptraceError "Not a valid validator address"
 
 --------------------------------------------------------------------------------
 

agora/Agora/Utils.hs

@@ -48,6 +48,8 @@ module Agora.Utils (
   hasOnlyOneTokenOfCurrencySymbol,
   mustFindDatum',
   containsSingleCurrencySymbol,
+  mustBePJust,
+  mustBePDJust,
 ) where
 
 --------------------------------------------------------------------------------
@@ -556,3 +558,15 @@ containsSingleCurrencySymbol :: Term s (PValue :--> PBool)
 containsSingleCurrencySymbol = phoistAcyclic $
   plam $ \v -> P.do
     (plength #$ pto $ pto $ pto v) #== 1
+
+mustBePJust :: forall a s. Term s (PString :--> PMaybe a :--> a)
+mustBePJust = phoistAcyclic $
+  plam $ \emsg mv' -> pmatch mv' $ \case
+    PJust v -> v
+    _ -> ptraceError emsg
+
+mustBePDJust :: forall a s. (PIsData a) => Term s (PString :--> PMaybeData a :--> a)
+mustBePDJust = phoistAcyclic $
+  plam $ \emsg mv' -> pmatch mv' $ \case
+    PDJust ((pfield @"_0" #) -> v) -> v
+    _ -> ptraceError emsg