Merge branch 'main' into connor/mutate-governor
This commit is contained in:
方泓睿
GitHub
commit
4bffc1005d
25 changed files with 1225 additions and 41 deletions
33
agora-bench/Bench.hs
Normal file
33
agora-bench/Bench.hs
Normal file
|
|
@ -0,0 +1,33 @@
|
|||
module Bench (Benchmark (..), benchmarkSize) where
|
||||
|
||||
import Codec.Serialise (serialise)
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.ByteString.Short qualified as SBS
|
||||
import Data.Set (Set)
|
||||
import Data.Set qualified as Set
|
||||
import Data.Text (Text)
|
||||
import Plutus.V1.Ledger.Scripts qualified as Plutus
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Represents the benchmark of a plutus script.
|
||||
data Benchmark = Benchmark
|
||||
{ name :: Text
|
||||
-- ^ Human readable name describing script.
|
||||
, size :: Int
|
||||
-- ^ The on-chain size of a script.
|
||||
}
|
||||
deriving stock (Show, Eq, Ord)
|
||||
|
||||
-- | Create a benchmark containing only the size of the script.
|
||||
benchmarkSize :: Text -> Plutus.Script -> Set Benchmark
|
||||
benchmarkSize name script =
|
||||
Set.singleton $
|
||||
Benchmark
|
||||
{ name = name
|
||||
, size = scriptSize script
|
||||
}
|
||||
|
||||
-- | Compute the size of a script on-chain.
|
||||
scriptSize :: Plutus.Script -> Int
|
||||
scriptSize = SBS.length . SBS.toShort . LBS.toStrict . serialise
|
||||
|
|
@ -1,14 +1,42 @@
|
|||
module Main (main) where
|
||||
|
||||
import Agora.AuthorityToken (authorityTokenPolicy)
|
||||
import Agora.Effect.TreasuryWithdrawal (treasuryWithdrawalValidator)
|
||||
import Agora.Governor (Governor (..))
|
||||
import Agora.Governor.Scripts (governorPolicy, governorValidator)
|
||||
import Agora.Proposal.Scripts (proposalPolicy, proposalValidator)
|
||||
import Agora.Stake.Scripts (stakePolicy, stakeValidator)
|
||||
import Agora.Treasury (treasuryValidator)
|
||||
import Bench
|
||||
import Data.Foldable (for_)
|
||||
import Plutus.V1.Ledger.Api (CurrencySymbol)
|
||||
import Sample.Shared
|
||||
import Prelude
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
main :: IO ()
|
||||
main = pure ()
|
||||
main = do
|
||||
let benchmarks =
|
||||
mconcat
|
||||
[ -- GATs
|
||||
benchmarkSize "authorityTokenPolicy" $ compile $ authorityTokenPolicy authorityToken
|
||||
, -- Governor
|
||||
benchmarkSize "governorValidator" $ compile $ governorValidator governor
|
||||
, benchmarkSize "governorPolicy" $ compile $ governorPolicy governor
|
||||
, -- Stake
|
||||
benchmarkSize "stakeValidator" $ compile $ stakeValidator stake
|
||||
, benchmarkSize "stakePolicy" $ compile $ stakePolicy governor.gtClassRef
|
||||
, -- Proposal
|
||||
benchmarkSize "proposalValidator" $ compile $ proposalValidator proposal
|
||||
, benchmarkSize "proposalPolicy" $ compile $ proposalPolicy govAssetClass
|
||||
, -- Treasury
|
||||
benchmarkSize "treasuryValidator" $ compile $ treasuryValidator gatCS
|
||||
, -- Effect validators
|
||||
benchmarkSize "treasuryWithdrawalValidator" $ compile $ treasuryWithdrawalValidator gatCS
|
||||
]
|
||||
|
||||
for_ benchmarks print
|
||||
|
||||
gatCS :: CurrencySymbol
|
||||
gatCS = "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049" -- arbitrary CS
|
||||
|
|
|
|||
|
|
@ -73,12 +73,14 @@ import Sample.Shared (
|
|||
gstUTXORef,
|
||||
minAda,
|
||||
proposalPolicySymbol,
|
||||
proposalTimingConfig,
|
||||
proposalValidatorAddress,
|
||||
signer,
|
||||
signer2,
|
||||
stake,
|
||||
stakeAddress,
|
||||
stakeAssetClass,
|
||||
tmpProposalStartingTime,
|
||||
)
|
||||
import Test.Util (datumPair, toDatumHash)
|
||||
|
||||
|
|
@ -234,6 +236,8 @@ createProposal =
|
|||
, cosigners = [signer]
|
||||
, thresholds = defaultProposalThresholds
|
||||
, votes = emptyVotesFor effects
|
||||
, timingConfig = proposalTimingConfig
|
||||
, startingTime = tmpProposalStartingTime
|
||||
}
|
||||
)
|
||||
proposalOutput :: TxOut
|
||||
|
|
@ -408,6 +412,8 @@ mintGATs =
|
|||
, cosigners = [signer, signer2]
|
||||
, thresholds = defaultProposalThresholds
|
||||
, votes = proposalVotes
|
||||
, timingConfig = proposalTimingConfig
|
||||
, startingTime = tmpProposalStartingTime
|
||||
}
|
||||
proposalInputDatum :: Datum
|
||||
proposalInputDatum = Datum $ toBuiltinData proposalInputDatum'
|
||||
|
|
|
|||
|
|
@ -11,6 +11,8 @@ module Sample.Proposal (
|
|||
cosignProposal,
|
||||
proposalRef,
|
||||
stakeRef,
|
||||
voteOnProposal,
|
||||
VotingParameters (..),
|
||||
) where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -21,6 +23,7 @@ import Plutus.V1.Ledger.Api (
|
|||
Address (Address),
|
||||
Credential (ScriptCredential),
|
||||
Datum (Datum),
|
||||
POSIXTimeRange,
|
||||
PubKeyHash,
|
||||
ScriptContext (..),
|
||||
ScriptPurpose (..),
|
||||
|
|
@ -43,14 +46,16 @@ import Agora.Proposal (
|
|||
ProposalDatum (..),
|
||||
ProposalId (..),
|
||||
ProposalStatus (..),
|
||||
ProposalVotes (..),
|
||||
ResultTag (..),
|
||||
emptyVotesFor,
|
||||
)
|
||||
import Agora.Stake (Stake (..), StakeDatum (StakeDatum))
|
||||
import Agora.Proposal.Time (ProposalTimingConfig (..))
|
||||
import Agora.Stake (ProposalLock (ProposalLock), Stake (..), StakeDatum (..))
|
||||
import Plutarch.SafeMoney (Tagged (Tagged), untag)
|
||||
import PlutusTx.AssocMap qualified as AssocMap
|
||||
import Sample.Shared
|
||||
import Test.Util (datumPair, toDatumHash)
|
||||
import Test.Util (closedBoundedInterval, datumPair, toDatumHash, updateMap)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -74,6 +79,8 @@ proposalCreation =
|
|||
, cosigners = [signer]
|
||||
, thresholds = defaultProposalThresholds
|
||||
, votes = emptyVotesFor effects
|
||||
, timingConfig = proposalTimingConfig
|
||||
, startingTime = tmpProposalStartingTime
|
||||
}
|
||||
)
|
||||
|
||||
|
|
@ -167,11 +174,18 @@ cosignProposal newSigners =
|
|||
, cosigners = [signer]
|
||||
, thresholds = defaultProposalThresholds
|
||||
, votes = emptyVotesFor effects
|
||||
, timingConfig = proposalTimingConfig
|
||||
, startingTime = tmpProposalStartingTime
|
||||
}
|
||||
stakeDatum :: StakeDatum
|
||||
stakeDatum = StakeDatum (Tagged 50_000_000) signer2 []
|
||||
proposalAfter :: ProposalDatum
|
||||
proposalAfter = proposalBefore {cosigners = newSigners <> proposalBefore.cosigners}
|
||||
validTimeRange :: POSIXTimeRange
|
||||
validTimeRange =
|
||||
closedBoundedInterval
|
||||
10
|
||||
(proposalTimingConfig.draftTime - 10)
|
||||
in TxInfo
|
||||
{ txInfoInputs =
|
||||
[ TxInInfo
|
||||
|
|
@ -223,7 +237,7 @@ cosignProposal newSigners =
|
|||
, txInfoMint = st
|
||||
, txInfoDCert = []
|
||||
, txInfoWdrl = []
|
||||
, txInfoValidRange = Interval.always
|
||||
, txInfoValidRange = validTimeRange
|
||||
, txInfoSignatories = newSigners
|
||||
, txInfoData =
|
||||
[ datumPair . Datum $ toBuiltinData proposalBefore
|
||||
|
|
@ -232,3 +246,157 @@ cosignProposal newSigners =
|
|||
]
|
||||
, txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
|
||||
}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Parameters for creating a voting transaction.
|
||||
data VotingParameters = VotingParameters
|
||||
{ voteFor :: ResultTag
|
||||
-- ^ The outcome the transaction is voting for.
|
||||
, voteCount :: Integer
|
||||
-- ^ The count of votes.
|
||||
}
|
||||
|
||||
-- | Create a valid transaction that votes on a propsal, given the parameters.
|
||||
voteOnProposal :: VotingParameters -> TxInfo
|
||||
voteOnProposal params =
|
||||
let pst = Value.singleton proposalPolicySymbol "" 1
|
||||
sst = Value.assetClassValue stakeAssetClass 1
|
||||
|
||||
---
|
||||
|
||||
stakeOwner = signer
|
||||
|
||||
---
|
||||
|
||||
effects =
|
||||
AssocMap.fromList
|
||||
[ (ResultTag 0, AssocMap.empty)
|
||||
, (ResultTag 1, AssocMap.empty)
|
||||
]
|
||||
|
||||
---
|
||||
|
||||
initialVotes :: AssocMap.Map ResultTag Integer
|
||||
initialVotes =
|
||||
AssocMap.fromList
|
||||
[ (ResultTag 0, 42)
|
||||
, (ResultTag 1, 4242)
|
||||
]
|
||||
|
||||
---
|
||||
|
||||
proposalInputDatum' :: ProposalDatum
|
||||
proposalInputDatum' =
|
||||
ProposalDatum
|
||||
{ proposalId = ProposalId 42
|
||||
, effects = effects
|
||||
, status = VotingReady
|
||||
, cosigners = [stakeOwner]
|
||||
, thresholds = defaultProposalThresholds
|
||||
, votes = ProposalVotes initialVotes
|
||||
, timingConfig = proposalTimingConfig
|
||||
, startingTime = tmpProposalStartingTime
|
||||
}
|
||||
proposalInputDatum :: Datum
|
||||
proposalInputDatum = Datum $ toBuiltinData proposalInputDatum'
|
||||
proposalInput :: TxOut
|
||||
proposalInput =
|
||||
TxOut
|
||||
{ txOutAddress = proposalValidatorAddress
|
||||
, txOutValue = pst
|
||||
, txOutDatumHash = Just $ toDatumHash proposalInputDatum
|
||||
}
|
||||
|
||||
---
|
||||
|
||||
existingLocks :: [ProposalLock]
|
||||
existingLocks =
|
||||
[ ProposalLock (ResultTag 0) (ProposalId 0)
|
||||
, ProposalLock (ResultTag 2) (ProposalId 1)
|
||||
]
|
||||
|
||||
---
|
||||
|
||||
stakeInputDatum' :: StakeDatum
|
||||
stakeInputDatum' =
|
||||
StakeDatum
|
||||
{ stakedAmount = Tagged params.voteCount
|
||||
, owner = stakeOwner
|
||||
, lockedBy = existingLocks
|
||||
}
|
||||
stakeInputDatum :: Datum
|
||||
stakeInputDatum = Datum $ toBuiltinData stakeInputDatum'
|
||||
stakeInput :: TxOut
|
||||
stakeInput =
|
||||
TxOut
|
||||
{ txOutAddress = stakeAddress
|
||||
, txOutValue =
|
||||
mconcat
|
||||
[ sst
|
||||
, Value.assetClassValue (untag stake.gtClassRef) params.voteCount
|
||||
, minAda
|
||||
]
|
||||
, txOutDatumHash = Just $ toDatumHash stakeInputDatum
|
||||
}
|
||||
|
||||
---
|
||||
|
||||
updatedVotes :: AssocMap.Map ResultTag Integer
|
||||
updatedVotes = updateMap (Just . (+ params.voteCount)) params.voteFor initialVotes
|
||||
|
||||
---
|
||||
|
||||
proposalOutputDatum' :: ProposalDatum
|
||||
proposalOutputDatum' =
|
||||
proposalInputDatum'
|
||||
{ votes = ProposalVotes updatedVotes
|
||||
}
|
||||
proposalOutputDatum :: Datum
|
||||
proposalOutputDatum = Datum $ toBuiltinData proposalOutputDatum'
|
||||
proposalOutput :: TxOut
|
||||
proposalOutput =
|
||||
proposalInput
|
||||
{ txOutDatumHash = Just $ toDatumHash proposalOutputDatum
|
||||
}
|
||||
|
||||
---
|
||||
|
||||
-- Off-chain code should do exactly like this: prepend new lock to the list.
|
||||
updatedLocks :: [ProposalLock]
|
||||
updatedLocks = ProposalLock params.voteFor proposalInputDatum'.proposalId : existingLocks
|
||||
|
||||
---
|
||||
|
||||
stakeOutputDatum' :: StakeDatum
|
||||
stakeOutputDatum' =
|
||||
stakeInputDatum'
|
||||
{ lockedBy = updatedLocks
|
||||
}
|
||||
stakeOutputDatum :: Datum
|
||||
stakeOutputDatum = Datum $ toBuiltinData stakeOutputDatum'
|
||||
stakeOutput :: TxOut
|
||||
stakeOutput =
|
||||
stakeInput
|
||||
{ txOutDatumHash = Just $ toDatumHash stakeOutputDatum
|
||||
}
|
||||
|
||||
---
|
||||
|
||||
validTimeRange =
|
||||
closedBoundedInterval (proposalTimingConfig.draftTime + 1) (proposalTimingConfig.votingTime - 1)
|
||||
in TxInfo
|
||||
{ txInfoInputs =
|
||||
[ TxInInfo proposalRef proposalInput
|
||||
, TxInInfo stakeRef stakeInput
|
||||
]
|
||||
, txInfoOutputs = [proposalOutput, stakeOutput]
|
||||
, txInfoFee = Value.singleton "" "" 2
|
||||
, txInfoMint = mempty
|
||||
, txInfoDCert = []
|
||||
, txInfoWdrl = []
|
||||
, txInfoValidRange = validTimeRange
|
||||
, txInfoSignatories = [stakeOwner]
|
||||
, txInfoData = datumPair <$> [proposalInputDatum, proposalOutputDatum, stakeInputDatum, stakeOutputDatum]
|
||||
, txInfoId = "827598fb2d69a896bbd9e645bb14c307df907f422b39eecbe4d6329bc30b428c"
|
||||
}
|
||||
|
|
|
|||
|
|
@ -36,6 +36,8 @@ module Sample.Shared (
|
|||
proposalPolicySymbol,
|
||||
proposalValidatorHash,
|
||||
proposalValidatorAddress,
|
||||
proposalTimingConfig,
|
||||
tmpProposalStartingTime,
|
||||
|
||||
-- ** Authority
|
||||
authorityToken,
|
||||
|
|
@ -74,6 +76,10 @@ import Agora.Proposal (
|
|||
Proposal (..),
|
||||
ProposalThresholds (..),
|
||||
)
|
||||
import Agora.Proposal.Time (
|
||||
ProposalStartingTime (..),
|
||||
ProposalTimingConfig (..),
|
||||
)
|
||||
import Agora.Stake (Stake (..))
|
||||
import Agora.Treasury (treasuryValidator)
|
||||
import Agora.Utils (validatorHashToTokenName)
|
||||
|
|
@ -184,6 +190,22 @@ authorityToken = authorityTokenFromGovernor governor
|
|||
authorityTokenSymbol :: CurrencySymbol
|
||||
authorityTokenSymbol = authorityTokenSymbolFromGovernor governor
|
||||
|
||||
proposalTimingConfig :: ProposalTimingConfig
|
||||
proposalTimingConfig =
|
||||
ProposalTimingConfig
|
||||
{ draftTime = 50
|
||||
, votingTime = 1000
|
||||
, lockingTime = 2000
|
||||
, executingTime = 3000
|
||||
}
|
||||
|
||||
{- | Hard coded starting time of every propoal.
|
||||
This will be calculated by the governor in the future.
|
||||
FIXME: Remove this.
|
||||
-}
|
||||
tmpProposalStartingTime :: ProposalStartingTime
|
||||
tmpProposalStartingTime = ProposalStartingTime 0
|
||||
|
||||
------------------------------------------------------------------
|
||||
|
||||
treasuryOut :: TxOut
|
||||
|
|
|
|||
45
agora-scripts/Options.hs
Normal file
45
agora-scripts/Options.hs
Normal file
|
|
@ -0,0 +1,45 @@
|
|||
{- |
|
||||
Module : Options
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Command line options for 'agora-scripts'.
|
||||
|
||||
Command line options for 'agora-scripts'.
|
||||
-}
|
||||
module Options (Options (..), parseOptions) where
|
||||
|
||||
import Options.Applicative ((<**>))
|
||||
import Options.Applicative qualified as Opt
|
||||
|
||||
data Options = Options
|
||||
{ config :: FilePath
|
||||
, output :: FilePath
|
||||
}
|
||||
deriving stock (Show, Eq)
|
||||
|
||||
opt :: Opt.Parser Options
|
||||
opt =
|
||||
Options
|
||||
<$> Opt.strOption
|
||||
( Opt.long "config"
|
||||
<> Opt.short 'c'
|
||||
<> Opt.metavar "CONFIG_PATH"
|
||||
<> Opt.value "./agora-scripts/agora-params.json"
|
||||
<> Opt.help "The path where the script configuration is."
|
||||
)
|
||||
<*> Opt.strOption
|
||||
( Opt.long "output"
|
||||
<> Opt.short 'o'
|
||||
<> Opt.metavar "OUTPUT_PATH"
|
||||
<> Opt.value "./agora-scripts/agora-scripts.json"
|
||||
<> Opt.help "Output where generated scripts will be."
|
||||
)
|
||||
|
||||
parseOptions :: IO Options
|
||||
parseOptions = Opt.execParser p
|
||||
where
|
||||
p =
|
||||
Opt.info
|
||||
(opt <**> Opt.helper)
|
||||
( Opt.fullDesc
|
||||
<> Opt.progDesc "Generate Agora scripts for off-chain use."
|
||||
)
|
||||
113
agora-scripts/Scripts.hs
Normal file
113
agora-scripts/Scripts.hs
Normal file
|
|
@ -0,0 +1,113 @@
|
|||
{- |
|
||||
Module : Scripts
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Export scripts given configuration.
|
||||
|
||||
Export scripts given configuration.
|
||||
-}
|
||||
module Main (main) where
|
||||
|
||||
import Agora.AuthorityToken (AuthorityToken, authorityTokenPolicy)
|
||||
import Agora.Governor (Governor (Governor))
|
||||
import Agora.Governor qualified as Governor
|
||||
import Agora.Governor.Scripts (
|
||||
authorityTokenFromGovernor,
|
||||
authorityTokenSymbolFromGovernor,
|
||||
governorPolicy,
|
||||
governorValidator,
|
||||
proposalFromGovernor,
|
||||
stakeFromGovernor,
|
||||
)
|
||||
import Agora.Proposal (Proposal)
|
||||
import Agora.Proposal.Scripts (proposalPolicy, proposalValidator)
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.ScriptInfo (PolicyInfo, ValidatorInfo, mkPolicyInfo, mkValidatorInfo)
|
||||
import Agora.Stake (Stake)
|
||||
import Agora.Stake.Scripts (stakePolicy, stakeValidator)
|
||||
import Agora.Treasury (treasuryValidator)
|
||||
import Control.Monad ((>=>))
|
||||
import Data.Aeson qualified as Aeson
|
||||
import GHC.Generics qualified as GHC
|
||||
import Options (Options (..), parseOptions)
|
||||
import Plutarch.Api.V1 (mintingPolicySymbol, mkMintingPolicy)
|
||||
import Plutarch.SafeMoney (Tagged)
|
||||
import Plutus.V1.Ledger.Api (TxOutRef)
|
||||
import Plutus.V1.Ledger.Value (AssetClass, CurrencySymbol)
|
||||
import Plutus.V1.Ledger.Value qualified as Value
|
||||
import System.Exit (exitFailure)
|
||||
import Text.Printf (printf)
|
||||
|
||||
-- | Params required for creating script export.
|
||||
data ScriptParams = ScriptParams
|
||||
{ governorInitialSpend :: TxOutRef
|
||||
, gtClassRef :: Tagged GTTag AssetClass
|
||||
, maximumCosigners :: Integer
|
||||
}
|
||||
deriving anyclass (Aeson.ToJSON, Aeson.FromJSON)
|
||||
deriving stock (Show, Eq, GHC.Generic)
|
||||
|
||||
-- | Scripts that get exported.
|
||||
data AgoraScripts = AgoraScripts
|
||||
{ governorPolicyInfo :: PolicyInfo
|
||||
, governorValidatorInfo :: ValidatorInfo
|
||||
, stakePolicyInfo :: PolicyInfo
|
||||
, stakeValidatorInfo :: ValidatorInfo
|
||||
, proposalPolicyInfo :: PolicyInfo
|
||||
, proposalValidatorInfo :: ValidatorInfo
|
||||
, treasuryValidatorInfo :: ValidatorInfo
|
||||
, authorityTokenPolicyInfo :: PolicyInfo
|
||||
}
|
||||
deriving anyclass (Aeson.ToJSON, Aeson.FromJSON)
|
||||
deriving stock (Show, Eq, GHC.Generic)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
options <- parseOptions
|
||||
|
||||
params <-
|
||||
Aeson.eitherDecodeFileStrict @ScriptParams options.config
|
||||
>>= either (putStrLn >=> const exitFailure) pure
|
||||
|
||||
let scripts = agoraScripts params
|
||||
|
||||
Aeson.encodeFile options.output scripts
|
||||
|
||||
printf "Done! Wrote to %s\n" options.output
|
||||
|
||||
-- | Create scripts from params.
|
||||
agoraScripts :: ScriptParams -> AgoraScripts
|
||||
agoraScripts params =
|
||||
AgoraScripts
|
||||
{ governorPolicyInfo = mkPolicyInfo (governorPolicy governor)
|
||||
, governorValidatorInfo = mkValidatorInfo (governorValidator governor)
|
||||
, stakePolicyInfo = mkPolicyInfo (stakePolicy params.gtClassRef)
|
||||
, stakeValidatorInfo = mkValidatorInfo (stakeValidator stake)
|
||||
, proposalPolicyInfo = mkPolicyInfo (proposalPolicy governorSTAssetClass)
|
||||
, proposalValidatorInfo = mkValidatorInfo (proposalValidator proposal)
|
||||
, treasuryValidatorInfo = mkValidatorInfo (treasuryValidator authorityTokenSymbol)
|
||||
, authorityTokenPolicyInfo = mkPolicyInfo (authorityTokenPolicy authorityToken)
|
||||
}
|
||||
where
|
||||
governor :: Governor
|
||||
governor =
|
||||
Governor
|
||||
{ Governor.gstOutRef = params.governorInitialSpend
|
||||
, Governor.gtClassRef = params.gtClassRef
|
||||
, Governor.maximumCosigners = params.maximumCosigners
|
||||
}
|
||||
|
||||
authorityToken :: AuthorityToken
|
||||
authorityToken = authorityTokenFromGovernor governor
|
||||
|
||||
authorityTokenSymbol :: CurrencySymbol
|
||||
authorityTokenSymbol = authorityTokenSymbolFromGovernor governor
|
||||
|
||||
governorSTAssetClass :: AssetClass
|
||||
governorSTAssetClass =
|
||||
Value.assetClass (mintingPolicySymbol $ mkMintingPolicy $ governorPolicy governor) ""
|
||||
|
||||
proposal :: Proposal
|
||||
proposal = proposalFromGovernor governor
|
||||
|
||||
stake :: Stake
|
||||
stake = stakeFromGovernor governor
|
||||
11
agora-scripts/agora-params.json
Normal file
11
agora-scripts/agora-params.json
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
{
|
||||
"governorInitialSpend": {
|
||||
"txOutRefId": "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be",
|
||||
"txOutRefIdx": 0
|
||||
},
|
||||
"gtClassRef": [
|
||||
"",
|
||||
""
|
||||
],
|
||||
"maximumCosigners": 5
|
||||
}
|
||||
1
agora-scripts/agora-scripts.json
Normal file
1
agora-scripts/agora-scripts.json
Normal file
File diff suppressed because one or more lines are too long
|
|
@ -13,10 +13,11 @@ module Spec.Proposal (tests) where
|
|||
|
||||
import Agora.Proposal (
|
||||
Proposal (..),
|
||||
ProposalDatum (ProposalDatum),
|
||||
ProposalDatum (..),
|
||||
ProposalId (ProposalId),
|
||||
ProposalRedeemer (Cosign),
|
||||
ProposalStatus (Draft),
|
||||
ProposalRedeemer (Cosign, Vote),
|
||||
ProposalStatus (Draft, VotingReady),
|
||||
ProposalVotes (ProposalVotes),
|
||||
ResultTag (ResultTag),
|
||||
cosigners,
|
||||
effects,
|
||||
|
|
@ -30,7 +31,11 @@ import Agora.Proposal.Scripts (
|
|||
proposalPolicy,
|
||||
proposalValidator,
|
||||
)
|
||||
import Agora.Stake (StakeDatum (StakeDatum), StakeRedeemer (WitnessStake))
|
||||
import Agora.Stake (
|
||||
ProposalLock (ProposalLock),
|
||||
StakeDatum (StakeDatum),
|
||||
StakeRedeemer (PermitVote, WitnessStake),
|
||||
)
|
||||
import Agora.Stake.Scripts (stakeValidator)
|
||||
import Plutarch.SafeMoney (Tagged (Tagged))
|
||||
import Plutus.V1.Ledger.Api (ScriptContext (..), ScriptPurpose (..))
|
||||
|
|
@ -77,6 +82,8 @@ tests =
|
|||
[ (ResultTag 0, AssocMap.empty)
|
||||
, (ResultTag 1, AssocMap.empty)
|
||||
]
|
||||
, timingConfig = Shared.proposalTimingConfig
|
||||
, startingTime = Shared.tmpProposalStartingTime
|
||||
}
|
||||
)
|
||||
(Cosign [signer2])
|
||||
|
|
@ -88,5 +95,62 @@ tests =
|
|||
WitnessStake
|
||||
(ScriptContext (Proposal.cosignProposal [signer2]) (Spending Proposal.stakeRef))
|
||||
]
|
||||
, testGroup
|
||||
"voting"
|
||||
[ validatorSucceedsWith
|
||||
"proposal"
|
||||
(proposalValidator Shared.proposal)
|
||||
( ProposalDatum
|
||||
{ proposalId = ProposalId 42
|
||||
, effects =
|
||||
AssocMap.fromList
|
||||
[ (ResultTag 0, AssocMap.empty)
|
||||
, (ResultTag 1, AssocMap.empty)
|
||||
]
|
||||
, status = VotingReady
|
||||
, cosigners = [signer]
|
||||
, thresholds = Shared.defaultProposalThresholds
|
||||
, votes =
|
||||
ProposalVotes
|
||||
( AssocMap.fromList
|
||||
[ (ResultTag 0, 42)
|
||||
, (ResultTag 1, 4242)
|
||||
]
|
||||
)
|
||||
, timingConfig = Shared.proposalTimingConfig
|
||||
, startingTime = Shared.tmpProposalStartingTime
|
||||
}
|
||||
)
|
||||
(Vote (ResultTag 0))
|
||||
( ScriptContext
|
||||
( Proposal.voteOnProposal
|
||||
Proposal.VotingParameters
|
||||
{ Proposal.voteFor = ResultTag 0
|
||||
, Proposal.voteCount = 27
|
||||
}
|
||||
)
|
||||
(Spending Proposal.proposalRef)
|
||||
)
|
||||
, validatorSucceedsWith
|
||||
"stake"
|
||||
(stakeValidator Shared.stake)
|
||||
( StakeDatum
|
||||
(Tagged 27)
|
||||
signer
|
||||
[ ProposalLock (ResultTag 0) (ProposalId 0)
|
||||
, ProposalLock (ResultTag 2) (ProposalId 1)
|
||||
]
|
||||
)
|
||||
(PermitVote $ ProposalLock (ResultTag 0) (ProposalId 42))
|
||||
( ScriptContext
|
||||
( Proposal.voteOnProposal
|
||||
Proposal.VotingParameters
|
||||
{ Proposal.voteFor = ResultTag 0
|
||||
, Proposal.voteCount = 27
|
||||
}
|
||||
)
|
||||
(Spending Proposal.stakeRef)
|
||||
)
|
||||
]
|
||||
]
|
||||
]
|
||||
|
|
|
|||
|
|
@ -9,17 +9,33 @@ module Spec.Utils (tests) where
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.Utils (phalve, pisUniq, pmergeBy, pmsort, pnubSort)
|
||||
import Agora.Utils (phalve, pisUniq, pmergeBy, pmsort, pnubSort, pupdate)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Data.List (nub, sort)
|
||||
import Data.Set as S
|
||||
import Data.Map qualified as M
|
||||
import Data.Set qualified as S
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Control.Monad.Cont (cont, runCont)
|
||||
import Test.Tasty (TestTree)
|
||||
import Test.Tasty.QuickCheck (testProperty)
|
||||
import Test.Tasty.QuickCheck (
|
||||
Arbitrary (arbitrary),
|
||||
Property,
|
||||
Testable (property),
|
||||
elements,
|
||||
forAll,
|
||||
suchThat,
|
||||
testProperty,
|
||||
(.&&.),
|
||||
)
|
||||
import Test.Util (updateMap)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import PlutusTx.AssocMap qualified as AssocMap
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -30,6 +46,7 @@ tests =
|
|||
, testProperty "'phalve' splits a list in half as expected" prop_halveCorrect
|
||||
, testProperty "'pnubSort' sorts a list and remove duplicate elements" prop_nubSortProperly
|
||||
, testProperty "'pisUniq' can tell whether all elements in a list are unique" prop_uniqueList
|
||||
, testProperty "'pupdate' updates assoc maps as 'updateMap' does" prop_updateAssocMapParity
|
||||
]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -142,3 +159,68 @@ prop_uniqueList l = isUnique == expected
|
|||
--
|
||||
|
||||
isUnique = plift $ pisUniq # pconstant l
|
||||
|
||||
{- | Test the parity between 'updateMap' and 'pupdate',
|
||||
also ensure they both work correctly.
|
||||
-}
|
||||
prop_updateAssocMapParity :: Property
|
||||
prop_updateAssocMapParity =
|
||||
runCont
|
||||
( do
|
||||
-- Generate a bunch unique keys.
|
||||
keys <-
|
||||
cont $
|
||||
forAll $
|
||||
arbitrary @(S.Set Integer) `suchThat` (not . S.null)
|
||||
|
||||
-- Generate key-value pairs.
|
||||
kvPairs <- cont $ forAll $ mapM (\k -> (k,) <$> (arbitrary @Integer)) $ S.toList keys
|
||||
|
||||
let initialMap = AssocMap.fromList kvPairs
|
||||
|
||||
pinitialMap :: Term _ _
|
||||
pinitialMap = phoistAcyclic $ pconstant initialMap
|
||||
|
||||
referenceMap = M.fromList kvPairs
|
||||
|
||||
let pupdatedValue :: Maybe Integer -> Term _ (PMaybe PInteger)
|
||||
pupdatedValue updatedValue = phoistAcyclic $ case updatedValue of
|
||||
Nothing -> pcon PNothing
|
||||
Just v -> pcon $ PJust $ pconstant v
|
||||
|
||||
-- Given the key and the updated value, test the parity
|
||||
parity key updatedValue =
|
||||
let native = updateMap (const updatedValue) key initialMap
|
||||
|
||||
plutarch :: AssocMap.Map Integer Integer
|
||||
plutarch =
|
||||
plift $
|
||||
pupdate
|
||||
# plam (\_ -> pupdatedValue updatedValue)
|
||||
# pconstant key
|
||||
# pinitialMap
|
||||
|
||||
expected =
|
||||
AssocMap.fromList $
|
||||
M.toList $
|
||||
M.update (const updatedValue) key referenceMap
|
||||
in expected == native
|
||||
&& expected == plutarch
|
||||
|
||||
-- Select a key, generate a maybe value.
|
||||
-- The value at the key should be set to the new value or removed.
|
||||
(targetKey, _) <- cont $ forAll $ elements kvPairs
|
||||
updatedValue <- cont $ forAll $ arbitrary @(Maybe Integer)
|
||||
|
||||
-- Now what if the key doesn't exist in our map?
|
||||
nonexistentKey <-
|
||||
cont $
|
||||
forAll $
|
||||
arbitrary @Integer `suchThat` (\k -> not $ S.member k keys)
|
||||
|
||||
pure
|
||||
( property (parity targetKey updatedValue)
|
||||
.&&. property (parity nonexistentKey updatedValue)
|
||||
)
|
||||
)
|
||||
id
|
||||
|
|
|
|||
|
|
@ -38,6 +38,8 @@ module Test.Util (
|
|||
toDatum,
|
||||
toDatumHash,
|
||||
datumPair,
|
||||
closedBoundedInterval,
|
||||
updateMap,
|
||||
) where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -62,9 +64,12 @@ import Plutarch.Crypto (pblake2b_256)
|
|||
import Plutarch.Evaluate (evalScript)
|
||||
import Plutarch.Lift (PUnsafeLiftDecl (PLifted))
|
||||
import Plutus.V1.Ledger.Contexts (ScriptContext)
|
||||
import Plutus.V1.Ledger.Interval as PlutusTx
|
||||
import Plutus.V1.Ledger.Scripts (Datum (Datum), DatumHash (DatumHash), Script)
|
||||
import PlutusTx.AssocMap qualified as AssocMap
|
||||
import PlutusTx.Builtins qualified as PlutusTx
|
||||
import PlutusTx.IsData qualified as PlutusTx
|
||||
import PlutusTx.Ord qualified as PlutusTx
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -231,3 +236,24 @@ toDatumHash datum =
|
|||
plift $
|
||||
pblake2b_256
|
||||
# pconstant (ByteString.Lazy.toStrict $ serialise $ PlutusTx.toData datum)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Create a closed bounded `Interval`.
|
||||
closedBoundedInterval :: PlutusTx.Ord a => a -> a -> PlutusTx.Interval a
|
||||
closedBoundedInterval from to = PlutusTx.intersection (PlutusTx.from from) (PlutusTx.to to)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
{- | / O(n) /. The expression @'updateMap' f k v@ will update the value @x@ at key @k@.
|
||||
If @f x@ is Nothing, the key-value pair will be deleted from the map, otherwise the
|
||||
value will be updated.
|
||||
-}
|
||||
updateMap :: Eq k => (v -> Maybe v) -> k -> AssocMap.Map k v -> AssocMap.Map k v
|
||||
updateMap f k =
|
||||
AssocMap.mapMaybeWithKey
|
||||
( \k' v ->
|
||||
if k' == k
|
||||
then f v
|
||||
else Just v
|
||||
)
|
||||
|
|
|
|||
40
agora.cabal
40
agora.cabal
|
|
@ -114,6 +114,7 @@ common test-deps
|
|||
, agora
|
||||
, apropos
|
||||
, apropos-tx
|
||||
, mtl
|
||||
, QuickCheck
|
||||
, quickcheck-instances
|
||||
, tasty
|
||||
|
|
@ -145,19 +146,21 @@ library
|
|||
Agora.Treasury
|
||||
Agora.Utils
|
||||
Agora.Utils.Value
|
||||
Agora.ScriptInfo
|
||||
|
||||
other-modules:
|
||||
Agora.Aeson.Orphans
|
||||
hs-source-dirs: agora
|
||||
|
||||
library pprelude
|
||||
default-language: Haskell2010
|
||||
exposed-modules: PPrelude
|
||||
hs-source-dirs: agora
|
||||
|
||||
build-depends:
|
||||
, base
|
||||
, plutarch
|
||||
|
||||
exposed-modules: PPrelude
|
||||
hs-source-dirs: agora
|
||||
default-language: Haskell2010
|
||||
|
||||
library agora-testlib
|
||||
import: lang, deps, test-deps
|
||||
exposed-modules: Test.Util
|
||||
|
|
@ -165,7 +168,6 @@ library agora-testlib
|
|||
|
||||
library agora-sample
|
||||
import: lang, deps, test-deps
|
||||
build-depends: agora-testlib
|
||||
exposed-modules:
|
||||
Sample.Effect.GovernorMutation
|
||||
Sample.Effect.TreasuryWithdrawal
|
||||
|
|
@ -174,9 +176,10 @@ library agora-sample
|
|||
Sample.Shared
|
||||
Sample.Stake
|
||||
Sample.Treasury
|
||||
|
||||
hs-source-dirs: agora-sample
|
||||
|
||||
build-depends: agora-testlib
|
||||
|
||||
test-suite agora-test
|
||||
import: lang, deps, test-deps
|
||||
type: exitcode-stdio-1.0
|
||||
|
|
@ -201,19 +204,32 @@ benchmark agora-bench
|
|||
import: lang, deps
|
||||
hs-source-dirs: agora-bench
|
||||
main-is: Main.hs
|
||||
other-modules: Bench
|
||||
type: exitcode-stdio-1.0
|
||||
build-depends: agora
|
||||
build-depends:
|
||||
, agora
|
||||
, agora-sample
|
||||
|
||||
executable agora-scripts
|
||||
import: lang, deps, exe-opts
|
||||
main-is: Scripts.hs
|
||||
hs-source-dirs: agora-scripts
|
||||
other-modules:
|
||||
Options
|
||||
build-depends:
|
||||
, agora
|
||||
, optparse-applicative
|
||||
|
||||
executable agora-purescript-bridge
|
||||
import: lang, deps, exe-opts
|
||||
main-is: Bridge.hs
|
||||
hs-source-dirs: agora-purescript-bridge
|
||||
other-modules:
|
||||
AgoraTypes
|
||||
Options
|
||||
|
||||
build-depends:
|
||||
, agora
|
||||
, optparse-applicative
|
||||
, path
|
||||
, purescript-bridge
|
||||
|
||||
hs-source-dirs: agora-purescript-bridge
|
||||
other-modules:
|
||||
AgoraTypes
|
||||
Options
|
||||
|
|
|
|||
146
agora/Agora/Aeson/Orphans.hs
Normal file
146
agora/Agora/Aeson/Orphans.hs
Normal file
|
|
@ -0,0 +1,146 @@
|
|||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module Agora.Aeson.Orphans (AsBase16Bytes (..)) where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Data.Coerce (Coercible, coerce)
|
||||
import Prelude
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Codec.Serialise qualified as Codec
|
||||
import Data.Aeson qualified as Aeson
|
||||
import Data.Aeson.Types qualified as Aeson
|
||||
import Data.ByteString.Lazy qualified as Lazy
|
||||
import Data.Text qualified as T
|
||||
import Data.Text.Encoding qualified as T
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Plutus.V1.Ledger.Api qualified as Plutus
|
||||
import Plutus.V1.Ledger.Bytes qualified as Plutus
|
||||
import Plutus.V1.Ledger.Value qualified as Plutus
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
newtype AsBase16Bytes a = AsBase16Bytes {unAsBase16Bytes :: a}
|
||||
newtype AsBase16Codec a = AsBase16Codec {unAsBase16Codec :: a}
|
||||
|
||||
deriving via
|
||||
(Plutus.CurrencySymbol, Plutus.TokenName)
|
||||
instance
|
||||
Aeson.ToJSON Plutus.AssetClass
|
||||
|
||||
deriving via
|
||||
(Plutus.CurrencySymbol, Plutus.TokenName)
|
||||
instance
|
||||
Aeson.FromJSON Plutus.AssetClass
|
||||
|
||||
deriving via
|
||||
AsBase16Bytes Plutus.TxId
|
||||
instance
|
||||
Aeson.FromJSON Plutus.TxId
|
||||
|
||||
deriving via
|
||||
AsBase16Bytes Plutus.TxId
|
||||
instance
|
||||
Aeson.ToJSON Plutus.TxId
|
||||
|
||||
deriving anyclass instance Aeson.FromJSON Plutus.TxOutRef
|
||||
deriving anyclass instance Aeson.ToJSON Plutus.TxOutRef
|
||||
|
||||
instance (Coercible a Plutus.LedgerBytes) => Aeson.ToJSON (AsBase16Bytes a) where
|
||||
toJSON =
|
||||
Aeson.String
|
||||
. Plutus.encodeByteString
|
||||
. Plutus.bytes
|
||||
. coerce @(AsBase16Bytes a) @Plutus.LedgerBytes
|
||||
|
||||
instance (Coercible Plutus.LedgerBytes a) => Aeson.FromJSON (AsBase16Bytes a) where
|
||||
parseJSON v =
|
||||
Aeson.parseJSON @T.Text v
|
||||
>>= either (Aeson.parserThrowError []) (pure . coerce @_ @(AsBase16Bytes a))
|
||||
. Plutus.fromHex
|
||||
. T.encodeUtf8
|
||||
|
||||
instance (Codec.Serialise a) => Aeson.ToJSON (AsBase16Codec a) where
|
||||
toJSON =
|
||||
Aeson.String
|
||||
. Plutus.encodeByteString
|
||||
. Lazy.toStrict
|
||||
. Codec.serialise @a
|
||||
. (.unAsBase16Codec)
|
||||
|
||||
instance (Codec.Serialise a) => Aeson.FromJSON (AsBase16Codec a) where
|
||||
parseJSON v =
|
||||
Aeson.parseJSON @T.Text v
|
||||
>>= either (Aeson.parserThrowError [] . show) (pure . AsBase16Codec)
|
||||
. Codec.deserialiseOrFail
|
||||
. Lazy.fromStrict
|
||||
. T.encodeUtf8
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
deriving via
|
||||
(AsBase16Bytes Plutus.CurrencySymbol)
|
||||
instance
|
||||
(Aeson.ToJSON Plutus.CurrencySymbol)
|
||||
deriving via
|
||||
(AsBase16Bytes Plutus.CurrencySymbol)
|
||||
instance
|
||||
(Aeson.FromJSON Plutus.CurrencySymbol)
|
||||
|
||||
deriving via
|
||||
(AsBase16Bytes Plutus.TokenName)
|
||||
instance
|
||||
(Aeson.ToJSON Plutus.TokenName)
|
||||
deriving via
|
||||
(AsBase16Bytes Plutus.TokenName)
|
||||
instance
|
||||
(Aeson.FromJSON Plutus.TokenName)
|
||||
|
||||
deriving via
|
||||
(AsBase16Bytes Plutus.ValidatorHash)
|
||||
instance
|
||||
(Aeson.ToJSON Plutus.ValidatorHash)
|
||||
deriving via
|
||||
(AsBase16Bytes Plutus.ValidatorHash)
|
||||
instance
|
||||
(Aeson.FromJSON Plutus.ValidatorHash)
|
||||
|
||||
deriving via
|
||||
(AsBase16Codec Plutus.Validator)
|
||||
instance
|
||||
(Aeson.ToJSON Plutus.Validator)
|
||||
deriving via
|
||||
(AsBase16Codec Plutus.Validator)
|
||||
instance
|
||||
(Aeson.FromJSON Plutus.Validator)
|
||||
|
||||
deriving via
|
||||
(AsBase16Codec Plutus.MintingPolicy)
|
||||
instance
|
||||
(Aeson.ToJSON Plutus.MintingPolicy)
|
||||
deriving via
|
||||
(AsBase16Codec Plutus.MintingPolicy)
|
||||
instance
|
||||
(Aeson.FromJSON Plutus.MintingPolicy)
|
||||
|
||||
deriving via
|
||||
(AsBase16Codec Plutus.Script)
|
||||
instance
|
||||
(Aeson.ToJSON Plutus.Script)
|
||||
deriving via
|
||||
(AsBase16Codec Plutus.Script)
|
||||
instance
|
||||
(Aeson.FromJSON Plutus.Script)
|
||||
|
||||
deriving via
|
||||
Integer
|
||||
instance
|
||||
(Aeson.ToJSON Plutus.POSIXTime)
|
||||
deriving via
|
||||
Integer
|
||||
instance
|
||||
(Aeson.FromJSON Plutus.POSIXTime)
|
||||
|
|
@ -126,6 +126,7 @@ import Plutarch.TryFrom (ptryFrom)
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.Proposal.Time (ProposalStartingTime (..), ProposalTimingConfig (..))
|
||||
import Plutus.V1.Ledger.Api (
|
||||
CurrencySymbol (..),
|
||||
MintingPolicy,
|
||||
|
|
@ -576,6 +577,10 @@ governorValidator gov =
|
|||
.& #cosigners .= proposalInputDatumF.cosigners
|
||||
.& #thresholds .= proposalInputDatumF.thresholds
|
||||
.& #votes .= proposalInputDatumF.votes
|
||||
-- FIXME: copy from the governor datum
|
||||
.& #timingConfig .= pdata (pconstant tmpTimingConfig)
|
||||
-- FIXME: calculate from 'txInfoValidRange'
|
||||
.& #startingTime .= pdata (pconstant tmpProposalStartingTime)
|
||||
)
|
||||
|
||||
tcassert "Unexpected output proposal datum" $
|
||||
|
|
@ -727,6 +732,20 @@ governorValidator gov =
|
|||
let sym = governorSTSymbolFromGovernor gov
|
||||
in phoistAcyclic $ pconstant sym
|
||||
|
||||
-- TODO: remove this. This is temperary.
|
||||
tmpTimingConfig :: ProposalTimingConfig
|
||||
tmpTimingConfig =
|
||||
ProposalTimingConfig
|
||||
{ draftTime = 50
|
||||
, votingTime = 1000
|
||||
, lockingTime = 2000
|
||||
, executingTime = 3000
|
||||
}
|
||||
|
||||
-- TODO: remove this.
|
||||
tmpProposalStartingTime :: ProposalStartingTime
|
||||
tmpProposalStartingTime = ProposalStartingTime 0
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Get the 'CurrencySymbol' of GST.
|
||||
|
|
|
|||
|
|
@ -44,6 +44,8 @@ import PlutusTx qualified
|
|||
import PlutusTx.AssocMap qualified as AssocMap
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.Proposal.Time (PProposalStartingTime, PProposalTimingConfig, ProposalStartingTime, ProposalTimingConfig)
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Utils (pkeysEqual, pnotNull)
|
||||
import Control.Applicative (Const)
|
||||
|
|
@ -186,6 +188,10 @@ data ProposalDatum = ProposalDatum
|
|||
-- ^ Thresholds copied over on initialization.
|
||||
, votes :: ProposalVotes
|
||||
-- ^ Vote tally on the proposal
|
||||
, timingConfig :: ProposalTimingConfig
|
||||
-- ^ Timing configuration copied over on initialization.
|
||||
, startingTime :: ProposalStartingTime
|
||||
-- ^ The time upon the creation of the proposal.
|
||||
}
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
|
||||
|
|
@ -303,7 +309,7 @@ data PProposalStatus (s :: S)
|
|||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData)
|
||||
(PlutusType, PIsData, PEq)
|
||||
via PIsDataReprInstances PProposalStatus
|
||||
|
||||
instance PUnsafeLiftDecl PProposalStatus where type PLifted PProposalStatus = ProposalStatus
|
||||
|
|
@ -354,6 +360,8 @@ newtype PProposalDatum (s :: S) = PProposalDatum
|
|||
, "cosigners" ':= PBuiltinList (PAsData PPubKeyHash)
|
||||
, "thresholds" ':= PProposalThresholds
|
||||
, "votes" ':= PProposalVotes
|
||||
, "timingConfig" ':= PProposalTimingConfig
|
||||
, "startingTime" ':= PProposalStartingTime
|
||||
]
|
||||
)
|
||||
}
|
||||
|
|
@ -361,7 +369,7 @@ newtype PProposalDatum (s :: S) = PProposalDatum
|
|||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData, PDataFields)
|
||||
(PlutusType, PIsData, PDataFields, PEq)
|
||||
via (PIsDataReprInstances PProposalDatum)
|
||||
|
||||
-- TODO: Derive this.
|
||||
|
|
|
|||
|
|
@ -13,18 +13,25 @@ module Agora.Proposal.Scripts (
|
|||
import Agora.Proposal (
|
||||
PProposalDatum (PProposalDatum),
|
||||
PProposalRedeemer (..),
|
||||
PProposalVotes (PProposalVotes),
|
||||
Proposal (governorSTAssetClass, stakeSTAssetClass),
|
||||
ProposalStatus (VotingReady),
|
||||
)
|
||||
import Agora.Proposal.Time (currentProposalTime, isVotingPeriod)
|
||||
import Agora.Record (mkRecordConstr, (.&), (.=))
|
||||
import Agora.Stake (findStakeOwnedBy)
|
||||
import Agora.Stake (PProposalLock (..), PStakeDatum (..), findStakeOwnedBy)
|
||||
import Agora.Utils (
|
||||
anyOutput,
|
||||
findTxOutByTxOutRef,
|
||||
getMintingPolicySymbol,
|
||||
mustBePJust,
|
||||
mustFindDatum',
|
||||
pisJust,
|
||||
pisUniqBy,
|
||||
psymbolValueOf,
|
||||
ptokenSpent,
|
||||
ptxSignedBy,
|
||||
pupdate,
|
||||
pvalueSpent,
|
||||
tcassert,
|
||||
tclet,
|
||||
|
|
@ -39,6 +46,8 @@ import Plutarch.Api.V1 (
|
|||
PValidator,
|
||||
)
|
||||
import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
|
||||
import Plutarch.Map.Extra (plookup)
|
||||
import Plutarch.SafeMoney (puntag)
|
||||
import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
|
||||
|
||||
{- | Policy for Proposals.
|
||||
|
|
@ -123,7 +132,17 @@ proposalValidator proposal =
|
|||
ctx <- tcont $ pletFields @'["txInfo", "purpose"] ctx'
|
||||
txInfo <- tclet $ pfromData ctx.txInfo
|
||||
PTxInfo txInfo' <- tcmatch txInfo
|
||||
txInfoF <- tcont $ pletFields @'["inputs", "mint", "datums", "signatories"] txInfo'
|
||||
txInfoF <-
|
||||
tcont $
|
||||
pletFields
|
||||
@'[ "inputs"
|
||||
, "outputs"
|
||||
, "mint"
|
||||
, "datums"
|
||||
, "signatories"
|
||||
, "validRange"
|
||||
]
|
||||
txInfo'
|
||||
PSpending ((pfield @"_0" #) -> txOutRef) <- tcmatch $ pfromData ctx.purpose
|
||||
|
||||
PJust txOut <- tcmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs
|
||||
|
|
@ -143,6 +162,8 @@ proposalValidator proposal =
|
|||
, "cosigners"
|
||||
, "thresholds"
|
||||
, "votes"
|
||||
, "timingConfig"
|
||||
, "startingTime"
|
||||
]
|
||||
proposalDatum
|
||||
|
||||
|
|
@ -163,9 +184,136 @@ proposalValidator proposal =
|
|||
|
||||
tcassert "ST at inputs must be 1" (spentST #== 1)
|
||||
|
||||
currentTime <- tclet $ currentProposalTime # txInfoF.validRange
|
||||
|
||||
-- Filter out own output with own address and PST.
|
||||
-- Delay the evaluation cause in some cases there won't be any continuing output.
|
||||
ownOutputD <-
|
||||
tclet $
|
||||
pdelay $
|
||||
mustBePJust # "Own output should be present" #$ pfind
|
||||
# plam
|
||||
( \input -> unTermCont $ do
|
||||
inputF <- tcont $ pletFields @'["address", "value"] input
|
||||
pure $
|
||||
inputF.address #== ownAddress
|
||||
#&& psymbolValueOf # stCurrencySymbol # inputF.value #== 1
|
||||
)
|
||||
# pfromData txInfoF.outputs
|
||||
|
||||
proposalOutD <-
|
||||
tclet $
|
||||
pdelay $
|
||||
mustFindDatum' @PProposalDatum
|
||||
# (pfield @"datumHash" # pforce ownOutputD)
|
||||
# txInfoF.datums
|
||||
|
||||
pure $
|
||||
pmatch proposalRedeemer $ \case
|
||||
PVote _r -> popaque (pconstant ())
|
||||
PVote r -> unTermCont $ do
|
||||
tcassert "Input proposal must be in VotingReady state" $
|
||||
proposalF.status #== pconstant VotingReady
|
||||
|
||||
tcassert "Proposal time should be wthin the voting period" $
|
||||
isVotingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime
|
||||
|
||||
-- Ensure the transaction is voting to a valid 'ResultTag'(outcome).
|
||||
PProposalVotes voteMap <- tcmatch proposalF.votes
|
||||
voteFor <- tclet $ pfromData $ pfield @"resultTag" # r
|
||||
|
||||
tcassert "Vote option should be valid" $
|
||||
pisJust #$ plookup # voteFor # voteMap
|
||||
|
||||
-- Find the input stake, the amount of new votes should be the 'stakedAmount'.
|
||||
let stakeInput =
|
||||
pfield @"resolved"
|
||||
#$ mustBePJust
|
||||
# "Stake input should be present"
|
||||
#$ pfind
|
||||
# plam
|
||||
( \(pfromData . (pfield @"value" #) . (pfield @"resolved" #) -> value) ->
|
||||
passetClassValueOf # value # stakeSTAssetClass #== 1
|
||||
)
|
||||
# pfromData txInfoF.inputs
|
||||
|
||||
stakeIn :: Term _ PStakeDatum
|
||||
stakeIn = mustFindDatum' # (pfield @"datumHash" # stakeInput) # txInfoF.datums
|
||||
|
||||
stakeInF <- tcont $ pletFields @'["stakedAmount", "lockedBy", "owner"] stakeIn
|
||||
|
||||
-- Ensure that no lock with the current proposal id has been put on the stake.
|
||||
tcassert "Same stake shouldn't vote on the same propsoal twice" $
|
||||
pnot #$ pany
|
||||
# plam
|
||||
( \((pfield @"proposalTag" #) . pfromData -> pid) ->
|
||||
pid #== proposalF.proposalId
|
||||
)
|
||||
# pfromData stakeInF.lockedBy
|
||||
|
||||
let -- Update the vote counter of the proposal, and leave other stuff as is.
|
||||
expectedNewVotes = pmatch (pfromData proposalF.votes) $ \(PProposalVotes m) ->
|
||||
pcon $
|
||||
PProposalVotes $
|
||||
pupdate
|
||||
# plam
|
||||
( \votes ->
|
||||
pcon $ PJust $ votes + (puntag stakeInF.stakedAmount)
|
||||
)
|
||||
# voteFor
|
||||
# m
|
||||
expectedProposalOut =
|
||||
mkRecordConstr
|
||||
PProposalDatum
|
||||
( #proposalId .= proposalF.proposalId
|
||||
.& #effects .= proposalF.effects
|
||||
.& #status .= proposalF.status
|
||||
.& #cosigners .= proposalF.cosigners
|
||||
.& #thresholds .= proposalF.thresholds
|
||||
.& #votes .= pdata expectedNewVotes
|
||||
.& #timingConfig .= proposalF.timingConfig
|
||||
.& #startingTime .= proposalF.startingTime
|
||||
)
|
||||
|
||||
tcassert "Output proposal should be valid" $ pforce proposalOutD #== expectedProposalOut
|
||||
|
||||
-- We validate the output stake datum here as well: We need the vote option
|
||||
-- to create a valid 'ProposalLock', however the vote option is encoded
|
||||
-- in the proposal redeemer, which is invisible for the stake validator.
|
||||
|
||||
let stakeOutput =
|
||||
mustBePJust # "Stake output should be present"
|
||||
#$ pfind
|
||||
# plam
|
||||
( \(pfromData . (pfield @"value" #) -> value) ->
|
||||
passetClassValueOf # value # stakeSTAssetClass #== 1
|
||||
)
|
||||
# pfromData txInfoF.outputs
|
||||
|
||||
stakeOut :: Term _ PStakeDatum
|
||||
stakeOut = mustFindDatum' # (pfield @"datumHash" # stakeOutput) # txInfoF.datums
|
||||
|
||||
let newProposalLock =
|
||||
mkRecordConstr
|
||||
PProposalLock
|
||||
( #vote .= pdata voteFor
|
||||
.& #proposalTag .= proposalF.proposalId
|
||||
)
|
||||
-- Prepend the new lock to existing locks
|
||||
expectedProposalLocks =
|
||||
pcons
|
||||
# pdata newProposalLock
|
||||
# pfromData stakeInF.lockedBy
|
||||
expectedStakeOut =
|
||||
mkRecordConstr
|
||||
PStakeDatum
|
||||
( #stakedAmount .= stakeInF.stakedAmount
|
||||
.& #owner .= stakeInF.owner
|
||||
.& #lockedBy .= pdata expectedProposalLocks
|
||||
)
|
||||
|
||||
tcassert "Output stake should be locked by the proposal" $ expectedStakeOut #== stakeOut
|
||||
|
||||
pure $ popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PCosign r -> unTermCont $ do
|
||||
newSigs <- tclet $ pfield @"newCosigners" # r
|
||||
|
|
@ -214,6 +362,8 @@ proposalValidator proposal =
|
|||
.& #cosigners .= pdata updatedSigs
|
||||
.& #thresholds .= proposalF.thresholds
|
||||
.& #votes .= proposalF.votes
|
||||
.& #timingConfig .= proposalF.timingConfig
|
||||
.& #startingTime .= proposalF.startingTime
|
||||
)
|
||||
)
|
||||
in foldr1
|
||||
|
|
|
|||
|
|
@ -39,7 +39,12 @@ import Plutarch.Api.V1 (
|
|||
PPOSIXTimeRange,
|
||||
PUpperBound (PUpperBound),
|
||||
)
|
||||
import Plutarch.DataRepr (PDataFields, PIsDataReprInstances (..))
|
||||
import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields, PIsDataReprInstances (..))
|
||||
import Plutarch.Lift (
|
||||
DerivePConstantViaNewtype (..),
|
||||
PConstantDecl,
|
||||
PUnsafeLiftDecl (..),
|
||||
)
|
||||
import Plutarch.Numeric (AdditiveSemigroup ((+)))
|
||||
import Plutarch.Unsafe (punsafeCoerce)
|
||||
import Plutus.V1.Ledger.Time (POSIXTime)
|
||||
|
|
@ -122,10 +127,24 @@ newtype PProposalTime (s :: S)
|
|||
(PlutusType, PIsData, PDataFields)
|
||||
via (PIsDataReprInstances PProposalTime)
|
||||
|
||||
instance PUnsafeLiftDecl PProposalTime where
|
||||
type PLifted PProposalTime = ProposalTime
|
||||
deriving via
|
||||
(DerivePConstantViaData ProposalTime PProposalTime)
|
||||
instance
|
||||
(PConstantDecl ProposalTime)
|
||||
|
||||
-- | Plutarch-level version of 'ProposalStartingTime'.
|
||||
newtype PProposalStartingTime (s :: S) = PProposalStartingTime (Term s PPOSIXTime)
|
||||
deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalStartingTime PPOSIXTime)
|
||||
|
||||
instance PUnsafeLiftDecl PProposalStartingTime where
|
||||
type PLifted PProposalStartingTime = ProposalStartingTime
|
||||
deriving via
|
||||
(DerivePConstantViaNewtype ProposalStartingTime PProposalStartingTime PPOSIXTime)
|
||||
instance
|
||||
(PConstantDecl ProposalStartingTime)
|
||||
|
||||
-- | Plutarch-level version of 'ProposalTimingConfig'.
|
||||
newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
|
||||
{ getProposalTimingConfig ::
|
||||
|
|
@ -146,6 +165,13 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
|
|||
(PlutusType, PIsData, PDataFields)
|
||||
via (PIsDataReprInstances PProposalTimingConfig)
|
||||
|
||||
instance PUnsafeLiftDecl PProposalTimingConfig where
|
||||
type PLifted PProposalTimingConfig = ProposalTimingConfig
|
||||
deriving via
|
||||
(DerivePConstantViaData ProposalTimingConfig PProposalTimingConfig)
|
||||
instance
|
||||
(PConstantDecl ProposalTimingConfig)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- FIXME: Orphan instance, move this to plutarch-extra.
|
||||
|
|
|
|||
|
|
@ -8,6 +8,9 @@ Tags and extras for "Plutarch.SafeMoney".
|
|||
module Agora.SafeMoney (
|
||||
ADATag,
|
||||
GTTag,
|
||||
GovernorSTTag,
|
||||
StakeSTTag,
|
||||
ProposalSTTag,
|
||||
adaRef,
|
||||
) where
|
||||
|
||||
|
|
@ -18,7 +21,7 @@ import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
|
|||
import Plutarch.SafeMoney
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Example tags
|
||||
-- Tags
|
||||
|
||||
-- | Governance token.
|
||||
data GTTag
|
||||
|
|
@ -26,6 +29,15 @@ data GTTag
|
|||
-- | ADA.
|
||||
data ADATag
|
||||
|
||||
-- | Governor ST token.
|
||||
data GovernorSTTag
|
||||
|
||||
-- | Stake ST token.
|
||||
data StakeSTTag
|
||||
|
||||
-- | Proposal ST token.
|
||||
data ProposalSTTag
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Resolves ada tags.
|
||||
|
|
|
|||
63
agora/Agora/ScriptInfo.hs
Normal file
63
agora/Agora/ScriptInfo.hs
Normal file
|
|
@ -0,0 +1,63 @@
|
|||
{- |
|
||||
Module : Agora.ScriptInfo
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Exportable script bundles for off-chain consumption.
|
||||
|
||||
Exportable script bundles for off-chain consumption.
|
||||
-}
|
||||
module Agora.ScriptInfo (
|
||||
-- * Types
|
||||
PolicyInfo (..),
|
||||
ValidatorInfo (..),
|
||||
|
||||
-- * Introduction functions
|
||||
mkValidatorInfo,
|
||||
mkPolicyInfo,
|
||||
) where
|
||||
|
||||
import Agora.Aeson.Orphans ()
|
||||
import Data.Aeson qualified as Aeson
|
||||
import GHC.Generics qualified as GHC
|
||||
import Plutarch.Api.V1 (PMintingPolicy, PValidator, mintingPolicySymbol, mkMintingPolicy, mkValidator, validatorHash)
|
||||
import Plutus.V1.Ledger.Api (MintingPolicy, Validator, ValidatorHash)
|
||||
import Plutus.V1.Ledger.Value (CurrencySymbol)
|
||||
|
||||
-- | Bundle containing a 'Validator' and its hash.
|
||||
data ValidatorInfo = ValidatorInfo
|
||||
{ script :: Validator
|
||||
-- ^ The validator script.
|
||||
, hash :: ValidatorHash
|
||||
-- ^ Hash of the validator.
|
||||
}
|
||||
deriving stock (Show, Eq, GHC.Generic)
|
||||
deriving anyclass (Aeson.ToJSON, Aeson.FromJSON)
|
||||
|
||||
-- | Create a 'ValidatorInfo' given a Plutarch term.
|
||||
mkValidatorInfo :: ClosedTerm PValidator -> ValidatorInfo
|
||||
mkValidatorInfo term =
|
||||
ValidatorInfo
|
||||
{ script = validator
|
||||
, hash = validatorHash validator
|
||||
}
|
||||
where
|
||||
validator = mkValidator term
|
||||
|
||||
-- | Bundle containing a 'MintingPolicy' and its symbol.
|
||||
data PolicyInfo = PolicyInfo
|
||||
{ policy :: MintingPolicy
|
||||
-- ^ The minting policy.
|
||||
, currencySymbol :: CurrencySymbol
|
||||
-- ^ The symbol given by the minting policy.
|
||||
}
|
||||
deriving stock (Show, Eq, GHC.Generic)
|
||||
deriving anyclass (Aeson.ToJSON, Aeson.FromJSON)
|
||||
|
||||
-- | Create a 'PolicyInfo' given a Plutarch term.
|
||||
mkPolicyInfo :: ClosedTerm PMintingPolicy -> PolicyInfo
|
||||
mkPolicyInfo term =
|
||||
PolicyInfo
|
||||
{ policy = policy
|
||||
, currencySymbol = mintingPolicySymbol policy
|
||||
}
|
||||
where
|
||||
policy = mkMintingPolicy term
|
||||
|
|
@ -191,7 +191,7 @@ newtype PStakeDatum (s :: S) = PStakeDatum
|
|||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData, PDataFields)
|
||||
(PlutusType, PIsData, PDataFields, PEq)
|
||||
via (PIsDataReprInstances PStakeDatum)
|
||||
|
||||
instance PTryFrom PData (PAsData PStakeDatum) where
|
||||
|
|
@ -241,7 +241,7 @@ newtype PProposalLock (s :: S) = PProposalLock
|
|||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData, PDataFields)
|
||||
(PlutusType, PIsData, PDataFields, PEq)
|
||||
via (PIsDataReprInstances PProposalLock)
|
||||
|
||||
deriving via
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@ Plutus Scripts for Stakes.
|
|||
-}
|
||||
module Agora.Stake.Scripts (stakePolicy, stakeValidator) where
|
||||
|
||||
import Agora.Record (mkRecordConstr, (.&), (.=))
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Stake
|
||||
import Agora.Utils (
|
||||
|
|
@ -222,7 +223,7 @@ stakeValidator stake =
|
|||
-- TODO: Use PTryFrom
|
||||
let stakeDatum' :: Term _ PStakeDatum
|
||||
stakeDatum' = pfromData $ punsafeCoerce datum
|
||||
stakeDatum <- tcont $ pletFields @'["owner", "stakedAmount"] stakeDatum'
|
||||
stakeDatum <- tcont $ pletFields @'["owner", "stakedAmount", "lockedBy"] stakeDatum'
|
||||
|
||||
PSpending txOutRef <- tcmatch $ pfromData ctx.purpose
|
||||
|
||||
|
|
@ -291,7 +292,7 @@ stakeValidator stake =
|
|||
|
||||
pure $ popaque (pconstant ())
|
||||
--------------------------------------------------------------------------
|
||||
PPermitVote _ -> unTermCont $ do
|
||||
PPermitVote l -> unTermCont $ do
|
||||
tcassert
|
||||
"Owner signs this transaction"
|
||||
ownerSignsTransaction
|
||||
|
|
@ -301,18 +302,38 @@ stakeValidator stake =
|
|||
tcassert "Proposal ST spent" $
|
||||
spentProposalST #== 1
|
||||
|
||||
-- Update the stake datum, but only the 'lockedBy' field.
|
||||
|
||||
let -- We actually don't know whether the given lock is valid or not.
|
||||
-- This is checked in the proposal validator.
|
||||
newLock = pfield @"lock" # l
|
||||
-- Prepend the new lock to the existing locks.
|
||||
expectedLocks = pcons # newLock # stakeDatum.lockedBy
|
||||
|
||||
expectedDatum <-
|
||||
tclet $
|
||||
pdata $
|
||||
mkRecordConstr
|
||||
PStakeDatum
|
||||
( #stakedAmount .= stakeDatum.stakedAmount
|
||||
.& #owner .= stakeDatum.owner
|
||||
.& #lockedBy .= pdata expectedLocks
|
||||
)
|
||||
|
||||
tcassert "A UTXO must exist with the correct output" $
|
||||
-- FIXME: no need to pass the whole txInfo to 'anyOutput'.
|
||||
anyOutput @PStakeDatum # txInfo
|
||||
#$ plam
|
||||
$ \value address newStakeDatum' ->
|
||||
let isScriptAddress = pdata address #== ownAddress
|
||||
_correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
|
||||
correctOutputDatum = pdata newStakeDatum' #== expectedDatum
|
||||
valueCorrect = pdata continuingValue #== pdata value
|
||||
in pif
|
||||
isScriptAddress
|
||||
( foldl1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "valueCorrect" valueCorrect
|
||||
, ptraceIfFalse "datumCorrect" correctOutputDatum
|
||||
]
|
||||
)
|
||||
(pcon PFalse)
|
||||
|
|
|
|||
|
|
@ -72,6 +72,7 @@ deriving via
|
|||
do so in a valid manner.
|
||||
-}
|
||||
treasuryValidator ::
|
||||
-- | Governance Authority Token that can unlock this validator.
|
||||
CurrencySymbol ->
|
||||
ClosedTerm PValidator
|
||||
treasuryValidator gatCs' = plam $ \_datum redeemer ctx' -> unTermCont $ do
|
||||
|
|
|
|||
|
|
@ -40,6 +40,8 @@ module Agora.Utils (
|
|||
pmsortBy,
|
||||
pmsort,
|
||||
pnubSort,
|
||||
pupdate,
|
||||
pmapMaybe,
|
||||
|
||||
-- * Functions which should (probably) not be upstreamed
|
||||
anyOutput,
|
||||
|
|
@ -288,6 +290,42 @@ pmapUnionWith = phoistAcyclic $
|
|||
# ys
|
||||
pure $ pcon (PMap $ pconcat # ls # rs)
|
||||
|
||||
-- | A special version of `pmap` which allows list elements to be thrown out.
|
||||
pmapMaybe :: forall s a list. (PIsListLike list a) => Term s ((a :--> PMaybe a) :--> list a :--> list a)
|
||||
pmapMaybe = phoistAcyclic $
|
||||
pfix #$ plam $ \self f l -> pif (pnull # l) pnil $
|
||||
unTermCont $ do
|
||||
x <- tclet $ phead # l
|
||||
xs <- tclet $ ptail # l
|
||||
|
||||
pure $
|
||||
pmatch (f # x) $ \case
|
||||
PJust ux -> pcons # ux #$ self # f # xs
|
||||
_ -> self # f # xs
|
||||
|
||||
-- | / O(n) /. Update the value at a given key in a `PMap`, have the same functionalities as 'Data.Map.update'.
|
||||
pupdate :: forall s k v. (PIsData k, PIsData v) => Term s ((v :--> PMaybe v) :--> k :--> PMap k v :--> PMap k v)
|
||||
pupdate = phoistAcyclic $
|
||||
plam $ \f (pdata -> tk) (pto -> (ps :: Term _ (PBuiltinList _))) ->
|
||||
pcon $
|
||||
PMap $
|
||||
pmapMaybe
|
||||
# plam
|
||||
( \kv ->
|
||||
let k = pfstBuiltin # kv
|
||||
v = pfromData $ psndBuiltin # kv
|
||||
in pif
|
||||
(k #== tk)
|
||||
-- 'PBuiltinPair' doesn't have 'PFunctor', so:
|
||||
( pmatch (f # v) $
|
||||
\case
|
||||
PJust uv -> pcon $ PJust $ ppairDataBuiltin # k # pdata uv
|
||||
_ -> pcon PNothing
|
||||
)
|
||||
(pcon $ PJust kv)
|
||||
)
|
||||
# ps
|
||||
|
||||
-- | Add two 'PValue's together.
|
||||
paddValue :: forall s. Term s (PValue :--> PValue :--> PValue)
|
||||
paddValue = phoistAcyclic $
|
||||
|
|
|
|||
85
docs/tech-design/safety-pool.md
Normal file
85
docs/tech-design/safety-pool.md
Normal file
|
|
@ -0,0 +1,85 @@
|
|||
# Safety Pool functionality for the Staking Pool
|
||||
|
||||
| Specification | Implementation | Last revision |
|
||||
|:-----------:|:-----------:|:-------------:|
|
||||
| WIP | WIP | 2022-05-13 |
|
||||
|
||||
---
|
||||
|
||||
**Specification ownership:** [Emily Martins]
|
||||
|
||||
**Authors**:
|
||||
|
||||
- [Emily Martins]
|
||||
|
||||
**Implementation ownership:** [Emily Martins]
|
||||
|
||||
[Emily Martins]: https://github.com/emiflake
|
||||
|
||||
[Jack Hodgkinson]: https://github.com/jhodgdev
|
||||
|
||||
**Current status:** Early revision of the document with low technical specification due to feature being further in the timeline. Has been reviewed by [Jack Hodgkinson].
|
||||
|
||||
---
|
||||
|
||||
In order for Agora’s staking pool to act as a *safety pool*, it needs to be able to support a workflow for slashing staked governance tokens (GT) to act as a safety mechanism. (Note: we use "slashing" to mean taking away some token from a particular user.) This document outlines the changes that need to be made to Agora in order to support this.
|
||||
|
||||
### Motivation
|
||||
|
||||
In the event of a protocol suffering loss of funds through a [shortfall event](https://docs.aave.com/aavenomics/safety-module#shortfall-events), slashing a percentage of locked GT can be used to attempt a recovery. Ultimately, doing this is beneficial for the stakeholders because it allows the protocol to recover and eventually benefits them as well (even though they bear the initial cost). Striking a balance (in the form of the right percentage slashed) is important in order for stakeholders to want to vote in favour of a proposal that results in such a slashing.
|
||||
|
||||
## Slashing functionality
|
||||
|
||||
In order to allow an admin to withdraw a set percentage of the amount staked, we create a new effect.
|
||||
|
||||
### The `SlashEffect` validator:
|
||||
|
||||
- Mint a `SlashToken` and send it to a validator ("the `Slash` validator") with a datum encoding the details of the slashing.
|
||||
|
||||
The `SlashDatum` could look like this:
|
||||
|
||||
```haskell
|
||||
data SlashDatum = SlashDatum
|
||||
{ -- | Identify which slash event this datum belongs to.
|
||||
slashId :: Integer
|
||||
, -- | Represents how much is to be slashed (as a ratio of the full staked amount).
|
||||
slashPercentage :: Rational
|
||||
, -- | The time range that must contain `txInfoValidRange` in order to slash.
|
||||
slashTimeRange :: POSIXTimeRange
|
||||
}
|
||||
```
|
||||
|
||||
- `SlashDatum` must, in some way, be present in the datum that is passed to the `SlashEffect` validator. This means that the `ProposalDatum` also indirectly contains `SlashDatum`.
|
||||
|
||||
### The `SlashToken` policy:
|
||||
|
||||
- Exclusively check for GAT burn. Delegated checking goes to the `SlashEffect` validator.
|
||||
- This `SlashToken` policy needs to be "known" by the Stake validator, in order to allow transactions to take place.
|
||||
|
||||
### The `Slash` validator:
|
||||
|
||||
- This validator allows spending of a percentage of a `Stake`s GT, provided a few conditions are met:
|
||||
- The `SlashToken` is present
|
||||
- The slash ID is tagged onto the new stake datum
|
||||
- The time range encoded in the `SlashDatum` includes the `txInfoValidRange`.
|
||||
- What is done with the recovered GT is up to the admin to determine. Q: Is this what we want?
|
||||
|
||||
Finally, we need to change `StakeDatum` to encode a list of slash IDs in order to prevent slashes happening twice.
|
||||
|
||||
---
|
||||
|
||||
## Preventing opting out of slashing
|
||||
|
||||
If this is where we call it quits, then users will each be able to just opt-out of this slashing event. GT holders are individually incentivized to do so, because it means they don’t forfeit their own assets. Obviously, then, in order to make the safety pool work at all, we need to prevent this.
|
||||
|
||||
### Time-locking stakes
|
||||
|
||||
A simple solution is time-locking stake withdrawal upon any interaction with it for a set amount of days. This ought to be long enough for a full proposal to go through, but not too long for it to become annoying for users of the staking pool. This presents a big drawback in general for all stakeholders as their assets are actually locked even though no slashing necessarily will ever happen. However, this is also a very simple solution for solving the opt-out problem. It should be something we can enable or disable after the fact, as well as in initial configuration.
|
||||
|
||||
### CIP-31 dependent central lock
|
||||
|
||||
Provided we have reference-inputs ([CIP-31](https://cips.cardano.org/cips/cip31/)) by the time we implement this, an alternative approach is viable:
|
||||
|
||||
- We create a script that manages a `StakeLockDatum`. The script (”`StakeLock` validator”) encodes whether or not `Stake`s are allowed to withdraw. Using reference-inputs, we are able to witness this datum without consuming it, allowing us to lose no throughput on withdrawals, while maintaining a centralized lock.
|
||||
- The `StakeLock` validator can only set to lock through an admin-controlled multisig. The admin multisig should do this in the event that a proposal has been created for the shortfall event.
|
||||
- The `StakeLock` utxo can be consumed by anyone after a set period of time, unlocking it again. This prevents admins from abusing the locking for whatever reason.
|
||||
Loading…
Add table
Add a link
Reference in a new issue