Merge #2687

2687: Empty RunNode r=mrBliss a=mrBliss

This is done in two steps, see the first two commit messages.

Co-authored-by: Thomas Winant <thomas@well-typed.com>

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

@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -10,7 +11,6 @@ module Ouroboros.Consensus.ByronDual.Node (
  protocolInfoDualByron
  ) where
 
-import Control.Monad
 import Data.Either (fromRight)
 import Data.Map.Strict (Map)
 import Data.Maybe (fromMaybe)
@@ -39,12 +39,13 @@ import Ouroboros.Consensus.Config
 import Ouroboros.Consensus.Ledger.Abstract
 import Ouroboros.Consensus.Ledger.Dual
 import Ouroboros.Consensus.Ledger.Extended
+import Ouroboros.Consensus.Node.InitStorage
 import Ouroboros.Consensus.Node.ProtocolInfo
 import Ouroboros.Consensus.Node.Run
 import Ouroboros.Consensus.NodeId
 import Ouroboros.Consensus.Protocol.PBFT
 import qualified Ouroboros.Consensus.Protocol.PBFT.State as S
-import qualified Ouroboros.Consensus.Storage.ChainDB.Init as InitChainDB
+import  Ouroboros.Consensus.Storage.ChainDB.Init (InitChainDB (..))
 import Ouroboros.Consensus.Util ((.....:))
 
 import Ouroboros.Consensus.Byron.Ledger
@@ -104,6 +105,10 @@ protocolInfoDualByron abstractGenesis@ByronSpecGenesis{..} params credss =
  dualCodecConfigMain = mkByronCodecConfig concreteGenesis
  , dualCodecConfigAux = ByronSpecCodecConfig
  }
+ , topLevelConfigStorage = DualStorageConfig {
+ dualStorageConfigMain = ByronStorageConfig concreteConfig
+ , dualStorageConfigAux = ByronSpecStorageConfig
+ }
  }
  , pInfoInitLedger = ExtLedgerState {
  ledgerState = DualLedgerState {
@@ -208,14 +213,13 @@ protocolInfoDualByron abstractGenesis@ByronSpecGenesis{..} params credss =
  (byronSpecLedgerState initAbstractState)
 
 {-------------------------------------------------------------------------------
- RunNode instance
+ NodeInitStorage instance
 -------------------------------------------------------------------------------}
 
-instance RunNode DualByronBlock where
+instance NodeInitStorage DualByronBlock where
  -- Just like Byron, we need to start with an EBB
- nodeInitChainDB cfg chainDB = do
- empty <- InitChainDB.checkEmpty chainDB
- when empty $ InitChainDB.addBlock chainDB genesisEBB
+ nodeInitChainDB cfg InitChainDB { addBlockIfEmpty } = do
+ addBlockIfEmpty (return genesisEBB)
  where
  genesisEBB :: DualByronBlock
  genesisEBB = DualBlock {
@@ -226,19 +230,21 @@ instance RunNode DualByronBlock where
 
  byronEBB :: ByronBlock
  byronEBB = forgeEBB
- (configBlock (dualTopLevelConfigMain cfg))
+ (getByronBlockConfig (dualStorageConfigMain cfg))
  (SlotNo 0)
  (BlockNo 0)
  GenesisHash
 
  -- Node config is a consensus concern, determined by the main block only
- nodeImmutableDbChunkInfo = nodeImmutableDbChunkInfo . dualTopLevelConfigMain
-
- -- For now the size of the block is just an estimate, and so we just reuse
- -- the estimate from the concrete header.
- nodeBlockFetchSize = nodeBlockFetchSize . dualHeaderMain
+ nodeImmutableDbChunkInfo = nodeImmutableDbChunkInfo . dualStorageConfigMain
 
  -- We don't really care too much about data loss or malicious behaviour for
  -- the dual ledger tests, so integrity and match checks can just use the
  -- concrete implementation
- nodeCheckIntegrity cfg = nodeCheckIntegrity (dualTopLevelConfigMain cfg) . dualBlockMain
+ nodeCheckIntegrity cfg = nodeCheckIntegrity (dualStorageConfigMain cfg) . dualBlockMain
+
+{-------------------------------------------------------------------------------
+ RunNode instance
+-------------------------------------------------------------------------------}
+
+instance RunNode DualByronBlock

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

@@ -89,7 +89,10 @@ instance DecodeDisk DualByronBlock (AnnTip DualByronBlock) where
  SerialiseNodeToNode
 -------------------------------------------------------------------------------}
 
-instance SerialiseNodeToNodeConstraints DualByronBlock
+instance SerialiseNodeToNodeConstraints DualByronBlock where
+ -- We don't enforce this estimate, so we just reuse the estimate from the
+ -- concrete header.
+ estimateBlockSize = estimateBlockSize . dualHeaderMain
 
 -- | CBOR-in-CBOR for the annotation. This also makes it compatible with the
 -- wrapped ('Serialised') variant.

ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Config.hs

@@ -16,6 +16,8 @@ module Ouroboros.Consensus.Byron.Ledger.Config (
  -- * Codec config
  , CodecConfig(..)
  , mkByronCodecConfig
+ -- * Storage config
+ , StorageConfig(..)
  -- * Compact genesis config
  , compactGenesisConfig
  ) where
@@ -82,6 +84,17 @@ mkByronCodecConfig cfg = ByronCodecConfig {
  getByronEpochSlots = CC.Genesis.configEpochSlots cfg
  }
 
+{-------------------------------------------------------------------------------
+ Storage config
+-------------------------------------------------------------------------------}
+
+newtype instance StorageConfig ByronBlock = ByronStorageConfig {
+ -- | We need the 'BlockConfig' to be able to forge an EBB in
+ -- 'nodeInitChainDB'.
+ getByronBlockConfig :: BlockConfig ByronBlock
+ }
+ deriving (Generic, NoThunks)
+
 {-------------------------------------------------------------------------------
  Compact genesis config
 -------------------------------------------------------------------------------}

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

@@ -41,13 +41,14 @@ import Ouroboros.Consensus.Config
 import Ouroboros.Consensus.Config.SupportsNode
 import Ouroboros.Consensus.HeaderValidation
 import Ouroboros.Consensus.Ledger.Extended
+import Ouroboros.Consensus.Node.InitStorage
 import Ouroboros.Consensus.Node.ProtocolInfo
 import Ouroboros.Consensus.Node.Run
 import Ouroboros.Consensus.NodeId (CoreNodeId)
 import Ouroboros.Consensus.Protocol.Abstract
 import Ouroboros.Consensus.Protocol.PBFT
 import qualified Ouroboros.Consensus.Protocol.PBFT.State as S
-import qualified Ouroboros.Consensus.Storage.ChainDB.Init as InitChainDB
+import  Ouroboros.Consensus.Storage.ChainDB.Init (InitChainDB (..))
 import Ouroboros.Consensus.Storage.ImmutableDB (simpleChunkInfo)
 import Ouroboros.Consensus.Util ((.....:))
 
@@ -182,9 +183,10 @@ protocolInfoByron ProtocolParamsByron {
  topLevelConfigProtocol = PBftConfig {
  pbftParams = byronPBftParams compactedGenesisConfig mSigThresh
  }
- , topLevelConfigLedger = compactedGenesisConfig
- , topLevelConfigBlock = mkByronConfig compactedGenesisConfig pVer sVer
- , topLevelConfigCodec = mkByronCodecConfig compactedGenesisConfig
+ , topLevelConfigLedger = compactedGenesisConfig
+ , topLevelConfigBlock = blockConfig
+ , topLevelConfigCodec = mkByronCodecConfig compactedGenesisConfig
+ , topLevelConfigStorage = ByronStorageConfig blockConfig
  }
  , pInfoInitLedger = ExtLedgerState {
  -- Important: don't pass the compacted genesis config to
@@ -199,6 +201,8 @@ protocolInfoByron ProtocolParamsByron {
  where
  compactedGenesisConfig = compactGenesisConfig genesisConfig
 
+ blockConfig = mkByronConfig compactedGenesisConfig pVer sVer
+
 protocolClientInfoByron :: EpochSlots -> ProtocolClientInfo ByronBlock
 protocolClientInfoByron epochSlots =
  ProtocolClientInfo {
@@ -244,12 +248,10 @@ extractGenesisData :: BlockConfig ByronBlock -> Genesis.GenesisData
 extractGenesisData = Genesis.configGenesisData . byronGenesisConfig
 
 {-------------------------------------------------------------------------------
- RunNode instance
+ NodeInitStorage instance
 -------------------------------------------------------------------------------}
 
-instance RunNode ByronBlock where
- nodeBlockFetchSize = byronHeaderBlockSizeHint
-
+instance NodeInitStorage ByronBlock where
  -- The epoch size is fixed and can be derived from @k@ by the ledger
  -- ('kEpochSlots').
  nodeImmutableDbChunkInfo =
@@ -258,14 +260,19 @@ instance RunNode ByronBlock where
  . kEpochSlots
  . Genesis.gdK
  . extractGenesisData
- . configBlock
+ . getByronBlockConfig
 
  -- If the current chain is empty, produce a genesis EBB and add it to the
  -- ChainDB. Only an EBB can have Genesis (= empty chain) as its predecessor.
- nodeInitChainDB cfg chainDB = do
- empty <- InitChainDB.checkEmpty chainDB
- when empty $ InitChainDB.addBlock chainDB genesisEBB
+ nodeInitChainDB cfg InitChainDB { addBlockIfEmpty } = do
+ addBlockIfEmpty (return genesisEBB)
  where
- genesisEBB = forgeEBB (configBlock cfg) (SlotNo 0) (BlockNo 0) GenesisHash
+ genesisEBB = forgeEBB (getByronBlockConfig cfg) (SlotNo 0) (BlockNo 0) GenesisHash
+
+ nodeCheckIntegrity = verifyBlockIntegrity . getByronBlockConfig
+
+{-------------------------------------------------------------------------------
+ RunNode instance
+-------------------------------------------------------------------------------}
 
- nodeCheckIntegrity = verifyBlockIntegrity . configBlock
+instance RunNode ByronBlock

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

@@ -73,7 +73,8 @@ instance DecodeDisk ByronBlock (AnnTip ByronBlock) where
  SerialiseNodeToNode
 -------------------------------------------------------------------------------}
 
-instance SerialiseNodeToNodeConstraints ByronBlock
+instance SerialiseNodeToNodeConstraints ByronBlock where
+ estimateBlockSize = byronHeaderBlockSizeHint
 
 -- | CBOR-in-CBOR for the annotation. This also makes it compatible with the
 -- wrapped ('Serialised') variant.

ouroboros-consensus-byronspec/src/Ouroboros/Consensus/ByronSpec/Ledger/Block.hs

@@ -11,6 +11,7 @@ module Ouroboros.Consensus.ByronSpec.Ledger.Block (
  , Header(..)
  , BlockConfig(..)
  , CodecConfig(..)
+ , StorageConfig(..)
  ) where
 
 import Codec.Serialise
@@ -102,3 +103,6 @@ data instance BlockConfig ByronSpecBlock = ByronSpecBlockConfig
 
 data instance CodecConfig ByronSpecBlock = ByronSpecCodecConfig
  deriving (Generic, NoThunks)
+
+data instance StorageConfig ByronSpecBlock = ByronSpecStorageConfig
+ deriving (Generic, NoThunks)

ouroboros-consensus-cardano-test/test/Test/Consensus/Cardano/ByronCompatibility.hs

@@ -296,7 +296,8 @@ instance SerialiseNodeToNode ByronToCardano (GenTxId ByronToCardano) where
  encodeNodeToNode = encodeNodeToNodeB2C (Proxy @WrapGenTxId) unGenTxIdB2C
  decodeNodeToNode = decodeNodeToNodeB2C (Proxy @WrapGenTxId) (\(GenTxIdByron txid) -> GenTxIdB2C txid)
 
-instance SerialiseNodeToNodeConstraints ByronToCardano
+instance SerialiseNodeToNodeConstraints ByronToCardano where
+ estimateBlockSize = estimateBlockSize . unHeaderB2C
 
 {------------------------------------------------------------------------------
  Byron to Cardano: NodeToClient
@@ -576,7 +577,8 @@ instance SerialiseNodeToNode CardanoToByron (GenTxId CardanoToByron) where
  encodeNodeToNode = encodeNodeToNodeC2B (Proxy @WrapGenTxId) (GenTxIdByron . unGenTxIdC2B)
  decodeNodeToNode = decodeNodeToNodeC2B (Proxy @WrapGenTxId) GenTxIdC2B
 
-instance SerialiseNodeToNodeConstraints CardanoToByron
+instance SerialiseNodeToNodeConstraints CardanoToByron where
+ estimateBlockSize = estimateBlockSize . unHeaderC2B
 
 {------------------------------------------------------------------------------
  Cardano to Byron: NodeToClient

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

@@ -99,6 +99,9 @@ module Ouroboros.Consensus.Cardano.Block (
  -- * BlockConfig
  , CardanoBlockConfig
  , BlockConfig (CardanoBlockConfig)
+ -- * StorageConfig
+ , CardanoStorageConfig
+ , StorageConfig (CardanoStorageConfig)
  -- * ConsensusConfig
  , CardanoConsensusConfig
  , ConsensusConfig (CardanoConsensusConfig)
@@ -616,6 +619,35 @@ pattern CardanoBlockConfig cfgByron cfgShelley cfgAllegra cfgMary =
 
 {-# COMPLETE CardanoBlockConfig #-}
 
+{-------------------------------------------------------------------------------
+ StorageConfig
+-------------------------------------------------------------------------------}
+
+-- | The 'StorageConfig' for 'CardanoBlock'.
+--
+-- Thanks to the pattern synonyms, you can treat this as the product of
+-- the Byron, Shelley, ... 'StorageConfig's.
+type CardanoStorageConfig c = StorageConfig (CardanoBlock c)
+
+pattern CardanoStorageConfig
+ :: StorageConfig ByronBlock
+ -> StorageConfig (ShelleyBlock (ShelleyEra c))
+ -> StorageConfig (ShelleyBlock (AllegraEra c))
+ -> StorageConfig (ShelleyBlock (MaryEra c))
+ -> CardanoStorageConfig c
+pattern CardanoStorageConfig cfgByron cfgShelley cfgAllegra cfgMary =
+ HardForkStorageConfig {
+ hardForkStorageConfigPerEra = PerEraStorageConfig
+ ( cfgByron
+ :* cfgShelley
+ :* cfgAllegra
+ :* cfgMary
+ :* Nil
+ )
+ }
+
+{-# COMPLETE CardanoStorageConfig #-}
+
 {-------------------------------------------------------------------------------
  ConsensusConfig
 -------------------------------------------------------------------------------}