Yeah! Treasury Withdrawal Effect works with good tests

agora-test/Spec.hs

@@ -8,8 +8,8 @@ import Test.Tasty (defaultMain, testGroup)
 
 --------------------------------------------------------------------------------
 
-import Spec.Effect.TreasuryWithdrawal qualified as TreasuryWithdrawal
 import Spec.AuthorityToken qualified as AuthorityToken
+import Spec.Effect.TreasuryWithdrawal qualified as TreasuryWithdrawal
 import Spec.Model.MultiSig qualified as MultiSig
 import Spec.Stake qualified as Stake
 

agora-test/Spec/Effect/TreasuryWithdrawal.hs

@@ -5,20 +5,117 @@ Description: Sample based testing for Treasury Withdrawal Effect
 
 This module tests the Treasury Withdrawal Effect.
 -}
-module Spec.Effect.TreasuryWithdrawal (currSymbol, signer, validator, validatorHashTN, scriptContext1, tests) where
+module Spec.Effect.TreasuryWithdrawal (tests) where
 
-import Spec.Sample.Effect.TreasuryWithdrawal
+import Spec.Sample.Effect.TreasuryWithdrawal (
+  buildReceiversOutputFromDatum,
+  buildScriptContext,
+  currSymbol,
+  inputGAT,
+  inputTreasury,
+  outputTreasury,
+  outputUser,
+  users,
+ )
 
+import Agora.Effect.TreasuryWithdrawal (
+  TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
+  treasuryWithdrawalValidator,
+ )
 
-import Agora.Effect.TreasuryWithdrawal
+import Plutus.V1.Ledger.Value qualified as Value
+import Spec.Util (effectFailsWith, effectSucceedsWith)
 
-import Spec.Util
+import Test.Tasty (TestTree, testGroup)
-
-import Test.Tasty
 
 tests :: [TestTree]
 tests =
   [ testGroup
       "effect"
-      [effectSucceedsWith "test1" (treasuryWithdrawalValidator currSymbol) datum scriptContext1]
+      [ effectSucceedsWith
+          "Simple"
+          (treasuryWithdrawalValidator currSymbol)
+          datum1
+          ( buildScriptContext
+              [ inputGAT
+              , inputTreasury 1 (asset1 10)
+              ]
+              $ outputTreasury 1 (asset1 7) :
+              buildReceiversOutputFromDatum datum1
+          )
+      , effectSucceedsWith
+          "Simple with multiple treasuries "
+          (treasuryWithdrawalValidator currSymbol)
+          datum1
+          ( buildScriptContext
+              [ inputGAT
+              , inputTreasury 1 (asset1 10)
+              , inputTreasury 2 (asset1 100)
+              , inputTreasury 3 (asset1 500)
+              ]
+              $ [ outputTreasury 1 (asset1 7)
+                , outputTreasury 2 (asset1 100)
+                , outputTreasury 3 (asset1 500)
+                ]
+                ++ buildReceiversOutputFromDatum datum1
+          )
+      , effectSucceedsWith
+          "Mixed Assets"
+          (treasuryWithdrawalValidator currSymbol)
+          datum2
+          ( buildScriptContext
+              [ inputGAT
+              , inputTreasury 1 (asset1 20)
+              , inputTreasury 2 (asset2 20)
+              ]
+              $ [ outputTreasury 1 (asset1 13)
+                , outputTreasury 2 (asset2 14)
+                ]
+                ++ buildReceiversOutputFromDatum datum2
+          )
+      , effectFailsWith
+          "Pay to uknown 3rd party"
+          (treasuryWithdrawalValidator currSymbol)
+          datum2
+          ( buildScriptContext
+              [ inputGAT
+              , inputTreasury 1 (asset1 20)
+              , inputTreasury 2 (asset2 20)
+              ]
+              $ [ outputUser 100 (asset1 2)
+                , outputTreasury 1 (asset1 11)
+                , outputTreasury 2 (asset2 14)
+                ]
+                ++ buildReceiversOutputFromDatum datum2
+          )
+      , effectFailsWith
+          "Missing receiver"
+          (treasuryWithdrawalValidator currSymbol)
+          datum2
+          ( buildScriptContext
+              [ inputGAT
+              , inputTreasury 1 (asset1 20)
+              , inputTreasury 2 (asset2 20)
+              ]
+              $ [ outputTreasury 1 (asset1 13)
+                , outputTreasury 2 (asset2 14)
+                ]
+                ++ drop 1 (buildReceiversOutputFromDatum datum2)
+          )
+      ]
   ]
+  where
+    asset1 = Value.singleton "abbc12" "OrangeBottle"
+    asset2 = Value.singleton "abbc12" "19721121"
+    datum1 =
+      TreasuryWithdrawalDatum
+        [ (head users, asset1 1)
+        , (users !! 1, asset1 1)
+        , (users !! 2, asset1 1)
+        ]
+    datum2 =
+      TreasuryWithdrawalDatum
+        [ (head users, asset1 4 <> asset2 5)
+        , (users !! 1, asset1 2 <> asset2 1)
+        , (users !! 2, asset1 1)
+        ]

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

@@ -5,16 +5,59 @@ Description: Sample based testing for Treasury Withdrawal Effect
 
 This module provides smaples for Treasury Withdrawal Effect tests.
 -}
-module Spec.Sample.Effect.TreasuryWithdrawal (datum, currSymbol, signer, validator, validatorHashTN, scriptContext1) where
+module Spec.Sample.Effect.TreasuryWithdrawal (
+  inputTreasury,
+  inputGAT,
+  outputTreasury,
+  outputUser,
+  buildReceiversOutputFromDatum,
+  currSymbol,
+  users,
+  treasuries,
+  buildScriptContext,
+) where
 
-import Plutarch.Api.V1
+import Plutarch.Api.V1 (mkValidator, validatorHash)
-import Plutus.V1.Ledger.Api
+import Plutus.V1.Ledger.Api (
+  Address (Address),
+  Credential (..),
+  CurrencySymbol (CurrencySymbol),
+  DatumHash (DatumHash),
+  PubKeyHash (PubKeyHash),
+  ScriptContext (..),
+  ScriptPurpose (Spending),
+  TokenName (TokenName),
+  TxInInfo (TxInInfo),
+  TxInfo (
+    TxInfo,
+    txInfoDCert,
+    txInfoData,
+    txInfoFee,
+    txInfoId,
+    txInfoInputs,
+    txInfoMint,
+    txInfoOutputs,
+    txInfoSignatories,
+    txInfoValidRange,
+    txInfoWdrl
+  ),
+  TxOut (..),
+  TxOutRef (TxOutRef),
+  Validator,
+  ValidatorHash (ValidatorHash),
+  Value,
+  toBuiltin,
+ )
 import Plutus.V1.Ledger.Interval qualified as Interval
 import Plutus.V1.Ledger.Value qualified as Value
 
-import Data.ByteString.Hash
+import Data.ByteString.Char8 qualified as C
+import Data.ByteString.Hash (sha2)
 
-import Agora.Effect.TreasuryWithdrawal
+import Agora.Effect.TreasuryWithdrawal (
+  TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
+  treasuryWithdrawalValidator,
+ )
 
 -- | A sample Currency Symbol.
 currSymbol :: CurrencySymbol
@@ -26,33 +69,57 @@ signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
 
 -- | List of users who the effect will pay to.
 users :: [Credential]
-users =
+users = PubKeyCredential . PubKeyHash . toBuiltin . sha2 . C.pack . show <$> ([1 ..] :: [Integer])
-  PubKeyCredential . PubKeyHash . toBuiltin . sha2
-    <$> [ "Orange"
-        , "Bottle"
-        , "Hello"
-        ]
 
 -- | List of users who the effect will pay to.
 treasuries :: [Credential]
-treasuries =
+treasuries = ScriptCredential . ValidatorHash . toBuiltin . sha2 . C.pack . show <$> ([1 ..] :: [Integer])
-  ScriptCredential . ValidatorHash . toBuiltin . sha2
-    <$> [ "1234"
-        , "qwer"
-        , "asdf"
-        ]
 
-_aa :: [Credential]
+inputGAT :: TxInInfo
-_aa = treasuries
+inputGAT =
+  TxInInfo -- Initiator
+    (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
+    TxOut
+      { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
+      , txOutValue = Value.singleton currSymbol validatorHashTN 1 -- Stake ST
+      , txOutDatumHash = Just (DatumHash "")
+      }
 
--- | Datum for Treasury Withdrawal Effect Validator.
+inputTreasury :: Int -> Value -> TxInInfo
-datum :: TreasuryWithdrawalDatum
+inputTreasury indx val =
-datum =
+  TxInInfo -- Initiator
-  TreasuryWithdrawalDatum
+    (TxOutRef "" 1)
-    [ (users !! 0, Value.singleton "1234ab" "LQ" 1)
+    TxOut
-    , (users !! 1, Value.singleton "1234ab" "LQ" 1)
+      { txOutAddress = Address (treasuries !! indx) Nothing
-    , (users !! 2, Value.singleton "1234ab" "LQ" 1)
+      , txOutValue = val
-    ]
+      , txOutDatumHash = Just (DatumHash "")
+      }
+
+outputTreasury :: Int -> Value -> TxOut
+outputTreasury indx val =
+  TxOut
+    { txOutAddress = Address (treasuries !! indx) Nothing
+    , txOutValue = val
+    , txOutDatumHash = Nothing
+    }
+
+outputUser :: Int -> Value -> TxOut
+outputUser indx val =
+  TxOut
+    { txOutAddress = Address (users !! indx) Nothing
+    , txOutValue = val
+    , txOutDatumHash = Nothing
+    }
+
+buildReceiversOutputFromDatum :: TreasuryWithdrawalDatum -> [TxOut]
+buildReceiversOutputFromDatum (TreasuryWithdrawalDatum xs) = f <$> xs
+  where
+    f x =
+      TxOut
+        { txOutAddress = Address (fst x) Nothing
+        , txOutValue = snd x
+        , txOutDatumHash = Nothing
+        }
 
 -- | Effect validator instance.
 validator :: Validator
@@ -62,62 +129,13 @@ validator = mkValidator $ treasuryWithdrawalValidator currSymbol
 validatorHashTN :: TokenName
 validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh
 
-scriptContext1 :: ScriptContext
+buildScriptContext :: [TxInInfo] -> [TxOut] -> ScriptContext
-scriptContext1 =
+buildScriptContext inputs outputs =
   ScriptContext
     { scriptContextTxInfo =
         TxInfo
-          { txInfoInputs =
+          { txInfoInputs = inputs
-              [ TxInInfo -- Initiator
+          , txInfoOutputs = outputs
-                  (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
-                  TxOut
-                    { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
-                    , txOutValue = Value.singleton currSymbol validatorHashTN 1 -- Stake ST
-                    , txOutDatumHash = Just (DatumHash "")
-                    }
-              , TxInInfo -- Treasury 1
-                  (TxOutRef "0b121212121212121212121212121212121212121212121212121221" 2)
-                  TxOut
-                    { txOutAddress = Address (treasuries !! 0) Nothing
-                    , txOutValue = Value.singleton "1234ab" "LQ" 10
-                    , txOutDatumHash = Just (DatumHash "")
-                    }
-              , TxInInfo -- Treasury 2
-                  (TxOutRef "0b121212121212121212a41212121212121212121212121212121221" 3)
-                  TxOut
-                    { txOutAddress = Address (treasuries !! 1) Nothing
-                    , txOutValue = Value.singleton "1234ab" "LQ" 10
-                    , txOutDatumHash = Just (DatumHash "")
-                    }
-              ]
-          , txInfoOutputs =
-              [ TxOut
-                  { txOutAddress = Address (users !! 0) Nothing
-                  , txOutValue = Value.singleton "1234ab" "LQ" 1
-                  , txOutDatumHash = Nothing
-                  }
-              , TxOut
-                  { txOutAddress = Address (users !! 1) Nothing
-                  , txOutValue = Value.singleton "1234ab" "LQ" 1
-                  , txOutDatumHash = Nothing
-                  }
-              , TxOut
-                  { txOutAddress = Address (users !! 2) Nothing
-                  , txOutValue = Value.singleton "1234ab" "LQ" 1
-                  , txOutDatumHash = Nothing
-                  }
-              , -- Send left overs to treasuries
-                TxOut
-                  { txOutAddress = Address (treasuries !! 0) Nothing
-                  , txOutValue = Value.singleton "1234ab" "LQ" 7
-                  , txOutDatumHash = Nothing
-                  }
-              , TxOut
-                  { txOutAddress = Address (treasuries !! 1) Nothing
-                  , txOutValue = Value.singleton "1234ab" "LQ" 10
-                  , txOutDatumHash = Nothing
-                  }
-              ]
           , txInfoFee = Value.singleton "" "" 2
           , txInfoMint = Value.singleton currSymbol validatorHashTN (-1)
           , txInfoDCert = []