From 57a0c104048844ae8f8ef95f93e9d503d2698a92 Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Wed, 20 Apr 2022 08:43:22 -0400 Subject: [PATCH] added test entree Something is wrong. It does not work. --- .../Spec/Effect/TreasuryWithdrawalEffect.hs | 67 +++++++++++++++---- agora-test/Spec/Util.hs | 41 ++++++++++++ 2 files changed, 96 insertions(+), 12 deletions(-) diff --git a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs index 751a3bc..f96fb65 100644 --- a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs +++ b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs @@ -5,8 +5,10 @@ Description: Sample based testing for Treasury Withdrawal Effect This module tests the Treasury Withdrawal Effect. -} -module Spec.Effect.TreasuryWithdrawalEffect (currSymbol, signer, validator, validatorHashTN, scriptContext1) where +module Spec.Effect.TreasuryWithdrawalEffect (currSymbol, signer, validator, validatorHashTN, scriptContext1, tests) where +import Plutarch.Evaluate +import Plutarch.Builtin import Plutarch.Api.V1 import Plutus.V1.Ledger.Api import Plutus.V1.Ledger.Interval qualified as Interval @@ -16,12 +18,16 @@ import Data.ByteString.Hash import Agora.Effect.TreasuryWithdrawal +import Spec.Util + +import Test.Tasty + -- receiverList :: TreasuryWithdrawalDatum -- receiverList = TreasuryWithdrawalDatum [(mempty, mempty)] -- | A sample Currency Symbol. currSymbol :: CurrencySymbol -currSymbol = CurrencySymbol "Orangebottle19721121" +currSymbol = CurrencySymbol "ff" -- | A sample 'PubKeyHash'. signer :: PubKeyHash @@ -31,14 +37,23 @@ signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c" users :: [Credential] users = PubKeyCredential . PubKeyHash . toBuiltin . sha2 - <$> [ "Hello world" - , "Hello Agora" - , "Hello Plutarch" + <$> [ "Orange" + , "Bottle" + , "Hello" + ] + +-- | List of users who the effect will pay to. +treasuries :: [Credential] +treasuries = + ScriptCredential . ValidatorHash . toBuiltin . sha2 + <$> [ "1234" + , "qwer" + , "asdf" ] -- | Datum for Treasury Withdrawal Effect Validator. -_datum :: TreasuryWithdrawalDatum -_datum = +datum :: TreasuryWithdrawalDatum +datum = TreasuryWithdrawalDatum [ (users !! 0, Value.singleton currSymbol validatorHashTN 1) , (users !! 1, Value.singleton currSymbol validatorHashTN 1) @@ -60,23 +75,23 @@ scriptContext1 = TxInfo { txInfoInputs = [ TxInInfo -- Initiator - (TxOutRef "Initiator" 1) + (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) TxOut { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing , txOutValue = Value.singleton "" "" 2000000 , txOutDatumHash = Nothing } , TxInInfo -- Treasury 1 - (TxOutRef "Treasury 1" 1) + (TxOutRef "Treasury 1" 2) TxOut - { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing + { txOutAddress = Address (treasuries !! 0) Nothing , txOutValue = Value.singleton currSymbol validatorHashTN 10 , txOutDatumHash = Nothing } , TxInInfo -- Treasury 2 - (TxOutRef "Treasury 2" 1) + (TxOutRef "Treasury 2" 3) TxOut - { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing + { txOutAddress = Address (treasuries !! 1) Nothing , txOutValue = Value.singleton currSymbol validatorHashTN 10 , txOutDatumHash = Nothing } @@ -97,6 +112,17 @@ scriptContext1 = , txOutValue = Value.singleton currSymbol validatorHashTN 1 , txOutDatumHash = Nothing } + -- Send left overs to treasuries + , TxOut + { txOutAddress = Address (treasuries !! 0) Nothing + , txOutValue = Value.singleton currSymbol validatorHashTN 7 + , txOutDatumHash = Nothing + } + , TxOut + { txOutAddress = Address (treasuries !! 1) Nothing + , txOutValue = Value.singleton currSymbol validatorHashTN 10 + , txOutDatumHash = Nothing + } ] , txInfoFee = Value.singleton "" "" 2 , txInfoMint = mempty @@ -110,3 +136,20 @@ scriptContext1 = , scriptContextPurpose = Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) } + + +tests :: [TestTree] +tests = + [ testGroup + "effect" + [ effectFailsWith "test1" (treasuryWithdrawalValidator currSymbol) datum scriptContext1] + ] + +_asdfa :: IO () +_asdfa = do + let (res, _budget, traces) = evalScript $ compile ((treasuryWithdrawalValidator currSymbol) # pforgetData (pconstantData datum) # pforgetData (pconstantData ()) # pconstant scriptContext1) + case res of + Left e -> do + putStrLn $ show e <> " Traces: " <> show traces + Right _v -> + pure () diff --git a/agora-test/Spec/Util.hs b/agora-test/Spec/Util.hs index 4350e45..1ebdc07 100644 --- a/agora-test/Spec/Util.hs +++ b/agora-test/Spec/Util.hs @@ -13,6 +13,8 @@ module Spec.Util ( policyFailsWith, validatorSucceedsWith, validatorFailsWith, + effectSucceedsWith, + effectFailsWith, -- * Plutus-land utils datumHash, @@ -129,6 +131,45 @@ validatorFailsWith tag policy datum redeemer scriptContext = # pconstant scriptContext ) + +-- | Check that a validator script succeeds, given a name and arguments. +effectSucceedsWith :: + ( PLift datum + , PlutusTx.ToData (PLifted datum) + ) => + String -> + ClosedTerm PValidator -> + PLifted datum -> + ScriptContext -> + TestTree +effectSucceedsWith tag eff datum scriptContext = + scriptSucceeds tag $ + compile + ( eff + # pforgetData (pconstantData datum) + # pforgetData (pconstantData ()) + # pconstant scriptContext + ) + +-- | Check that a validator script fails, given a name and arguments. +effectFailsWith :: + ( PLift datum + , PlutusTx.ToData (PLifted datum) + ) => + String -> + ClosedTerm PValidator -> + PLifted datum -> + ScriptContext -> + TestTree +effectFailsWith tag eff datum scriptContext = + scriptFails tag $ + compile + ( eff + # pforgetData (pconstantData datum) + # pforgetData (pconstantData ()) + # pconstant scriptContext + ) + -- | Check that an arbitrary script doesn't error when evaluated, given a name. scriptSucceeds :: String -> Script -> TestTree scriptSucceeds name script = testCase name $ do