Merge pull request #1104 from Concordium/block-hashing-pv-height

Include finalization committee and block height in block hash

concordium-consensus/src/Concordium/GlobalState/BlockState.hs

@@ -567,7 +567,7 @@ class (ContractStateOperations m, AccountOperations m, ModuleQuery m) => BlockSt
     -- | Get the transactionOutcomesHash of a given block.
     getTransactionOutcomesHash :: BlockState m -> m TransactionOutcomesHash
 
-    -- | Get the stateHash of a given block.
+    -- | Get the StateHash of a given block.
     getStateHash :: BlockState m -> m StateHash
 
     -- | Get all transaction outcomes for this block.

concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs

@@ -408,6 +408,7 @@ blobBSFileLength BlobStoreAccess{..} = mask $ \restore -> do
 readBlobBS :: BlobStoreAccess -> BlobRef a -> IO BS.ByteString
 readBlobBS bs@BlobStoreAccess{..} br@(BlobRef offset) = do
     let ioffset = fromIntegral offset
+    when (ioffset < 0) $ throwIO $ userError "Attempted to read an invalid BlobRef"
     let dataOffset = ioffset + 8
     mmap0 <- readIORef blobStoreMMap
     mmap <-

concordium-consensus/src/Concordium/KonsensusV1/Consensus.hs

@@ -49,7 +49,7 @@ class MonadBroadcast m where
     sendQuorumMessage :: QuorumMessage -> m ()
 
     -- | Broadcast a 'SignedBlock'.
-    sendBlock :: SignedBlock -> m ()
+    sendBlock :: SignedBlock (MPV m) -> m ()
 
 -- | This class provides event handlers for consensus events. A runner should implement this to
 --  handle these events.
@@ -225,14 +225,17 @@ computeFinalizationCommittee FullBakers{..} FinalizationCommitteeParameters{..}
     committeeFinalizers = Vec.fromList $ zipWith mkFinalizer [FinalizerIndex 0 ..] sortedFinalizers
     committeeTotalWeight = sum $ finalizerWeight <$> committeeFinalizers
 
--- | Compute the finalization committee given the bakers and the finalization committee parameters,
---  returning a 'BakersAndFinalizers'.
+-- | Compute the finalization committee and finalization committee hash given the bakers and the
+-- finalization committee parameters, returning a 'BakersAndFinalizers'.
 computeBakersAndFinalizers :: FullBakers -> FinalizationCommitteeParameters -> BakersAndFinalizers
 computeBakersAndFinalizers bakers fcp =
     BakersAndFinalizers
         { _bfBakers = bakers,
-          _bfFinalizers = computeFinalizationCommittee bakers fcp
+          _bfFinalizers = finalizers,
+          _bfFinalizerHash = computeFinalizationCommitteeHash finalizers
         }
+  where
+    finalizers = computeFinalizationCommittee bakers fcp
 
 -- | Get the baker identity and finalizer info if we are a finalizer in the specified epoch.
 --  This checks that the signing key and aggregate signing key match those for the finalizer,

concordium-consensus/src/Concordium/KonsensusV1/Consensus/CatchUp.hs

@@ -76,7 +76,7 @@ data CatchUpPartialResponse m
     = -- | The next block in the stream.
       CatchUpPartialResponseBlock
         { -- | Next block.
-          cuprNextBlock :: SignedBlock,
+          cuprNextBlock :: SignedBlock (MPV m),
           -- | Continuation for getting any further blocks.
           cuprContinue :: m (CatchUpPartialResponse m),
           -- | Continuation that gets the terminal data in the case where there are no further

concordium-consensus/src/Concordium/KonsensusV1/Flag.hs

@@ -18,58 +18,61 @@ data FlaggableOffense (pv :: ProtocolVersion)
       DuplicateBlock !BlockSignatureWitness !BlockSignatureWitness
     | -- | The 'Round' of the 'QuorumCertificate' is not consistent with the
       --  'Round' of the parent block. Witnessed by the block received.
-      BlockQCRoundInconsistent !SignedBlock
+      BlockQCRoundInconsistent !(SignedBlock pv)
     | -- | The 'Epoch' of the 'QuorumCertificate' is not consistent with the
       --  'Epoch' of the parent block. Witnessed by the block received.
-      BlockQCEpochInconsistent !SignedBlock
+      BlockQCEpochInconsistent !(SignedBlock pv)
     | -- | The round is not greater than the parent block. Witnessed by
       --  the block received.
-      BlockRoundInconsistent !SignedBlock
+      BlockRoundInconsistent !(SignedBlock pv)
     | -- | The epoch is not the current or current + 1 epoch. Witnessed
       --  by the block received.
-      BlockEpochInconsistent !SignedBlock
+      BlockEpochInconsistent !(SignedBlock pv)
     | -- | The block received contains an invalid 'QuorumCertificate'.
       --  Witnessed by the block received.
-      BlockInvalidQC !SignedBlock
+      BlockInvalidQC !(SignedBlock pv)
     | -- | The 'TimeoutCertificate' is missing and the 'Round' of the block is
       --  not sequentially the next 'Round'. Witnessed by the block received.
-      BlockTCMissing !SignedBlock
+      BlockTCMissing !(SignedBlock pv)
     | -- | The 'Round' of the 'TimeoutCertificate' is inconsistent.
       --  Witnessed by the block received.
-      BlockTCRoundInconsistent !SignedBlock
+      BlockTCRoundInconsistent !(SignedBlock pv)
     | -- | The 'QuorumCertificate' is inconsistent
       --  with the 'TimeoutCertificate' of the block.
       --  Witnessed by the block received.
-      BlockQCInconsistentWithTC !SignedBlock
+      BlockQCInconsistentWithTC !(SignedBlock pv)
     | -- | The previous round did not timeout, but there is a
       --  'TimeoutCertificate' present in the block.
       --  Witnessed by the block received.
-      BlockUnexpectedTC !SignedBlock
+      BlockUnexpectedTC !(SignedBlock pv)
     | -- | The 'TimeoutCertificate' is invalid.
       --  Witnessed by the block received.
-      BlockInvalidTC !SignedBlock
+      BlockInvalidTC !(SignedBlock pv)
     | -- | The 'SignedBlock' is too close to its parent @Block pv@.
-      BlockTooFast !SignedBlock !(Block pv)
+      BlockTooFast !(SignedBlock pv) !(Block pv)
     | -- | The block nonce is invalid. Witnessed by the block received.
-      BlockNonceIncorrect !SignedBlock
+      BlockNonceIncorrect !(SignedBlock pv)
     | -- | The block is in a new 'Epoch', but it is missing the finalization entry.
       --  Witnessed by the block received.
-      BlockEpochFinalizationMissing !SignedBlock
+      BlockEpochFinalizationMissing !(SignedBlock pv)
     | -- | The block was not in a new 'Epoch', but a finalization entry is presnet.
       --  Witnessed by the block received.
-      BlockUnexpectedEpochFinalization !SignedBlock
+      BlockUnexpectedEpochFinalization !(SignedBlock pv)
     | -- | The block is in a new 'Epoch' but the finalization entry is deemed invalid.
       --  Witnessed by the block received.
-      BlockInvalidEpochFinalization !SignedBlock
+      BlockInvalidEpochFinalization !(SignedBlock pv)
     | -- | Execution of the block failed.
       --  Witnessed by the block received.
-      BlockExecutionFailure !SignedBlock
+      BlockExecutionFailure !(SignedBlock pv)
     | -- | Execution of the block resulted in an unexpected outcome.
       --  Witnessed by the block received and the parent block.
-      BlockInvalidTransactionOutcomesHash !SignedBlock !(Block pv)
+      BlockInvalidTransactionOutcomesHash !(SignedBlock pv) !(Block pv)
     | -- | Execution of the block resulted in an unexpected state.
       --  Witnessed by the block received and the parent block.
-      BlockInvalidStateHash !SignedBlock !(Block pv)
+      BlockInvalidStateHash !(SignedBlock pv) !(Block pv)
+    | -- | Execution of the block resulted in an unexpected result.
+      --  Witnessed by the block received and the parent block.
+      BlockInvalidResultHash !(SignedBlock pv) !(Block pv)
     | -- | An invalid block was signed by the 'QuorumMessage'.
       --  Witnessed by the 'QuorumMessage' received.
       SignedInvalidBlock !QuorumMessage

concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs

@@ -149,7 +149,7 @@ data HandlerContext (pv :: ProtocolVersion) m = HandlerContext
       -- | Handler to broadcast a quorum message.
       _sendQuorumHandler :: QuorumMessage -> m (),
       -- | Handler to broadcast a block.
-      _sendBlockHandler :: SignedBlock -> m (),
+      _sendBlockHandler :: SignedBlock pv -> m (),
       -- | An event handler called when a block becomes live.
       _onBlockHandler :: BlockPointer pv -> m (),
       -- | An event handler called per finalization. It is called with the
@@ -491,12 +491,13 @@ instance LMDBAccountMap.HasDatabaseHandlers (LMDBDatabases pv) where
 initialiseExistingSkovV1 ::
     forall pv m.
     (IsProtocolVersion pv, IsConsensusV1 pv) =>
+    GenesisBlockHeightInfo ->
     BakerContext ->
     HandlerContext pv m ->
     (forall a. SkovV1T pv m a -> IO a) ->
     GlobalStateConfig ->
     LogIO (Maybe (ExistingSkov pv m))
-initialiseExistingSkovV1 bakerCtx handlerCtx unliftSkov gsc@GlobalStateConfig{..} = do
+initialiseExistingSkovV1 genesisBlockHeightInfo bakerCtx handlerCtx unliftSkov gsc@GlobalStateConfig{..} = do
     logEvent Skov LLDebug "Attempting to use existing global state."
     existingDB <- checkExistingDatabase gscTreeStateDirectory gscBlockStateFile
     if existingDB
@@ -517,7 +518,7 @@ initialiseExistingSkovV1 bakerCtx handlerCtx unliftSkov gsc@GlobalStateConfig{..
                     let initContext = InitContext pbsc skovLldb
                     (initialSkovData, effectiveProtocolUpdate) <-
                         runInitMonad
-                            (loadSkovData gscRuntimeParameters (rbrCount > 0))
+                            (loadSkovData genesisBlockHeightInfo gscRuntimeParameters (rbrCount > 0))
                             initContext
                     let !es =
                             ExistingSkov
@@ -554,12 +555,13 @@ initialiseNewSkovV1 ::
     forall pv m.
     (IsProtocolVersion pv, IsConsensusV1 pv) =>
     GenesisData pv ->
+    GenesisBlockHeightInfo ->
     BakerContext ->
     HandlerContext pv m ->
     (forall a. SkovV1T pv m a -> IO a) ->
     GlobalStateConfig ->
     LogIO (SkovV1Context pv m, SkovV1State pv)
-initialiseNewSkovV1 genData bakerCtx handlerCtx unliftSkov gsConfig@GlobalStateConfig{..} = do
+initialiseNewSkovV1 genData genesisBlockHeightInfo bakerCtx handlerCtx unliftSkov gsConfig@GlobalStateConfig{..} = do
     logEvent Skov LLDebug "Creating new global state."
     pbsc@PersistentBlockStateContext{..} <- newPersistentBlockStateContext True gsConfig
     let
@@ -587,7 +589,7 @@ initialiseNewSkovV1 genData bakerCtx handlerCtx unliftSkov gsConfig@GlobalStateC
                     chainParams ^. cpConsensusParameters . cpTimeoutParameters . tpTimeoutBase
             genEpochBakers <- genesisEpochBakers pbs
             let !initSkovData =
-                    mkInitialSkovData gscRuntimeParameters genMeta pbs genTimeoutDuration genEpochBakers genTT emptyPendingTransactionTable
+                    mkInitialSkovData gscRuntimeParameters genMeta genesisBlockHeightInfo pbs genTimeoutDuration genEpochBakers genTT emptyPendingTransactionTable
             let storedGenesis =
                     LowLevel.StoredBlock
                         { stbStatePointer = stateRef,
@@ -673,6 +675,8 @@ migrateSkovV1 ::
       IsProtocolVersion pv,
       IsProtocolVersion lastpv
     ) =>
+    -- | Block height information for the genesis block.
+    GenesisBlockHeightInfo ->
     -- | The genesis for the protocol after the protocol update.
     Regenesis pv ->
     -- | The migration.
@@ -696,7 +700,7 @@ migrateSkovV1 ::
     PendingTransactionTable ->
     -- | Return back the 'SkovV1Context' and the migrated 'SkovV1State'
     LogIO (SkovV1Context pv m, SkovV1State pv)
-migrateSkovV1 regenesis migration gsConfig@GlobalStateConfig{..} oldPbsc oldBlockState bakerCtx handlerCtx unliftSkov migrateTT migratePTT = do
+migrateSkovV1 genesisBlockHeightInfo regenesis migration gsConfig@GlobalStateConfig{..} oldPbsc oldBlockState bakerCtx handlerCtx unliftSkov migrateTT migratePTT = do
     pbsc@PersistentBlockStateContext{..} <- newPersistentBlockStateContext True gsConfig
     logEvent GlobalState LLDebug "Migrating existing global state."
     let newInitialBlockState :: InitMonad pv (HashedPersistentBlockState pv)
@@ -714,7 +718,7 @@ migrateSkovV1 regenesis migration gsConfig@GlobalStateConfig{..} oldPbsc oldBloc
             let genTimeoutDuration =
                     chainParams ^. cpConsensusParameters . cpTimeoutParameters . tpTimeoutBase
             let !initSkovData =
-                    mkInitialSkovData gscRuntimeParameters genMeta newState genTimeoutDuration genEpochBakers migrateTT migratePTT
+                    mkInitialSkovData gscRuntimeParameters genMeta genesisBlockHeightInfo newState genTimeoutDuration genEpochBakers migrateTT migratePTT
             let storedGenesis =
                     LowLevel.StoredBlock
                         { stbStatePointer = stateRef,

concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs

@@ -101,7 +101,7 @@ data TestEvent (pv :: ProtocolVersion)
     | -- | Implements 'sendQuorumMessage' of 'MonadBroadcast'.
       SendQuorumMessage !QuorumMessage
     | -- | Implements 'sendBlock' of 'MonadBroadcast'.
-      SendBlock !SignedBlock
+      SendBlock !(SignedBlock pv)
     | -- | Implements 'onBlock' of 'MonadConsensusEvent'.
       OnBlock !(Block pv)
     | -- | Implements 'onFinalize' of 'MonadConsensusEvent'.
@@ -183,10 +183,16 @@ runTestMonad _tcBakerContext _tcCurrentTime genData (TestMonad a) =
                       gmFirstGenesisHash = genesisBlockHash genData,
                       gmStateHash = getHash genState
                     }
+        let genesisBlockHeightInfo =
+                GenesisBlockHeightInfo
+                    { gbhiAbsoluteHeight = 0,
+                      gbhiGenesisIndex = 0
+                    }
         let _tsSkovData =
                 mkInitialSkovData
                     defaultRuntimeParameters
                     genMetadata
+                    genesisBlockHeightInfo
                     genState
                     genTimeoutBase
                     genEpochBakers

concordium-consensus/src/Concordium/KonsensusV1/Transactions.hs

@@ -274,7 +274,7 @@ processBlockItems ::
       GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m)
     ) =>
     -- | The baked block
-    BakedBlock ->
+    BakedBlock pv ->
     -- | Pointer to the parent block.
     BlockPointer pv ->
     -- | Return 'True' only if all transactions were

concordium-consensus/src/Concordium/KonsensusV1/TreeState/Implementation.hs

@@ -42,6 +42,7 @@ import qualified Data.Sequence as Seq
 
 import qualified Concordium.Genesis.Data.BaseV1 as Base
 import Concordium.Types
+import qualified Concordium.Types.Conditionally as Cond
 import Concordium.Types.Execution
 import Concordium.Types.HashableTo
 import Concordium.Types.Option
@@ -183,6 +184,8 @@ data SkovData (pv :: ProtocolVersion) = SkovData
       _roundExistingQCs :: !(Map.Map Round QuorumCertificateCheckedWitness),
       -- | Genesis metadata
       _genesisMetadata :: !GenesisMetadata,
+      -- | Block height information of the (current) genesis block.
+      _genesisBlockHeight :: !GenesisBlockHeightInfo,
       -- | Pointer to the last finalized block.
       _lastFinalized :: !(BlockPointer pv),
       -- | A finalization entry that finalizes the last finalized block, unless that is the
@@ -277,10 +280,14 @@ purgeRoundExistingQCs rnd = roundExistingQCs %=! snd . Map.split (rnd - 1)
 --   * The caller must make sure, that the supplied 'TransactionTable' does NOT contain any @Committed@ transactions
 --     and all transactions have their commit point set to 0.
 mkInitialSkovData ::
+    forall pv.
+    (IsProtocolVersion pv) =>
     -- | The 'RuntimeParameters'
     RuntimeParameters ->
     -- | Genesis metadata. State hash should match the hash of the state.
     GenesisMetadata ->
+    -- | Block height information for the genesis block.
+    GenesisBlockHeightInfo ->
     -- | Genesis state
     PBS.HashedPersistentBlockState pv ->
     -- | The base timeout
@@ -293,7 +300,7 @@ mkInitialSkovData ::
     TT.PendingTransactionTable ->
     -- | The initial 'SkovData'
     SkovData pv
-mkInitialSkovData rp genMeta genState _currentTimeout _skovEpochBakers transactionTable' pendingTransactionTable' =
+mkInitialSkovData rp genMeta genesisBlockHeightInfo genState _currentTimeout _skovEpochBakers transactionTable' pendingTransactionTable' =
     let genesisBlock = GenesisBlock genMeta
         genesisTime = timestampToUTCTime $ Base.genesisTime (gmParameters genMeta)
         genesisBlockMetadata =
@@ -302,7 +309,13 @@ mkInitialSkovData rp genMeta genState _currentTimeout _skovEpochBakers transacti
                   bmReceiveTime = genesisTime,
                   bmArriveTime = genesisTime,
                   bmEnergyCost = 0,
-                  bmTransactionsSize = 0
+                  bmTransactionsSize = 0,
+                  bmBlockStateHash =
+                    Cond.conditionally
+                        ( sBlockStateHashInMetadata
+                            (sBlockHashVersionFor (protocolVersion @pv))
+                        )
+                        (getHash genState)
                 }
         genesisBlockPointer =
             BlockPointer
@@ -325,6 +338,7 @@ mkInitialSkovData rp genMeta genState _currentTimeout _skovEpochBakers transacti
         _roundExistingBlocks = Map.empty
         _roundExistingQCs = Map.empty
         _genesisMetadata = genMeta
+        _genesisBlockHeight = genesisBlockHeightInfo
         _lastFinalized = genesisBlockPointer
         _latestFinalizationEntry = Absent
         _statistics = Stats.initialConsensusStatistics
@@ -375,7 +389,7 @@ mkBlockPointer [email protected]{..} = do
   where
     mkHashedPersistentBlockState = do
         hpbsPointers <- newIORef $! BlobStore.blobRefToBufferedRef stbStatePointer
-        let hpbsHash = blockStateHash sb
+        let hpbsHash = LowLevel.stbBlockStateHash sb
         return $! PBS.HashedPersistentBlockState{..}
 
 -- | Get the 'BlockStatus' of a block based on the provided 'BlockHash'.
@@ -461,9 +475,10 @@ getFirstFinalizedBlockOfEpoch epochOrBlock sd
 --  The hash of the block state MUST match the block state hash of the block; this is not checked.
 --  [Note: this does not affect the '_branches' of the 'SkovData'.]
 makeLiveBlock ::
-    (MonadState (SkovData pv) m) =>
+    forall m pv.
+    (MonadState (SkovData pv) m, IsProtocolVersion pv) =>
     -- | Pending block to make live
-    PendingBlock ->
+    PendingBlock pv ->
     -- | Block state associated with the block
     PBS.HashedPersistentBlockState pv ->
     BlockHeight ->
@@ -480,7 +495,11 @@ makeLiveBlock pb st height arriveTime energyCost = do
                           bmArriveTime = arriveTime,
                           bmHeight = height,
                           bmEnergyCost = energyCost,
-                          bmTransactionsSize = fromIntegral $ sum (biSize <$> blockTransactions pb)
+                          bmTransactionsSize = fromIntegral $ sum (biSize <$> blockTransactions pb),
+                          bmBlockStateHash =
+                            Cond.conditionally
+                                (sBlockStateHashInMetadata (sBlockHashVersionFor (protocolVersion @pv)))
+                                (getHash st)
                         },
                   bpBlock = NormalBlock (pbBlock pb),
                   bpState = st