Merge pull request #1046 from Concordium/fix-1045

Fix startup time regression

CHANGELOG.md

@@ -2,6 +2,10 @@
 
 ## Unreleased changes
 
+- Fix a regression in the start up time. When upgrading from an earlier version, the first start-up
+  time may be longer than usual, as the genesis state hashes are computed. Subsequent restarts
+  will not suffer this penalty.
+
 ## 6.1.5
 
 - Enable out of band catchup by default in all distributions.

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

@@ -28,6 +28,7 @@ module Concordium.GlobalState.Persistent.LMDB (
     resizeOnResized,
     finalizedByHeightStore,
     StoredBlock (..),
+    StoredBlockWithStateHash (..),
     readBlock,
     readFinalizationRecord,
     readTransactionStatus,
@@ -38,6 +39,7 @@ module Concordium.GlobalState.Persistent.LMDB (
     getFinalizedBlockAtHeight,
     getLastBlock,
     getFirstBlock,
+    writeGenesisBlockStateHash,
     writeBlock,
     writeFinalizationRecord,
     writeTransactionStatus,
@@ -97,6 +99,18 @@ putStoredBlock StoredBlock{..} =
         <> putBlock (protocolVersion @pv) sbBlock
         <> S.put sbState
 
+-- | A stored block together with its state hash.
+--  If the stored block is a baked block, then the state hash must always be present, and match
+--  the state hash present in the block. For a genesis block, the state hash should be present,
+--  unless it is not available. (This can be the case when updating from earlier node versions
+--  that did not store the state hash of the genesis block in the tree state database.)
+data StoredBlockWithStateHash pv st = StoredBlockWithStateHash
+    { -- | The stored block.
+      sbshStoredBlock :: !(StoredBlock pv st),
+      -- | The block state hash.
+      sbshStateHash :: !(Maybe StateHash)
+    }
+
 -- | A block store table. A @BlockStore pv st@ stores @StoredBlock pv st@ blocks
 --  indexed by 'BlockHash'.
 newtype BlockStore (pv :: ProtocolVersion) st = BlockStore MDB_dbi'
@@ -217,6 +231,13 @@ instance MDBDatabase MetadataStore where
 versionMetadata :: DBKey MetadataStore
 versionMetadata = "version"
 
+-- | Key used to store the state hash for the genesis block in the metadata.
+--  If a value is present at this key, it must be the block state hash for the genesis block.
+--  Since this entry was not present in older databases, its absence is permissible and must be
+--  handled gracefully.
+genesisStateHashMetadata :: DBKey MetadataStore
+genesisStateHashMetadata = "genesisStateHash"
+
 data VersionMetadata = VersionMetadata
     { -- | Version signifier for the database itself.
       vmDatabaseVersion :: !Version,
@@ -396,10 +417,12 @@ initializeDatabase ::
     PersistentBlockPointer pv bs ->
     -- | Genesis block state
     st ->
+    -- | Genesis block state hash
+    StateHash ->
     -- | Tree state directory
     FilePath ->
     IO (DatabaseHandlers pv st)
-initializeDatabase gb stRef treeStateDir = do
+initializeDatabase gb stRef gbStateHash treeStateDir = do
     createDirectoryIfMissing False treeStateDir
     let storedGenesis =
             StoredBlock
@@ -427,6 +450,7 @@ initializeDatabase gb stRef treeStateDir = do
                     { vmDatabaseVersion = 0,
                       vmProtocolVersion = demoteProtocolVersion (protocolVersion @pv)
                     }
+        storeRecord txn _metadataStore genesisStateHashMetadata $ S.encode gbStateHash
     return handlers
 
 -- | Add a database version record to a database (if one is not already present).
@@ -513,16 +537,44 @@ resizeDatabaseHandlers dbh size = do
     logEvent LMDB LLDebug $ "Resizing database from " ++ show oldMapSize ++ " to " ++ show newMapSize
     liftIO . withWriteStoreEnv (dbh ^. storeEnv) $ flip mdb_env_set_mapsize newMapSize
 
+-- | Load a block and its state hash (if available).
+-- Normal blocks already contain their state hash. For genesis blocks, the state hash is loaded
+-- from the metadata table if it is present there.
+loadBlock ::
+    (MDBDatabase (BlockStore pv st)) =>
+    MDB_txn ->
+    DatabaseHandlers pv st ->
+    DBKey (BlockStore pv st) ->
+    IO (Maybe (StoredBlockWithStateHash pv st))
+loadBlock txn dbh bh = do
+    mblock <- loadRecord txn (dbh ^. blockStore) bh
+    forM mblock $ \sb -> case sbBlock sb of
+        GenesisBlock{} -> do
+            let tryDecode Nothing = Nothing
+                tryDecode (Just bs) = S.decode bs ^? _Right
+            mGenHashBS <- loadRecord txn (dbh ^. metadataStore) genesisStateHashMetadata
+            return $!
+                StoredBlockWithStateHash
+                    { sbshStoredBlock = sb,
+                      sbshStateHash = tryDecode mGenHashBS
+                    }
+        NormalBlock bb ->
+            return $!
+                StoredBlockWithStateHash
+                    { sbshStoredBlock = sb,
+                      sbshStateHash = Just (bbStateHash bb)
+                    }
+
 -- | Read a block from the database by hash.
 readBlock ::
     (MonadIO m, MonadState s m, IsProtocolVersion pv, HasDatabaseHandlers pv st s, FixedSizeSerialization st) =>
     BlockHash ->
-    m (Maybe (StoredBlock pv st))
+    m (Maybe (StoredBlockWithStateHash pv st))
 readBlock bh = do
     dbh <- use dbHandlers
     liftIO $
         transaction (dbh ^. storeEnv) True $
-            \txn -> loadRecord txn (dbh ^. blockStore) bh
+            \txn -> loadBlock txn dbh bh
 
 -- | Read a finalization record from the database by finalization index.
 readFinalizationRecord ::
@@ -551,17 +603,17 @@ getFinalizedBlockAtHeight ::
     (IsProtocolVersion pv, FixedSizeSerialization st) =>
     DatabaseHandlers pv st ->
     BlockHeight ->
-    IO (Maybe (StoredBlock pv st))
+    IO (Maybe (StoredBlockWithStateHash pv st))
 getFinalizedBlockAtHeight dbh bHeight = transaction (dbh ^. storeEnv) True $
     \txn -> do
         mbHash <- loadRecord txn (dbh ^. finalizedByHeightStore) bHeight
-        join <$> mapM (loadRecord txn (dbh ^. blockStore)) mbHash
+        join <$> mapM (loadBlock txn dbh) mbHash
 
 -- | Read a block from the database by its height.
 readFinalizedBlockAtHeight ::
     (MonadIO m, MonadState s m, IsProtocolVersion pv, HasDatabaseHandlers pv st s, FixedSizeSerialization st) =>
     BlockHeight ->
-    m (Maybe (StoredBlock pv st))
+    m (Maybe (StoredBlockWithStateHash pv st))
 readFinalizedBlockAtHeight bHeight = do
     dbh <- use dbHandlers
     liftIO $ getFinalizedBlockAtHeight dbh bHeight
@@ -608,22 +660,28 @@ loadBlocksFinalizationIndexes dbh = transaction (dbh ^. storeEnv) True $ \txn ->
         loop fstRes HM.empty
 
 -- | Get the last finalized block by block height.
-getLastBlock :: (IsProtocolVersion pv, FixedSizeSerialization st) => DatabaseHandlers pv st -> IO (Either String (FinalizationRecord, StoredBlock pv st))
+getLastBlock ::
+    (IsProtocolVersion pv, FixedSizeSerialization st) =>
+    DatabaseHandlers pv st ->
+    IO (Either String (FinalizationRecord, StoredBlockWithStateHash pv st))
 getLastBlock dbh = transaction (dbh ^. storeEnv) True $ \txn -> do
     mLastFin <- withCursor txn (dbh ^. finalizationRecordStore) $ getCursor CursorLast
     case mLastFin of
         Just (Right (_, finRec)) ->
-            loadRecord txn (dbh ^. blockStore) (finalizationBlockPointer finRec) >>= \case
+            loadBlock txn dbh (finalizationBlockPointer finRec) >>= \case
                 Just block -> return $ Right (finRec, block)
                 Nothing -> return . Left $ "Could not read last finalized block by hash " <> show (finalizationBlockPointer finRec)
         Just (Left s) -> return $ Left $ "Could not read last finalization record: " ++ s
         Nothing -> return $ Left "No last finalized block found"
 
 -- | Get the first block
-getFirstBlock :: (IsProtocolVersion pv, FixedSizeSerialization st) => DatabaseHandlers pv st -> IO (Maybe (StoredBlock pv st))
+getFirstBlock ::
+    (IsProtocolVersion pv, FixedSizeSerialization st) =>
+    DatabaseHandlers pv st ->
+    IO (Maybe (StoredBlockWithStateHash pv st))
 getFirstBlock dbh = transaction (dbh ^. storeEnv) True $ \txn -> do
     mbHash <- loadRecord txn (dbh ^. finalizedByHeightStore) 0
-    join <$> mapM (loadRecord txn (dbh ^. blockStore)) mbHash
+    join <$> mapM (loadBlock txn dbh) mbHash
 
 -- | Perform a database action that may require the database to be resized,
 --  resizing the database if necessary. The size argument is only evaluated
@@ -667,6 +725,17 @@ resizeOnFullInternal addSize dbh a = inner
         (LMDB_Error _ _ (Right MDB_MAP_FULL)) -> Just ()
         _ -> Nothing
 
+-- | Write the state hash of the genesis block into the metadata store.
+writeGenesisBlockStateHash ::
+    (MonadLogger m, MonadIO m) =>
+    DatabaseHandlers pv st ->
+    StateHash ->
+    m ()
+writeGenesisBlockStateHash dbh0 genBlockStateHash = resizeOnFullInternal 1024 dbh0 $
+    \dbh -> transaction (dbh ^. storeEnv) False $ \txn -> do
+        let encHash = S.encode genBlockStateHash
+        storeReplaceRecord txn (dbh ^. metadataStore) genesisStateHashMetadata encHash
+
 -- | Write a block to the database. Adds it both to the index by height and
 --  by block hash.
 writeBlock ::
@@ -774,35 +843,38 @@ unrollTreeStateWhile ::
     -- | A predicate determining if a block should be removed from the database. It is allowed to
     --  perform IO actions, for example, to attempt to read the block state from the blob store.
     (StoredBlock pv st -> m Bool) ->
-    m (Either String (FinalizationRecord, StoredBlock pv st))
+    m (Either String (FinalizationRecord, StoredBlockWithStateHash pv st))
 unrollTreeStateWhile dbh shouldDelete =
-    let loopBlocks h txn delbhs finIndex sb | NormalBlock block <- sbBlock sb = do
-            let bh = _bpHash . sbInfo $ sb
+    let loopBlocks h txn delbhs finIndex sblock | NormalBlock block <- sbBlock (sbshStoredBlock sblock) = do
+            let blockInfo = sbInfo . sbshStoredBlock $ sblock
+            let bh = _bpHash blockInfo
             -- When deleting a block, also delete the corresponding entry in the block height index
             -- and the statuses of all transactions included in the block. If any of those are not
             -- present in the database, report the treestate corruption, so it can be treated
             -- elsewhere.
             delBlockOK <- deleteRecord txn (h ^. blockStore) bh
-            delBlockHashOK <- deleteRecord txn (h ^. finalizedByHeightStore) (_bpHeight . sbInfo $ sb)
+            delBlockHashOK <- deleteRecord txn (h ^. finalizedByHeightStore) (_bpHeight blockInfo)
             delTxsOK <- mapM (deleteRecord txn (h ^. transactionStatusStore)) ((wmdHash <$>) . blockTransactions $ block)
             if delBlockOK && delBlockHashOK && and delTxsOK
                 then do
-                    loadRecord txn (h ^. blockStore) (blockPointer block) >>= \case
-                        Just sbParent | finIndex == sbFinalizationIndex sbParent -> loopBlocks h txn (bh : delbhs) finIndex sbParent
+                    loadBlock txn h (blockPointer block) >>= \case
+                        Just sbParent
+                            | finIndex == sbFinalizationIndex (sbshStoredBlock sbParent) ->
+                                loopBlocks h txn (bh : delbhs) finIndex sbParent
                         -- In particular, we stop deleting blocks when the current block's parent is the genesis
                         -- block, which is the only block with the finalization index 0.
                         Just sbParent -> return . Right $ (sbParent, bh : delbhs)
                         Nothing -> return . Left $ "Could not read the parent of the block " <> show bh
                 else return . Left $ "Could not rollback block " <> show bh
         -- If the rollback reached the genesis block, do nothing. The genesis block state corruption
         -- is to be handled as part of handling global state initialisation failure.
-        loopBlocks _ _ delbhs _ sb | otherwise = return . Right $ (sb, delbhs)
+        loopBlocks _ _ delbhs _ sblock = return . Right $ (sblock, delbhs)
 
-        loopFinRecs finIndex sb = do
-            isP <- shouldDelete sb
+        loopFinRecs finIndex sblock = do
+            isP <- shouldDelete (sbshStoredBlock sblock)
             if isP
                 then do
-                    let bh = _bpHash . sbInfo $ sb
+                    let bh = _bpHash . sbInfo $ sbshStoredBlock sblock
                     eancestor <- resizeOnFullInternal 4096 dbh $ \h -> transaction (h ^. storeEnv) False $ \txn -> do
                         -- After a finalization record is deleted, we must delete not only the block explicitly
                         -- finalized by it but also all ancestors of that block having the same finalization
@@ -811,7 +883,7 @@ unrollTreeStateWhile dbh shouldDelete =
                         -- finalization record.
                         delFinRecOK <- deleteRecord txn (h ^. finalizationRecordStore) finIndex
                         if delFinRecOK
-                            then loopBlocks h txn [] finIndex sb
+                            then loopBlocks h txn [] finIndex sblock
                             else
                                 return . Left $
                                     "Could not delete the finalization record with index "
@@ -828,8 +900,8 @@ unrollTreeStateWhile dbh shouldDelete =
                                     <> intercalate ", " (show <$> delbhs)
                                     <> " and finalization record "
                                     <> show finIndex
-                            loopFinRecs (sbFinalizationIndex ancestor) ancestor
-                else return . Right $ (finIndex, sb)
+                            loopFinRecs (sbFinalizationIndex $ sbshStoredBlock ancestor) ancestor
+                else return . Right $ (finIndex, sblock)
     in  liftIO (getLastBlock dbh) >>= \case
             Left s -> return . Left $ s
             Right (finRec, sb) ->
@@ -847,4 +919,4 @@ unrollTreeStateWhile dbh shouldDelete =
                                 Nothing ->
                                     return . Left $
                                         "Could not read the finalization record for the block "
-                                            <> show (_bpHash . sbInfo $ sb')
+                                            <> show (_bpHash . sbInfo . sbshStoredBlock $ sb')

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

@@ -45,7 +45,7 @@ import qualified Data.HashSet as HS
 import Data.Kind (Type)
 import Data.List (partition)
 import qualified Data.Map.Strict as Map
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, isNothing)
 import qualified Data.PQueue.Prio.Min as MPQ
 import qualified Data.Sequence as Seq
 import Data.Typeable
@@ -288,7 +288,7 @@ initialSkovPersistentData rp treeStateDir gd genState serState genTT mPending =
     gb <- makeGenesisPersistentBlockPointer gd genState
     let gbh = bpHash gb
         gbfin = FinalizationRecord 0 gbh emptyFinalizationProof 0
-    initialDb <- liftIO $ initializeDatabase gb serState treeStateDir
+    initialDb <- liftIO $ initializeDatabase gb serState (getHash genState) treeStateDir
     return
         SkovPersistentData
             { _blockTable = emptyBlockTable,
@@ -416,12 +416,22 @@ loadSkovPersistentData rp _treeStateDirectory pbsc = do
                 "The block state database is corrupt. Recovery attempt failed: " <> e
         Right (_lastFinalizationRecord, lfStoredBlock) -> do
             -- Truncate the blobstore beyond the last finalized blockstate.
-            liftIO $ truncateBlobStore (bscBlobStore . PBS.pbscBlobStore $ pbsc) (sbState lfStoredBlock)
+            liftIO $
+                truncateBlobStore
+                    (bscBlobStore . PBS.pbscBlobStore $ pbsc)
+                    (sbState . sbshStoredBlock $ lfStoredBlock)
             -- Get the genesis block.
             genStoredBlock <-
                 maybe (logExceptionAndThrowTS GenesisBlockNotInDataBaseError) return
                     =<< liftIO (getFirstBlock _db)
             _genesisBlockPointer <- liftIO $ makeBlockPointer genStoredBlock
+            when (isNothing (sbshStateHash genStoredBlock)) $ do
+                -- This should only occur when updating from a node version prior to 6.1.6
+                -- the first time the database is loaded.
+                let genStateHash = bpBlockStateHash _genesisBlockPointer
+                logEvent GlobalState LLDebug $
+                    "Writing genesis state hash to tree state database: " ++ show genStateHash
+                writeGenesisBlockStateHash _db genStateHash
             _genesisData <- case _bpBlock _genesisBlockPointer of
                 GenesisBlock gd' -> return gd'
                 _ -> logExceptionAndThrowTS (DatabaseInvariantViolation "Block at height 0 is not a genesis block.")
@@ -446,12 +456,11 @@ loadSkovPersistentData rp _treeStateDirectory pbsc = do
                       ..
                     }
   where
-    makeBlockPointer :: StoredBlock pv (TS.BlockStatePointer (PBS.PersistentBlockState pv)) -> IO (PersistentBlockPointer pv (PBS.HashedPersistentBlockState pv))
-    makeBlockPointer StoredBlock{..} = do
-        let stateHashM = case sbBlock of
-                GenesisBlock{} -> Nothing
-                NormalBlock bb -> Just $ bbStateHash bb
-        bstate <- runReaderT (PBS.runPersistentBlockStateMonad (loadBlockState stateHashM sbState)) pbsc
+    makeBlockPointer ::
+        StoredBlockWithStateHash pv (TS.BlockStatePointer (PBS.PersistentBlockState pv)) ->
+        IO (PersistentBlockPointer pv (PBS.HashedPersistentBlockState pv))
+    makeBlockPointer StoredBlockWithStateHash{sbshStoredBlock = StoredBlock{..}, ..} = do
+        bstate <- runReaderT (PBS.runPersistentBlockStateMonad (loadBlockState sbshStateHash sbState)) pbsc
         makeBlockPointerFromPersistentBlock sbBlock bstate sbInfo
     isBlockStateCorrupted :: StoredBlock pv (TS.BlockStatePointer (PBS.PersistentBlockState pv)) -> IO Bool
     isBlockStateCorrupted block =
@@ -599,13 +608,11 @@ constructBlock ::
       BlockStateStorage m,
       TS.BlockState m ~ bs
     ) =>
-    StoredBlock pv (TS.BlockStatePointer bs) ->
+    -- | The stored block and its state hash (if known).
+    StoredBlockWithStateHash pv (TS.BlockStatePointer bs) ->
     m (PersistentBlockPointer pv bs)
-constructBlock StoredBlock{..} = do
-    let stateHashM = case sbBlock of
-            GenesisBlock{} -> Nothing
-            NormalBlock bb -> Just $ bbStateHash bb
-    bstate <- loadBlockState stateHashM sbState
+constructBlock StoredBlockWithStateHash{sbshStoredBlock = StoredBlock{..}, ..} = do
+    bstate <- loadBlockState sbshStateHash sbState
     makeBlockPointerFromPersistentBlock sbBlock bstate sbInfo
 
 instance
@@ -652,7 +659,7 @@ instance
                                         deadBlocks <- use (skovPersistentData . blockTable . deadCache)
                                         return $! if memberDeadCache bh deadBlocks then Just TS.BlockDead else Nothing
                                     Just sb -> do
-                                        fr <- readFinalizationRecord (sbFinalizationIndex sb)
+                                        fr <- readFinalizationRecord (sbFinalizationIndex (sbshStoredBlock sb))
                                         case fr of
                                             Just finr -> do
                                                 block <- constructBlock sb