Merge pull request #65 from Liqwid-Labs/emiflake/drop-allInputs

drop `allInputs`, fix `authorityTokensValidIn`

agora-test/Spec.hs

@@ -8,6 +8,7 @@ import Test.Tasty (defaultMain, testGroup)
 
 --------------------------------------------------------------------------------
 
+import Spec.AuthorityToken qualified as AuthorityToken
 import Spec.Model.MultiSig qualified as MultiSig
 import Spec.Stake qualified as Stake
 
@@ -28,4 +29,7 @@ main =
               , MultiSig.genTests
               ]
           ]
+      , testGroup
+          "AuthorityToken tests"
+          AuthorityToken.tests
       ]

agora-test/Spec/AuthorityToken.hs

@@ -0,0 +1,154 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+{- |
+Module     : Spec.AuthorityToken
+Maintainer : emi@haskell.fyi
+Description: Tests for Authority token functions
+
+Tests for Authority token functions
+-}
+module Spec.AuthorityToken (tests) where
+
+--------------------------------------------------------------------------------
+
+import Agora.AuthorityToken (singleAuthorityTokenBurned)
+import Plutarch
+import Test.Tasty (TestTree, testGroup)
+import Prelude
+
+--------------------------------------------------------------------------------
+
+import Plutus.V1.Ledger.Api (
+  Address (Address),
+  Credential (PubKeyCredential, ScriptCredential),
+  CurrencySymbol,
+  Script,
+  TxInInfo (TxInInfo),
+  TxInfo (..),
+  TxOut (TxOut),
+  TxOutRef (TxOutRef),
+  ValidatorHash (ValidatorHash),
+  Value,
+ )
+import Plutus.V1.Ledger.Interval qualified as Interval
+import Plutus.V1.Ledger.Value qualified as Value
+import PlutusTx.AssocMap qualified as AssocMap
+import Spec.Util (scriptFails, scriptSucceeds)
+
+currencySymbol :: CurrencySymbol
+currencySymbol = "deadbeef"
+
+mkTxInfo :: Value -> [TxOut] -> TxInfo
+mkTxInfo mint outs =
+  TxInfo
+    { txInfoInputs = fmap (TxInInfo (TxOutRef "" 0)) outs
+    , txInfoOutputs = []
+    , txInfoFee = Value.singleton "" "" 1000
+    , txInfoMint = mint
+    , txInfoDCert = []
+    , txInfoWdrl = []
+    , txInfoValidRange = Interval.always
+    , txInfoSignatories = []
+    , txInfoData = []
+    , txInfoId = ""
+    }
+
+singleAuthorityTokenBurnedTest :: Value -> [TxOut] -> Script
+singleAuthorityTokenBurnedTest mint outs =
+  let actual :: ClosedTerm PBool
+      actual = singleAuthorityTokenBurned (pconstant currencySymbol) (pconstantData (mkTxInfo mint outs)) (pconstant mint)
+      s :: ClosedTerm POpaque
+      s =
+        pif
+          actual
+          (popaque (pconstant ()))
+          perror
+   in compile s
+
+tests :: [TestTree]
+tests =
+  [ -- This is better suited for plutarch-test
+    testGroup
+      "singleAuthorityTokenBurned"
+      [ scriptSucceeds
+          "Correct simple"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.singleton currencySymbol "deadbeef" (-1)
+                  <> Value.singleton "aa" "USDC" 100_000
+              )
+              [ TxOut
+                  (Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
+                  (Value.singleton currencySymbol "deadbeef" 1)
+                  Nothing
+              ]
+          )
+      , scriptSucceeds
+          "Correct many inputs"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.singleton currencySymbol "deadbeef" (-1)
+                  <> Value.singleton "aa" "USDC" 100_000
+              )
+              [ TxOut
+                  (Address (PubKeyCredential "") Nothing)
+                  (Value.singleton "aaabcc" "hello-token" 1)
+                  Nothing
+              , TxOut
+                  (Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
+                  (Value.singleton currencySymbol "deadbeef" 1)
+                  Nothing
+              , TxOut
+                  (Address (PubKeyCredential "") Nothing)
+                  (Value.singleton "" "" 1_000_000_000)
+                  Nothing
+              ]
+          )
+      , scriptFails
+          "Incorrect no burn"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.Value AssocMap.empty
+              )
+              []
+          )
+      , scriptFails
+          "Incorrect no GAT burn"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.singleton "aabbcc" "not a GAT!" (-100)
+              )
+              []
+          )
+      , scriptFails
+          "Incorrect script mismatch"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.singleton currencySymbol "i'm not deadbeef!" (-1)
+              )
+              [ TxOut
+                  (Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
+                  (Value.singleton currencySymbol "i'm not deadbeef!" 1)
+                  Nothing
+              ]
+          )
+      , scriptFails
+          "Incorrect spent from PK"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.singleton currencySymbol "doesn't matter" (-1)
+              )
+              [ TxOut
+                  (Address (PubKeyCredential "") Nothing)
+                  (Value.singleton currencySymbol "doesn't matter" 1)
+                  Nothing
+              ]
+          )
+      , scriptFails
+          "Incorrect two GATs"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.singleton currencySymbol "deadbeef" (-2)
+                  <> Value.singleton "aa" "USDC" 100_000
+              )
+              [ TxOut
+                  (Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
+                  (Value.singleton currencySymbol "deadbeef" 2)
+                  Nothing
+              ]
+          )
+      ]
+  ]

agora.cabal

@@ -155,6 +155,7 @@ test-suite agora-test
     Spec.Sample.Stake
     Spec.Stake
     Spec.Util
+    Spec.AuthorityToken
 
   build-depends:  agora
 

agora/Agora/AuthorityToken.hs

@@ -34,7 +34,6 @@ import Prelude
 --------------------------------------------------------------------------------
 
 import Agora.Utils (
-  allInputs,
   allOutputs,
   passert,
   passetClassValueOf,
@@ -81,15 +80,16 @@ authorityTokensValidIn = phoistAcyclic $
         pmatch (pfield @"credential" # address) $ \case
           PPubKeyCredential _ ->
             -- GATs should only be sent to Effect validators
-            pconstant False
+            ptraceIfFalse "authorityTokensValidIn: GAT incorrectly lives at PubKey" $ pconstant False
           PScriptCredential ((pfromData . (pfield @"_0" #)) -> cred) -> P.do
             PMap tokenMap <- pmatch tokenMap'
-            pall
+            ptraceIfFalse "authorityTokensValidIn: GAT TokenName doesn't match ScriptHash" $
-              # plam
+              pall
-                ( \pair ->
+                # plam
-                    pforgetData (pfstBuiltin # pair) #== pforgetData (pdata cred)
+                  ( \pair ->
-                )
+                      pforgetData (pfstBuiltin # pair) #== pforgetData (pdata cred)
-              # tokenMap
+                  )
+                # tokenMap
       PNothing ->
         -- No GATs exist at this output!
         pconstant True
@@ -105,14 +105,20 @@ singleAuthorityTokenBurned gatCs txInfo mint = P.do
   let gatAmountMinted :: Term _ PInteger
       gatAmountMinted = psymbolValueOf # gatCs # mint
 
+  txInfoF <- pletFields @'["inputs"] $ txInfo
+
   foldr1
     (#&&)
-    [ ptraceIfFalse "GAT not burned." $ gatAmountMinted #== -1
+    [ ptraceIfFalse "singleAuthorityTokenBurned: Must burn exactly 1 GAT" $ gatAmountMinted #== -1
-    , ptraceIfFalse "All inputs only have valid GATs" $
+    , ptraceIfFalse "singleAuthorityTokenBurned: All GAT tokens must be valid at the inputs" $
-        allInputs @PUnit # pfromData txInfo #$ plam $ \txOut _value _address _datum ->
+        pall
-          authorityTokensValidIn
+          # plam
-            # gatCs
+            ( \txInInfo' -> P.do
-            # txOut
+                PTxInInfo txInInfo <- pmatch (pfromData txInInfo')
+                let txOut' = pfield @"resolved" # txInInfo
+                authorityTokensValidIn # gatCs # pfromData txOut'
+            )
+          # txInfoF.inputs
     ]
 
 -- | Policy given 'AuthorityToken' params.

agora/Agora/Utils.hs

@@ -32,7 +32,6 @@ module Agora.Utils (
   anyOutput,
   allOutputs,
   anyInput,
-  allInputs,
   findTxOutByTxOutRef,
   scriptHashFromAddress,
   findOutputsToAddress,
@@ -376,30 +375,6 @@ anyInput = phoistAcyclic $
         )
       # pfromData txInfo.inputs
 
--- | Check if all (resolved) inputs match the predicate.
-allInputs ::
-  forall (datum :: PType) s.
-  ( PIsData datum
-  ) =>
-  Term s (PTxInfo :--> (PTxOut :--> PValue :--> PAddress :--> datum :--> PBool) :--> PBool)
-allInputs = phoistAcyclic $
-  plam $ \txInfo' predicate -> P.do
-    txInfo <- pletFields @'["inputs"] txInfo'
-    pall
-      # plam
-        ( \txInInfo'' -> P.do
-            PTxInInfo txInInfo' <- pmatch (pfromData txInInfo'')
-            let txOut'' = pfield @"resolved" # txInInfo'
-            PTxOut txOut' <- pmatch (pfromData txOut'')
-            txOut <- pletFields @'["value", "datumHash", "address"] txOut'
-            PDJust dh <- pmatch txOut.datumHash
-            pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo') $ \case
-              PJust datum -> P.do
-                predicate # pfromData txOut'' # txOut.value # txOut.address # pfromData datum
-              PNothing -> pcon PFalse
-        )
-      # pfromData txInfo.inputs
-
 -- | Create a value with a single asset class.
 psingletonValue :: forall s. Term s (PCurrencySymbol :--> PTokenName :--> PInteger :--> PValue)
 psingletonValue = phoistAcyclic $