stricter constraints over inputs

It will only allow treasuries given in the datum as input. It prevents
unwanted change in the system.

agora-test/Spec/Effect/TreasuryWithdrawal.hs

@@ -7,16 +7,18 @@ This module tests the Treasury Withdrawal Effect.
 -}
 module Spec.Effect.TreasuryWithdrawal (tests) where
 
-import Spec.Sample.Effect.TreasuryWithdrawal
+import Spec.Sample.Effect.TreasuryWithdrawal (
-    ( currSymbol,
+  buildReceiversOutputFromDatum,
-      users,
+  buildScriptContext,
-      treasuries,
+  currSymbol,
-      inputGAT,
+  inputGAT,
-      inputTreasury,
+  inputTreasury,
-      outputTreasury,
+  inputUser,
-      outputUser,
+  outputTreasury,
-      buildReceiversOutputFromDatum,
+  outputUser,
-      buildScriptContext )
+  treasuries,
+  users,
+ )
 
 import Agora.Effect.TreasuryWithdrawal (
   TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
@@ -110,10 +112,23 @@ tests =
               [ inputGAT
               , inputTreasury 999 (asset1 20)
               ]
-              $ [ outputTreasury 999 (asset1 17)
+              $ outputTreasury 999 (asset1 17) :
+              buildReceiversOutputFromDatum datum3
+          )
+      , effectFailsWith
+          "Prevent transactions besides the withdrawal"
+          (treasuryWithdrawalValidator currSymbol)
+          datum3
+          ( buildScriptContext
+              [ inputGAT
+              , inputTreasury 1 (asset1 20)
+              , inputUser 99 (asset2 100)
+              ]
+              $ [ outputTreasury 1 (asset1 17)
+                , outputUser 100 (asset2 100)
                 ]
                 ++ buildReceiversOutputFromDatum datum3
-          )          
+          )
       ]
   ]
   where
@@ -124,17 +139,17 @@ tests =
         [ (head users, asset1 1)
         , (users !! 1, asset1 1)
         , (users !! 2, asset1 1)
-        ] $
+        ]
-        [ head treasuries
+        [ treasuries !! 1
-        , treasuries !! 1
         , treasuries !! 2
+        , treasuries !! 3
         ]
     datum2 =
       TreasuryWithdrawalDatum
         [ (head users, asset1 4 <> asset2 5)
         , (users !! 1, asset1 2 <> asset2 1)
         , (users !! 2, asset1 1)
-        ] $
+        ]
         [ head treasuries
         , treasuries !! 1
         , treasuries !! 2
@@ -144,6 +159,5 @@ tests =
         [ (head users, asset1 1)
         , (users !! 1, asset1 1)
         , (users !! 2, asset1 1)
-        ] $
+        ]
-        [ treasuries !! 1
+        [treasuries !! 1]
-        ]        

agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs

@@ -7,6 +7,7 @@ This module provides smaples for Treasury Withdrawal Effect tests.
 -}
 module Spec.Sample.Effect.TreasuryWithdrawal (
   inputTreasury,
+  inputUser,
   inputGAT,
   outputTreasury,
   outputUser,
@@ -77,7 +78,7 @@ treasuries = ScriptCredential . ValidatorHash . toBuiltin . sha2 . C.pack . show
 
 inputGAT :: TxInInfo
 inputGAT =
-  TxInInfo -- Initiator
+  TxInInfo
     (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
     TxOut
       { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
@@ -87,7 +88,7 @@ inputGAT =
 
 inputTreasury :: Int -> Value -> TxInInfo
 inputTreasury indx val =
-  TxInInfo -- Initiator
+  TxInInfo
     (TxOutRef "" 1)
     TxOut
       { txOutAddress = Address (treasuries !! indx) Nothing
@@ -95,6 +96,16 @@ inputTreasury indx val =
       , txOutDatumHash = Just (DatumHash "")
       }
 
+inputUser :: Int -> Value -> TxInInfo
+inputUser indx val =
+  TxInInfo
+    (TxOutRef "" 1)
+    TxOut
+      { txOutAddress = Address (users !! indx) Nothing
+      , txOutValue = val
+      , txOutDatumHash = Just (DatumHash "")
+      }
+
 outputTreasury :: Int -> Value -> TxOut
 outputTreasury indx val =
   TxOut

agora-test/Spec/Util.hs

@@ -141,8 +141,7 @@ effectSucceedsWith ::
   PLifted datum ->
   ScriptContext ->
   TestTree
-effectSucceedsWith tag eff datum scriptContext =
+effectSucceedsWith tag eff datum = validatorSucceedsWith tag eff datum ()
-  validatorSucceedsWith tag eff datum () scriptContext
 
 -- | Check that a validator script fails, given a name and arguments.
 effectFailsWith ::
@@ -154,8 +153,7 @@ effectFailsWith ::
   PLifted datum ->
   ScriptContext ->
   TestTree
-effectFailsWith tag eff datum scriptContext =
+effectFailsWith tag eff datum = validatorFailsWith tag eff datum ()
-  validatorFailsWith tag eff datum () scriptContext
 
 -- | Check that an arbitrary script doesn't error when evaluated, given a name.
 scriptSucceeds :: String -> Script -> TestTree

agora/Agora/Effect/TreasuryWithdrawal.hs

@@ -38,11 +38,10 @@ import Plutus.V1.Ledger.Credential (Credential)
 import Plutus.V1.Ledger.Value (CurrencySymbol, Value)
 import PlutusTx qualified
 
-data TreasuryWithdrawalDatum =
+data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum
-  TreasuryWithdrawalDatum
+  { receivers :: [(Credential, Value)]
-    { receivers :: [(Credential, Value)]
+  , treasuries :: [Credential]
-    , treasuries :: [Credential]
+  }
-    }
   deriving stock (Show, GHC.Generic)
   deriving anyclass (Generic)
 
@@ -119,23 +118,15 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
     let treasuryOutputValues =
           pfilter
             # plam
-              ( \((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries)
+              (\((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries)
             # outputValues
-        treasuryInputValuesSum =
+        sumValues =
           pfoldr
             # plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y)
             # pconstant (mempty :: Value)
-            # treasuryInputValues
+        treasuryInputValuesSum = sumValues # treasuryInputValues
-        treasuryOutputValuesSum =
+        treasuryOutputValuesSum = sumValues # treasuryOutputValues
-          pfoldr
+        receiverValuesSum = sumValues # datum.receivers
-            # plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y)
-            # pconstant (mempty :: Value)
-            # treasuryOutputValues
-        receiverValuesSum =
-          pfoldr
-            # plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y)
-            # pconstant (mempty :: Value)
-            # datum.receivers
         outputContentMatchesRecivers =
           pall # plam (\out -> pelem # out # outputValues)
             #$ datum.receivers
@@ -148,8 +139,17 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
                   effInput.address #== pfield @"address" # pfromData x
               )
             # pfromData txInfo.outputs
+        inputsAreOnlyTreasuries =
+          pall
+            # plam
+              ( \((pfield @"_0" #) . pfromData -> cred) ->
+                  cred #== pfield @"credential" # effInput.address
+                    #|| pelem # cred # datum.treasuries
+              )
+            # inputValues
 
     passert "Transaction output does not match receivers" outputContentMatchesRecivers
     passert "Transaction should not pay to effects" shouldNotPayToEffect
+    passert "Transaction should only have treasuries specified in the datum as input" inputsAreOnlyTreasuries
     passert "Remainders should be returned to the treasury" excessShouldBePaidToInputs
     popaque $ pconstant ()