Merge pull request #56 from Liqwid-Labs/seungheonoh/treasurywithdrawaleffect

Treasury Withdrawal Effect

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

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]

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)
+    }

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

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

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 ()