From 13a241bf0b85c9bfda9378766996cd0955d1ced9 Mon Sep 17 00:00:00 2001 From: sourabhxyz Date: Wed, 8 Jan 2025 17:37:12 +0530 Subject: [PATCH] feat(#387): add committee related certificates --- atlas-cardano.cabal | 2 + src/GeniusYield/Test/Privnet/Ctx.hs | 9 ++ src/GeniusYield/Test/Privnet/Setup.hs | 114 ++++++++++-------- src/GeniusYield/Types.hs | 1 + src/GeniusYield/Types/Certificate.hs | 13 +- src/GeniusYield/Types/Pool.hs | 5 - src/GeniusYield/Types/Reexpose.hs | 16 +++ src/GeniusYield/Types/TxCert.hs | 28 +++++ .../GeniusYield/Test/Privnet/Committee.hs | 48 ++++++++ tests-privnet/atlas-privnet-tests.hs | 2 + 10 files changed, 183 insertions(+), 55 deletions(-) create mode 100644 src/GeniusYield/Types/Reexpose.hs create mode 100644 tests-privnet/GeniusYield/Test/Privnet/Committee.hs diff --git a/atlas-cardano.cabal b/atlas-cardano.cabal index 137b2a87..0845c5e7 100644 --- a/atlas-cardano.cabal +++ b/atlas-cardano.cabal @@ -153,6 +153,7 @@ library GeniusYield.Types.PubKeyHash GeniusYield.Types.Rational GeniusYield.Types.Redeemer + GeniusYield.Types.Reexpose GeniusYield.Types.Script GeniusYield.Types.Script.ScriptHash GeniusYield.Types.Script.SimpleScript @@ -368,6 +369,7 @@ test-suite atlas-privnet-tests main-is: atlas-privnet-tests.hs other-modules: GeniusYield.Test.Privnet.Blueprint + GeniusYield.Test.Privnet.Committee GeniusYield.Test.Privnet.DRep GeniusYield.Test.Privnet.SimpleScripts GeniusYield.Test.Privnet.Stake diff --git a/src/GeniusYield/Test/Privnet/Ctx.hs b/src/GeniusYield/Test/Privnet/Ctx.hs index 186caeaa..d7efa5e2 100644 --- a/src/GeniusYield/Test/Privnet/Ctx.hs +++ b/src/GeniusYield/Test/Privnet/Ctx.hs @@ -8,6 +8,7 @@ Stability : develop module GeniusYield.Test.Privnet.Ctx ( -- * Context Ctx (..), + CtxCommittee (..), ctxNetworkId, -- * User @@ -86,6 +87,14 @@ data Ctx = Ctx , ctxAwaitTxConfirmed :: !GYAwaitTx , ctxQueryUtxos :: !GYQueryUTxO , ctxGetParams :: !GYGetParameters + , ctxCommittee :: !CtxCommittee + } + +data CtxCommittee = CtxCommittee + { ctxCommitteeMembers :: !(Map (GYSigningKey 'GYKeyRoleColdCommittee) GYEpochNo) + -- ^ Committee members with epoch number when each of them expires + , ctxCommitteeThreshold :: !UnitInterval + -- ^ Threshold of the committee that is necessary for a successful vote } ctxNetworkId :: Ctx -> GYNetworkId diff --git a/src/GeniusYield/Test/Privnet/Setup.hs b/src/GeniusYield/Test/Privnet/Setup.hs index 5063a01e..b1594d80 100644 --- a/src/GeniusYield/Test/Privnet/Setup.hs +++ b/src/GeniusYield/Test/Privnet/Setup.hs @@ -24,6 +24,7 @@ module GeniusYield.Test.Privnet.Setup ( import Cardano.Api qualified as Api import Cardano.Api.Ledger +import Cardano.Ledger.Conway.Governance qualified as Ledger import Cardano.Ledger.Plutus qualified as Ledger import Cardano.Testnet import Control.Concurrent ( @@ -33,7 +34,7 @@ import Control.Concurrent ( ) import Control.Concurrent.STM qualified as STM import Control.Exception (finally) -import Control.Monad (forever) +import Control.Monad (forever, replicateM) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Resource ( MonadResource (liftResourceT), @@ -41,6 +42,7 @@ import Control.Monad.Trans.Resource ( ) import Data.Default (Default (..)) import Data.Default.Class qualified as DefaultClass +import Data.Map.Strict qualified as Map import Data.Text qualified as Txt import Data.Vector qualified as V import GeniusYield.Api.TestTokens qualified as GY.TestTokens @@ -56,7 +58,7 @@ import GeniusYield.TxBuilder import GeniusYield.Types import Hedgehog qualified as H import Hedgehog.Extras.Stock qualified as H' -import Test.Cardano.Ledger.Core.Rational ((%!)) +import Test.Cardano.Ledger.Core.Rational (unsafeBoundRational, (%!)) import Test.Tasty (TestName, TestTree) import Test.Tasty.HUnit (testCaseSteps) import Testnet.Property.Util @@ -125,51 +127,57 @@ debug :: String -> IO () -- debug = putStrLn debug _ = return () -conwayGenesis :: ConwayGenesis StandardCrypto -conwayGenesis = - let upPParams :: UpgradeConwayPParams Identity - upPParams = - UpgradeConwayPParams - { ucppPoolVotingThresholds = poolVotingThresholds - , ucppDRepVotingThresholds = drepVotingThresholds - , ucppCommitteeMinSize = 0 - , ucppCommitteeMaxTermLength = EpochInterval 200 - , ucppGovActionLifetime = EpochInterval 1 -- One Epoch - , ucppGovActionDeposit = Coin 1_000_000 - , ucppDRepDeposit = Coin 500_000_000 - , ucppDRepActivity = EpochInterval 100 - , ucppMinFeeRefScriptCostPerByte = 15 %! 1 - , ucppPlutusV3CostModel = either (error "Couldn't build PlutusV3 cost models") id $ Ledger.mkCostModel Ledger.PlutusV3 [100788, 420, 1, 1, 1000, 173, 0, 1, 1000, 59957, 4, 1, 11183, 32, 201305, 8356, 4, 16000, 100, 16000, 100, 16000, 100, 16000, 100, 16000, 100, 16000, 100, 100, 100, 16000, 100, 94375, 32, 132994, 32, 61462, 4, 72010, 178, 0, 1, 22151, 32, 91189, 769, 4, 2, 85848, 123203, 7305, -900, 1716, 549, 57, 85848, 0, 1, 1, 1000, 42921, 4, 2, 24548, 29498, 38, 1, 898148, 27279, 1, 51775, 558, 1, 39184, 1000, 60594, 1, 141895, 32, 83150, 32, 15299, 32, 76049, 1, 13169, 4, 22100, 10, 28999, 74, 1, 28999, 74, 1, 43285, 552, 1, 44749, 541, 1, 33852, 32, 68246, 32, 72362, 32, 7243, 32, 7391, 32, 11546, 32, 85848, 123203, 7305, -900, 1716, 549, 57, 85848, 0, 1, 90434, 519, 0, 1, 74433, 32, 85848, 123203, 7305, -900, 1716, 549, 57, 85848, 0, 1, 1, 85848, 123203, 7305, -900, 1716, 549, 57, 85848, 0, 1, 955506, 213312, 0, 2, 270652, 22588, 4, 1457325, 64566, 4, 20467, 1, 4, 0, 141992, 32, 100788, 420, 1, 1, 81663, 32, 59498, 32, 20142, 32, 24588, 32, 20744, 32, 25933, 32, 24623, 32, 43053543, 10, 53384111, 14333, 10, 43574283, 26308, 10, 16000, 100, 16000, 100, 962335, 18, 2780678, 6, 442008, 1, 52538055, 3756, 18, 267929, 18, 76433006, 8868, 18, 52948122, 18, 1995836, 36, 3227919, 12, 901022, 1, 166917843, 4307, 36, 284546, 36, 158221314, 26549, 36, 74698472, 36, 333849714, 1, 254006273, 72, 2174038, 72, 2261318, 64571, 4, 207616, 8310, 4, 1293828, 28716, 63, 0, 1, 1006041, 43623, 251, 0, 1] - } - drepVotingThresholds = - DRepVotingThresholds - { dvtMotionNoConfidence = 67 %! 100 - , dvtCommitteeNormal = 67 %! 100 - , dvtCommitteeNoConfidence = 6 %! 10 - , dvtUpdateToConstitution = 75 %! 100 - , dvtHardForkInitiation = 6 %! 10 - , dvtPPNetworkGroup = 67 %! 100 - , dvtPPEconomicGroup = 67 %! 100 - , dvtPPTechnicalGroup = 67 %! 100 - , dvtPPGovGroup = 75 %! 100 - , dvtTreasuryWithdrawal = 67 %! 100 - } - poolVotingThresholds = - PoolVotingThresholds - { pvtMotionNoConfidence = commonPoolVotingThreshold - , pvtCommitteeNormal = commonPoolVotingThreshold - , pvtCommitteeNoConfidence = commonPoolVotingThreshold - , pvtHardForkInitiation = commonPoolVotingThreshold - , pvtPPSecurityGroup = commonPoolVotingThreshold - } - commonPoolVotingThreshold = 51 %! 100 - in ConwayGenesis - { cgUpgradePParams = upPParams - , cgConstitution = DefaultClass.def - , cgCommittee = DefaultClass.def - , cgDelegs = mempty - , cgInitialDReps = mempty +conwayGenesis :: CtxCommittee -> ConwayGenesis StandardCrypto +conwayGenesis ctxCommittee = + let + upPParams :: UpgradeConwayPParams Identity + upPParams = + UpgradeConwayPParams + { ucppPoolVotingThresholds = poolVotingThresholds + , ucppDRepVotingThresholds = drepVotingThresholds + , ucppCommitteeMinSize = 0 + , ucppCommitteeMaxTermLength = EpochInterval 200 + , ucppGovActionLifetime = EpochInterval 1 -- One Epoch + , ucppGovActionDeposit = Coin 1_000_000 + , ucppDRepDeposit = Coin 500_000_000 + , ucppDRepActivity = EpochInterval 100 + , ucppMinFeeRefScriptCostPerByte = 15 %! 1 + , ucppPlutusV3CostModel = either (error "Couldn't build PlutusV3 cost models") id $ Ledger.mkCostModel Ledger.PlutusV3 [100788, 420, 1, 1, 1000, 173, 0, 1, 1000, 59957, 4, 1, 11183, 32, 201305, 8356, 4, 16000, 100, 16000, 100, 16000, 100, 16000, 100, 16000, 100, 16000, 100, 100, 100, 16000, 100, 94375, 32, 132994, 32, 61462, 4, 72010, 178, 0, 1, 22151, 32, 91189, 769, 4, 2, 85848, 123203, 7305, -900, 1716, 549, 57, 85848, 0, 1, 1, 1000, 42921, 4, 2, 24548, 29498, 38, 1, 898148, 27279, 1, 51775, 558, 1, 39184, 1000, 60594, 1, 141895, 32, 83150, 32, 15299, 32, 76049, 1, 13169, 4, 22100, 10, 28999, 74, 1, 28999, 74, 1, 43285, 552, 1, 44749, 541, 1, 33852, 32, 68246, 32, 72362, 32, 7243, 32, 7391, 32, 11546, 32, 85848, 123203, 7305, -900, 1716, 549, 57, 85848, 0, 1, 90434, 519, 0, 1, 74433, 32, 85848, 123203, 7305, -900, 1716, 549, 57, 85848, 0, 1, 1, 85848, 123203, 7305, -900, 1716, 549, 57, 85848, 0, 1, 955506, 213312, 0, 2, 270652, 22588, 4, 1457325, 64566, 4, 20467, 1, 4, 0, 141992, 32, 100788, 420, 1, 1, 81663, 32, 59498, 32, 20142, 32, 24588, 32, 20744, 32, 25933, 32, 24623, 32, 43053543, 10, 53384111, 14333, 10, 43574283, 26308, 10, 16000, 100, 16000, 100, 962335, 18, 2780678, 6, 442008, 1, 52538055, 3756, 18, 267929, 18, 76433006, 8868, 18, 52948122, 18, 1995836, 36, 3227919, 12, 901022, 1, 166917843, 4307, 36, 284546, 36, 158221314, 26549, 36, 74698472, 36, 333849714, 1, 254006273, 72, 2174038, 72, 2261318, 64571, 4, 207616, 8310, 4, 1293828, 28716, 63, 0, 1, 1006041, 43623, 251, 0, 1] + } + drepVotingThresholds = + DRepVotingThresholds + { dvtMotionNoConfidence = 67 %! 100 + , dvtCommitteeNormal = 67 %! 100 + , dvtCommitteeNoConfidence = 6 %! 10 + , dvtUpdateToConstitution = 75 %! 100 + , dvtHardForkInitiation = 6 %! 10 + , dvtPPNetworkGroup = 67 %! 100 + , dvtPPEconomicGroup = 67 %! 100 + , dvtPPTechnicalGroup = 67 %! 100 + , dvtPPGovGroup = 75 %! 100 + , dvtTreasuryWithdrawal = 67 %! 100 } + poolVotingThresholds = + PoolVotingThresholds + { pvtMotionNoConfidence = commonPoolVotingThreshold + , pvtCommitteeNormal = commonPoolVotingThreshold + , pvtCommitteeNoConfidence = commonPoolVotingThreshold + , pvtHardForkInitiation = commonPoolVotingThreshold + , pvtPPSecurityGroup = commonPoolVotingThreshold + } + commonPoolVotingThreshold = 51 %! 100 + in + ConwayGenesis + { cgUpgradePParams = upPParams + , cgConstitution = DefaultClass.def + , cgCommittee = + Ledger.Committee + { Ledger.committeeMembers = Map.map epochNoToLedger $ Map.mapKeys (\sk -> let vkh = verificationKeyHash $ getVerificationKey sk in credentialToLedger $ GYCredentialByKey vkh) $ ctxCommitteeMembers ctxCommittee + , Ledger.committeeThreshold = ctxCommitteeThreshold ctxCommittee + } + , cgDelegs = mempty + , cgInitialDReps = mempty + } {- | Spawn a resource managed privnet and do things with it (closing it in the end). @@ -183,6 +191,13 @@ given a logging -- function and the action itself (which receives the Privnet Ct -} withPrivnet :: (CardanoTestnetOptions, GenesisOptions) -> (Setup -> IO ()) -> IO () withPrivnet (testnetOpts, genesisOpts) setupUser = do + coldCommitteeMembers :: [GYSigningKey 'GYKeyRoleColdCommittee] <- replicateM 3 generateSigningKey + let ctxCommittee :: CtxCommittee + ctxCommittee = + CtxCommittee + { ctxCommitteeMembers = Map.fromList $ map (,GYEpochNo 100000000) coldCommitteeMembers + , ctxCommitteeThreshold = unsafeBoundRational 0.51 + } -- Based on: https://github.com/IntersectMBO/cardano-node/blob/master/cardano-testnet/src/Testnet/Property/Run.hs -- They are using hedgehog (property testing framework) to orchestrate a testnet running in the background -- ....for some god forsaken reason @@ -200,7 +215,7 @@ withPrivnet (testnetOpts, genesisOpts) setupUser = do , testnetNodes , testnetMagic } <- - cardanoTestnet' testnetOpts genesisOpts conf + cardanoTestnet' testnetOpts genesisOpts conf ctxCommittee liftIO . STM.atomically $ STM.writeTMVar @@ -314,6 +329,7 @@ withPrivnet (testnetOpts, genesisOpts) setupUser = do , ctxAwaitTxConfirmed = localAwaitTxConfirmed , ctxQueryUtxos = localQueryUtxo , ctxGetParams = localGetParams + , ctxCommittee } V.imapM_ @@ -354,11 +370,11 @@ withPrivnet (testnetOpts, genesisOpts) setupUser = do setupUser setup where -- \| This is defined same as `cardanoTestnetDefault` except we use our own conway genesis parameters. - cardanoTestnet' testnetOptions shelleyOptions conf = do + cardanoTestnet' testnetOptions shelleyOptions conf ctxCommittee = do Api.AnyShelleyBasedEra sbe <- pure cardanoNodeEra alonzoGenesis <- getDefaultAlonzoGenesis sbe shelleyGenesis <- getDefaultShelleyGenesis cardanoNodeEra cardanoMaxSupply shelleyOptions - cardanoTestnet testnetOptions conf shelleyGenesis alonzoGenesis conwayGenesis + cardanoTestnet testnetOptions conf shelleyGenesis alonzoGenesis (conwayGenesis ctxCommittee) where CardanoTestnetOptions {cardanoNodeEra, cardanoMaxSupply} = testnetOptions diff --git a/src/GeniusYield/Types.hs b/src/GeniusYield/Types.hs index 9e1aede6..9e962445 100644 --- a/src/GeniusYield/Types.hs +++ b/src/GeniusYield/Types.hs @@ -184,6 +184,7 @@ import GeniusYield.Types.Providers as X import GeniusYield.Types.PubKeyHash as X import GeniusYield.Types.Rational as X import GeniusYield.Types.Redeemer as X +import GeniusYield.Types.Reexpose as X import GeniusYield.Types.Script as X import GeniusYield.Types.Slot as X import GeniusYield.Types.SlotConfig as X diff --git a/src/GeniusYield/Types/Certificate.hs b/src/GeniusYield/Types/Certificate.hs index f3695004..59290e25 100644 --- a/src/GeniusYield/Types/Certificate.hs +++ b/src/GeniusYield/Types/Certificate.hs @@ -54,6 +54,8 @@ data GYCertificatePreBuild | GYDRepUnregistrationCertificatePB !(GYCredential 'GYKeyRoleDRep) !Natural | GYStakePoolRegistrationCertificatePB !GYPoolParams | GYStakePoolRetirementCertificatePB !(GYKeyHash 'GYKeyRoleStakePool) !GYEpochNo + | GYCommitteeHotKeyAuthCertificatePB !(GYCredential 'GYKeyRoleColdCommittee) !(GYCredential 'GYKeyRoleHotCommittee) + | GYCommitteeColdKeyResignationCertificatePB !(GYCredential 'GYKeyRoleColdCommittee) !(Maybe GYAnchor) deriving stock (Eq, Ord, Show) -- | Certificate state after populating missing entries from `GYCertificatePreBuild`. @@ -67,6 +69,8 @@ data GYCertificate | GYDRepUnregistrationCertificate !(GYCredential 'GYKeyRoleDRep) !Natural | GYStakePoolRegistrationCertificate !GYPoolParams | GYStakePoolRetirementCertificate !(GYKeyHash 'GYKeyRoleStakePool) !GYEpochNo + | GYCommitteeHotKeyAuthCertificate !(GYCredential 'GYKeyRoleColdCommittee) !(GYCredential 'GYKeyRoleHotCommittee) + | GYCommitteeColdKeyResignationCertificate !(GYCredential 'GYKeyRoleColdCommittee) !(Maybe GYAnchor) deriving stock (Eq, Ord, Show) -- FIXME: Stake address unregistration should make use of deposit that was actually used when registering earlier. @@ -81,6 +85,8 @@ finaliseCert pp = \case GYDRepUnregistrationCertificatePB cred dep -> GYDRepUnregistrationCertificate cred dep GYStakePoolRegistrationCertificatePB poolParams -> GYStakePoolRegistrationCertificate poolParams GYStakePoolRetirementCertificatePB poolId epoch -> GYStakePoolRetirementCertificate poolId epoch + GYCommitteeHotKeyAuthCertificatePB cold hot -> GYCommitteeHotKeyAuthCertificate cold hot + GYCommitteeColdKeyResignationCertificatePB cold manchor -> GYCommitteeColdKeyResignationCertificate cold manchor where Ledger.Coin ppDep = pp ^. Ledger.ppKeyDepositL ppDep' :: Natural = fromIntegral ppDep @@ -106,6 +112,8 @@ certificateToApi = \case GYDRepUnregistrationCertificate cred refund -> Api.makeDrepUnregistrationCertificate (Api.DRepUnregistrationRequirements Api.ConwayEraOnwardsConway (credentialToLedger cred) (fromIntegral refund)) GYStakePoolRegistrationCertificate poolParams -> Api.makeStakePoolRegistrationCertificate (Api.StakePoolRegistrationRequirementsConwayOnwards Api.ConwayEraOnwardsConway (poolParamsToLedger poolParams)) GYStakePoolRetirementCertificate poolId epoch -> Api.makeStakePoolRetirementCertificate (Api.StakePoolRetirementRequirementsConwayOnwards Api.ConwayEraOnwardsConway (keyHashToApi poolId) (epochNoToLedger epoch)) + GYCommitteeHotKeyAuthCertificate cold hot -> Api.makeCommitteeHotKeyAuthorizationCertificate (Api.CommitteeHotKeyAuthorizationRequirements Api.ConwayEraOnwardsConway (credentialToLedger cold) (credentialToLedger hot)) + GYCommitteeColdKeyResignationCertificate cold manchor -> Api.makeCommitteeColdkeyResignationCertificate (Api.CommitteeColdkeyResignationRequirements Api.ConwayEraOnwardsConway (credentialToLedger cold) (anchorToLedger <$> manchor)) where f = stakeCredentialToApi g = delegateeToLedger @@ -123,7 +131,8 @@ certificateFromApiMaybe (Api.ConwayCertificate _ x) = case x of Ledger.ConwayRegDRep cred dep manchor -> Just $ GYDRepRegistrationCertificate (fromIntegral dep) (credentialFromLedger cred) (Ledger.strictMaybeToMaybe (anchorFromLedger <$> manchor)) Ledger.ConwayUpdateDRep cred manchor -> Just $ GYDRepUpdateCertificate (credentialFromLedger cred) (Ledger.strictMaybeToMaybe (anchorFromLedger <$> manchor)) Ledger.ConwayUnRegDRep cred refund -> Just $ GYDRepUnregistrationCertificate (credentialFromLedger cred) (fromIntegral refund) - _anyOther -> Nothing + Ledger.ConwayAuthCommitteeHotKey cold hot -> Just $ GYCommitteeHotKeyAuthCertificate (credentialFromLedger cold) (credentialFromLedger hot) + Ledger.ConwayResignCommitteeColdKey cold manchor -> Just $ GYCommitteeColdKeyResignationCertificate (credentialFromLedger cold) (Ledger.strictMaybeToMaybe (anchorFromLedger <$> manchor)) Ledger.ConwayTxCertPool poolCert -> case poolCert of Ledger.RegPool poolParams -> Just $ GYStakePoolRegistrationCertificate (poolParamsFromLedger poolParams) Ledger.RetirePool poolId epoch -> Just $ GYStakePoolRetirementCertificate (keyHashFromLedger poolId) (epochNoFromLedger epoch) @@ -144,5 +153,7 @@ certificateToStakeCredential = \case GYDRepUnregistrationCertificate cred _ -> castCred cred GYStakePoolRegistrationCertificate GYPoolParams {poolId} -> castCred $ GYCredentialByKey poolId GYStakePoolRetirementCertificate poolId _ -> castCred $ GYCredentialByKey poolId + GYCommitteeHotKeyAuthCertificate cold _ -> castCred cold + GYCommitteeColdKeyResignationCertificate cold _ -> castCred cold where castCred cred = credentialToLedger cred & Ledger.coerceKeyRole & credentialFromLedger diff --git a/src/GeniusYield/Types/Pool.hs b/src/GeniusYield/Types/Pool.hs index bf2d9363..4db1c4bb 100644 --- a/src/GeniusYield/Types/Pool.hs +++ b/src/GeniusYield/Types/Pool.hs @@ -7,11 +7,6 @@ Stability : develop -} module GeniusYield.Types.Pool ( GYStakePoolRelay (..), - Port (..), - DnsName (..), - Network (..), - BoundedRational (..), - UnitInterval, GYPoolParams (..), poolParamsToLedger, poolParamsFromLedger, diff --git a/src/GeniusYield/Types/Reexpose.hs b/src/GeniusYield/Types/Reexpose.hs new file mode 100644 index 00000000..4eef3010 --- /dev/null +++ b/src/GeniusYield/Types/Reexpose.hs @@ -0,0 +1,16 @@ +{- | +Module : GeniusYield.Types.Reexpose +Copyright : (c) 2025 GYELD GMBH +License : Apache 2.0 +Maintainer : support@geniusyield.co +Stability : develop +-} +module GeniusYield.Types.Reexpose ( + Port (..), + DnsName (..), + Network (..), + BoundedRational (..), + UnitInterval, +) where + +import Cardano.Ledger.BaseTypes diff --git a/src/GeniusYield/Types/TxCert.hs b/src/GeniusYield/Types/TxCert.hs index 3f0a64c2..4093ace6 100644 --- a/src/GeniusYield/Types/TxCert.hs +++ b/src/GeniusYield/Types/TxCert.hs @@ -17,6 +17,8 @@ module GeniusYield.Types.TxCert ( mkDRepUnregistrationCertificate, mkStakePoolRegistrationCertificate, mkStakePoolRetirementCertificate, + mkCommitteeHotKeyAuthCertificate, + mkCommitteeColdKeyResignationCertificate, ) where import GeniusYield.Imports (Natural) @@ -104,3 +106,29 @@ Note that deposit made earlier is returned at epoch transition. -} mkStakePoolRetirementCertificate :: GYKeyHash 'GYKeyRoleStakePool -> GYEpochNo -> GYTxCert v mkStakePoolRetirementCertificate poolId epoch = GYTxCert (GYStakePoolRetirementCertificatePB poolId epoch) (Just GYTxCertWitnessKey) + +{- | Note that committee hot key auth certificate requires following preconditions: + +1. Cold key must not have resigned from the committee. + +2. Should be part of current committee or future committee as dictated by a governance action. + +3. Signature from the corresponding cold committee key. +-} +mkCommitteeHotKeyAuthCertificate :: GYCredential 'GYKeyRoleColdCommittee -> GYCredential 'GYKeyRoleHotCommittee -> GYTxCert v +mkCommitteeHotKeyAuthCertificate cold hot = GYTxCert (GYCommitteeHotKeyAuthCertificatePB cold hot) (Just GYTxCertWitnessKey) + +{- | Note that committee cold key resignation certificate requires following preconditions: + +1. Cold key must not have resigned from the committee. + +2. Should be part of current committee or future committee as dictated by a governance action. + +3. Signature from the corresponding cold committee key. +-} +mkCommitteeColdKeyResignationCertificate :: + GYCredential 'GYKeyRoleColdCommittee -> + -- | Potential explanation for resignation. + Maybe GYAnchor -> + GYTxCert v +mkCommitteeColdKeyResignationCertificate cold anchor = GYTxCert (GYCommitteeColdKeyResignationCertificatePB cold anchor) (Just GYTxCertWitnessKey) diff --git a/tests-privnet/GeniusYield/Test/Privnet/Committee.hs b/tests-privnet/GeniusYield/Test/Privnet/Committee.hs new file mode 100644 index 00000000..b9b45feb --- /dev/null +++ b/tests-privnet/GeniusYield/Test/Privnet/Committee.hs @@ -0,0 +1,48 @@ +module GeniusYield.Test.Privnet.Committee ( + committeeTests, +) where + +import Control.Lens ((^.)) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Set qualified as Set +import GeniusYield.Imports ((&)) +import GeniusYield.Test.Privnet.Asserts +import GeniusYield.Test.Privnet.Ctx +import GeniusYield.Test.Privnet.Setup +import GeniusYield.TxBuilder +import GeniusYield.Types +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCaseSteps) + +committeeTests :: Setup -> TestTree +committeeTests setup = + testGroup + "committeeTests" + [ testCaseSteps "able to authorize hot key & resign cold key" $ \info -> withSetup info setup $ \ctx -> do + exerciseCommittee ctx info + ] + +exerciseCommittee :: Ctx -> (String -> IO ()) -> IO () +exerciseCommittee ctx info = do + info "Generating a hot committee key" + hotSKey <- generateSigningKey @'GYKeyRoleHotCommittee + let hotCred = GYCredentialByKey $ verificationKeyHash $ getVerificationKey hotSKey + info $ "Generated hot key: " <> show hotSKey <> ", with corresponding credential: " <> show hotCred + let coldKey = ctxCommittee ctx & ctxCommitteeMembers & Map.findMin & fst + coldCred = GYCredentialByKey $ verificationKeyHash $ getVerificationKey coldKey + info $ "Cold key: " <> show coldKey <> ", with corresponding credential: " <> show coldCred + let fundUser = ctxUserF ctx + txId <- ctxRun ctx fundUser $ do + txBody <- buildTxBody $ mustHaveCertificate $ mkCommitteeHotKeyAuthCertificate coldCred hotCred + gyLogInfo' "" $ "txBody: " <> show txBody + submitTxBodyConfirmed txBody [GYSomeSigningKey $ userPaymentSKey fundUser, GYSomeSigningKey coldKey] + info $ "Successfully authorized hot key, with tx id: " <> show txId + + let anchor = GYAnchor (unsafeTextToUrl "https://www.geniusyield.io") (hashAnchorData "we are awesome") + info "Resigning cold key" + txIdUnreg <- ctxRun ctx fundUser $ do + txBody <- buildTxBody $ mustHaveCertificate $ mkCommitteeColdKeyResignationCertificate coldCred (Just anchor) + gyLogInfo' "" $ "txBody: " <> show txBody + submitTxBodyConfirmed txBody [GYSomeSigningKey $ userPaymentSKey fundUser, GYSomeSigningKey coldKey] + info $ "Successfully resigned cold key, with tx id: " <> show txIdUnreg diff --git a/tests-privnet/atlas-privnet-tests.hs b/tests-privnet/atlas-privnet-tests.hs index 0f0af238..71d420fd 100644 --- a/tests-privnet/atlas-privnet-tests.hs +++ b/tests-privnet/atlas-privnet-tests.hs @@ -16,6 +16,7 @@ import GeniusYield.CardanoApi.EraHistory import GeniusYield.Types import GeniusYield.Test.Privnet.Blueprint qualified +import GeniusYield.Test.Privnet.Committee qualified import GeniusYield.Test.Privnet.Ctx import GeniusYield.Test.Privnet.DRep qualified import GeniusYield.Test.Privnet.Examples qualified @@ -68,4 +69,5 @@ main = do , GeniusYield.Test.Privnet.SimpleScripts.simpleScriptsTests setup , GeniusYield.Test.Privnet.DRep.drepTests setup , GeniusYield.Test.Privnet.StakePool.stakePoolTests setup + , GeniusYield.Test.Privnet.Committee.committeeTests setup ]