diff --git a/agora-test/Spec.hs b/agora-test/Spec.hs index 2f443cd..40a7b7f 100644 --- a/agora-test/Spec.hs +++ b/agora-test/Spec.hs @@ -9,6 +9,7 @@ import Test.Tasty (defaultMain, testGroup) -------------------------------------------------------------------------------- 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 @@ -19,6 +20,12 @@ main = testGroup "test suite" [ testGroup + "Effects" + [ testGroup + "Treasury Withdrawal Effect" + TreasuryWithdrawal.tests + ] + , testGroup "Stake tests" Stake.tests , testGroup diff --git a/agora-test/Spec/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Effect/TreasuryWithdrawal.hs new file mode 100644 index 0000000..db0aed6 --- /dev/null +++ b/agora-test/Spec/Effect/TreasuryWithdrawal.hs @@ -0,0 +1,171 @@ +{- | +Module : Spec.Effect.TreasuryWithdrawalEffect +Maintainer : seungheon.ooh@gmail.com +Description: Sample based testing for Treasury Withdrawal Effect + +This module tests the Treasury Withdrawal Effect. +-} +module Spec.Effect.TreasuryWithdrawal (tests) where + +import Spec.Sample.Effect.TreasuryWithdrawal ( + buildReceiversOutputFromDatum, + buildScriptContext, + currSymbol, + inputCollateral, + inputGAT, + inputTreasury, + inputUser, + outputTreasury, + outputUser, + treasuries, + users, + ) + +import Agora.Effect.TreasuryWithdrawal ( + TreasuryWithdrawalDatum (TreasuryWithdrawalDatum), + treasuryWithdrawalValidator, + ) + +import Plutus.V1.Ledger.Value qualified as Value +import Spec.Util (effectFailsWith, effectSucceedsWith) + +import Test.Tasty (TestTree, testGroup) + +tests :: [TestTree] +tests = + [ testGroup + "effect" + [ effectSucceedsWith + "Simple" + (treasuryWithdrawalValidator currSymbol) + datum1 + ( buildScriptContext + [ inputGAT + , inputCollateral 10 + , inputTreasury 1 (asset1 10) + ] + $ outputTreasury 1 (asset1 7) : + buildReceiversOutputFromDatum datum1 + ) + , effectSucceedsWith + "Simple with multiple treasuries " + (treasuryWithdrawalValidator currSymbol) + 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" + (treasuryWithdrawalValidator currSymbol) + 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" + (treasuryWithdrawalValidator currSymbol) + 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" + (treasuryWithdrawalValidator currSymbol) + 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" + (treasuryWithdrawalValidator currSymbol) + datum3 + ( buildScriptContext + [ inputGAT + , inputCollateral 10 + , inputTreasury 999 (asset1 20) + ] + $ outputTreasury 999 (asset1 17) : + buildReceiversOutputFromDatum datum3 + ) + , effectFailsWith + "Prevent transactions besides the withdrawal" + (treasuryWithdrawalValidator currSymbol) + 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 + ) + ] + ] + 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) + ] + [ 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 + ] + datum3 = + TreasuryWithdrawalDatum + [ (head users, asset1 1) + , (users !! 1, asset1 1) + , (users !! 2, asset1 1) + ] + [treasuries !! 1] diff --git a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs new file mode 100644 index 0000000..81709fe --- /dev/null +++ b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs @@ -0,0 +1,172 @@ +{- | +Module : Spec.Sample.Effect.TreasuryWithdrawalEffect +Maintainer : seungheon.ooh@gmail.com +Description: Sample based testing for Treasury Withdrawal Effect + +This module provides smaples for Treasury Withdrawal Effect tests. +-} +module Spec.Sample.Effect.TreasuryWithdrawal ( + inputTreasury, + inputUser, + inputGAT, + inputCollateral, + outputTreasury, + outputUser, + buildReceiversOutputFromDatum, + currSymbol, + users, + treasuries, + buildScriptContext, +) where + +import Plutarch.Api.V1 (mkValidator, validatorHash) +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.Char8 qualified as C +import Data.ByteString.Hash (sha2) + +import Agora.Effect.TreasuryWithdrawal ( + TreasuryWithdrawalDatum (TreasuryWithdrawalDatum), + treasuryWithdrawalValidator, + ) + +-- | A sample Currency Symbol. +currSymbol :: CurrencySymbol +currSymbol = CurrencySymbol "12312099" + +-- | A sample 'PubKeyHash'. +signer :: PubKeyHash +signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c" + +-- | List of users who the effect will pay to. +users :: [Credential] +users = PubKeyCredential . PubKeyHash . toBuiltin . sha2 . C.pack . show <$> ([1 ..] :: [Integer]) + +-- | List of users who the effect will pay to. +treasuries :: [Credential] +treasuries = ScriptCredential . ValidatorHash . toBuiltin . sha2 . C.pack . show <$> ([1 ..] :: [Integer]) + +inputGAT :: TxInInfo +inputGAT = + TxInInfo + (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) + TxOut + { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing + , txOutValue = Value.singleton currSymbol validatorHashTN 1 -- Stake ST + , txOutDatumHash = Just (DatumHash "") + } + +inputTreasury :: Int -> Value -> TxInInfo +inputTreasury indx val = + TxInInfo + (TxOutRef "" 1) + TxOut + { txOutAddress = Address (treasuries !! indx) Nothing + , txOutValue = 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 "") + } + +inputCollateral :: Int -> TxInInfo +inputCollateral indx = + TxInInfo -- Initiator + (TxOutRef "" 1) + TxOut + { txOutAddress = Address (users !! indx) Nothing + , txOutValue = Value.singleton "" "" 2000000 + , 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 +validator = mkValidator $ treasuryWithdrawalValidator currSymbol + +-- | 'TokenName' that represents the hash of the 'Stake' validator. +validatorHashTN :: TokenName +validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh + +buildScriptContext :: [TxInInfo] -> [TxOut] -> ScriptContext +buildScriptContext inputs outputs = + ScriptContext + { scriptContextTxInfo = + TxInfo + { txInfoInputs = inputs + , txInfoOutputs = outputs + , txInfoFee = Value.singleton "" "" 2 + , txInfoMint = Value.singleton currSymbol validatorHashTN (-1) + , txInfoDCert = [] + , txInfoWdrl = [] + , txInfoValidRange = Interval.always + , txInfoSignatories = [signer] + , txInfoData = [] + , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" + } + , scriptContextPurpose = + Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1) + } diff --git a/agora-test/Spec/Util.hs b/agora-test/Spec/Util.hs index 4350e45..f36b3ba 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,30 @@ 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 = validatorSucceedsWith tag eff datum () + +-- | 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 = validatorFailsWith tag eff datum () + -- | Check that an arbitrary script doesn't error when evaluated, given a name. scriptSucceeds :: String -> Script -> TestTree scriptSucceeds name script = testCase name $ do diff --git a/agora.cabal b/agora.cabal index ea06771..c1729d0 100644 --- a/agora.cabal +++ b/agora.cabal @@ -124,6 +124,7 @@ library Agora.AuthorityToken Agora.Effect Agora.Effect.NoOp + Agora.Effect.TreasuryWithdrawal Agora.Governor Agora.MultiSig Agora.Proposal @@ -153,7 +154,9 @@ test-suite agora-test hs-source-dirs: agora-test other-modules: Spec.AuthorityToken + Spec.Effect.TreasuryWithdrawal Spec.Model.MultiSig + Spec.Sample.Effect.TreasuryWithdrawal Spec.Sample.Stake Spec.Stake Spec.Util diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs new file mode 100644 index 0000000..209877f --- /dev/null +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE TemplateHaskell #-} + +{- | +Module : Agora.Effect.TreasuryWithdrawal +Maintainer : seungheon.ooh@gmail.com +Description: An Effect that withdraws treasury deposit + +An Effect that withdraws treasury deposit +-} +module Agora.Effect.TreasuryWithdrawal ( + TreasuryWithdrawalDatum (..), + PTreasuryWithdrawalDatum (..), + treasuryWithdrawalValidator, +) where + +import Control.Applicative (Const) +import GHC.Generics qualified as GHC +import Generics.SOP (Generic, I (I)) + +import Agora.Effect (makeEffect) +import Agora.Utils (findTxOutByTxOutRef, paddValue, passert) +import Plutarch (popaque) +import Plutarch.Api.V1 ( + PCredential (..), + PTuple, + PValidator, + PValue, + ptuple, + ) +import Plutarch.Internal (punsafeCoerce) + +import Plutarch.DataRepr ( + DerivePConstantViaData (..), + PDataFields, + PIsDataReprInstances (..), + ) +import Plutarch.Lift (PUnsafeLiftDecl (..)) +import Plutarch.Monadic qualified as P +import Plutarch.TryFrom (PTryFrom (..)) +import Plutus.V1.Ledger.Credential (Credential) +import Plutus.V1.Ledger.Value (CurrencySymbol, Value) +import PlutusTx qualified + +data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum + { receivers :: [(Credential, Value)] + , treasuries :: [Credential] + } + deriving stock (Show, GHC.Generic) + deriving anyclass (Generic) + +PlutusTx.makeLift ''TreasuryWithdrawalDatum +PlutusTx.unstableMakeIsData ''TreasuryWithdrawalDatum + +newtype PTreasuryWithdrawalDatum (s :: S) + = PTreasuryWithdrawalDatum + ( Term + s + ( PDataRecord + '[ "receivers" ':= PBuiltinList (PAsData (PTuple PCredential PValue)) + , "treasuries" ':= PBuiltinList (PAsData PCredential) + ] + ) + ) + deriving stock (GHC.Generic) + deriving anyclass (Generic, PIsDataRepr) + deriving + (PlutusType, PIsData, PDataFields) + via PIsDataReprInstances PTreasuryWithdrawalDatum + +instance PUnsafeLiftDecl PTreasuryWithdrawalDatum where + type PLifted PTreasuryWithdrawalDatum = TreasuryWithdrawalDatum +deriving via + (DerivePConstantViaData TreasuryWithdrawalDatum PTreasuryWithdrawalDatum) + instance + (PConstant TreasuryWithdrawalDatum) + +instance PTryFrom PData PTreasuryWithdrawalDatum where + type PTryFromExcess PData PTreasuryWithdrawalDatum = Const () + ptryFrom' opq cont = + -- this will need to not use punsafeCoerce... + cont (punsafeCoerce opq, ()) + +{- | Withdraws given list of values to specific target addresses. + It can be evoked by burning GAT. The transaction should have correct + outputs to the users and any left overs should be paid back to the treasury. + + The validator does not accept any Redeemer as all "parameters" are provided + via encoded Datum. + + Note: + It should check... + 1. Transaction outputs should contain all of what Datum specified + 2. Left over assests should be redirected back to Treasury + It can be more flexiable over... + - The number of outputs themselves +-} +treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator +treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ + \_cs (datum' :: Term _ PTreasuryWithdrawalDatum) txOutRef' txInfo' -> P.do + datum <- pletFields @'["receivers", "treasuries"] datum' + txInfo <- pletFields @'["outputs", "inputs"] txInfo' + PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef' # pfromData txInfo' + effInput <- pletFields @'["address", "value"] $ txOut + outputValues <- + plet $ + pmap + # plam + ( \(pfromData -> txOut') -> P.do + txOut <- pletFields @'["address", "value"] $ txOut' + let cred = pfield @"credential" # pfromData txOut.address + pdata $ ptuple # cred # txOut.value + ) + # txInfo.outputs + inputValues <- + plet $ + pmap + # plam + ( \((pfield @"resolved" #) . pfromData -> txOut') -> P.do + txOut <- pletFields @'["address", "value"] $ txOut' + let cred = pfield @"credential" # pfromData txOut.address + pdata $ ptuple # cred # txOut.value + ) + # txInfo.inputs + let ofTreasury = + pfilter + # plam (\((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries) + sumValues = + pfoldr + # plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y) + # pconstant (mempty :: Value) + treasuryInputValuesSum = sumValues #$ ofTreasury # inputValues + treasuryOutputValuesSum = sumValues #$ ofTreasury # outputValues + receiverValuesSum = sumValues # datum.receivers + isPubkey = plam $ \cred -> P.do + pmatch cred $ \case + PPubKeyCredential _ -> pcon PTrue + PScriptCredential _ -> pcon PFalse + + -- Constraints + outputContentMatchesRecivers = + pall # plam (\out -> pelem # out # outputValues) + #$ datum.receivers + excessShouldBePaidToInputs = + pdata (paddValue # receiverValuesSum # treasuryOutputValuesSum) #== pdata treasuryInputValuesSum + shouldNotPayToEffect = + pnot #$ pany + # plam + ( \x -> + effInput.address #== pfield @"address" # pfromData x + ) + # pfromData txInfo.outputs + inputsAreOnlyTreasuriesOrCollateral = + pall + # plam + ( \((pfield @"_0" #) . pfromData -> cred) -> + cred #== pfield @"credential" # effInput.address + #|| pelem # cred # datum.treasuries + #|| isPubkey # pfromData cred + ) + # inputValues + + passert "Transaction should not pay to effects" shouldNotPayToEffect + passert "Transaction output does not match receivers" outputContentMatchesRecivers + passert "Remainders should be returned to the treasury" excessShouldBePaidToInputs + passert "Transaction should only have treasuries specified in the datum as input" inputsAreOnlyTreasuriesOrCollateral + popaque $ pconstant ()