Test: Add Conway governance tests

cardano-chain-gen/cardano-chain-gen.cabal

@@ -158,6 +158,7 @@ test-suite cardano-chain-gen
                         Test.Cardano.Db.Mock.Unit.Conway.CommandLineArg.ForceIndex
                         Test.Cardano.Db.Mock.Unit.Conway.Config.Parse
                         Test.Cardano.Db.Mock.Unit.Conway.Config.MigrateConsumedPruneTxOut
+                        Test.Cardano.Db.Mock.Unit.Conway.Governance
                         Test.Cardano.Db.Mock.Unit.Conway.InlineAndReference
                         Test.Cardano.Db.Mock.Unit.Conway.Other
                         Test.Cardano.Db.Mock.Unit.Conway.Plutus

cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway.hs

@@ -1,12 +1,15 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 
 module Cardano.Mock.Forging.Tx.Conway (
+  ConwayLedgerState,
   Babbage.TxOutScriptType (..),
   Babbage.DatumType (..),
   Babbage.ReferenceScript (..),
@@ -29,12 +32,17 @@ module Cardano.Mock.Forging.Tx.Conway (
   mkScriptDCertTx,
   mkMultiAssetsScriptTx,
   mkDepositTxPools,
+  mkRegisterDRepTx,
   mkDummyRegisterTx,
   mkDummyTxBody,
   mkTxDelegCert,
   mkRegTxCert,
   mkUnRegTxCert,
   mkDelegTxCert,
+  mkRegDelegTxCert,
+  mkAddCommitteeTx,
+  mkGovActionProposalTx,
+  mkGovVoteTx,
   Babbage.mkParamUpdateTx,
   mkFullTx,
   mkScriptMint',
@@ -51,10 +59,10 @@ import Cardano.Ledger.Alonzo.Scripts
 import Cardano.Ledger.Alonzo.Tx (IsValid (..))
 import Cardano.Ledger.Alonzo.TxAuxData (AlonzoTxAuxData (..), mkAlonzoTxAuxData)
 import Cardano.Ledger.Babbage.TxOut (BabbageEraTxOut, BabbageTxOut (..))
-import Cardano.Ledger.BaseTypes (EpochNo (..), Network (..))
+import Cardano.Ledger.BaseTypes
 import Cardano.Ledger.Binary (Sized (..))
 import Cardano.Ledger.Coin (Coin (..))
-import Cardano.Ledger.Conway.Governance (VotingProcedures (..))
+import qualified Cardano.Ledger.Conway.Governance as Governance
 import Cardano.Ledger.Conway.Scripts
 import Cardano.Ledger.Conway.Tx (AlonzoTx (..))
 import Cardano.Ledger.Conway.TxBody (ConwayTxBody (..))
@@ -85,7 +93,7 @@ import Cardano.Prelude
 import Data.List (nub)
 import qualified Data.List.NonEmpty as NonEmpty
 import qualified Data.Map as Map
-import Data.Maybe.Strict (StrictMaybe (..), maybeToStrictMaybe)
+import Data.Maybe (fromJust)
 import qualified Data.OSet.Strict as OSet
 import Data.Sequence.Strict (StrictSeq ())
 import qualified Data.Sequence.Strict as StrictSeq
@@ -128,7 +136,7 @@ consTxBody ins cols ref outs colOut fees minted certs withdrawals =
     , ctbScriptIntegrityHash = SNothing
     , ctbAdHash = SNothing
     , ctbTxNetworkId = SJust Testnet
-    , ctbVotingProcedures = VotingProcedures mempty
+    , ctbVotingProcedures = Governance.VotingProcedures mempty
     , ctbProposalProcedures = mempty
     , ctbCurrentTreasuryValue = SNothing
     , ctbTreasuryDonation = Coin 0
@@ -436,6 +444,14 @@ mkDepositTxPools inputIndex deposit state' = do
         (allPoolStakeCert' state')
         (Withdrawals mempty)
 
+mkRegisterDRepTx ::
+  Credential 'DRepRole StandardCrypto ->
+  Either ForgingError (AlonzoTx StandardConway)
+mkRegisterDRepTx cred = mkDCertTx [cert] (Withdrawals mempty) Nothing
+  where
+    cert = ConwayTxCertGov (ConwayRegDRep cred deposit SNothing)
+    deposit = Coin 500_000_000
+
 mkDummyRegisterTx :: Int -> Int -> Either ForgingError (AlonzoTx StandardConway)
 mkDummyRegisterTx n m = mkDCertTx consDelegCert (Withdrawals mempty) Nothing
   where
@@ -459,6 +475,14 @@ mkUnRegTxCert ::
   ConwayTxCert StandardConway
 mkUnRegTxCert coin' = mkTxDelegCert $ \cred -> ConwayUnRegCert cred coin'
 
+mkRegDelegTxCert ::
+  Coin ->
+  Delegatee StandardCrypto ->
+  StakeCredential StandardCrypto ->
+  ConwayTxCert StandardConway
+mkRegDelegTxCert deposit delegatee =
+  mkTxDelegCert $ \cred -> ConwayRegDelegCert cred delegatee deposit
+
 mkDelegTxCert ::
   Delegatee StandardCrypto ->
   StakeCredential StandardCrypto ->
@@ -471,6 +495,52 @@ mkTxDelegCert ::
   ConwayTxCert StandardConway
 mkTxDelegCert f = ConwayTxCertDeleg . f
 
+mkAddCommitteeTx ::
+  Credential 'ColdCommitteeRole StandardCrypto ->
+  AlonzoTx StandardConway
+mkAddCommitteeTx cred = mkGovActionProposalTx govAction
+  where
+    govAction = Governance.UpdateCommittee SNothing mempty newMembers threshold
+    newMembers = Map.singleton cred (EpochNo 20)
+    threshold = fromJust $ boundRational (1 % 1)
+
+mkGovActionProposalTx ::
+  Governance.GovAction StandardConway ->
+  AlonzoTx StandardConway
+mkGovActionProposalTx govAction = mkSimpleTx True txBody
+  where
+    txBody = mkDummyTxBody {ctbProposalProcedures = OSet.singleton proposal}
+
+    proposal =
+      Governance.ProposalProcedure
+        { Governance.pProcDeposit = Coin 50_000_000_000
+        , Governance.pProcReturnAddr =
+            RewardAccount Testnet (Prelude.head unregisteredStakeCredentials)
+        , Governance.pProcGovAction = govAction
+        , Governance.pProcAnchor = anchor
+        }
+
+    anchor =
+      Governance.Anchor
+        { Governance.anchorUrl = fromJust (textToUrl 64 "best.cc")
+        , Governance.anchorDataHash = hashAnchorData (Governance.AnchorData mempty)
+        }
+
+mkGovVoteTx ::
+  Governance.GovActionId StandardCrypto ->
+  [Governance.Voter StandardCrypto] ->
+  AlonzoTx StandardConway
+mkGovVoteTx govAction voters = mkSimpleTx True txBody
+  where
+    txBody = mkDummyTxBody {ctbVotingProcedures = Governance.VotingProcedures votes}
+    votes = Map.fromList . map (,govActionVote) $ voters
+    govActionVote = Map.singleton govAction vote
+    vote =
+      Governance.VotingProcedure
+        { Governance.vProcVote = Governance.VoteYes
+        , Governance.vProcAnchor = SNothing
+        }
+
 mkDummyTxBody :: ConwayTxBody StandardConway
 mkDummyTxBody =
   consTxBody
@@ -535,7 +605,7 @@ mkFullTx n m state' = do
         , ctbScriptIntegrityHash = SNothing
         , ctbAdHash = SNothing
         , ctbTxNetworkId = SJust Testnet
-        , ctbVotingProcedures = VotingProcedures mempty
+        , ctbVotingProcedures = Governance.VotingProcedures mempty
         , ctbProposalProcedures = mempty
         , ctbCurrentTreasuryValue = SNothing
         , ctbTreasuryDonation = Coin 0

cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway/Scenarios.hs

@@ -1,16 +1,22 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE TypeFamilies #-}
 
 module Cardano.Mock.Forging.Tx.Conway.Scenarios (
   delegateAndSendBlocks,
+  registerDRepsAndDelegateVotes,
 ) where
 
 import Cardano.Ledger.Address (Addr (..), Withdrawals (..))
+import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..))
 import Cardano.Ledger.BaseTypes (Network (..))
 import Cardano.Ledger.Coin
 import Cardano.Ledger.Conway.TxCert (Delegatee (..))
 import Cardano.Ledger.Core (Tx ())
-import Cardano.Ledger.Credential (StakeCredential (), StakeReference (..))
+import Cardano.Ledger.Credential (Credential (..), StakeCredential (), StakeReference (..))
 import Cardano.Ledger.Crypto (StandardCrypto ())
+import Cardano.Ledger.DRep (DRep (..))
+import Cardano.Ledger.Keys (KeyRole (..))
 import Cardano.Ledger.Mary.Value (MaryValue (..))
 import Cardano.Mock.Forging.Interpreter
 import qualified Cardano.Mock.Forging.Tx.Conway as Conway
@@ -22,7 +28,7 @@ import Data.Maybe.Strict (StrictMaybe (..))
 import Ouroboros.Consensus.Cardano.Block (LedgerState (..))
 import Ouroboros.Consensus.Shelley.Eras (StandardConway ())
 import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock ())
-import Prelude ()
+import qualified Prelude
 
 newtype ShelleyLedgerState era = ShelleyLedgerState
   {unState :: LedgerState (ShelleyBlock PraosStandard era)}
@@ -81,3 +87,31 @@ forgeBlocksChunked interpreter vs f = forM (chunksOf 500 vs) $ \blockCreds -> do
     forM (chunksOf 10 blockCreds) $ \txCreds ->
       f txCreds (ShelleyLedgerState state')
   forgeNextFindLeader interpreter (TxConway <$> blockTxs)
+
+registerDRepsAndDelegateVotes :: Interpreter -> IO CardanoBlock
+registerDRepsAndDelegateVotes interpreter = do
+  blockTxs <-
+    withConwayLedgerState interpreter $
+      registerDRepAndDelegateVotes'
+        (Prelude.head unregisteredDRepIds)
+        (StakeIndex 4)
+
+  forgeNextFindLeader interpreter (map TxConway blockTxs)
+
+registerDRepAndDelegateVotes' ::
+  Credential 'DRepRole StandardCrypto ->
+  StakeIndex ->
+  Conway.ConwayLedgerState ->
+  Either ForgingError [AlonzoTx StandardConway]
+registerDRepAndDelegateVotes' drepId stakeIx ledger = do
+  stakeCreds <- resolveStakeCreds stakeIx ledger
+
+  let utxoStake = UTxOAddressNewWithStake 0 stakeIx
+      regDelegCert =
+        Conway.mkDelegTxCert (DelegVote $ DRepCredential drepId) stakeCreds
+
+  paymentTx <- Conway.mkPaymentTx (UTxOIndex 0) utxoStake 10_000 500 ledger
+  regTx <- Conway.mkRegisterDRepTx drepId
+  delegTx <- Conway.mkDCertTx [regDelegCert] (Withdrawals mempty) Nothing
+
+  pure [paymentTx, regTx, delegTx]

cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Generic.hs

@@ -24,6 +24,8 @@ module Cardano.Mock.Forging.Tx.Generic (
   unregisteredPools,
   registeredByronGenesisKeys,
   registeredShelleyGenesisKeys,
+  bootstrapCommitteeCreds,
+  unregisteredDRepIds,
   consPoolParams,
   getPoolStakeCreds,
 ) where
@@ -262,6 +264,18 @@ registeredShelleyGenesisKeys =
   , KeyHash "471cc34983f6a2fd7b4018e3147532185d69a448d6570d46019e58e6"
   ]
 
+bootstrapCommitteeCreds :: [Credential 'ColdCommitteeRole StandardCrypto]
+bootstrapCommitteeCreds =
+  [ KeyHashObj $ KeyHash "2c698e41831684b16477fb50082b0c0e396d436504e39037d5366582"
+  , KeyHashObj $ KeyHash "8fc13431159fdda66347a38c55105d50d77d67abc1c368b876d52ad1"
+  , KeyHashObj $ KeyHash "921e1ccb4812c4280510c9ccab81c561f3d413e7d744d48d61215d1f"
+  , KeyHashObj $ KeyHash "d5d09d9380cf9dcde1f3c6cd88b08ca9e00a3d550022ca7ee4026342"
+  ]
+
+unregisteredDRepIds :: [Credential 'DRepRole StandardCrypto]
+unregisteredDRepIds =
+  [KeyHashObj $ KeyHash "0d94e174732ef9aae73f395ab44507bfa983d65023c11a951f0c32e4"]
+
 createStakeCredentials :: Int -> [StakeCredential StandardCrypto]
 createStakeCredentials n =
   fmap (KeyHashObj . KeyHash . mkDummyHash (Proxy @(ADDRHASH StandardCrypto))) [1 .. n]

cardano-chain-gen/src/Cardano/Mock/Query.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Cardano.Mock.Query (
@@ -6,10 +7,12 @@ module Cardano.Mock.Query (
   queryNullTxDepositExists,
   queryMultiAssetCount,
   queryTxMetadataCount,
+  queryDRepDistrAmount,
+  queryGovActionCounts,
 ) where
 
 import qualified Cardano.Db as Db
-import Cardano.Prelude hiding (from)
+import Cardano.Prelude hiding (from, on)
 import Database.Esqueleto.Experimental
 import Prelude ()
 
@@ -68,3 +71,46 @@ queryTxMetadataCount = do
     pure countRows
 
   pure $ maybe 0 unValue res
+
+queryDRepDistrAmount ::
+  MonadIO io =>
+  ByteString ->
+  Word64 ->
+  ReaderT SqlBackend io Word64
+queryDRepDistrAmount drepHash epochNo = do
+  res <- selectOne $ do
+    (distr :& hash) <-
+      from
+        $ table @Db.DrepDistr
+          `innerJoin` table @Db.DrepHash
+        `on` (\(distr :& hash) -> (hash ^. Db.DrepHashId) ==. (distr ^. Db.DrepDistrHashId))
+
+    where_ $ hash ^. Db.DrepHashRaw ==. just (val drepHash)
+    where_ $ distr ^. Db.DrepDistrEpochNo ==. val epochNo
+
+    pure (distr ^. Db.DrepDistrAmount)
+
+  pure $ maybe 0 unValue res
+
+queryGovActionCounts ::
+  MonadIO io =>
+  ReaderT SqlBackend io (Word, Word, Word, Word)
+queryGovActionCounts = do
+  ratified <- countNonNulls Db.GovActionProposalRatifiedEpoch
+  enacted <- countNonNulls Db.GovActionProposalEnactedEpoch
+  dropped <- countNonNulls Db.GovActionProposalDroppedEpoch
+  expired <- countNonNulls Db.GovActionProposalExpiredEpoch
+
+  pure (ratified, enacted, dropped, expired)
+  where
+    countNonNulls ::
+      (MonadIO io, PersistField field) =>
+      EntityField Db.GovActionProposal (Maybe field) ->
+      ReaderT SqlBackend io Word
+    countNonNulls field = do
+      res <- selectOne $ do
+        e <- from $ table @Db.GovActionProposal
+        where_ $ not_ (isNothing_ (e ^. field))
+        pure countRows
+
+      pure (maybe 0 unValue res)

cardano-chain-gen/test/Test/Cardano/Db/Mock/UnifiedApi.hs

@@ -21,12 +21,14 @@ module Test.Cardano.Db.Mock.UnifiedApi (
   fillEpochPercentage,
   rollbackTo,
   registerAllStakeCreds,
+  registerDRepsAndDelegateVotes,
 ) where
 
 import Cardano.Ledger.Alonzo (AlonzoEra)
 import qualified Cardano.Ledger.Core as Core
 import Cardano.Mock.ChainSync.Server
 import Cardano.Mock.Forging.Interpreter
+import qualified Cardano.Mock.Forging.Tx.Conway.Scenarios as Conway
 import Cardano.Mock.Forging.Types
 import Cardano.Slotting.Slot (SlotNo (..))
 import Control.Concurrent.Class.MonadSTM.Strict (atomically)
@@ -207,6 +209,12 @@ registerAllStakeCreds interpreter mockServer = do
   atomically $ addBlock mockServer blk
   pure blk
 
+registerDRepsAndDelegateVotes :: Interpreter -> ServerHandle IO CardanoBlock -> IO CardanoBlock
+registerDRepsAndDelegateVotes interpreter mockServer = do
+  blk <- Conway.registerDRepsAndDelegateVotes interpreter
+  atomically (addBlock mockServer blk)
+  pure blk
+
 -- Expected number. This should be taken from the parameters, instead of hardcoded.
 blocksPerEpoch :: Int
 blocksPerEpoch = 100

cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway.hs

@@ -7,6 +7,7 @@ import qualified Test.Cardano.Db.Mock.Unit.Conway.CommandLineArg.EpochDisabled a
 import qualified Test.Cardano.Db.Mock.Unit.Conway.CommandLineArg.ForceIndex as ForceIndex
 import qualified Test.Cardano.Db.Mock.Unit.Conway.Config.MigrateConsumedPruneTxOut as MigrateConsumedPruneTxOut
 import qualified Test.Cardano.Db.Mock.Unit.Conway.Config.Parse as Config
+import qualified Test.Cardano.Db.Mock.Unit.Conway.Governance as Governance
 import qualified Test.Cardano.Db.Mock.Unit.Conway.InlineAndReference as InlineRef
 import qualified Test.Cardano.Db.Mock.Unit.Conway.Other as Other
 import qualified Test.Cardano.Db.Mock.Unit.Conway.Plutus as Plutus
@@ -214,6 +215,11 @@ unitTests iom knownMigrations =
         , test "fork from Babbage to Conway and rollback" Other.rollbackFork
         , test "fork with protocol change proposal" Other.forkParam
         ]
+    , testGroup
+        "Governance"
+        [ test "drep distribution" Governance.drepDistr
+        , test "new committee member" Governance.newCommittee
+        ]
     ]
   where
     test :: String -> (IOManager -> [(Text, Text)] -> Assertion) -> TestTree