Control block forging through NodeKernel

ouroboros-consensus-cardano/changelog.d/20230612_125709_armandoifsantos_dynamic_block_forging.md

@@ -0,0 +1,24 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+-->
+
+<!--
+### Patch
+
+- A bullet item for the Patch category.
+
+-->
+
+### Non-Breaking
+
+- Refactor code because block forging credentials got extracted out of
+  `ProtocolInfo` type.
+
+### Breaking
+
+- Change the return type of numerous functions to include block forging credentials since
+  they got extracted out of `ProtocolInfo` type.
+  - Refactor the type signatures to accommodate the fact that `ProtocolInfo` does not
+  need monad type variable.

ouroboros-consensus-cardano/src/byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs

@@ -82,9 +82,11 @@ protocolInfoDualByron :: forall m. Monad m
                       => ByronSpecGenesis
                       -> PBftParams
                       -> [CoreNodeId] -- ^ Are we a core node?
-                      -> ProtocolInfo m DualByronBlock
+                      -> ( ProtocolInfo DualByronBlock
+                         , m [BlockForging m DualByronBlock]
+                         )
 protocolInfoDualByron abstractGenesis@ByronSpecGenesis{..} params credss =
-    ProtocolInfo {
+    ( ProtocolInfo {
         pInfoConfig = TopLevelConfig {
             topLevelConfigProtocol = PBftConfig {
                 pbftParams = params
@@ -114,9 +116,9 @@ protocolInfoDualByron abstractGenesis@ByronSpecGenesis{..} params credss =
                }
            , headerState = genesisHeaderState S.empty
            }
-      , pInfoBlockForging =
-           return $ dualByronBlockForging . byronLeaderCredentials <$> credss
       }
+    , return $ dualByronBlockForging . byronLeaderCredentials <$> credss
+    )
   where
     initUtxo :: Impl.UTxO
     txIdMap  :: Map Spec.TxId Impl.TxId

ouroboros-consensus-cardano/src/byron-testlib/Test/ThreadNet/Infra/Byron/ProtocolInfo.hs

@@ -19,6 +19,7 @@ import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (fromMaybe)
 import           GHC.Stack (HasCallStack)
+import           Ouroboros.Consensus.Block.Forging (BlockForging)
 import           Ouroboros.Consensus.Byron.Crypto.DSIGN (ByronDSIGN,
                      SignKeyDSIGN (..))
 import           Ouroboros.Consensus.Byron.Ledger (ByronBlock)
@@ -34,11 +35,11 @@ mkProtocolByron ::
   -> CoreNodeId
   -> Genesis.Config
   -> Genesis.GeneratedSecrets
-  -> (ProtocolInfo m ByronBlock, SignKeyDSIGN ByronDSIGN)
+  -> (ProtocolInfo ByronBlock, [BlockForging m ByronBlock], SignKeyDSIGN ByronDSIGN)
      -- ^ We return the signing key which is needed in some tests, because it
      -- cannot easily be extracted from the 'ProtocolInfo'.
 mkProtocolByron params coreNodeId genesisConfig genesisSecrets =
-    (protocolInfo, signingKey)
+    (protocolInfo, blockForging, signingKey)
   where
     leaderCredentials :: ByronLeaderCredentials
     leaderCredentials =
@@ -52,9 +53,14 @@ mkProtocolByron params coreNodeId genesisConfig genesisSecrets =
 
     PBftParams { pbftSignatureThreshold } = params
 
-    protocolInfo :: ProtocolInfo m ByronBlock
-    protocolInfo =
-        protocolInfoByron $ ProtocolParamsByron {
+    protocolInfo :: ProtocolInfo ByronBlock
+    protocolInfo = protocolInfoByron protocolParams
+
+    blockForging :: [BlockForging m ByronBlock]
+    blockForging = blockForgingByron protocolParams
+
+    protocolParams :: ProtocolParamsByron
+    protocolParams = ProtocolParamsByron {
             byronGenesis                = genesisConfig
           , byronPbftSignatureThreshold = Just $ pbftSignatureThreshold
           , byronProtocolVersion        = theProposedProtocolVersion

ouroboros-consensus-cardano/src/byron-testlib/Test/ThreadNet/Infra/Byron/TrackUpdates.hs

@@ -374,14 +374,16 @@ mkProtocolByronAndHardForkTxs
     TestNodeInitialization
       { tniCrucialTxs   = proposals ++ votes
       , tniProtocolInfo = pInfo
+      , tniBlockForging = pure blockForging
       }
   where
     ProtocolInfo{pInfoConfig} = pInfo
     bcfg = configBlock pInfoConfig
 
-    pInfo :: ProtocolInfo m ByronBlock
+    pInfo :: ProtocolInfo ByronBlock
+    blockForging :: [BlockForging m ByronBlock]
     opKey :: Crypto.SigningKey
-    (pInfo, Crypto.SignKeyByronDSIGN opKey) =
+    (pInfo, blockForging, Crypto.SignKeyByronDSIGN opKey) =
         mkProtocolByron params cid genesisConfig genesisSecrets
 
     proposals :: [Byron.GenTx ByronBlock]
@@ -431,9 +433,10 @@ mkHardForkProposal params genesisConfig genesisSecrets propPV =
       propBody
       (Crypto.noPassSafeSigner opKey)
   where
-    pInfo :: ProtocolInfo Identity ByronBlock
+    pInfo :: ProtocolInfo ByronBlock
+    _blockForging :: [BlockForging Identity ByronBlock]
     opKey :: Crypto.SigningKey
-    (pInfo, Crypto.SignKeyByronDSIGN opKey) =
+    (pInfo, _blockForging, Crypto.SignKeyByronDSIGN opKey) =
         mkProtocolByron params (CoreNodeId 0) genesisConfig genesisSecrets
 
     ProtocolInfo{pInfoConfig} = pInfo

ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs

@@ -9,6 +9,7 @@
 module Ouroboros.Consensus.Byron.Node (
     PBftSignatureThreshold (..)
   , ProtocolParamsByron (..)
+  , blockForgingByron
   , byronBlockForging
   , defaultPBftSignatureThreshold
   , mkByronConfig
@@ -149,6 +150,15 @@ mkPBftCanBeLeader (ByronLeaderCredentials sk cert nid _) = PBftCanBeLeader {
     , pbftCanBeLeaderDlgCert    = cert
     }
 
+blockForgingByron :: Monad m
+                  => ProtocolParamsByron
+                  -> [BlockForging m ByronBlock]
+blockForgingByron ProtocolParamsByron { byronLeaderCredentials      = mLeaderCreds
+                                      , byronMaxTxCapacityOverrides = maxTxCapacityOverrides
+                                      } =
+            byronBlockForging maxTxCapacityOverrides
+            <$> maybeToList mLeaderCreds
+
 {-------------------------------------------------------------------------------
   ProtocolInfo
 -------------------------------------------------------------------------------}
@@ -168,17 +178,13 @@ data ProtocolParamsByron = ProtocolParamsByron {
     , byronMaxTxCapacityOverrides :: Mempool.TxOverrides ByronBlock
     }
 
-protocolInfoByron ::
-     forall m. Monad m
-  => ProtocolParamsByron
-  -> ProtocolInfo m ByronBlock
+protocolInfoByron :: ProtocolParamsByron
+                  -> ProtocolInfo ByronBlock
 protocolInfoByron ProtocolParamsByron {
                       byronGenesis                = genesisConfig
                     , byronPbftSignatureThreshold = mSigThresh
                     , byronProtocolVersion        = pVer
                     , byronSoftwareVersion        = sVer
-                    , byronLeaderCredentials      = mLeaderCreds
-                    , byronMaxTxCapacityOverrides = maxTxCapacityOverrides
                     } =
     ProtocolInfo {
         pInfoConfig = TopLevelConfig {
@@ -197,10 +203,6 @@ protocolInfoByron ProtocolParamsByron {
             ledgerState = initByronLedgerState genesisConfig Nothing
           , headerState = genesisHeaderState S.empty
           }
-      , pInfoBlockForging =
-            return
-          $ fmap (byronBlockForging maxTxCapacityOverrides)
-          $ maybeToList mLeaderCreds
       }
   where
     compactedGenesisConfig = compactGenesisConfig genesisConfig

ouroboros-consensus-cardano/src/cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs

@@ -33,6 +33,7 @@ import qualified Data.SOP.InPairs as InPairs
 import           Data.SOP.Strict
 import qualified Data.SOP.Tails as Tails
 import           Data.Void (Void)
+import           Ouroboros.Consensus.Block.Forging (BlockForging)
 import           Ouroboros.Consensus.Cardano.CanHardFork
                      (ShelleyPartialLedgerConfig (..), forecastAcrossShelley,
                      translateChainDepStateAcrossShelley)
@@ -228,7 +229,9 @@ protocolInfoShelleyBasedHardFork ::
   -> SL.ProtVer
   -> SL.TranslationContext era1
   -> ProtocolTransitionParamsShelleyBased era2
-  -> ProtocolInfo m (ShelleyBasedHardForkBlock proto1 era1 proto2 era2)
+  -> ( ProtocolInfo      (ShelleyBasedHardForkBlock proto1 era1 proto2 era2)
+     , m [BlockForging m (ShelleyBasedHardForkBlock proto1 era1 proto2 era2)]
+     )
 protocolInfoShelleyBasedHardFork protocolParamsShelleyBased
                                  protVer1
                                  protVer2
@@ -237,11 +240,13 @@ protocolInfoShelleyBasedHardFork protocolParamsShelleyBased
     protocolInfoBinary
       -- Era 1
       protocolInfo1
+      blockForging1
       eraParams1
       tpraosParams
       toPartialLedgerConfig1
       -- Era 2
       protocolInfo2
+      blockForging2
       eraParams2
       tpraosParams
       toPartialLedgerConfig2
@@ -257,8 +262,9 @@ protocolInfoShelleyBasedHardFork protocolParamsShelleyBased
     genesis :: SL.ShelleyGenesis (EraCrypto era1)
     genesis = shelleyBasedGenesis
 
-    protocolInfo1 :: ProtocolInfo m (ShelleyBlock proto1 era1)
-    protocolInfo1 =
+    protocolInfo1 :: ProtocolInfo (ShelleyBlock proto1 era1)
+    blockForging1 :: m [BlockForging m (ShelleyBlock proto1 era1)]
+    (protocolInfo1, blockForging1) =
         protocolInfoTPraosShelleyBased
           protocolParamsShelleyBased
           ((), transCtx1)
@@ -283,8 +289,9 @@ protocolInfoShelleyBasedHardFork protocolParamsShelleyBased
 
     -- Era 2
 
-    protocolInfo2 :: ProtocolInfo m (ShelleyBlock proto2 era2)
-    protocolInfo2 =
+    protocolInfo2 :: ProtocolInfo (ShelleyBlock proto2 era2)
+    blockForging2 :: m [BlockForging m (ShelleyBlock proto2 era2)]
+    (protocolInfo2, blockForging2) =
         protocolInfoTPraosShelleyBased
           ProtocolParamsShelleyBased {
               shelleyBasedGenesis = genesis

ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs

@@ -584,7 +584,9 @@ protocolInfoCardano ::
   -> ProtocolTransitionParamsShelleyBased (AlonzoEra c)
   -> ProtocolTransitionParamsShelleyBased (BabbageEra c)
   -> ProtocolTransitionParamsShelleyBased (ConwayEra c)
-  -> ProtocolInfo m (CardanoBlock c)
+  -> ( ProtocolInfo      (CardanoBlock c)
+     , m [BlockForging m (CardanoBlock c)]
+     )
 protocolInfoCardano protocolParamsByron@ProtocolParamsByron {
                         byronGenesis                = genesisByron
                       , byronLeaderCredentials      = mCredsByron
@@ -647,12 +649,13 @@ protocolInfoCardano protocolParamsByron@ProtocolParamsByron {
   , length credssShelleyBased > 1
   = error "Multiple Shelley-based credentials not allowed for mainnet"
   | otherwise
-  = assertWithMsg (validateGenesis genesisShelley) $
-    ProtocolInfo {
+  = assertWithMsg (validateGenesis genesisShelley)
+    ( ProtocolInfo {
         pInfoConfig       = cfg
       , pInfoInitLedger   = initExtLedgerStateCardano
-      , pInfoBlockForging = blockForging
       }
+    , blockForging
+    )
   where
     -- The major protocol version of the last era is the maximum major protocol
     -- version we support.
@@ -684,7 +687,7 @@ protocolInfoCardano protocolParamsByron@ProtocolParamsByron {
           , topLevelConfigBlock    = blockConfigByron
           }
       , pInfoInitLedger = initExtLedgerStateByron
-      } = protocolInfoByron @m protocolParamsByron
+      } = protocolInfoByron protocolParamsByron
 
     partialConsensusConfigByron :: PartialConsensusConfig (BlockProtocol ByronBlock)
     partialConsensusConfigByron = consensusConfigByron

ouroboros-consensus-cardano/src/shelley-testlib/Test/ThreadNet/Infra/Shelley.hs

@@ -412,7 +412,9 @@ mkProtocolShelley ::
   -> SL.Nonce
   -> ProtVer
   -> CoreNode c
-  -> ProtocolInfo m (ShelleyBlock (TPraos c) (ShelleyEra c))
+  -> ( ProtocolInfo (ShelleyBlock (TPraos c) (ShelleyEra c))
+     , m [BlockForging m (ShelleyBlock (TPraos c) (ShelleyEra c))]
+     )
 mkProtocolShelley genesis initialNonce protVer coreNode =
     protocolInfoShelley
       ProtocolParamsShelleyBased {
@@ -424,6 +426,7 @@ mkProtocolShelley genesis initialNonce protVer coreNode =
           shelleyProtVer                = protVer
         , shelleyMaxTxCapacityOverrides = Mempool.mkOverrides Mempool.noOverridesMeasure
         }
+
 {-------------------------------------------------------------------------------
   Necessary transactions for updating the 'DecentralizationParam'
 -------------------------------------------------------------------------------}

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs

@@ -222,7 +222,9 @@ protocolInfoShelley ::
       )
   => ProtocolParamsShelleyBased (ShelleyEra c)
   -> ProtocolParamsShelley c
-  -> ProtocolInfo m (ShelleyBlock (TPraos c)(ShelleyEra c) )
+  -> ( ProtocolInfo (ShelleyBlock (TPraos c)(ShelleyEra c) )
+     , m [BlockForging m (ShelleyBlock (TPraos c) (ShelleyEra c))]
+     )
 protocolInfoShelley protocolParamsShelleyBased
                     ProtocolParamsShelley {
                         shelleyProtVer                = protVer
@@ -246,7 +248,9 @@ protocolInfoTPraosShelleyBased ::
   -> (SL.AdditionalGenesisConfig era, Core.TranslationContext era)
   -> SL.ProtVer
   -> Mempool.TxOverrides (ShelleyBlock (TPraos c) era)
-  -> ProtocolInfo m     (ShelleyBlock (TPraos c) era)
+  -> ( ProtocolInfo (ShelleyBlock (TPraos c) era)
+     , m [BlockForging m (ShelleyBlock (TPraos c) era)]
+     )
 protocolInfoTPraosShelleyBased ProtocolParamsShelleyBased {
                              shelleyBasedGenesis           = genesis
                            , shelleyBasedInitialNonce      = initialNonce
@@ -256,14 +260,14 @@ protocolInfoTPraosShelleyBased ProtocolParamsShelleyBased {
                          protVer
                          maxTxCapacityOverrides =
     assertWithMsg (validateGenesis genesis) $
-    ProtocolInfo {
+    ( ProtocolInfo {
         pInfoConfig       = topLevelConfig
       , pInfoInitLedger   = initExtLedgerState
-      , pInfoBlockForging =
-          traverse
-            (shelleyBlockForging tpraosParams maxTxCapacityOverrides)
-            credentialss
       }
+    , traverse
+        (shelleyBlockForging tpraosParams maxTxCapacityOverrides)
+        credentialss
+    )
   where
     maxMajorProtVer :: MaxMajorProtVer
     maxMajorProtVer = MaxMajorProtVer $ SL.pvMajor protVer

ouroboros-consensus-cardano/src/tools/Cardano/Api/Protocol/Types.hs

@@ -18,6 +18,8 @@ module Cardano.Api.Protocol.Types (
   ) where
 
 import           Cardano.Chain.Slotting (EpochSlots)
+import           Data.Bifunctor (bimap)
+import           Ouroboros.Consensus.Block.Forging (BlockForging)
 import           Ouroboros.Consensus.Cardano
 import           Ouroboros.Consensus.Cardano.Block
 import           Ouroboros.Consensus.Cardano.ByronHFC (ByronBlockHFC)
@@ -41,7 +43,9 @@ import           Ouroboros.Consensus.Util.IOLike (IOLike)
 
 class (RunNode blk, IOLike m) => Protocol m blk where
   data ProtocolInfoArgs m blk
-  protocolInfo :: ProtocolInfoArgs m blk -> ProtocolInfo m blk
+  protocolInfo :: ProtocolInfoArgs m blk -> ( ProtocolInfo blk
+                                            , m [BlockForging m blk]
+                                            )
 
 -- | Node client support for each consensus protocol.
 --
@@ -56,7 +60,9 @@ class RunNode blk => ProtocolClient blk where
 -- | Run PBFT against the Byron ledger
 instance IOLike m => Protocol m ByronBlockHFC where
   data ProtocolInfoArgs m ByronBlockHFC = ProtocolInfoArgsByron ProtocolParamsByron
-  protocolInfo (ProtocolInfoArgsByron params) = inject $ protocolInfoByron params
+  protocolInfo (ProtocolInfoArgsByron params) = ( inject $ protocolInfoByron params
+                                                , pure . map inject $ blockForgingByron params
+                                                )
 
 instance (CardanoHardForkConstraints StandardCrypto, IOLike m) => Protocol m (CardanoBlock StandardCrypto) where
   data ProtocolInfoArgs m (CardanoBlock StandardCrypto) =
@@ -129,7 +135,7 @@ instance ( IOLike m
     (ProtocolParamsShelleyBased StandardShelley)
     (ProtocolParamsShelley StandardCrypto)
   protocolInfo (ProtocolInfoArgsShelley paramsShelleyBased paramsShelley) =
-    inject $ protocolInfoShelley paramsShelleyBased paramsShelley
+    bimap inject (fmap $ map inject) $ protocolInfoShelley paramsShelleyBased paramsShelley
 
 instance Consensus.LedgerSupportsProtocol
           (Consensus.ShelleyBlock

ouroboros-consensus-cardano/src/tools/Cardano/Tools/DBAnalyser/Block/Byron.hs

@@ -104,7 +104,7 @@ openGenesisByron configFile mHash requiresNetworkMagic = do
 
 mkByronProtocolInfo :: Genesis.Config
                     -> Maybe PBftSignatureThreshold
-                    -> ProtocolInfo IO ByronBlock
+                    -> ProtocolInfo ByronBlock
 mkByronProtocolInfo genesisConfig signatureThreshold =
     protocolInfoByron $ ProtocolParamsByron {
         byronGenesis                = genesisConfig

ouroboros-consensus-cardano/src/tools/Cardano/Tools/DBAnalyser/Block/Cardano.hs

@@ -294,9 +294,9 @@ mkCardanoProtocolInfo ::
   -> SL.ConwayGenesis StandardCrypto
   -> Nonce
   -> NP ShelleyTransitionArguments (CardanoShelleyEras StandardCrypto)
-  -> ProtocolInfo IO (CardanoBlock StandardCrypto)
+  -> ProtocolInfo (CardanoBlock StandardCrypto)
 mkCardanoProtocolInfo genesisByron signatureThreshold genesisShelley genesisAlonzo genesisConway initialNonce hardForkTriggers =
-    protocolInfoCardano
+    fst $ protocolInfoCardano @_ @IO
       ProtocolParamsByron {
           byronGenesis                = genesisByron
         , byronPbftSignatureThreshold = signatureThreshold