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
-    ( currSymbol,
-      users,
-      treasuries,
-      inputGAT,
-      inputTreasury,
-      outputTreasury,
-      outputUser,
-      buildReceiversOutputFromDatum,
-      buildScriptContext )
+import Spec.Sample.Effect.TreasuryWithdrawal (
+  buildReceiversOutputFromDatum,
+  buildScriptContext,
+  currSymbol,
+  inputGAT,
+  inputTreasury,
+  inputUser,
+  outputTreasury,
+  outputUser,
+  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 =
-  validatorSucceedsWith tag eff datum () scriptContext
+effectSucceedsWith tag eff datum = validatorSucceedsWith tag eff datum ()
 
 -- | 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 =
-  validatorFailsWith tag eff datum () scriptContext
+effectFailsWith tag eff datum = validatorFailsWith tag eff datum ()
 
 -- | Check that an arbitrary script doesn't error when evaluated, given a name.
 scriptSucceeds :: String -> Script -> TestTree