164 lines
4.7 KiB
Haskell
164 lines
4.7 KiB
Haskell
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# OPTIONS_GHC -Wwarn #-}
|
|
|
|
{- |
|
|
Module: Spec.Sample.Treasury
|
|
Description: Sample data for `Spec.Treasury`.
|
|
Maintainer: jack@mlabs.city
|
|
|
|
This module contains sample data, used in the tests written in
|
|
`Spec.Treasury`.
|
|
-}
|
|
module Spec.Sample.Treasury (
|
|
BadTreasuryRedeemer (NukeTheSystem),
|
|
gatCs,
|
|
validCtx,
|
|
treasuryRef,
|
|
gatTn,
|
|
) where
|
|
|
|
import Agora.Effect.NoOp (noOpValidator)
|
|
import Agora.Treasury (TreasuryRedeemer (SpendTreasuryGAT), treasuryValidator)
|
|
import GHC.Generics qualified as GHC
|
|
import Generics.SOP (Generic, I (I))
|
|
import Plutarch.Api.V1 (mkValidator, validatorHash)
|
|
import Plutarch.DataRepr (
|
|
DerivePConstantViaData (..),
|
|
PIsDataReprInstances (..),
|
|
)
|
|
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
|
|
import Plutus.V1.Ledger.Address (Address (..))
|
|
import Plutus.V1.Ledger.Api (BuiltinByteString)
|
|
import Plutus.V1.Ledger.Contexts (
|
|
ScriptContext (..),
|
|
ScriptPurpose (Minting),
|
|
TxInInfo (..),
|
|
TxInfo (..),
|
|
TxOut (..),
|
|
TxOutRef (..),
|
|
)
|
|
import Plutus.V1.Ledger.Credential (Credential (ScriptCredential))
|
|
import Plutus.V1.Ledger.Interval qualified as Interval
|
|
import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash (ValidatorHash))
|
|
import Plutus.V1.Ledger.Value (CurrencySymbol, TokenName (TokenName))
|
|
import Plutus.V1.Ledger.Value qualified as Value
|
|
import PlutusTx qualified
|
|
import Spec.Sample.Shared (signer)
|
|
import Spec.Util (datumPair, toDatumHash)
|
|
|
|
{- | Arbitrary 'CurrencySymbol', representing the 'CurrencySymbol'
|
|
of a valid governance authority token (GAT).
|
|
-}
|
|
gatCs :: CurrencySymbol
|
|
gatCs = "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
|
|
|
|
trValidator :: Validator
|
|
trValidator = mkValidator (treasuryValidator gatCs)
|
|
|
|
{- | A `ScriptContext` that should be compatible with treasury
|
|
transactions.
|
|
-}
|
|
validCtx :: ScriptContext
|
|
validCtx =
|
|
ScriptContext
|
|
{ scriptContextPurpose = Minting gatCs
|
|
, scriptContextTxInfo =
|
|
TxInfo
|
|
{ txInfoInputs =
|
|
[ treasuryIn
|
|
, effectIn
|
|
]
|
|
, txInfoOutputs =
|
|
[ treasuryOut
|
|
]
|
|
, -- Ensure sufficient ADA for transaction costs.
|
|
txInfoFee = Value.singleton "" "" 2 -- 2 ADA.
|
|
, -- Burn the GAT.
|
|
txInfoMint = Value.singleton gatCs gatTn (-1)
|
|
, txInfoDCert = []
|
|
, txInfoWdrl = []
|
|
, txInfoValidRange = Interval.always
|
|
, txInfoSignatories = [signer]
|
|
, txInfoData =
|
|
[ datumPair treasuryIn
|
|
, datumPair treasuryOut
|
|
, datumPair effectIn
|
|
]
|
|
, txInfoId =
|
|
"73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
|
|
}
|
|
}
|
|
where
|
|
treasuryIn =
|
|
TxInInfo
|
|
{ txInInfoOutRef = treasuryRef
|
|
, txInInfoResolved = treasuryOut
|
|
}
|
|
effectIn =
|
|
TxInInfo
|
|
{ txInInfoOutRef = effectRef
|
|
, txInInfoResolved =
|
|
TxOut
|
|
{ txOutAddress =
|
|
Address (ScriptCredential $ validatorHash mockEffect) Nothing
|
|
, txOutValue = Value.singleton gatCs gatTn 1
|
|
, txOutDatumHash = Just (toDatumHash ())
|
|
}
|
|
}
|
|
treasuryOut :: TxOut =
|
|
TxOut
|
|
{ txOutAddress =
|
|
Address
|
|
(ScriptCredential $ validatorHash trValidator)
|
|
Nothing
|
|
, txOutValue = Value.singleton "" "" 0
|
|
, txOutDatumHash = Just (toDatumHash ())
|
|
}
|
|
|
|
treasuryRef :: TxOutRef
|
|
treasuryRef = TxOutRef "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049" 1
|
|
|
|
effectRef :: TxOutRef
|
|
effectRef = TxOutRef "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3" 0
|
|
|
|
mockEffect :: Validator
|
|
mockEffect = mkValidator $ noOpValidator gatCs
|
|
|
|
addressBs :: BuiltinByteString
|
|
(ValidatorHash addressBs) = validatorHash mockEffect
|
|
|
|
gatTn :: TokenName
|
|
gatTn = TokenName addressBs
|
|
|
|
------------------------------------------------------------------
|
|
|
|
-- Invalid treasury redeemer.
|
|
|
|
data BadTreasuryRedeemer = NukeTheSystem
|
|
deriving stock (Eq, Show, GHC.Generic)
|
|
|
|
PlutusTx.makeIsDataIndexed
|
|
''BadTreasuryRedeemer
|
|
[ ('NukeTheSystem, 0)
|
|
]
|
|
|
|
data PBadTreasuryRedeemer (s :: S)
|
|
= PNukeTheSystem (Term s (PDataRecord '[]))
|
|
deriving stock (GHC.Generic)
|
|
deriving anyclass (Generic)
|
|
deriving anyclass (PIsDataRepr)
|
|
deriving
|
|
(PlutusType, PIsData)
|
|
via PIsDataReprInstances PBadTreasuryRedeemer
|
|
|
|
instance PUnsafeLiftDecl PBadTreasuryRedeemer where
|
|
type PLifted PBadTreasuryRedeemer = BadTreasuryRedeemer
|
|
deriving via
|
|
( DerivePConstantViaData
|
|
BadTreasuryRedeemer
|
|
PBadTreasuryRedeemer
|
|
)
|
|
instance
|
|
(PConstantDecl BadTreasuryRedeemer)
|
|
|
|
------------------------------------------------------------------
|