Control block forging through NodeKernel

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

@@ -90,9 +90,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
@@ -122,9 +124,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-byron-test/src/Test/ThreadNet/Infra/Byron/ProtocolInfo.hs

@@ -21,6 +21,7 @@ import qualified Cardano.Chain.Genesis as Genesis
 import qualified Cardano.Chain.Update as Update
 import qualified Cardano.Crypto as Crypto
 
+import           Ouroboros.Consensus.Block.Forging (BlockForging)
 import qualified Ouroboros.Consensus.Mempool.TxLimits as TxLimits
 import           Ouroboros.Consensus.Node.ProtocolInfo (ProtocolInfo (..))
 import           Ouroboros.Consensus.NodeId (CoreNodeId (..))
@@ -37,11 +38,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 =
@@ -55,9 +56,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-byron-test/src/Test/ThreadNet/Infra/Byron/TrackUpdates.hs

@@ -380,14 +380,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]
@@ -437,9 +439,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-byron-test/test/Test/Consensus/Byron/Serialisation.hs

@@ -15,7 +15,6 @@ module Test.Consensus.Byron.Serialisation (tests) where
 
 import           Codec.CBOR.Write (toLazyByteString)
 import qualified Data.ByteString.Lazy as Lazy
-import           Data.Functor.Identity
 
 import           Cardano.Chain.Block (ABlockOrBoundary (..))
 import qualified Cardano.Chain.Block as CC.Block
@@ -101,7 +100,7 @@ prop_detectCorruption_RegularBlock (RegularBlock blk) =
 testCfg :: TopLevelConfig ByronBlock
 testCfg = pInfoConfig protocolInfo
   where
-    protocolInfo :: ProtocolInfo Identity ByronBlock
+    protocolInfo :: ProtocolInfo ByronBlock
     protocolInfo =
       protocolInfoByron $ ProtocolParamsByron {
           byronGenesis                = CC.dummyConfig

ouroboros-consensus-byron-test/test/Test/ThreadNet/Byron.hs

@@ -22,7 +22,7 @@ import qualified Data.ByteString as BS
 import           Data.Coerce (coerce)
 import           Data.Functor ((<&>))
 import qualified Data.Map.Strict as Map
-import           Data.Maybe (listToMaybe, mapMaybe)
+import           Data.Maybe (mapMaybe)
 import qualified Data.Set as Set
 import           Data.Word (Word64)
 
@@ -1290,27 +1290,27 @@ mkRekeyUpd
   => Genesis.Config
   -> Genesis.GeneratedSecrets
   -> CoreNodeId
-  -> ProtocolInfo m ByronBlock
+  -> ProtocolInfo ByronBlock
+  -> m [BlockForging m ByronBlock]
   -> EpochNo
   -> Crypto.SignKeyDSIGN Crypto.ByronDSIGN
   -> m (Maybe (TestNodeInitialization m ByronBlock))
-mkRekeyUpd genesisConfig genesisSecrets cid pInfo eno newSK =
-    pInfoBlockForging pInfo <&> \blockForging ->
-      case listToMaybe blockForging of
-        Nothing -> Nothing
-        Just _  ->
-          let genSK = genesisSecretFor genesisConfig genesisSecrets cid
-              creds' = updSignKey genSK bcfg cid (coerce eno) newSK
-              blockForging' =
-                byronBlockForging
-                  (TxLimits.mkOverrides TxLimits.noOverridesMeasure)
-                  creds'
-              pInfo' = pInfo { pInfoBlockForging = return [blockForging'] }
-
-          in Just TestNodeInitialization
-            { tniCrucialTxs = [dlgTx (blcDlgCert creds')]
-            , tniProtocolInfo = pInfo'
-            }
+mkRekeyUpd genesisConfig genesisSecrets cid pInfo blockForging eno newSK = do
+  blockForging <&> \case
+    []    -> Nothing
+    (_:_) ->
+      let genSK = genesisSecretFor genesisConfig genesisSecrets cid
+          creds' = updSignKey genSK bcfg cid (coerce eno) newSK
+          blockForging' =
+            byronBlockForging
+              (TxLimits.mkOverrides TxLimits.noOverridesMeasure)
+              creds'
+
+      in Just TestNodeInitialization
+        { tniCrucialTxs = [dlgTx (blcDlgCert creds')]
+        , tniProtocolInfo = pInfo
+        , tniBlockForging = pure [blockForging']
+        }
   where
     bcfg = configBlock (pInfoConfig pInfo)
 

ouroboros-consensus-byron-test/test/Test/ThreadNet/DualByron.hs

@@ -150,11 +150,11 @@ setupTestOutput :: SetupDualByron -> TestOutput DualByronBlock
 setupTestOutput setup@SetupDualByron{..} =
     runTestNetwork testConfig testConfigB TestConfigMB {
         nodeInfo = \coreNodeId ->
-          plainTestNodeInitialization $
-          protocolInfoDualByron
-            setupGenesis
-            (setupParams setup)
-            [coreNodeId]
+          uncurry plainTestNodeInitialization
+            (protocolInfoDualByron
+              setupGenesis
+              (setupParams setup)
+              [coreNodeId])
       , mkRekeyM = Nothing -- TODO
       }
   where

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

@@ -9,6 +9,7 @@
 module Ouroboros.Consensus.Byron.Node (
     PBftSignatureThreshold (..)
   , ProtocolParamsByron (..)
+  , blockForgingByron
   , byronBlockForging
   , defaultPBftSignatureThreshold
   , mkByronConfig
@@ -153,6 +154,15 @@ mkPBftCanBeLeader (ByronLeaderCredentials sk cert nid _) = PBftCanBeLeader {
     , pbftCanBeLeaderDlgCert    = cert
     }
 
+blockForgingByron :: Monad m
+                  => ProtocolParamsByron
+                  -> [BlockForging m ByronBlock]
+blockForgingByron ProtocolParamsByron { byronLeaderCredentials      = mLeaderCreds
+                                      , byronMaxTxCapacityOverrides = maxTxCapacityOverrides
+                                      } =
+            fmap (byronBlockForging maxTxCapacityOverrides)
+          $ maybeToList mLeaderCreds
+
 {-------------------------------------------------------------------------------
   ProtocolInfo
 -------------------------------------------------------------------------------}
@@ -173,16 +183,13 @@ data ProtocolParamsByron = ProtocolParamsByron {
     }
 
 protocolInfoByron ::
-     forall m. Monad m
-  => ProtocolParamsByron
-  -> ProtocolInfo m ByronBlock
+     ProtocolParamsByron
+  -> ProtocolInfo ByronBlock
 protocolInfoByron ProtocolParamsByron {
                       byronGenesis                = genesisConfig
                     , byronPbftSignatureThreshold = mSigThresh
                     , byronProtocolVersion        = pVer
                     , byronSoftwareVersion        = sVer
-                    , byronLeaderCredentials      = mLeaderCreds
-                    , byronMaxTxCapacityOverrides = maxTxCapacityOverrides
                     } =
     ProtocolInfo {
         pInfoConfig = TopLevelConfig {
@@ -201,10 +208,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-test/src/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs

@@ -29,6 +29,7 @@ import qualified Data.Map.Strict as Map
 import           Data.SOP.Strict
 import           Data.Void (Void)
 
+import           Ouroboros.Consensus.Block.Forging (BlockForging)
 import           Ouroboros.Consensus.Ledger.Basics (LedgerConfig)
 import           Ouroboros.Consensus.Node
 import           Ouroboros.Consensus.Node.NetworkProtocolVersion
@@ -233,19 +234,23 @@ protocolInfoShelleyBasedHardFork ::
   -> SL.ProtVer
   -> SL.ProtVer
   -> 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
                                  protocolTransitionParams =
     protocolInfoBinary
       -- Era 1
       protocolInfo1
+      blockForging1
       eraParams1
       tpraosParams
       toPartialLedgerConfig1
       -- Era 2
       protocolInfo2
+      blockForging2
       eraParams2
       tpraosParams
       toPartialLedgerConfig2
@@ -261,8 +266,9 @@ protocolInfoShelleyBasedHardFork protocolParamsShelleyBased
     genesis1 :: SL.ShelleyGenesis era1
     genesis1 = shelleyBasedGenesis
 
-    protocolInfo1 :: ProtocolInfo m (ShelleyBlock proto1 era1)
-    protocolInfo1 =
+    protocolInfo1 :: ProtocolInfo (ShelleyBlock proto1 era1)
+    blockForging1 :: m [BlockForging m (ShelleyBlock proto1 era1)]
+    (protocolInfo1, blockForging1) =
         protocolInfoTPraosShelleyBased
           protocolParamsShelleyBased
           ()  -- trivial translation context
@@ -290,8 +296,9 @@ protocolInfoShelleyBasedHardFork protocolParamsShelleyBased
     genesis2 :: SL.ShelleyGenesis era2
     genesis2 = SL.translateEra' transCtxt2 genesis1
 
-    protocolInfo2 :: ProtocolInfo m (ShelleyBlock proto2 era2)
-    protocolInfo2 =
+    protocolInfo2 :: ProtocolInfo (ShelleyBlock proto2 era2)
+    blockForging2 :: m [BlockForging m (ShelleyBlock proto2 era2)]
+    (protocolInfo2, blockForging2) =
         protocolInfoTPraosShelleyBased
           ProtocolParamsShelleyBased {
               shelleyBasedGenesis = genesis2

ouroboros-consensus-cardano-test/test/Test/ThreadNet/AllegraMary.hs

@@ -246,34 +246,41 @@ prop_simple_allegraMary_convergence TestSetup
     testOutput :: TestOutput AllegraMaryBlock
     testOutput = runTestNetwork setupTestConfig testConfigB TestConfigMB {
           nodeInfo = \(CoreNodeId nid) ->
-            TestNodeInitialization {
-                tniCrucialTxs   =
-                  if not setupHardFork then [] else
-                  fmap GenTxShelley1 $
-                  Shelley.mkMASetDecentralizationParamTxs
-                    coreNodes
-                    (SL.ProtVer majorVersion2 0)
-                    (SlotNo $ unNumSlots numSlots)   -- never expire
-                    setupD   -- unchanged
-              , tniProtocolInfo =
+            let protocolParamsShelleyBased =
+                  ProtocolParamsShelleyBased {
+                      shelleyBasedGenesis           = genesisShelley
+                    , shelleyBasedInitialNonce      = setupInitialNonce
+                    , shelleyBasedLeaderCredentials =
+                        [Shelley.mkLeaderCredentials
+                          (coreNodes !! fromIntegral nid)]
+                    }
+
+                protocolTransitionParamsShelleyBased =
+                  ProtocolTransitionParamsShelleyBased {
+                      transitionTranslationContext = ()
+                    , transitionTrigger            =
+                        TriggerHardForkAtVersion majorVersion2
+                    }
+                (protocolInfo, blockForging) =
                   protocolInfoShelleyBasedHardFork
-                    ProtocolParamsShelleyBased {
-                        shelleyBasedGenesis           = genesisShelley
-                      , shelleyBasedInitialNonce      = setupInitialNonce
-                      , shelleyBasedLeaderCredentials =
-                          [Shelley.mkLeaderCredentials
-                            (coreNodes !! fromIntegral nid)]
-                      }
+                    protocolParamsShelleyBased
                     (SL.ProtVer majorVersion1 0)
                     (SL.ProtVer majorVersion2 0)
-                    ProtocolTransitionParamsShelleyBased {
-                        transitionTranslationContext = ()
-                      , transitionTrigger            =
-                          TriggerHardForkAtVersion majorVersion2
-                      }
-              }
-          , mkRekeyM = Nothing
-          }
+                    protocolTransitionParamsShelleyBased
+            in TestNodeInitialization {
+                  tniCrucialTxs   =
+                    if not setupHardFork then [] else
+                    fmap GenTxShelley1 $
+                    Shelley.mkMASetDecentralizationParamTxs
+                      coreNodes
+                      (SL.ProtVer majorVersion2 0)
+                      (SlotNo $ unNumSlots numSlots)   -- never expire
+                      setupD   -- unchanged
+                , tniProtocolInfo = protocolInfo
+                , tniBlockForging = blockForging
+                }
+            , mkRekeyM = Nothing
+            }
 
     maxForkLength :: NumBlocks
     maxForkLength = NumBlocks $ maxRollbacks setupK