fix the test

agora-specs/Sample/Effect/TreasuryWithdrawal.hs

@@ -6,175 +6,208 @@ Description: Sample based testing for Treasury Withdrawal Effect
 This module provides samples for Treasury Withdrawal Effect tests.
 -}
 module Sample.Effect.TreasuryWithdrawal (
-  validator,
-  inputTreasury,
-  inputUser,
-  inputGAT,
-  inputCollateral,
-  outputTreasury,
-  outputUser,
-  buildReceiversOutputFromDatum,
-  currSymbol,
-  users,
-  treasuries,
-  buildScriptContext,
+  runEffect,
+  Parameters (..),
+  Validity (..),
+  totallyValidParameters,
+  mkTestTree,
 ) where
 
 import Agora.Effect.TreasuryWithdrawal (
-  TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
+  TreasuryWithdrawalDatum (..),
  )
+import Control.Composition ((.*))
+import Data.Foldable (Foldable (fold))
+import Data.List (singleton)
 import Data.Map ((!))
+import Data.Map.Ordered (OMap)
+import Data.Map.Ordered qualified as Map
+import Data.Semigroup (mtimesDefault)
 import Plutarch.Api.V2 (scriptHash)
+import Plutarch.Context (credential, input, mint, output, script, withInlineDatum, withRef, withRefTxId, withValue)
 import Plutarch.Script (Script)
-import PlutusLedgerApi.V1.Interval qualified as Interval (always)
-import PlutusLedgerApi.V1.Value qualified as Value (singleton)
+import PlutusLedgerApi.V1.Value qualified as Value (scale, singleton)
 import PlutusLedgerApi.V2 (
-  Address (Address),
   Credential (..),
-  CurrencySymbol,
-  DatumHash (DatumHash),
-  OutputDatum (OutputDatumHash),
-  PubKeyHash,
-  Redeemer (Redeemer),
-  ScriptContext (..),
-  ScriptHash (ScriptHash),
-  ScriptPurpose (Spending),
-  TokenName (TokenName),
-  TxInInfo (TxInInfo),
-  TxInfo (..),
-  TxOut (..),
+  TxId,
   TxOutRef (TxOutRef),
   Value,
-  toBuiltinData,
  )
-import PlutusTx.AssocMap qualified as AssocMap
-import Sample.Shared (agoraScripts, authorityTokenSymbol)
-import Test.Util (scriptCredentials, userCredentials)
+import PlutusLedgerApi.V3 (ScriptHash)
+import Sample.Shared (agoraScripts, authorityTokenPolicy, authorityTokenSymbol, signer, signer2, trScriptHash, trValidator)
+import Test.Specification (SpecificationTree, group, testPolicy, testValidator)
+import Test.Util (CombinableBuilder, mkMinting, mkSpending, subtractValue, validatorHashes)
 
--- | A sample Currency Symbol.
-currSymbol :: CurrencySymbol
-currSymbol = authorityTokenSymbol
+data Parameters = Parameters
+  { shouldDeliver ::
+      OMap Credential Value
+  , treasuryInputCount :: Integer
+  , badReceivedValue :: Bool
+  , badReceivers :: Bool
+  , badReceiverOrder :: Bool
+  , badTreasuryPaybackValue :: Bool
+  }
 
--- | A sample 'PubKeyHash'.
-signer :: PubKeyHash
-signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
+data Validity = Validity
+  { forGATPolicy :: Bool
+  , forEffectValidator :: Bool
+  , forTreasury :: Bool
+  }
 
--- | List of users who the effect will pay to.
-users :: [Credential]
-users = userCredentials
+effectValidator :: Script
+effectValidator = agoraScripts ! "agora:treasuryWithdrawalValidator"
 
--- | List of users who the effect will pay to.
-treasuries :: [Credential]
-treasuries = scriptCredentials
+effectHash :: ScriptHash
+effectHash = scriptHash effectValidator
 
-inputGAT :: TxInInfo
-inputGAT =
-  TxInInfo
-    (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
-    TxOut
-      { txOutAddress = Address (ScriptCredential $ scriptHash validator) Nothing
-      , txOutValue = Value.singleton currSymbol validatorHashTN 1 -- Stake ST
-      , txOutDatum = OutputDatumHash (DatumHash "")
-      , txOutReferenceScript = Nothing
-      }
-
--- | Create an input given the index of the treasury and the 'Value' at this input.
-inputTreasury :: Int -> Value -> TxInInfo
-inputTreasury indx val =
-  TxInInfo
-    (TxOutRef "" 1)
-    TxOut
-      { txOutAddress = Address (treasuries !! indx) Nothing
-      , txOutValue = val
-      , txOutDatum = OutputDatumHash (DatumHash "")
-      , txOutReferenceScript = Nothing
-      }
-
--- | Create a input given the index of the user and the 'Value' at this input.
-inputUser :: Int -> Value -> TxInInfo
-inputUser indx val =
-  TxInInfo
-    (TxOutRef "" 1)
-    TxOut
-      { txOutAddress = Address (users !! indx) Nothing
-      , txOutValue = val
-      , txOutDatum = OutputDatumHash (DatumHash "")
-      , txOutReferenceScript = Nothing
-      }
-
--- | Create a input representing the collateral given by a user.
-inputCollateral :: Int -> TxInInfo
-inputCollateral indx =
-  TxInInfo -- Initiator
-    (TxOutRef "" 1)
-    TxOut
-      { txOutAddress = Address (users !! indx) Nothing
-      , txOutValue = Value.singleton "" "" 2000000
-      , txOutDatum = OutputDatumHash (DatumHash "")
-      , txOutReferenceScript = Nothing
-      }
-
--- | Create an output at the nth treasury with the given 'Value'.
-outputTreasury :: Int -> Value -> TxOut
-outputTreasury indx val =
-  TxOut
-    { txOutAddress = Address (treasuries !! indx) Nothing
-    , txOutValue = val
-    , txOutDatum = OutputDatumHash (DatumHash "")
-    , txOutReferenceScript = Nothing
+mkEffectDatum :: Parameters -> TreasuryWithdrawalDatum
+mkEffectDatum ps =
+  TreasuryWithdrawalDatum
+    { receivers = Map.assocs ps.shouldDeliver
+    , treasuries = [ScriptCredential trScriptHash]
     }
 
--- | Create an output at the nth user with the given 'Value'.
-outputUser :: Int -> Value -> TxOut
-outputUser indx val =
-  TxOut
-    { txOutAddress = Address (users !! indx) Nothing
-    , txOutValue = val
-    , txOutDatum = OutputDatumHash (DatumHash "")
-    , txOutReferenceScript = Nothing
+effectRef :: TxOutRef
+effectRef = TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 0
+
+treasuryTxId :: TxId
+treasuryTxId = "0ca36f3a357bc69579ab2531aecd1e7d3714d993c7820f40b864be15"
+
+mkEffectInputBuilder :: forall b. CombinableBuilder b => Parameters -> b
+mkEffectInputBuilder ps =
+  let mkGATValue = Value.singleton authorityTokenSymbol ""
+   in mconcat
+        [ mint $ mkGATValue (-1)
+        , input $
+            mconcat
+              [ script effectHash
+              , withRef effectRef
+              , withInlineDatum $ mkEffectDatum ps
+              , withValue $ mkGATValue 1
+              ]
+        ]
+
+mkTreasuryInputBuilder ::
+  forall b.
+  CombinableBuilder b =>
+  Parameters ->
+  b
+mkTreasuryInputBuilder ps =
+  mtimesDefault ps.treasuryInputCount $
+    input $
+      mconcat
+        [ script trScriptHash
+        , withRefTxId treasuryTxId
+        , withInlineDatum ()
+        , withValue $ fold ps.shouldDeliver
+        ]
+
+mkTreasuryPaybackOutputBuilder ::
+  forall b.
+  CombinableBuilder b =>
+  Parameters ->
+  b
+mkTreasuryPaybackOutputBuilder ps =
+  let sentAmount = fold ps.shouldDeliver
+      inputAmount =
+        flip Value.scale sentAmount $
+          if ps.badTreasuryPaybackValue
+            then 1
+            else ps.treasuryInputCount
+      paybackValue = inputAmount `subtractValue` sentAmount
+   in output $
+        mconcat
+          [ script trScriptHash
+          , withValue paybackValue
+          , withInlineDatum ()
+          ]
+
+mkReceiverOutputBuilder ::
+  forall b.
+  CombinableBuilder b =>
+  Parameters ->
+  b
+mkReceiverOutputBuilder ps =
+  let mkOutputValue =
+        if ps.badReceivedValue
+          then const $ Value.singleton "" "bruh" 1
+          else id
+      mkFinalOutputs =
+        mconcat
+          . (if ps.badReceiverOrder then reverse else id)
+          . (if ps.badReceivers then drop 1 else id)
+      mkOutput :: _ -> _ -> b
+      mkOutput cred value =
+        output $
+          mconcat
+            [ credential cred
+            , withValue $ mkOutputValue value
+            , withInlineDatum ()
+            ]
+      rawOutputs =
+        foldMap (uncurry $ singleton .* mkOutput) $
+          Map.assocs ps.shouldDeliver
+   in mkFinalOutputs rawOutputs
+
+runEffect :: forall b. CombinableBuilder b => Parameters -> b
+runEffect ps =
+  foldMap
+    ($ ps)
+    [ mkEffectInputBuilder
+    , mkTreasuryInputBuilder
+    , mkReceiverOutputBuilder
+    , mkTreasuryPaybackOutputBuilder
+    ]
+
+totallyValidParameters :: Parameters
+totallyValidParameters =
+  Parameters
+    { shouldDeliver =
+        Map.fromList
+          [ (PubKeyCredential signer, Value.singleton "" "" 42_000_000)
+          , (PubKeyCredential signer2, Value.singleton "" "" 42_000_000)
+          , (ScriptCredential (head validatorHashes), Value.singleton "" "" 42_000_000)
+          ]
+    , treasuryInputCount = 2
+    , badReceivedValue = False
+    , badReceivers = False
+    , badReceiverOrder = False
+    , badTreasuryPaybackValue = False
     }
 
--- | Create a list of the outputs that are required as encoded in 'TreasuryWithdrawalDatum'.
-buildReceiversOutputFromDatum :: TreasuryWithdrawalDatum -> [TxOut]
-buildReceiversOutputFromDatum (TreasuryWithdrawalDatum xs _) = f <$> xs
+mkTestTree ::
+  String ->
+  Parameters ->
+  Validity ->
+  SpecificationTree
+mkTestTree name ps val =
+  group name [effect, treasury, authority]
   where
-    f x =
-      TxOut
-        { txOutAddress = Address (fst x) Nothing
-        , txOutValue = snd x
-        , txOutDatum = OutputDatumHash (DatumHash "")
-        , txOutReferenceScript = Nothing
-        }
+    spend = mkSpending runEffect ps
+    mint = mkMinting runEffect ps
 
--- | Effect validator instance.
-validator :: Script
-validator = agoraScripts ! "agora:treasuryWithdrawalValidator"
+    effect =
+      testValidator
+        val.forEffectValidator
+        "effect"
+        effectValidator
+        (mkEffectDatum ps)
+        ()
+        (spend effectRef)
 
--- | 'TokenName' that represents the hash of the 'Agora.Stake.Stake' validator.
-validatorHashTN :: TokenName
-validatorHashTN = let ScriptHash hash = scriptHash validator in TokenName hash
+    treasury =
+      testValidator
+        val.forTreasury
+        "treasury"
+        trValidator
+        ()
+        ()
+        (spend $ TxOutRef treasuryTxId 1)
 
-buildScriptContext :: [TxInInfo] -> [TxOut] -> ScriptContext
-buildScriptContext inputs outputs =
-  let spending = Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
-   in ScriptContext
-        { scriptContextTxInfo =
-            TxInfo
-              { txInfoInputs = inputs
-              , txInfoReferenceInputs = []
-              , txInfoOutputs = outputs
-              , txInfoFee = Value.singleton "" "" 2
-              , txInfoMint = Value.singleton currSymbol validatorHashTN (-1)
-              , txInfoDCert = []
-              , txInfoWdrl = AssocMap.empty
-              , txInfoValidRange = Interval.always
-              , txInfoSignatories = [signer]
-              , txInfoData = AssocMap.empty
-              , txInfoRedeemers =
-                  AssocMap.fromList
-                    [ (spending, Redeemer $ toBuiltinData ())
-                    ]
-              , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
-              }
-        , scriptContextPurpose = spending
-        }
+    authority =
+      testPolicy
+        val.forGATPolicy
+        "authority"
+        authorityTokenPolicy
+        ()
+        (mint authorityTokenSymbol)

agora-specs/Sample/Shared.hs

@@ -58,6 +58,7 @@ module Sample.Shared (
   mockTrEffect,
   mockTrEffectHash,
   trValidator,
+  trScriptHash,
   trCredential,
   wrongEffHash,
 ) where
@@ -276,9 +277,12 @@ gatCs = authorityTokenSymbol
 trValidator :: Script
 trValidator = agoraScripts ! "agora:treasuryValidator"
 
+trScriptHash :: ScriptHash
+trScriptHash = scriptHash trValidator
+
 -- | `ScriptCredential` used for the dummy treasury validator.
 trCredential :: Credential
-trCredential = ScriptCredential $ scriptHash trValidator
+trCredential = ScriptCredential trScriptHash
 
 -- | `TokenName` for GAT generated from address of `mockTrEffect`.
 gatTn :: TokenName

agora-specs/Spec/Effect/TreasuryWithdrawal.hs

@@ -7,172 +7,44 @@ This module specs the Treasury Withdrawal Effect.
 -}
 module Spec.Effect.TreasuryWithdrawal (specs) where
 
-import Agora.Effect.TreasuryWithdrawal (
-  TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
- )
-import PlutusLedgerApi.V1.Value qualified as Value
 import Sample.Effect.TreasuryWithdrawal (
-  buildReceiversOutputFromDatum,
-  buildScriptContext,
-  inputCollateral,
-  inputGAT,
-  inputTreasury,
-  inputUser,
-  outputTreasury,
-  outputUser,
-  treasuries,
-  users,
-  validator,
+  Parameters (..),
+  Validity (..),
+  mkTestTree,
+  totallyValidParameters,
  )
 import Test.Specification (
   SpecificationTree,
-  effectFailsWith,
-  effectSucceedsWith,
-  group,
  )
-import Test.Util (sortValue)
 
 specs :: [SpecificationTree]
 specs =
-  [ group
-      "effect"
-      [ effectSucceedsWith
-          "Simple"
-          validator
-          datum1
-          ( buildScriptContext
-              [ inputGAT
-              , inputCollateral 10
-              , inputTreasury 1 (asset1 10)
-              ]
-              $ outputTreasury 1 (asset1 7)
-                : buildReceiversOutputFromDatum datum1
-          )
-      , effectSucceedsWith
-          "Simple with multiple treasuries "
-          validator
-          datum1
-          ( buildScriptContext
-              [ inputGAT
-              , inputCollateral 10
-              , 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"
-          validator
-          datum2
-          ( buildScriptContext
-              [ inputGAT
-              , inputCollateral 10
-              , inputTreasury 1 (asset1 20)
-              , inputTreasury 2 (asset2 20)
-              ]
-              $ [ outputTreasury 1 (asset1 13)
-                , outputTreasury 2 (asset2 14)
-                ]
-                ++ buildReceiversOutputFromDatum datum2
-          )
-      , effectFailsWith
-          "Pay to uknown 3rd party"
-          validator
-          datum2
-          ( buildScriptContext
-              [ inputGAT
-              , inputCollateral 10
-              , 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"
-          validator
-          datum2
-          ( buildScriptContext
-              [ inputGAT
-              , inputCollateral 10
-              , inputTreasury 1 (asset1 20)
-              , inputTreasury 2 (asset2 20)
-              ]
-              $ [ outputTreasury 1 (asset1 13)
-                , outputTreasury 2 (asset2 14)
-                ]
-                ++ drop 1 (buildReceiversOutputFromDatum datum2)
-          )
-      , effectFailsWith
-          "Unauthorized treasury"
-          validator
-          datum3
-          ( buildScriptContext
-              [ inputGAT
-              , inputCollateral 10
-              , inputTreasury 999 (asset1 20)
-              ]
-              $ outputTreasury 999 (asset1 17)
-                : buildReceiversOutputFromDatum datum3
-          )
-      , effectFailsWith
-          "Prevent transactions besides the withdrawal"
-          validator
-          datum3
-          ( buildScriptContext
-              [ inputGAT
-              , inputTreasury 1 (asset1 20)
-              , inputTreasury 999 (asset1 20)
-              , inputUser 99 (asset2 100)
-              ]
-              $ [ outputTreasury 1 (asset1 17)
-                , outputUser 100 (asset2 100)
-                ]
-                ++ buildReceiversOutputFromDatum datum3
-          )
-      ]
+  [ mkTestTree
+      "totally valid"
+      totallyValidParameters
+      Validity
+        { forGATPolicy = True
+        , forEffectValidator = True
+        , forTreasury = True
+        }
+  , mkTestTree
+      "bad received value"
+      totallyValidParameters
+        { badReceivedValue = True
+        }
+      Validity
+        { forGATPolicy = True
+        , forEffectValidator = False
+        , forTreasury = True
+        }
+  , mkTestTree
+      "bad receiver order"
+      totallyValidParameters
+        { badReceiverOrder = True
+        }
+      Validity
+        { forGATPolicy = True
+        , forEffectValidator = False
+        , forTreasury = True
+        }
   ]
-  where
-    asset1 =
-      Value.singleton
-        "0d586e057e76238f8c56c0752507bfa45ae13b04f8497a311d4aaa48"
-        "OrangeBottle"
-    asset2 =
-      Value.singleton
-        "7e6aa764bceeba1f7acf47d20f1a2a85440afa2928f8ae96376f4d85"
-        "19721121"
-    datum1 =
-      TreasuryWithdrawalDatum
-        [ (head users, asset1 1)
-        , (users !! 1, asset1 1)
-        , (users !! 2, asset1 1)
-        ]
-        [ treasuries !! 1
-        , treasuries !! 2
-        , treasuries !! 3
-        ]
-    datum2 =
-      TreasuryWithdrawalDatum
-        [ (head users, sortValue $ asset2 5 <> asset1 4)
-        , (users !! 1, sortValue $ asset2 1 <> asset1 2)
-        , (users !! 2, asset1 1)
-        ]
-        [ head treasuries
-        , treasuries !! 1
-        , treasuries !! 2
-        ]
-    datum3 =
-      TreasuryWithdrawalDatum
-        [ (head users, asset1 1)
-        , (users !! 1, asset1 1)
-        , (users !! 2, asset1 1)
-        ]
-        [treasuries !! 1]

agora-testlib/Test/Util.hs

@@ -23,6 +23,7 @@ module Test.Util (
   mkSpending,
   mkMinting,
   CombinableBuilder,
+  subtractValue,
 ) where
 
 --------------------------------------------------------------------------------
@@ -45,6 +46,7 @@ import Plutarch.Context (
 import Plutarch.Crypto (pblake2b_256)
 import PlutusLedgerApi.V1.Interval qualified as PlutusTx
 import PlutusLedgerApi.V1.Value (Value (..))
+import PlutusLedgerApi.V1.Value qualified as Value
 import PlutusLedgerApi.V2 (
   Credential (
     PubKeyCredential,
@@ -212,3 +214,8 @@ mkMinting mkBuilder ps cs =
     mkBuilder ps <> withMinting cs
 
 type CombinableBuilder b = (Monoid b, Builder b)
+
+--------------------------------------------------------------------------------
+
+subtractValue :: Value -> Value -> Value
+subtractValue = Value.unionWith (-)

agora.cabal

@@ -226,7 +226,9 @@ library agora-specs
     Spec.Utils
 
   hs-source-dirs:  agora-specs
-  build-depends:   agora-testlib
+  build-depends:
+    , agora-testlib
+    , ordered-containers
 
 test-suite agora-test
   import:         lang, deps, plutarch-prelude, test-deps, test-opts