began reworking treasury

src/Agora/Treasury.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wwarn #-}
+
 {- |
 Module: Agora.Treasury
 Maintainer: jack@mlabs.city
@@ -28,6 +30,7 @@ import Plutarch.DataRepr (
   PIsDataReprInstances (PIsDataReprInstances),
  )
 import Plutarch.Monadic qualified as P
+import Agora.Utils (pisValueSubset)
 
 {- | Validator ensuring that transactions consuming the treasury
      do so in a valid manner.
@@ -41,92 +44,27 @@ treasuryV ::
         :--> PUnit
     )
 treasuryV = plam $ \d r ctx' -> P.do
-  -- Load txInfo and purpose fields from script context.
-  ctx <- pletFields @["txInfo", "purpose"] ctx'
-
-  -- Extract txInfo.
-  PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo
-
-  -- Pattern match on type of treasury redeemer.
   pmatch (pfromData r) $ \case
-    -- Treasury is merely being witnessed. It's datum and value
-    -- must be unchanged.
-    PWitnessTreasury _ -> P.do
-      txInfo <- pletFields @'["inputs", "outputs", "data"] txInfo'
+    -- Redeemer seeking to alter treasury parameters. Must ensure
+    -- a valid GAT is burned in the transaction.
+    PAlterTrParams _ ->
+      ptraceError "Altering treasury parameters is not currently supported."
+    -- Redeemer for all other treasury actions. Must ensure datum
+    -- is unchanged and no value has been removed from the
+    -- treasury.
+    PRedeemTreasury _ -> P.do
+      -- Amount of value treasury has before transaction.
+      let valueTrIn = undefined
 
-      -- Get datum hash of datum supplied to validator.
-      let dat = pfield @"data" # txInfo'
-          dH = getTrDatumHash # d # dat
+      -- Amount of value treasury has after transaction.
+      let valueTrOut = undefined
 
-      -- Get inputs in TxOut form.
-      let inputs = txInfo.inputs
-          rs = pmap # toResolved # inputs
+      let vOutExceedsVIn = pisValueSubset # valueTrIn # valueTrOut
 
-      -- Find the value the treasury had before being spent.
-      let valueIn = getValAtDHash # dH # rs
-
-      -- Find the value the treasury has after being spent.
-      let outputs = txInfo.outputs
-          valueOut = getValAtDHash # dH # outputs
-
-      -- If the value in equals the value out, validate the
-      -- transaction. Otherwise, fail.
       pif
-        (valueIn #== valueOut)
+        (vOutExceedsVIn)
         (pconstant ())
-        $ ptraceError "Treasury is altered when witnessing transaction"
-
-    -- Treasury is receiving amount of funds specified in the
-    -- redeemer. It's datum must be unchanged but it's value
-    -- must be increased by the specified amount.
-    PReceiveFunds _ -> P.do
-      pconstant ()
-
-{- | Plutarch level function that, given a treasury datum and a
-    list of the transaction's data, will find its hash.
--}
-getTrDatumHash ::
-  Term
-    s
-    ( PAsData PTreasuryDatum
-        :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum))
-        :--> PDatumHash
-    )
-getTrDatumHash = plam $ \d l -> P.do
-  let t = phead #$ pfilter # (matchDatums # d) # l
-  pfield @"_0" # t
-  where
-    matchDatums ::
-      Term
-        s
-        ( PAsData PTreasuryDatum
-            :--> PAsData (PTuple PDatumHash PDatum)
-            :--> PBool
-        )
-    matchDatums = plam $ \d t' ->
-      let t = pfield @"_1" # t'
-       in pforgetData d #== pforgetData t
-
--- | Get the "resolved" field of a TxInInfo.
-toResolved :: Term s (PAsData PTxInInfo :--> PAsData PTxOut)
-toResolved = plam $ \txIn -> pfield @"resolved" # txIn
-
--- | Gets the value kept at a given datum hash.
-getValAtDHash ::
-  Term
-    s
-    ( PDatumHash
-        :--> PBuiltinList (PAsData PTxOut)
-        :--> PAsData PValue
-    )
-getValAtDHash = plam $ \dh outs -> P.do
-  let matchingOut = phead #$ pfilter # (matchHashes # dh) # outs
-  pfield @"value" # matchingOut
-  where
-    matchHashes :: Term s (PDatumHash :--> PAsData PTxOut :--> PBool)
-    matchHashes = plam $ \dh out' -> P.do
-      PDJust dh' <- pmatch $ pfield @"datumHash" # pfromData out'
-      dh #== pfield @"_0" # dh'
+        (ptraceError "Value has been illegally deducted from treasury.")
 
 {- | Plutarch level type representing datum of the treasury.
      Contains:
@@ -153,10 +91,10 @@ newtype PTreasuryDatum (s :: S)
      treasury.
 -}
 data PTreasuryRedeemer (s :: S)
-  = -- | Receive funds and place them in the treasury.
-    PReceiveFunds (Term s (PDataRecord '["_0" ':= PValue]))
-  | -- | Serve as a witness for any transaction. Must remain unaltered.
-    PWitnessTreasury (Term s (PDataRecord '[]))
+  = -- | TODO: will allow the burning of GATs to alter Treasury params.
+    PAlterTrParams (Term s (PDataRecord '[]))
+  | -- | All other treasury actions. Value must not decrease.
+    PRedeemTreasury (Term s (PDataRecord '[]))
   deriving stock (GHC.Generic)
   deriving anyclass (Generic, PIsDataRepr)
   deriving

src/Agora/Utils.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wwarn #-}
+
 {- |
 Module     : Agora.Utils
 Maintainer : emi@haskell.fyi
@@ -22,6 +24,7 @@ module Agora.Utils (
   pfindTxInByTxOutRef,
   psingletonValue,
   pfindMap,
+  pisValueSubset,
 
   -- * Functions which should (probably) not be upstreamed
   anyOutput,
@@ -50,6 +53,8 @@ import Plutarch.Api.V1 (
   PTxOutRef,
   PValue (PValue),
  )
+import Plutarch.Api.V1.Tuple (ptupleFromBuiltin)
+import Plutarch.Bool (pand)
 import Plutarch.Builtin (ppairDataBuiltin)
 import Plutarch.Internal (punsafeCoerce)
 import Plutarch.Monadic qualified as P
@@ -255,6 +260,59 @@ pfindTxInByTxOutRef = phoistAcyclic $
           )
         #$ (pfield @"inputs" # txInfo)
 
+-- | Determines if a value is a subset of another.
+pisValueSubset :: Term s (PValue :--> PValue :--> PBool)
+pisValueSubset = plam $ \v0 _v1 -> P.do
+  -- v0Map :: Term s (PMap PCurrencySymbol (PMap PTokenName PInteger))
+  PValue v0Map <- pmatch v0
+
+  -- v0BuiltinMap :: Term s (PBuiltinMap k v)
+  PMap v0BuiltinMap <- pmatch v0Map
+
+  -- ks0 :: Term s (PBuiltinList PCurrencySymbol)
+  let ks0 = pmap # pfstBuiltin # v0BuiltinMap
+  pconstant True
+
+-- | Determines if a PTokenName/PInteger pmap is a subset of another.
+pisTnISubset ::
+  Term
+    s
+    ( PMap PTokenName PInteger
+        :--> PMap PTokenName PInteger
+        :--> PBool
+    )
+pisTnISubset = plam $ \m0 m1 -> P.do
+  -- m0BuiltinMap :: Term s (PBuiltinMap PTokenName PInteger)
+  PMap m0BuiltinMap <- pmatch m0
+
+  -- ks0 :: Term s (PBuiltinList PTokenName)
+  let ks0 = pmap # pfstBuiltin # m0BuiltinMap
+  pconstant True
+
+pcompareKeysForEq ::
+  Term
+    s
+    ( PBuiltinList k
+        :--> PMap k v
+        :--> PMap k v
+        :--> PBool
+    )
+pcompareKeysForEq = plam $ \ks m0' m1' -> P.do
+  PMap m0 <- m0'
+  PMap m1 <- m1'
+  bs <- pmatch $ pmap # f # ks
+  pcon PTrue
+
+f :: Term s (k :--> PMap k v :--> PMap k v)
+f = plam $ \k m0' m1' -> P.do
+  PMap m0 <- m0'
+  PMap m1 <- m1'
+  pmatch (plookup # k # m1) $ \case
+    PNothing -> pconstant False
+    PJust n1 -> P.do
+      PJust n0 <- pmatch $ plookup # k # m0
+      n0 #<= n1
+
 --------------------------------------------------------------------------------
 -- Functions which should (probably) not be upstreamed