test(cardano-chain-gen): Add a more realistic hard-fork test

Create a hard fork test from Babbage -> Conway by using a parameter
update proposal, rather than hardcoding the epoch number

Author: sgillespie

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

@@ -4,6 +4,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeOperators #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
@@ -44,6 +45,7 @@ module Cardano.Mock.Forging.Tx.Babbage (
   mkWitnesses,
   mkUTxOBabbage,
   mkUTxOCollBabbage,
+  mkParamUpdateTx,
   mkFullTx,
   emptyTxBody,
   emptyTx,
@@ -90,6 +92,7 @@ import Lens.Micro
 import Ouroboros.Consensus.Cardano.Block (LedgerState)
 import Ouroboros.Consensus.Shelley.Eras (StandardBabbage, StandardCrypto)
 import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock)
+import Prelude hiding (map)
 
 type BabbageUTxOIndex = UTxOIndex StandardBabbage
 
@@ -515,6 +518,37 @@ emptyTx =
     , auxiliaryData = maybeToStrictMaybe Nothing
     }
 
+mkParamUpdateTx :: Either ForgingError (AlonzoTx StandardBabbage)
+mkParamUpdateTx = Right (mkSimpleTx True txBody)
+  where
+    txBody =
+      BabbageTxBody
+        { btbInputs = mempty
+        , btbCollateral = mempty
+        , btbReferenceInputs = mempty
+        , btbOutputs = mempty
+        , btbCollateralReturn = SNothing
+        , btbTotalCollateral = SNothing
+        , btbCerts = mempty
+        , btbWithdrawals = Withdrawals mempty
+        , btbTxFee = Coin 0
+        , btbValidityInterval = ValidityInterval SNothing SNothing
+        , btbUpdate = SJust $ Update update (EpochNo 1)
+        , btbReqSignerHashes = mempty
+        , btbMint = mempty
+        , btbScriptIntegrityHash = SNothing
+        , btbAuxDataHash = SNothing
+        , btbTxNetworkId = SJust Testnet
+        }
+    update =
+      ProposedPPUpdates $
+        Map.fromList $
+          map (,paramsUpdate) registeredShelleyGenesisKeys
+    paramsUpdate =
+      Core.emptyPParamsUpdate
+        & ppuProtocolVersionL
+          .~ SJust (ProtVer (natVersion @9) 0)
+
 mkFullTx ::
   Int ->
   Integer ->

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

@@ -32,6 +32,7 @@ module Cardano.Mock.Forging.Tx.Conway (
   mkRegTxCert,
   mkUnRegTxCert,
   mkDelegTxCert,
+  Babbage.mkParamUpdateTx,
   mkFullTx,
   mkScriptMint,
   Babbage.mkScriptInp,

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

@@ -22,6 +22,8 @@ module Cardano.Mock.Forging.Tx.Generic (
   unregisteredAddresses,
   unregisteredStakeCredentials,
   unregisteredPools,
+  registeredByronGenesisKeys,
+  registeredShelleyGenesisKeys,
   consPoolParams,
   getPoolStakeCreds,
 ) where
@@ -249,6 +251,17 @@ unregisteredGenesisKeys =
   , KeyHash "33323876542397465497834256329487563428975634827956348975"
   ]
 
+registeredByronGenesisKeys :: [KeyHash 'Genesis StandardCrypto]
+registeredByronGenesisKeys =
+  [ KeyHash "1a3e49767796fd99b057ad54db3310fd640806fcb0927399bbca7b43"
+  ]
+
+registeredShelleyGenesisKeys :: [KeyHash 'Genesis StandardCrypto]
+registeredShelleyGenesisKeys =
+  [ KeyHash "30c3083efd794227fde2351a04500349d1b467556c30e35d6794a501"
+  , KeyHash "471cc34983f6a2fd7b4018e3147532185d69a448d6570d46019e58e6"
+  ]
+
 createStakeCredentials :: Int -> [StakeCredential StandardCrypto]
 createStakeCredentials n =
   fmap (KeyHashObj . KeyHash . mkDummyHash (Proxy @(ADDRHASH StandardCrypto))) [1 .. n]

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

@@ -202,6 +202,7 @@ unitTests iom knownMigrations =
         "Hard Fork"
         [ test "fork from Babbage to Conway fixed epoch" Other.forkFixedEpoch
         , test "fork from Babbage to Conway and rollback" Other.rollbackFork
+        , test "fork with protocol change proposal" Other.forkParam
         ]
     ]
   where

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

@@ -1,5 +1,10 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ExplicitNamespaces #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Test.Cardano.Db.Mock.Unit.Conway.Other (
   -- * Different configs
@@ -16,25 +21,47 @@ module Test.Cardano.Db.Mock.Unit.Conway.Other (
   -- * Hard fork
   forkFixedEpoch,
   rollbackFork,
+  forkParam,
 ) where
 
+import Cardano.Db (
+  EntityField (
+    EpochParamEpochNo,
+    EpochParamProtocolMajor,
+    ParamProposalEpochNo,
+    ParamProposalProtocolMajor
+  ),
+  EpochParam (),
+  ParamProposal (),
+ )
 import Cardano.DbSync.Era.Shelley.Generic.Util (unKeyHashRaw)
-import Cardano.Ledger.BaseTypes (EpochNo ())
+import Cardano.Ledger.BaseTypes (EpochNo (..))
 import Cardano.Ledger.Conway.TxCert (ConwayTxCert (..))
 import Cardano.Ledger.Core (PoolCert (..))
 import Cardano.Ledger.Credential (StakeCredential ())
 import Cardano.Ledger.Crypto (StandardCrypto ())
 import Cardano.Ledger.Keys (KeyHash (), KeyRole (..))
 import Cardano.Mock.ChainSync.Server (IOManager (), addBlock, rollback)
-import Cardano.Mock.Forging.Interpreter (forgeNext)
+import Cardano.Mock.Forging.Interpreter (Interpreter (), forgeNext, getCurrentEpoch)
 import qualified Cardano.Mock.Forging.Tx.Babbage as Babbage
 import qualified Cardano.Mock.Forging.Tx.Conway as Conway
 import Cardano.Mock.Forging.Tx.Generic (resolvePool)
 import Cardano.Mock.Forging.Types
-import Cardano.Prelude
+import Cardano.Prelude hiding (from)
 import Cardano.SMASH.Server.PoolDataLayer (PoolDataLayer (..), dbToServantPoolId)
 import Cardano.SMASH.Server.Types (DBFail (..))
 import Data.List (last)
+import Database.Esqueleto.Experimental (
+  from,
+  selectOne,
+  table,
+  unValue,
+  val,
+  where_,
+  (==.),
+  (^.),
+ )
+import Database.Persist.Sql (SqlBackend ())
 import Ouroboros.Consensus.Shelley.Eras (StandardConway ())
 import Ouroboros.Network.Block (blockPoint)
 import Test.Cardano.Db.Mock.Config
@@ -436,3 +463,90 @@ rollbackFork =
   where
     configDir = "config-conway-hf-epoch1"
     testLabel = "conwayRollbackFork"
+
+forkParam :: IOManager -> [(Text, Text)] -> Assertion
+forkParam =
+  withFullConfig configDir testLabel $ \interpreter mockServer dbSync -> do
+    startDBSync dbSync
+
+    -- Forge a block with stake credentials
+    void $ Api.registerAllStakeCreds interpreter mockServer
+    -- Protocol params aren't added to the DB until the following epoch
+    epoch0 <- Api.fillUntilNextEpoch interpreter mockServer
+    -- Wait for it to sync
+    assertBlockNoBackoff dbSync (1 + length epoch0)
+    -- Protocol major version should still match config
+    assertEqBackoff
+      dbSync
+      (queryCurrentMajVer interpreter)
+      (Just 7)
+      []
+      "Unexpected protocol major version"
+
+    -- Propose a parameter update
+    void $
+      Api.withBabbageFindLeaderAndSubmitTx interpreter mockServer $
+        const Babbage.mkParamUpdateTx
+    -- Wait for it to sync
+    assertBlockNoBackoff dbSync (2 + length epoch0)
+    -- Query protocol param proposals
+    assertEqBackoff
+      dbSync
+      (queryMajVerProposal interpreter)
+      (Just 9)
+      []
+      "Unexpected protocol major version proposal"
+
+    -- The fork will be applied on the first block of the next epoch
+    epoch1 <- Api.fillUntilNextEpoch interpreter mockServer
+    -- Wait for it to sync
+    assertBlockNoBackoff dbSync $ 2 + length (epoch0 <> epoch1)
+    -- Protocol major version should now be updated
+    assertEqBackoff
+      dbSync
+      (queryCurrentMajVer interpreter)
+      (Just 9)
+      []
+      "Unexpected protocol major version"
+
+    -- Add a simple Conway tx
+    void $
+      Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $
+        Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 500
+    -- Wait for it to sync
+    assertBlockNoBackoff dbSync $ 3 + length (epoch0 <> epoch1)
+  where
+    testLabel = "conwayForkParam"
+    configDir = babbageConfigDir
+
+    queryCurrentMajVer ::
+      MonadIO m =>
+      Interpreter ->
+      ReaderT SqlBackend m (Maybe Word16)
+    queryCurrentMajVer interpreter = do
+      -- Look up current epoch from ledger
+      EpochNo currentEpoch <- liftIO $ getCurrentEpoch interpreter
+
+      -- Query epoch params from database
+      res <- selectOne $ do
+        param <- from $ table @EpochParam
+        where_ (param ^. EpochParamEpochNo ==. val currentEpoch)
+        pure (param ^. EpochParamProtocolMajor)
+
+      pure $ unValue <$> res
+
+    queryMajVerProposal ::
+      MonadIO m =>
+      Interpreter ->
+      ReaderT SqlBackend m (Maybe Word16)
+    queryMajVerProposal interpreter = do
+      -- Look up current epoch from ledger
+      EpochNo currentEpoch <- liftIO $ getCurrentEpoch interpreter
+
+      -- Query proposals from database
+      res <- selectOne $ do
+        prop <- from $ table @ParamProposal
+        where_ $ prop ^. ParamProposalEpochNo ==. val (Just currentEpoch)
+        pure (prop ^. ParamProposalProtocolMajor)
+
+      pure $ join (unValue <$> res)

cardano-chain-gen/test/testfiles/config/genesis.json

@@ -2,7 +2,7 @@
     "maxLovelaceSupply": 60000000,
     "securityParam": 10,
     "slotsPerKESPeriod": 129600,
-    "updateQuorum": 5,
+    "updateQuorum": 2,
     "activeSlotsCoeff": 0.2,
     "protocolParams": {
         "minUTxOValue": 0,
@@ -43,7 +43,16 @@
     },
     "networkId": "Testnet",
     "maxKESEvolutions": 60,
-    "genDelegs": { },
+    "genDelegs": {
+        "30c3083efd794227fde2351a04500349d1b467556c30e35d6794a501": {
+            "delegate": "3af50e522694318e8856d34021140817aa21d47ff62a4d0ddcba1924",
+            "vrf": "2846ed605f6629976ec92e9e65140c1cb3a95c563c996592c926a2ae7e5a461f"
+        },
+        "471cc34983f6a2fd7b4018e3147532185d69a448d6570d46019e58e6": {
+            "delegate": "1683652d05e83e25eb648a9543db33cf8ff1f7a2af9129d3a901dd4a",
+            "vrf": "4df7c5a5b30469756bd09db60cbe9b0cf1b2447e0c41122d130768c179b7d166"
+        }
+    },
     "slotLength": 1,
     "systemStart": "2021-11-18T20:22:02Z",
     "epochLength": 500,
@@ -106,4 +115,4 @@
             "95be61304693df94ba89ff989e6542f174bb10d5ff49e8e8b1292519": "9f1b441b9b781b3c3abb43b25679dc17dbaaf116dddca1ad09dc1de0"
         }
     }
-}
+}

cardano-chain-gen/test/testfiles/fingerprint/conwayForkParam

@@ -0,0 +1 @@
+[2,7,10,12,19,24,26,27,35,37,39,61,70,74,75,84,99,101,103,112,120,125,136,137,138,141,146,151,166,180,188,205,207,215,216,226,234,235,246,253,261,272,275,279,284,285,287,299,307,311,314,315,318,321,341,345,353,355,361,362,366,367,372,377,379,389,391,393,396,401,403,410,427,435,455,460,465,470,484,486,487,488,497,499,506,510,511,512,516,519,520,523,530,532,537,540,550,558,559,571,579,581,583,600,604,605,607,610,613,621,630,631,651,658,665,669,678,679,687,692,693,696,698,699,712,725,728,742,758,765,774,775,778,787,789,792,794,796,801,804,808,815,816,818,821,828,837,841,842,851,853,863,866,873,880,883,885,886,896,901,903,904,909,911,914,915,918,920,927,931,932,938,949,956,966,976,981,983,988,994,996,999,1000,1002]