From 431d3840a735d9dbf15a6bf8d20b11286185e377 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Thu, 28 Sep 2023 21:08:03 +0200 Subject: [PATCH 01/92] Some initial work on having accountmap in lmdb. --- .../GlobalState/AccountMap/AccountMap.hs | 57 ++++++ .../Concordium/GlobalState/AccountMap/LMDB.hs | 191 ++++++++++++++++++ 2 files changed, 248 insertions(+) create mode 100644 concordium-consensus/src/Concordium/GlobalState/AccountMap/AccountMap.hs create mode 100644 concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/AccountMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/AccountMap.hs new file mode 100644 index 0000000000..e9bcdce217 --- /dev/null +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/AccountMap.hs @@ -0,0 +1,57 @@ +-- | This module exposes an account map backed by a LMDB database. +-- The ‘AccountMap’ is a simple key/value store where the keys consists +-- of the first 29 bytes of an ‘AccountAddress’ and the values are the +-- associated ‘AccountIndex’. +-- +-- The account map is integrated with the block state “on-the-fly” meaning that +-- whenver the node starts up and the ‘AccountMap’ is not populated, then it will be +-- initialized on startup via the existing ‘PersistentAccountMap’. +-- +-- Invariants: +-- * Only finalized accounts may be added to the ‘AccountMap’ +-- The following operations are applicable to the ‘AccountMap’. +-- +module Concordium.GlobalState.AccountMap.AccountMap ( + -- | The account map. + AccountMap(..), + -- | Initialize the account map. + initialize, + -- | Check whether the account map is initialized. + isInitialized, + -- | Add an account to the ‘AccountMap’. + addAccount, + -- | Look up an ‘AccountIndex’ by the supplied ‘AccountAddress’. + lookupAccount +) where + +import Concordium.Types +import Concordium.GlobalState.AccountMap.LMDB +import qualified Concordium.GlobalState.AccountMap as GSA + +data AccountMap = AccountMap + +-- | Create and initialize the ‘AccountMap’ via the supplied +-- ‘GSA.PersistentAccountMap’. +-- +-- Depending on the protocol version, then the ‘GSA.PersistentAccountMap’ may +-- contain keys which refer to the same ‘AccountIndex’. +-- The constructed ‘AccountMap’ will only retain one entry per account. +initialize :: GSA.PersistentAccountMap pv -> AccountMap +initialize _ = undefined + +-- | Check whether the ‘AccountMap’ is initialized. +-- Returns “Just BlockHash” if the ‘AccountMap’ is initialized, +-- the ‘BlockHash’ indicates the last finalized block for the ‘AccountMap’. +-- Returns @Nothing@ if the account map is not initialized. +isInitialized :: Monad m => m (Maybe BlockHash) +isInitialized = return Nothing + +-- | Adds an account to the ‘AccountMap’. +addAccount :: Monad m => BlockHash -> AccountAddress -> AccountIndex -> m () +addAccount _ = undefined + +-- | Looks up the ‘AccountIndex’ for the provided ‘AccountAddress’. +-- Returns @Just AccountIndex@ if the account is present in the ‘AccountMap’ +-- and returns @Nothing@ if the account was not present. +lookupAccount :: Monad m => AccountAddress -> m (Maybe AccountIndex) +lookupAccount _ = undefined diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs new file mode 100644 index 0000000000..2e06f1351d --- /dev/null +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- |Module for the low level LMDB account map. +module Concordium.GlobalState.AccountMap.LMDB where + +import Control.Concurrent +import Control.Monad +import Control.Monad.Catch +import Control.Monad.IO.Class +import Control.Monad.Reader.Class +import Data.Data (Data, Typeable) +import qualified Data.ByteString as BS +import qualified Data.Serialize as S +import Database.LMDB.Raw +import System.Directory +import Lens.Micro.Platform + +import Concordium.Logger +import qualified Data.FixedByteString as FBS +import Concordium.Types +import Concordium.GlobalState.LMDB.Helpers + +-- * Database stores + +-- | Store that yields the last finalized block from the perspective +-- of the lmdb database. +newtype MetadataStore = MetadataStore MDB_dbi' + +-- | Name of the 'MetadataStore' +metadataStoreName :: String +metadataStoreName = "metadata" + +-- | Store that retains the account address -> account index mappings. +newtype AccountMapStore = AccountMapStore MDB_dbi' + +accountMapStoreName :: String +accountMapStoreName = "accounts" + +-- | We only store the first 29 bytes of the account address +-- as these uniquely determine the account. +-- The remaining 3 bytes of an account address are used for the +-- account aliasing feature. +prefixAccountAddressSize :: Int +prefixAccountAddressSize = 29 + +data PrefixAccountAddressSize + deriving (Data, Typeable) + +instance FBS.FixedLength PrefixAccountAddressSize where + fixedLength _ = prefixAccountAddressSize + +-- | The prefix account address which is used as keys in the underlying store. +newtype PrefixAccountAddress = PrefixAccountAddress (FBS.FixedByteString PrefixAccountAddressSize) + +instance S.Serialize PrefixAccountAddress where + put (PrefixAccountAddress addr) = S.putByteString $ FBS.toByteString addr + get = PrefixAccountAddress . FBS.fromByteString <$> S.getByteString prefixAccountAddressSize + +accountAddressToPrefixAccountAddress :: AccountAddress -> PrefixAccountAddress +accountAddressToPrefixAccountAddress = undefined + +instance MDBDatabase AccountMapStore where + type DBKey AccountMapStore = PrefixAccountAddress + type DBValue AccountMapStore = AccountIndex + + +lfbKey :: DBKey MetadataStore +lfbKey = "lfb" + +instance MDBDatabase MetadataStore where + type DBKey MetadataStore = BS.ByteString + type DBValue MetadataStore = BlockHash + +data DatabaseHandlers = DatabaseHandlers + { + _storeEnv :: !StoreEnv, + _metadataStore :: !MetadataStore, + _accountMapStore :: !AccountMapStore + } +makeClassy ''DatabaseHandlers + +-- | The number of stores in the LMDB environment for 'DatabaseHandlers'. +databaseCount :: Int +databaseCount = 2 + +-- | Database growth size increment. +-- This is currently set at 64MB, and must be a multiple of the page size. +dbStepSize :: Int +dbStepSize = 2 ^ (25 :: Int) -- 32MB + +-- | Maximum step to increment the database size. +dbMaxStepSize :: Int +dbMaxStepSize = 2 ^ (28 :: Int) -- 256mb + +-- | Initial database size. +-- This is currently set to be the same as 'dbStepSize'. +dbInitSize :: Int +dbInitSize = dbStepSize + +-- ** Helpers + + +-- TODO: These helper functions below should probably be refactored and moved into LDMBHelpers so +-- they can be used across all lmdb database implementations. + + +-- | Resize the LMDB map if the file size has changed. +-- This is used to allow a secondary process that is reading the database +-- to handle resizes to the database that are made by the writer. +-- The supplied action will be executed. If it fails with an 'MDB_MAP_RESIZED' +-- error, then the map will be resized and the action retried. +resizeOnResized :: (MonadIO m, MonadReader r m, HasDatabaseHandlers r, MonadCatch m) => m a -> m a +resizeOnResized a = do + dbh <- view databaseHandlers + resizeOnResizedInternal (dbh ^. storeEnv) a + +-- | Perform a database action and resize the LMDB map if the file size has changed. The difference +-- with `resizeOnResized` is that this function takes database handlers as an argument, instead of +-- reading their value from `HasDatabaseHandlers`. +resizeOnResizedInternal :: (MonadIO m, MonadCatch m) => StoreEnv -> m a -> m a +resizeOnResizedInternal se a = inner + where + inner = handleJust checkResized onResized a + checkResized LMDB_Error{..} = guard (e_code == Right MDB_MAP_RESIZED) + onResized _ = do + liftIO (withWriteStoreEnv se $ flip mdb_env_set_mapsize 0) + inner + +-- | Increase the database size by at least the supplied size. +-- The size SHOULD be a multiple of 'dbStepSize', and MUST be a multiple of the page size. +resizeDatabaseHandlers :: (MonadIO m, MonadLogger m) => DatabaseHandlers -> Int -> m () +resizeDatabaseHandlers dbh delta = do + envInfo <- liftIO $ mdb_env_info (dbh ^. storeEnv . seEnv) + let oldMapSize = fromIntegral $ me_mapsize envInfo + newMapSize = oldMapSize + delta + _storeEnv = dbh ^. storeEnv + logEvent LMDB LLDebug $ "Resizing database from " ++ show oldMapSize ++ " to " ++ show newMapSize + liftIO . withWriteStoreEnv (dbh ^. storeEnv) $ flip mdb_env_set_mapsize newMapSize + +-- ** Initialization + +-- | Initialize database handlers. +-- The size will be rounded up to a multiple of 'dbStepSize'. +-- (This ensures in particular that the size is a multiple of the page size, which is required by +-- LMDB.) +makeDatabaseHandlers :: + -- | Path of database + FilePath -> + -- | Open read only + Bool -> + -- | Initial database size + Int -> + IO DatabaseHandlers +makeDatabaseHandlers treeStateDir readOnly initSize = do + _storeEnv <- makeStoreEnv + -- here nobody else has access to the environment, so we need not lock + let env = _storeEnv ^. seEnv + mdb_env_set_mapsize env (initSize + dbStepSize - initSize `mod` dbStepSize) + mdb_env_set_maxdbs env databaseCount + mdb_env_set_maxreaders env 126 + mdb_env_open env treeStateDir [MDB_RDONLY | readOnly] + transaction _storeEnv readOnly $ \txn -> do + _accountMapStore <- + AccountMapStore + <$> mdb_dbi_open' + txn + (Just accountMapStoreName) + [MDB_CREATE | not readOnly] + _metadataStore <- + MetadataStore + <$> mdb_dbi_open' + txn + (Just metadataStoreName) + [MDB_CREATE | not readOnly] + return DatabaseHandlers{..} + +-- | Initialize database handlers in ReadWrite mode. +-- This simply loads the references and does not initialize the databases. +-- The initial size is set to 64MB. +openDatabase :: FilePath -> IO DatabaseHandlers +openDatabase accountMapDir = do + createDirectoryIfMissing False accountMapDir + makeDatabaseHandlers accountMapDir False dbInitSize + +-- | Close the database. The database should not be used after it is closed. +closeDatabase :: DatabaseHandlers -> IO () +closeDatabase dbHandlers = runInBoundThread $ mdb_env_close $ dbHandlers ^. storeEnv . seEnv + From e4bda2ad42d1587810668e285f28063b8ddf3e34 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Fri, 29 Sep 2023 11:05:42 +0200 Subject: [PATCH 02/92] LMDB implementation for AccountMap. --- .../GlobalState/AccountMap/AccountMap.hs | 57 -------- .../Concordium/GlobalState/AccountMap/LMDB.hs | 135 +++++++++++++++--- 2 files changed, 118 insertions(+), 74 deletions(-) delete mode 100644 concordium-consensus/src/Concordium/GlobalState/AccountMap/AccountMap.hs diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/AccountMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/AccountMap.hs deleted file mode 100644 index e9bcdce217..0000000000 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/AccountMap.hs +++ /dev/null @@ -1,57 +0,0 @@ --- | This module exposes an account map backed by a LMDB database. --- The ‘AccountMap’ is a simple key/value store where the keys consists --- of the first 29 bytes of an ‘AccountAddress’ and the values are the --- associated ‘AccountIndex’. --- --- The account map is integrated with the block state “on-the-fly” meaning that --- whenver the node starts up and the ‘AccountMap’ is not populated, then it will be --- initialized on startup via the existing ‘PersistentAccountMap’. --- --- Invariants: --- * Only finalized accounts may be added to the ‘AccountMap’ --- The following operations are applicable to the ‘AccountMap’. --- -module Concordium.GlobalState.AccountMap.AccountMap ( - -- | The account map. - AccountMap(..), - -- | Initialize the account map. - initialize, - -- | Check whether the account map is initialized. - isInitialized, - -- | Add an account to the ‘AccountMap’. - addAccount, - -- | Look up an ‘AccountIndex’ by the supplied ‘AccountAddress’. - lookupAccount -) where - -import Concordium.Types -import Concordium.GlobalState.AccountMap.LMDB -import qualified Concordium.GlobalState.AccountMap as GSA - -data AccountMap = AccountMap - --- | Create and initialize the ‘AccountMap’ via the supplied --- ‘GSA.PersistentAccountMap’. --- --- Depending on the protocol version, then the ‘GSA.PersistentAccountMap’ may --- contain keys which refer to the same ‘AccountIndex’. --- The constructed ‘AccountMap’ will only retain one entry per account. -initialize :: GSA.PersistentAccountMap pv -> AccountMap -initialize _ = undefined - --- | Check whether the ‘AccountMap’ is initialized. --- Returns “Just BlockHash” if the ‘AccountMap’ is initialized, --- the ‘BlockHash’ indicates the last finalized block for the ‘AccountMap’. --- Returns @Nothing@ if the account map is not initialized. -isInitialized :: Monad m => m (Maybe BlockHash) -isInitialized = return Nothing - --- | Adds an account to the ‘AccountMap’. -addAccount :: Monad m => BlockHash -> AccountAddress -> AccountIndex -> m () -addAccount _ = undefined - --- | Looks up the ‘AccountIndex’ for the provided ‘AccountAddress’. --- Returns @Just AccountIndex@ if the account is present in the ‘AccountMap’ --- and returns @Nothing@ if the account was not present. -lookupAccount :: Monad m => AccountAddress -> m (Maybe AccountIndex) -lookupAccount _ = undefined diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index 2e06f1351d..c328acb901 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -1,27 +1,69 @@ -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} - --- |Module for the low level LMDB account map. +{-# LANGUAGE TypeFamilies #-} +-- Here because of the MonadReader instance for AccountMapStoreMonad +-- Revise this. +{-# LANGUAGE UndecidableInstances #-} + +-- | This module exposes an account map backed by a LMDB database. +-- The ‘AccountMap’ is a simple key/value store where the keys consists +-- of the first 29 bytes of an ‘AccountAddress’ and the values are the +-- associated ‘AccountIndex’. +-- +-- The account map is integrated with the block state “on-the-fly” meaning that +-- whenver the node starts up and the ‘AccountMap’ is not populated, then it will be +-- initialized on startup via the existing ‘PersistentAccountMap’. +-- +-- Invariants: +-- * Only finalized accounts are present in the ‘AccountMap’ module Concordium.GlobalState.AccountMap.LMDB where import Control.Concurrent -import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class +import Control.Monad.Identity import Control.Monad.Reader.Class -import Data.Data (Data, Typeable) +import Control.Monad.Trans.Class import qualified Data.ByteString as BS +import Data.Data (Data, Typeable) import qualified Data.Serialize as S import Database.LMDB.Raw -import System.Directory import Lens.Micro.Platform +import System.Directory +import Concordium.GlobalState.LMDB.Helpers import Concordium.Logger -import qualified Data.FixedByteString as FBS import Concordium.Types -import Concordium.GlobalState.LMDB.Helpers +import qualified Data.FixedByteString as FBS + +-- | The interface to the LMDB account map. +-- For more information, refer to the module documentation. +-- Invariants: +-- * All accounts in the store are finalized. +class (Monad m) => MonadAccountMapStore m where + -- | Create and initialize the ‘AccountMap’ via the supplied map of accounts + -- for the supplied 'BlockHash'. + -- The provided 'BlockHash' must correspond to the hash of last finalized block + -- when this function is invoked. + -- The @[(AccountAddress, AccountIndex)]@ should generally be obtained by the 'PersistentAccountMap'. + initialize :: BlockHash -> [(AccountAddress, AccountIndex)] -> m () + + -- | Check whether the ‘AccountMap’ is initialized. + -- Returns @Just BlockHash@ if the 'AccountMap' is initialized, + -- the ‘BlockHash’ indicates the last finalized block for the 'AccountMap'. + -- Returns @Nothing@ if the account map is not initialized. + isInitialized :: m (Maybe BlockHash) + + -- | Adds an account to the 'AccountMap'. + addAccount :: BlockHash -> AccountAddress -> AccountIndex -> m () + + -- | Looks up the ‘AccountIndex’ for the provided ‘AccountAddress’. + -- Returns @Just AccountIndex@ if the account is present in the ‘AccountMap’ + -- and returns @Nothing@ if the account was not present. + lookupAccount :: AccountAddress -> m (Maybe AccountIndex) -- * Database stores @@ -51,7 +93,7 @@ data PrefixAccountAddressSize instance FBS.FixedLength PrefixAccountAddressSize where fixedLength _ = prefixAccountAddressSize - + -- | The prefix account address which is used as keys in the underlying store. newtype PrefixAccountAddress = PrefixAccountAddress (FBS.FixedByteString PrefixAccountAddressSize) @@ -59,24 +101,27 @@ instance S.Serialize PrefixAccountAddress where put (PrefixAccountAddress addr) = S.putByteString $ FBS.toByteString addr get = PrefixAccountAddress . FBS.fromByteString <$> S.getByteString prefixAccountAddressSize +-- | Create a 'PrefixAccountAddress' from the supplied 'AccountAddress'. +-- The 'PrefixAccountAddress' is the first 29 bytes of the original 'AccountAddress'. accountAddressToPrefixAccountAddress :: AccountAddress -> PrefixAccountAddress -accountAddressToPrefixAccountAddress = undefined +accountAddressToPrefixAccountAddress (AccountAddress afbs) = toPrefixAccountAddress $ FBS.toByteString afbs + where + toPrefixAccountAddress = PrefixAccountAddress . FBS.fromByteString . first29Bytes + first29Bytes = BS.take prefixAccountAddressSize instance MDBDatabase AccountMapStore where type DBKey AccountMapStore = PrefixAccountAddress type DBValue AccountMapStore = AccountIndex - lfbKey :: DBKey MetadataStore lfbKey = "lfb" - + instance MDBDatabase MetadataStore where type DBKey MetadataStore = BS.ByteString type DBValue MetadataStore = BlockHash data DatabaseHandlers = DatabaseHandlers - { - _storeEnv :: !StoreEnv, + { _storeEnv :: !StoreEnv, _metadataStore :: !MetadataStore, _accountMapStore :: !AccountMapStore } @@ -102,11 +147,9 @@ dbInitSize = dbStepSize -- ** Helpers - -- TODO: These helper functions below should probably be refactored and moved into LDMBHelpers so -- they can be used across all lmdb database implementations. - -- | Resize the LMDB map if the file size has changed. -- This is used to allow a secondary process that is reading the database -- to handle resizes to the database that are made by the writer. @@ -188,4 +231,62 @@ openDatabase accountMapDir = do -- | Close the database. The database should not be used after it is closed. closeDatabase :: DatabaseHandlers -> IO () closeDatabase dbHandlers = runInBoundThread $ mdb_env_close $ dbHandlers ^. storeEnv . seEnv - + +-- ** Monad implementation +newtype AccountMapStoreMonad m a = AccountMapStoreMonad {runAccountMapStoreMonad :: m a} + deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadLogger) via m + deriving (MonadTrans) via IdentityT + +deriving instance (MonadReader r m) => MonadReader r (AccountMapStoreMonad m) + +-- | Run a read-only transaction. +asReadTransaction :: (MonadIO m, MonadReader r m, HasDatabaseHandlers r) => (DatabaseHandlers -> MDB_txn -> IO a) -> AccountMapStoreMonad m a +asReadTransaction t = do + dbh <- view databaseHandlers + liftIO $ transaction (dbh ^. storeEnv) True $ t dbh + +-- | Run a write transaction. If the transaction fails due to the database being full, this resizes +-- the database and retries the transaction. +asWriteTransaction :: (MonadIO m, MonadReader r m, HasDatabaseHandlers r, MonadLogger m) => (DatabaseHandlers -> MDB_txn -> IO a) -> AccountMapStoreMonad m a +asWriteTransaction t = do + dbh <- view databaseHandlers + let doTransaction = transaction (dbh ^. storeEnv) False $ t dbh + inner step = do + r <- liftIO $ tryJust selectDBFullError doTransaction + case r of + Left _ -> do + -- We resize by the step size initially, and by double for each successive + -- failure. + resizeDatabaseHandlers dbh step + inner (min (step * 2) dbMaxStepSize) + Right res -> return res + inner dbStepSize + where + -- only handle the db full error and propagate other exceptions. + selectDBFullError = \case + (LMDB_Error _ _ (Right MDB_MAP_FULL)) -> Just () + _ -> Nothing + +instance + ( MonadReader r m, + HasDatabaseHandlers r, + MonadIO m, + MonadLogger m + ) => + MonadAccountMapStore (AccountMapStoreMonad m) + where + initialize lfbHash accounts = asWriteTransaction $ \dbh txn -> do + forM_ + accounts + ( \(accAddr, accIndex) -> do + storeRecord txn (dbh ^. accountMapStore) (accountAddressToPrefixAccountAddress accAddr) accIndex + ) + storeRecord txn (dbh ^. metadataStore) lfbKey lfbHash + isInitialized = asReadTransaction $ \dbh txn -> + loadRecord txn (dbh ^. metadataStore) lfbKey + addAccount lfbHash accAddr accIndex = asWriteTransaction $ \dbh txn -> do + storeRecord txn (dbh ^. accountMapStore) (accountAddressToPrefixAccountAddress accAddr) accIndex + storeReplaceRecord txn (dbh ^. metadataStore) lfbKey lfbHash + + lookupAccount accAddr = asReadTransaction $ \dbh txn -> + loadRecord txn (dbh ^. accountMapStore) $ accountAddressToPrefixAccountAddress accAddr From 7ce65f9f9534dd0bfad6bc14cd82b9211f67823f Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Fri, 29 Sep 2023 11:07:01 +0200 Subject: [PATCH 03/92] Cleanup. --- .../src/Concordium/GlobalState/AccountMap/LMDB.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index c328acb901..6ea1b7e035 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -197,14 +197,14 @@ makeDatabaseHandlers :: -- | Initial database size Int -> IO DatabaseHandlers -makeDatabaseHandlers treeStateDir readOnly initSize = do +makeDatabaseHandlers accountMapDir readOnly initSize = do _storeEnv <- makeStoreEnv -- here nobody else has access to the environment, so we need not lock let env = _storeEnv ^. seEnv mdb_env_set_mapsize env (initSize + dbStepSize - initSize `mod` dbStepSize) mdb_env_set_maxdbs env databaseCount mdb_env_set_maxreaders env 126 - mdb_env_open env treeStateDir [MDB_RDONLY | readOnly] + mdb_env_open env accountMapDir [MDB_RDONLY | readOnly] transaction _storeEnv readOnly $ \txn -> do _accountMapStore <- AccountMapStore From c782bf77a2dde5c1522eaa9cd644a0ed80c2f758 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Fri, 29 Sep 2023 14:09:31 +0200 Subject: [PATCH 04/92] ... --- .../Concordium/GlobalState/AccountMap/LMDB.hs | 25 +++++++--- .../GlobalState/Persistent/Accounts.hs | 50 +++++++------------ .../GlobalState/Persistent/BlockState.hs | 6 ++- 3 files changed, 41 insertions(+), 40 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index 6ea1b7e035..eb6f0ef295 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -48,8 +48,10 @@ class (Monad m) => MonadAccountMapStore m where -- for the supplied 'BlockHash'. -- The provided 'BlockHash' must correspond to the hash of last finalized block -- when this function is invoked. - -- The @[(AccountAddress, AccountIndex)]@ should generally be obtained by the 'PersistentAccountMap'. - initialize :: BlockHash -> [(AccountAddress, AccountIndex)] -> m () + -- The @[AccountAddress]@ should be obtained by the account table. + -- Precondition: offset of the @AccountAddress@ in the list must correspond to + -- the account index of that particular account. + initialize :: BlockHash -> [AccountAddress] -> m () -- | Check whether the ‘AccountMap’ is initialized. -- Returns @Just BlockHash@ if the 'AccountMap' is initialized, @@ -57,13 +59,17 @@ class (Monad m) => MonadAccountMapStore m where -- Returns @Nothing@ if the account map is not initialized. isInitialized :: m (Maybe BlockHash) - -- | Adds an account to the 'AccountMap'. - addAccount :: BlockHash -> AccountAddress -> AccountIndex -> m () + -- | Adds an account to the 'AccountMap' and return @Just AccountIndex@ if + -- the account was added. + insert :: BlockHash -> AccountAddress -> m (Maybe AccountIndex) -- | Looks up the ‘AccountIndex’ for the provided ‘AccountAddress’. -- Returns @Just AccountIndex@ if the account is present in the ‘AccountMap’ -- and returns @Nothing@ if the account was not present. - lookupAccount :: AccountAddress -> m (Maybe AccountIndex) + lookup :: AccountAddress -> m (Maybe AccountIndex) + + -- | Get all account addresses + all :: m [AccountAddress] -- * Database stores @@ -277,16 +283,19 @@ instance where initialize lfbHash accounts = asWriteTransaction $ \dbh txn -> do forM_ - accounts + (zip accounts [0..]) ( \(accAddr, accIndex) -> do storeRecord txn (dbh ^. accountMapStore) (accountAddressToPrefixAccountAddress accAddr) accIndex ) storeRecord txn (dbh ^. metadataStore) lfbKey lfbHash isInitialized = asReadTransaction $ \dbh txn -> loadRecord txn (dbh ^. metadataStore) lfbKey - addAccount lfbHash accAddr accIndex = asWriteTransaction $ \dbh txn -> do + insert lfbHash accAddr = asWriteTransaction $ \dbh txn -> do storeRecord txn (dbh ^. accountMapStore) (accountAddressToPrefixAccountAddress accAddr) accIndex storeReplaceRecord txn (dbh ^. metadataStore) lfbKey lfbHash - lookupAccount accAddr = asReadTransaction $ \dbh txn -> + lookup accAddr = asReadTransaction $ \dbh txn -> loadRecord txn (dbh ^. accountMapStore) $ accountAddressToPrefixAccountAddress accAddr + all = asReadTransaction $ \dbh txn -> do + map fst <$> loadAll txn (dbh ^.accountMapStore) + diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 609f9102fe..984132fd77 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -35,6 +35,9 @@ import Concordium.GlobalState.Persistent.LFMBTree (LFMBTree') import qualified Concordium.GlobalState.Persistent.LFMBTree as L import Concordium.ID.Parameters import Concordium.Types.HashableTo +import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap +import Concordium.GlobalState.AccountMap.LMDB (MonadAccountMapStore) +import qualified Concordium.GlobalState.AccountMap as LMDB -- | Representation of the set of accounts on the chain. -- Each account has an 'AccountIndex' which is the order @@ -69,9 +72,7 @@ import Concordium.Types.HashableTo -- hence the current solution was chosen. Caching by account index (probably with an LRU strategy) -- would likely be a more effective strategy over all. data Accounts (pv :: ProtocolVersion) = Accounts - { -- | Unique index of accounts by 'AccountAddress' - accountMap :: !(AccountMap.PersistentAccountMap pv), - -- | Hashed Merkle-tree of the accounts + { -- | Hashed Merkle-tree of the accounts accountTable :: !(LFMBTree' AccountIndex HashedBufferedRef (AccountRef (AccountVersionFor pv))), -- | Persisted representation of the map from registration ids to account indices. accountRegIdHistory :: !(Trie.TrieN UnbufferedFix ID.RawCredentialRegistrationID AccountIndex) @@ -83,7 +84,8 @@ data Accounts (pv :: ProtocolVersion) = Accounts type SupportsPersistentAccount pv m = ( IsProtocolVersion pv, MonadBlobStore m, - MonadCache (AccountCache (AccountVersionFor pv)) m + MonadCache (AccountCache (AccountVersionFor pv)) m, + LMDBAccountMap.MonadAccountMapStore m ) instance (IsProtocolVersion pv) => Show (Accounts pv) where @@ -94,50 +96,38 @@ instance (SupportsPersistentAccount pv m) => MHashableTo m H.Hash (Accounts pv) instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where storeUpdate Accounts{..} = do - (pMap, accountMap') <- storeUpdate accountMap (pTable, accountTable') <- storeUpdate accountTable (pRegIdHistory, regIdHistory') <- storeUpdate accountRegIdHistory let newAccounts = Accounts - { accountMap = accountMap', - accountTable = accountTable', + { accountTable = accountTable', accountRegIdHistory = regIdHistory' } - return (pMap >> pTable >> pRegIdHistory, newAccounts) + return (pTable >> pRegIdHistory, newAccounts) load = do - maccountMap <- load maccountTable <- load mrRIH <- load return $ do - accountMap <- maccountMap accountTable <- maccountTable accountRegIdHistory <- mrRIH return $ Accounts{..} instance (SupportsPersistentAccount pv m, av ~ AccountVersionFor pv) => Cacheable1 m (Accounts pv) (PersistentAccount av) where liftCache cch accts@Accounts{..} = do - acctMap <- cache accountMap acctTable <- liftCache (liftCache @_ @(HashedCachedRef (AccountCache av) (PersistentAccount av)) cch) accountTable return - accts - { accountMap = acctMap, - accountTable = acctTable - } - --- | An 'Accounts' with no accounts. -emptyAccounts :: Accounts pv -emptyAccounts = Accounts AccountMap.empty L.empty Trie.empty + accts { accountTable = acctTable } -- | Add a new account. Returns @Just idx@ if the new account is fresh, i.e., the address does not exist, -- or @Nothing@ in case the account already exists. In the latter case there is no change to the accounts structure. putNewAccount :: (SupportsPersistentAccount pv m) => PersistentAccount (AccountVersionFor pv) -> Accounts pv -> m (Maybe AccountIndex, Accounts pv) putNewAccount !acct accts0 = do addr <- accountCanonicalAddress acct - (existingAccountId, newAccountMap) <- AccountMap.maybeInsert addr acctIndex (accountMap accts0) + mAccountIndex <- LMDBAccountMap.insert addr if isNothing existingAccountId then do (_, newAccountTable) <- L.append acct (accountTable accts0) - return (Just acctIndex, accts0{accountMap = newAccountMap, accountTable = newAccountTable}) + return (Just acctIndex, accts0{accountTable = newAccountTable}) else return (Nothing, accts0) where acctIndex = fromIntegral $ L.size (accountTable accts0) @@ -154,9 +144,9 @@ exists addr Accounts{..} = AccountMap.isAddressAssigned addr accountMap -- | Retrieve an account with the given address. -- Returns @Nothing@ if no such account exists. -getAccount :: (SupportsPersistentAccount pv m) => AccountAddress -> Accounts pv -> m (Maybe (PersistentAccount (AccountVersionFor pv))) +getAccount :: (SupportsPersistentAccount pv m, LMDBAccountMap.MonadAccountMapStore m) => AccountAddress -> Accounts pv -> m (Maybe (PersistentAccount (AccountVersionFor pv))) getAccount addr Accounts{..} = - AccountMap.lookup addr accountMap >>= \case + LMDBAccountMap.lookup addr >>= \case Nothing -> return Nothing Just ai -> L.lookup ai accountTable @@ -174,9 +164,9 @@ getAccountIndex addr Accounts{..} = AccountMap.lookup addr accountMap -- | Retrieve an account and its index from a given address. -- Returns @Nothing@ if no such account exists. -getAccountWithIndex :: (SupportsPersistentAccount pv m) => AccountAddress -> Accounts pv -> m (Maybe (AccountIndex, PersistentAccount (AccountVersionFor pv))) +getAccountWithIndex :: (SupportsPersistentAccount pv m, LMDBAccountMap.MonadAccountMapStore m) => AccountAddress -> Accounts pv -> m (Maybe (AccountIndex, PersistentAccount (AccountVersionFor pv))) getAccountWithIndex addr Accounts{..} = - AccountMap.lookup addr accountMap >>= \case + LMDBAccountMap.lookup addr >>= \case Nothing -> return Nothing Just ai -> fmap (ai,) <$> L.lookup ai accountTable @@ -186,7 +176,7 @@ indexedAccount ai Accounts{..} = L.lookup ai accountTable -- | Retrieve an account with the given address. -- An account with the address is required to exist. -unsafeGetAccount :: (SupportsPersistentAccount pv m) => AccountAddress -> Accounts pv -> m (PersistentAccount (AccountVersionFor pv)) +unsafeGetAccount :: (SupportsPersistentAccount pv m, LMDBAccountMap.MonadAccountMapStore m) => AccountAddress -> Accounts pv -> m (PersistentAccount (AccountVersionFor pv)) unsafeGetAccount addr accts = getAccount addr accts <&> \case Just acct -> acct @@ -257,8 +247,8 @@ updateAccountsAtIndex' fupd ai = fmap snd . updateAccountsAtIndex fupd' ai fupd' = fmap ((),) . fupd -- | Get a list of all account addresses. -accountAddresses :: (MonadBlobStore m) => Accounts pv -> m [AccountAddress] -accountAddresses = AccountMap.addresses . accountMap +accountAddresses :: (MonadBlobStore m, LMDBAccountMap.MonadAccountMapStore m) => m [AccountAddress] +accountAddresses = LMDBAccountMap.all -- | Serialize accounts in V0 format. serializeAccounts :: (SupportsPersistentAccount pv m, MonadPut m) => GlobalContext -> Accounts pv -> m () @@ -287,14 +277,12 @@ migrateAccounts :: Accounts oldpv -> t m (Accounts pv) migrateAccounts migration Accounts{..} = do - newAccountMap <- AccountMap.migratePersistentAccountMap accountMap newAccountTable <- L.migrateLFMBTree (migrateHashedCachedRef' (migratePersistentAccount migration)) accountTable -- The account registration IDs are not cached. There is a separate cache -- that is purely in-memory and just copied over. newAccountRegIds <- Trie.migrateUnbufferedTrieN return accountRegIdHistory return $! Accounts - { accountMap = newAccountMap, - accountTable = newAccountTable, + { accountTable = newAccountTable, accountRegIdHistory = newAccountRegIds } diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 42adf57205..4801dc1cbc 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -86,6 +86,7 @@ import Concordium.Utils.BinarySearch import Concordium.Utils.Serialization import Concordium.Utils.Serialization.Put import qualified Concordium.Wasm as Wasm +import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import qualified Control.Monad.Except as MTL import Control.Monad.Reader @@ -3328,7 +3329,8 @@ type PersistentState av pv r m = HasBlobStore r, AccountVersionFor pv ~ av, Cache.HasCache (AccountCache av) r, - Cache.HasCache Modules.ModuleCache r + Cache.HasCache Modules.ModuleCache r, + LMDBAccountMap.MonadAccountMapStore m ) instance MonadTrans (PersistentBlockStateMonad pv r) where @@ -3341,6 +3343,8 @@ instance (PersistentState av pv r m) => MonadBlobStore (PutH (PersistentBlockSta instance (PersistentState av pv r m) => Cache.MonadCache (AccountCache av) (PersistentBlockStateMonad pv r m) instance (PersistentState av pv r m) => Cache.MonadCache Modules.ModuleCache (PersistentBlockStateMonad pv r m) +instance (PersistentState av pv r m) => LMDBAccountMap.MonadAccountMapStore (PersistentBlockStateMonad pv r m) + type instance BlockStatePointer (PersistentBlockState pv) = BlobRef (BlockStatePointers pv) type instance BlockStatePointer (HashedPersistentBlockState pv) = BlobRef (BlockStatePointers pv) From 114518e9f528bb0cdc78214299a343e95dca8ae9 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Mon, 2 Oct 2023 20:29:07 +0200 Subject: [PATCH 05/92] Introduced DifferenceAccountMap. --- .../GlobalState/AccountMap/DifferenceMap.hs | 67 +++++++++++++++ .../Concordium/GlobalState/AccountMap/LMDB.hs | 66 +++++++++++---- .../GlobalState/Persistent/Accounts.hs | 83 +++++++++++++------ .../GlobalState/Persistent/BlockState.hs | 2 +- .../KonsensusV1/Consensus/Finality.hs | 2 + 5 files changed, 174 insertions(+), 46 deletions(-) create mode 100644 concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs new file mode 100644 index 0000000000..13a9be1d3b --- /dev/null +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | The 'DifferenceMap' stores accounts have been created in a non-finalized block. +-- When a block is being finalized then the assoicated 'DifferenceMap' must be written +-- to disk via 'Concordium.GlobalState.AccountMap.LMDB.insert'. +module Concordium.GlobalState.AccountMap.DifferenceMap where + +import qualified Data.List as List +import Prelude hiding (lookup) + +import Concordium.Types + +-- | A difference map that indicates newly added accounts for +-- a block identified by a 'BlockHash' and its associated 'BlockHeight'. +-- The difference map only contains accounds that was added since the '_dmParentMap'. +data DifferenceMap = DifferenceMap + { + -- | Accounts added to the chain in the + -- block 'amdmLfbHash'. + -- Note. The list is in descending order of the 'AccountIndex'. + -- TODO: Use Ordered set or a sequence instead? + dmAccounts :: ![(AccountAddress, AccountIndex)], + -- | Next available account index. + dmNextAccountIndex :: !AccountIndex, + -- | Parent map of non-finalized blocks. + -- In other words, if the parent block is finalized, + -- then the parent map is @Nothing@ as the LMDB account map + -- should be consulted instead. + dmParentMap :: !(Maybe DifferenceMap) + } + +-- | Create a new empty 'DifferenceMap' based on either a finalized block (in which case +-- the @dmNextAccountIndex@ must be provided explicitly or in case that the parent block is +-- not yet finalized then that map is supplied. +empty :: AccountIndex -> DifferenceMap +empty nextAccountIndex = + DifferenceMap + { dmAccounts = [], + dmNextAccountIndex = nextAccountIndex, + dmParentMap = Nothing + } + +-- | Check if an account exists in the difference map or any of the parent +-- difference maps. +-- Returns @Just AccountIndex@ if the account is present and +-- otherwise @Nothing@. +-- Note. It is up to the caller to check whether the account exists in the last finalized block. +lookup :: AccountAddress -> DifferenceMap -> Maybe AccountIndex +lookup addr DifferenceMap{..} = + case List.lookup addr dmAccounts of + Nothing -> case dmParentMap of + Nothing -> Nothing + Just parentMap -> lookup addr parentMap + Just idx -> Just idx + +-- | Insert an account into the difference and return @Just AccountIndex@ if the +-- account was added and @Nothing@ if it was already present. +-- +-- If a an account was succesfully added the 'dmNextAccountIndex' is being incremented by one. +addAccount :: AccountAddress -> AccountIndex -> DifferenceMap -> DifferenceMap +addAccount addr accIndex diffMap = + diffMap { + dmAccounts = (addr,accIndex) : dmAccounts diffMap, + dmNextAccountIndex = 1 + dmNextAccountIndex diffMap + } + + + diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index eb6f0ef295..91f30b6bda 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -13,6 +13,16 @@ -- of the first 29 bytes of an ‘AccountAddress’ and the values are the -- associated ‘AccountIndex’. -- +-- The LMDB account map only stores finalized accounts. +-- Non finalized accounts are being kept in a 'DifferenceMap' which +-- is being written to this LMDB account map when a block is finalized. +-- +-- As opposed to the account table of the block state this database does not +-- include historical data i.e., the state of this database is from the perspective +-- of the last finalized block always. +-- For querying historical data (e.g. which accounts existed in a given block) then one +-- should use the account table. +-- -- The account map is integrated with the block state “on-the-fly” meaning that -- whenver the node starts up and the ‘AccountMap’ is not populated, then it will be -- initialized on startup via the existing ‘PersistentAccountMap’. @@ -34,11 +44,23 @@ import Database.LMDB.Raw import Lens.Micro.Platform import System.Directory +import Concordium.GlobalState.AccountMap.DifferenceMap import Concordium.GlobalState.LMDB.Helpers import Concordium.Logger import Concordium.Types import qualified Data.FixedByteString as FBS +-- * Exceptions + +-- | Exception occurring from a violation of database invariants in the LMDB database. +newtype DatabaseInvariantViolation = DatabaseInvariantViolation String + deriving (Eq, Show, Typeable) + +instance Exception DatabaseInvariantViolation where + displayException (DatabaseInvariantViolation reason) = + "Database invariant violation: " + ++ show reason + -- | The interface to the LMDB account map. -- For more information, refer to the module documentation. -- Invariants: @@ -51,26 +73,27 @@ class (Monad m) => MonadAccountMapStore m where -- The @[AccountAddress]@ should be obtained by the account table. -- Precondition: offset of the @AccountAddress@ in the list must correspond to -- the account index of that particular account. - initialize :: BlockHash -> [AccountAddress] -> m () + initialize :: BlockHash -> BlockHeight -> [AccountAddress] -> m () -- | Check whether the ‘AccountMap’ is initialized. -- Returns @Just BlockHash@ if the 'AccountMap' is initialized, -- the ‘BlockHash’ indicates the last finalized block for the 'AccountMap'. -- Returns @Nothing@ if the account map is not initialized. - isInitialized :: m (Maybe BlockHash) + isInitialized :: m (Maybe (BlockHash, BlockHeight)) - -- | Adds an account to the 'AccountMap' and return @Just AccountIndex@ if - -- the account was added. - insert :: BlockHash -> AccountAddress -> m (Maybe AccountIndex) + -- | Adds accounts present in the provided difference maps to the lmdb store. + -- The argument is a list as multiple blocks can be finalized at the same time. + -- Implementations should update the last finalized block pointer. + -- + -- Postcondition: The list of 'AccountMapDifferenceMap' MUST be provided in + -- ascending order of the block height. + insert :: BlockHash -> BlockHeight -> [DifferenceMap] -> m () -- | Looks up the ‘AccountIndex’ for the provided ‘AccountAddress’. -- Returns @Just AccountIndex@ if the account is present in the ‘AccountMap’ -- and returns @Nothing@ if the account was not present. lookup :: AccountAddress -> m (Maybe AccountIndex) - -- | Get all account addresses - all :: m [AccountAddress] - -- * Database stores -- | Store that yields the last finalized block from the perspective @@ -124,7 +147,7 @@ lfbKey = "lfb" instance MDBDatabase MetadataStore where type DBKey MetadataStore = BS.ByteString - type DBValue MetadataStore = BlockHash + type DBValue MetadataStore = (BlockHash, BlockHeight) data DatabaseHandlers = DatabaseHandlers { _storeEnv :: !StoreEnv, @@ -281,21 +304,28 @@ instance ) => MonadAccountMapStore (AccountMapStoreMonad m) where - initialize lfbHash accounts = asWriteTransaction $ \dbh txn -> do + initialize lfbHash lfbHeight accounts = asWriteTransaction $ \dbh txn -> do forM_ - (zip accounts [0..]) + (zip accounts [0 ..]) ( \(accAddr, accIndex) -> do storeRecord txn (dbh ^. accountMapStore) (accountAddressToPrefixAccountAddress accAddr) accIndex ) - storeRecord txn (dbh ^. metadataStore) lfbKey lfbHash + storeRecord txn (dbh ^. metadataStore) lfbKey (lfbHash, lfbHeight) isInitialized = asReadTransaction $ \dbh txn -> loadRecord txn (dbh ^. metadataStore) lfbKey - insert lfbHash accAddr = asWriteTransaction $ \dbh txn -> do - storeRecord txn (dbh ^. accountMapStore) (accountAddressToPrefixAccountAddress accAddr) accIndex - storeReplaceRecord txn (dbh ^. metadataStore) lfbKey lfbHash + insert lfbHash lfbHeight differenceMaps = asWriteTransaction $ \dbh txn -> do + forM_ differenceMaps (doInsert dbh txn) + where + doInsert dbh txn DifferenceMap{..} = do + forM_ dmAccounts $ \(accAddr, expectedAccIndex) -> do + let addr = accountAddressToPrefixAccountAddress accAddr + accIndex <- AccountIndex . subtract 1 <$> databaseSize txn (dbh ^. accountMapStore) + when (accIndex /= expectedAccIndex) $ + throwM . DatabaseInvariantViolation $ + "The actual account index " <> show accIndex <> "did not match the expected one " <> show expectedAccIndex + storeRecord txn (dbh ^. accountMapStore) addr accIndex + storeReplaceRecord txn (dbh ^. metadataStore) lfbKey (lfbHash, lfbHeight) + return $ Just accIndex lookup accAddr = asReadTransaction $ \dbh txn -> loadRecord txn (dbh ^. accountMapStore) $ accountAddressToPrefixAccountAddress accAddr - all = asReadTransaction $ \dbh txn -> do - map fst <$> loadAll txn (dbh ^.accountMapStore) - diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 984132fd77..4b16f46a04 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -29,15 +29,13 @@ import Concordium.Types import Concordium.Utils.Serialization.Put import qualified Concordium.Crypto.SHA256 as H -import qualified Concordium.GlobalState.AccountMap as AccountMap +import qualified Concordium.GlobalState.AccountMap.DifferenceMap as DiffMap +import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import Concordium.GlobalState.Parameters import Concordium.GlobalState.Persistent.LFMBTree (LFMBTree') import qualified Concordium.GlobalState.Persistent.LFMBTree as L import Concordium.ID.Parameters import Concordium.Types.HashableTo -import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap -import Concordium.GlobalState.AccountMap.LMDB (MonadAccountMapStore) -import qualified Concordium.GlobalState.AccountMap as LMDB -- | Representation of the set of accounts on the chain. -- Each account has an 'AccountIndex' which is the order @@ -72,7 +70,9 @@ import qualified Concordium.GlobalState.AccountMap as LMDB -- hence the current solution was chosen. Caching by account index (probably with an LRU strategy) -- would likely be a more effective strategy over all. data Accounts (pv :: ProtocolVersion) = Accounts - { -- | Hashed Merkle-tree of the accounts + { -- | Accounts that has been created since the last finalized block. + accountDifferenceMap :: !DiffMap.DifferenceMap, + -- | Hashed Merkle-tree of the accounts accountTable :: !(LFMBTree' AccountIndex HashedBufferedRef (AccountRef (AccountVersionFor pv))), -- | Persisted representation of the map from registration ids to account indices. accountRegIdHistory :: !(Trie.TrieN UnbufferedFix ID.RawCredentialRegistrationID AccountIndex) @@ -101,7 +101,10 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where let newAccounts = Accounts { accountTable = accountTable', - accountRegIdHistory = regIdHistory' + accountRegIdHistory = regIdHistory', + -- Carry over the difference map. The difference map is persisted + -- when the block is finalized. + accountDifferenceMap = accountDifferenceMap } return (pTable >> pRegIdHistory, newAccounts) load = do @@ -110,25 +113,36 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where return $ do accountTable <- maccountTable accountRegIdHistory <- mrRIH + -- Empty diff map is ok when loading an old block as lookups will just go through the LMDB database. + let accountDifferenceMap = DiffMap.empty . AccountIndex $ L.size accountTable return $ Accounts{..} instance (SupportsPersistentAccount pv m, av ~ AccountVersionFor pv) => Cacheable1 m (Accounts pv) (PersistentAccount av) where liftCache cch accts@Accounts{..} = do acctTable <- liftCache (liftCache @_ @(HashedCachedRef (AccountCache av) (PersistentAccount av)) cch) accountTable return - accts { accountTable = acctTable } + accts{accountTable = acctTable} + +emptyAccounts :: Accounts pv +emptyAccounts = Accounts (DiffMap.empty $ AccountIndex 0) L.empty Trie.empty -- | Add a new account. Returns @Just idx@ if the new account is fresh, i.e., the address does not exist, -- or @Nothing@ in case the account already exists. In the latter case there is no change to the accounts structure. putNewAccount :: (SupportsPersistentAccount pv m) => PersistentAccount (AccountVersionFor pv) -> Accounts pv -> m (Maybe AccountIndex, Accounts pv) putNewAccount !acct accts0 = do addr <- accountCanonicalAddress acct - mAccountIndex <- LMDBAccountMap.insert addr - if isNothing existingAccountId - then do - (_, newAccountTable) <- L.append acct (accountTable accts0) - return (Just acctIndex, accts0{accountTable = newAccountTable}) - else return (Nothing, accts0) + -- check whether the account is in the difference map. + case DiffMap.lookup addr (accountDifferenceMap accts0) of + Just _ -> return (Nothing, accts0) + Nothing -> do + -- Check whether the account is present in a finalized block. + existingAccountId <- LMDBAccountMap.lookup addr + if isNothing existingAccountId + then do + (_, newAccountTable) <- L.append acct (accountTable accts0) + let accountDifferenceMap' = DiffMap.addAccount addr acctIndex (accountDifferenceMap accts0) + return (Just acctIndex, accts0{accountTable = newAccountTable, accountDifferenceMap = accountDifferenceMap'}) + else return (Nothing, accts0) where acctIndex = fromIntegral $ L.size (accountTable accts0) @@ -139,8 +153,8 @@ fromList = foldlM insert emptyAccounts insert accounts account = snd <$> putNewAccount account accounts -- | Determine if an account with the given address exists. -exists :: (IsProtocolVersion pv, MonadBlobStore m) => AccountAddress -> Accounts pv -> m Bool -exists addr Accounts{..} = AccountMap.isAddressAssigned addr accountMap +exists :: (IsProtocolVersion pv, LMDBAccountMap.MonadAccountMapStore m) => AccountAddress -> Accounts pv -> m Bool +exists addr accts = isJust <$> getAccountIndex addr accts -- | Retrieve an account with the given address. -- Returns @Nothing@ if no such account exists. @@ -159,8 +173,13 @@ getAccountByCredId cid accs@Accounts{..} = Just ai -> fmap (ai,) <$> indexedAccount ai accs -- | Get the account at a given index (if any). -getAccountIndex :: (IsProtocolVersion pv, MonadBlobStore m) => AccountAddress -> Accounts pv -> m (Maybe AccountIndex) -getAccountIndex addr Accounts{..} = AccountMap.lookup addr accountMap +getAccountIndex :: (IsProtocolVersion pv, LMDBAccountMap.MonadAccountMapStore m) => AccountAddress -> Accounts pv -> m (Maybe AccountIndex) +getAccountIndex addr Accounts{..} = case DiffMap.lookup addr accountDifferenceMap of + Just accIdx -> return $ Just accIdx + Nothing -> + LMDBAccountMap.lookup addr >>= \case + Nothing -> return Nothing + Just accIdx -> return $ Just accIdx -- | Retrieve an account and its index from a given address. -- Returns @Nothing@ if no such account exists. @@ -184,8 +203,9 @@ unsafeGetAccount addr accts = -- | Check whether the given account address would clash with any existing account address. -- The meaning of "clash" depends on the protocol version. -addressWouldClash :: (IsProtocolVersion pv, MonadBlobStore m) => AccountAddress -> Accounts pv -> m Bool -addressWouldClash addr Accounts{..} = AccountMap.addressWouldClash addr accountMap +-- todo: remove this ? exists would suffice. +addressWouldClash :: (IsProtocolVersion pv, MonadBlobStore m, LMDBAccountMap.MonadAccountMapStore m) => AccountAddress -> Accounts pv -> m Bool +addressWouldClash = exists -- | Check that an account registration ID is not already on the chain. -- See the foundation (Section 4.2) for why this is necessary. @@ -220,12 +240,17 @@ loadRegIds accts = Trie.toMap (accountRegIdHistory accts) -- disallowed). updateAccounts :: (SupportsPersistentAccount pv m) => (PersistentAccount (AccountVersionFor pv) -> m (a, PersistentAccount (AccountVersionFor pv))) -> AccountAddress -> Accounts pv -> m (Maybe (AccountIndex, a), Accounts pv) updateAccounts fupd addr a0@Accounts{..} = - AccountMap.lookup addr accountMap >>= \case - Nothing -> return (Nothing, a0) - Just ai -> - L.update fupd ai accountTable >>= \case + case DiffMap.lookup addr accountDifferenceMap of + Nothing -> + LMDBAccountMap.lookup addr >>= \case Nothing -> return (Nothing, a0) - Just (res, act') -> return (Just (ai, res), a0{accountTable = act'}) + Just ai -> update ai + Just ai -> update ai + where + update ai = + L.update fupd ai accountTable >>= \case + Nothing -> return (Nothing, a0) + Just (res, act') -> return (Just (ai, res), a0{accountTable = act'}) -- | Perform an update to an account with the given index. -- Does nothing (returning @Nothing@) if the account does not exist. @@ -247,8 +272,11 @@ updateAccountsAtIndex' fupd ai = fmap snd . updateAccountsAtIndex fupd' ai fupd' = fmap ((),) . fupd -- | Get a list of all account addresses. -accountAddresses :: (MonadBlobStore m, LMDBAccountMap.MonadAccountMapStore m) => m [AccountAddress] -accountAddresses = LMDBAccountMap.all +-- TODO: This is probably not good enough, revise or at least test. +accountAddresses :: (SupportsPersistentAccount pv m) => Accounts pv -> m [AccountAddress] +accountAddresses accounts = do + accs <- (L.toAscList . accountTable) accounts + mapM accountCanonicalAddress accs -- | Serialize accounts in V0 format. serializeAccounts :: (SupportsPersistentAccount pv m, MonadPut m) => GlobalContext -> Accounts pv -> m () @@ -284,5 +312,6 @@ migrateAccounts migration Accounts{..} = do return $! Accounts { accountTable = newAccountTable, - accountRegIdHistory = newAccountRegIds + accountRegIdHistory = newAccountRegIds, + accountDifferenceMap = DiffMap.empty . AccountIndex $ L.size newAccountTable } diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 4801dc1cbc..62509c0f0b 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -40,6 +40,7 @@ module Concordium.GlobalState.Persistent.BlockState ( import qualified Concordium.Crypto.SHA256 as H import qualified Concordium.Genesis.Data.P6 as P6 import Concordium.GlobalState.Account hiding (addIncomingEncryptedAmount, addToSelfEncryptedAmount) +import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import Concordium.GlobalState.BakerInfo import Concordium.GlobalState.BlockState import Concordium.GlobalState.CapitalDistribution @@ -86,7 +87,6 @@ import Concordium.Utils.BinarySearch import Concordium.Utils.Serialization import Concordium.Utils.Serialization.Put import qualified Concordium.Wasm as Wasm -import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import qualified Control.Monad.Except as MTL import Control.Monad.Reader diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs index b80c07c056..b03d02bdf1 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs @@ -22,6 +22,7 @@ import Concordium.Types.SeedState import Concordium.Utils import Concordium.Genesis.Data.BaseV1 +import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import Concordium.GlobalState.BlockState import qualified Concordium.GlobalState.Persistent.BlockState as PBS import Concordium.GlobalState.Statistics @@ -294,6 +295,7 @@ processFinalizationHelper newFinalizedBlock newFinalizationEntry mCertifiedBlock -- Archive the state of the last finalized block and all newly finalized blocks -- excluding the new last finalized block. mapM_ (archiveBlockState . bpState) (init (oldLastFinalized : prFinalized)) + -- TODO!: Record the accounts created in the finalized blocks in the LMDB database. -- Remove the blocks from the live block table. markLiveBlocksFinal prFinalized -- Finalize the transactions in the in-memory transaction table. From b14775f617759d7cdce87af70827c12899127f4c Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Mon, 2 Oct 2023 20:29:43 +0200 Subject: [PATCH 06/92] Removed obsolete extension. --- .../src/Concordium/GlobalState/AccountMap/DifferenceMap.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index 13a9be1d3b..438415342e 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} -- | The 'DifferenceMap' stores accounts have been created in a non-finalized block. -- When a block is being finalized then the assoicated 'DifferenceMap' must be written -- to disk via 'Concordium.GlobalState.AccountMap.LMDB.insert'. From 6420f70c3f0f58e90e8cd3adbfa0966c0b03194d Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Tue, 3 Oct 2023 15:03:37 +0200 Subject: [PATCH 07/92] Starting to integrate the persistent accountmap into the skovs. --- .../src/Concordium/GlobalState.hs | 10 ++- .../GlobalState/AccountMap/DifferenceMap.hs | 14 ++-- .../Concordium/GlobalState/AccountMap/LMDB.hs | 75 ++++++++++++------- .../GlobalState/Persistent/Accounts.hs | 10 +-- .../GlobalState/Persistent/BlockState.hs | 5 +- .../GlobalState/Persistent/TreeState.hs | 60 +++++++++++++-- .../src/Concordium/KonsensusV1/SkovMonad.hs | 12 ++- 7 files changed, 126 insertions(+), 60 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState.hs b/concordium-consensus/src/Concordium/GlobalState.hs index 3f0c21d5dd..e91971883d 100644 --- a/concordium-consensus/src/Concordium/GlobalState.hs +++ b/concordium-consensus/src/Concordium/GlobalState.hs @@ -31,7 +31,8 @@ import Concordium.Types.ProtocolVersion data GlobalStateConfig = GlobalStateConfig { dtdbRuntimeParameters :: !RuntimeParameters, dtdbTreeStateDirectory :: !FilePath, - dtdbBlockStateFile :: !FilePath + dtdbBlockStateFile :: !FilePath, + dtdAccountMapDirectory :: !FilePath } -- | Exceptions that can occur when initialising the global state. @@ -65,7 +66,7 @@ type GSState pv = SkovPersistentData pv initialiseExistingGlobalState :: forall pv. (IsProtocolVersion pv) => SProtocolVersion pv -> GlobalStateConfig -> LogIO (Maybe (GSContext pv, GSState pv)) initialiseExistingGlobalState _ GlobalStateConfig{..} = do -- check if all the necessary database files exist - existingDB <- checkExistingDatabase dtdbTreeStateDirectory dtdbBlockStateFile + existingDB <- checkExistingDatabase dtdbTreeStateDirectory dtdbBlockStateFile dtdAccountMapDirectory if existingDB then do logm <- ask @@ -75,7 +76,7 @@ initialiseExistingGlobalState _ GlobalStateConfig{..} = do pbscBlobStore <- loadBlobStore dtdbBlockStateFile let pbsc = PersistentBlockStateContext{..} skovData <- - runLoggerT (loadSkovPersistentData dtdbRuntimeParameters dtdbTreeStateDirectory pbsc) logm + runLoggerT (loadSkovPersistentData dtdbRuntimeParameters dtdbTreeStateDirectory dtdAccountMapDirectory pbsc) logm `onException` closeBlobStore pbscBlobStore return (Just (pbsc, skovData)) else return Nothing @@ -125,6 +126,7 @@ migrateExistingState GlobalStateConfig{..} oldPbsc oldState migration genData = initialSkovPersistentData dtdbRuntimeParameters dtdbTreeStateDirectory + dtdAccountMapDirectory (regenesisConfiguration genData) newInitialBlockState ser @@ -153,7 +155,7 @@ initialiseNewGlobalState genData GlobalStateConfig{..} = do logEvent GlobalState LLTrace "Writing persistent global state" ser <- saveBlockState pbs logEvent GlobalState LLTrace "Creating persistent global state context" - initialSkovPersistentData dtdbRuntimeParameters dtdbTreeStateDirectory (genesisConfiguration genData) pbs ser genTT Nothing + initialSkovPersistentData dtdbRuntimeParameters dtdbTreeStateDirectory dtdAccountMapDirectory (genesisConfiguration genData) pbs ser genTT Nothing isd <- runReaderT (runPersistentBlockStateMonad initGS) pbsc `onException` liftIO (destroyBlobStore pbscBlobStore) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index 438415342e..b1603cc5a8 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -12,8 +12,7 @@ import Concordium.Types -- a block identified by a 'BlockHash' and its associated 'BlockHeight'. -- The difference map only contains accounds that was added since the '_dmParentMap'. data DifferenceMap = DifferenceMap - { - -- | Accounts added to the chain in the + { -- | Accounts added to the chain in the -- block 'amdmLfbHash'. -- Note. The list is in descending order of the 'AccountIndex'. -- TODO: Use Ordered set or a sequence instead? @@ -57,10 +56,7 @@ lookup addr DifferenceMap{..} = -- If a an account was succesfully added the 'dmNextAccountIndex' is being incremented by one. addAccount :: AccountAddress -> AccountIndex -> DifferenceMap -> DifferenceMap addAccount addr accIndex diffMap = - diffMap { - dmAccounts = (addr,accIndex) : dmAccounts diffMap, - dmNextAccountIndex = 1 + dmNextAccountIndex diffMap - } - - - + diffMap + { dmAccounts = (addr, accIndex) : dmAccounts diffMap, + dmNextAccountIndex = 1 + dmNextAccountIndex diffMap + } diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index 91f30b6bda..4f62a969e3 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -35,8 +35,8 @@ import Control.Concurrent import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Identity -import Control.Monad.Reader.Class -import Control.Monad.Trans.Class +import Control.Monad.Reader +import Control.Monad.State import qualified Data.ByteString as BS import Data.Data (Data, Typeable) import qualified Data.Serialize as S @@ -45,7 +45,10 @@ import Lens.Micro.Platform import System.Directory import Concordium.GlobalState.AccountMap.DifferenceMap +import Concordium.GlobalState.BlockState +import Concordium.GlobalState.Classes import Concordium.GlobalState.LMDB.Helpers +import qualified Concordium.GlobalState.Types as GSTypes import Concordium.Logger import Concordium.Types import qualified Data.FixedByteString as FBS @@ -61,26 +64,14 @@ instance Exception DatabaseInvariantViolation where "Database invariant violation: " ++ show reason --- | The interface to the LMDB account map. +-- | The interface to the LMDB account map to use under normal operation. -- For more information, refer to the module documentation. +-- +-- An implementation should ensure atomicity of operations. +-- -- Invariants: -- * All accounts in the store are finalized. class (Monad m) => MonadAccountMapStore m where - -- | Create and initialize the ‘AccountMap’ via the supplied map of accounts - -- for the supplied 'BlockHash'. - -- The provided 'BlockHash' must correspond to the hash of last finalized block - -- when this function is invoked. - -- The @[AccountAddress]@ should be obtained by the account table. - -- Precondition: offset of the @AccountAddress@ in the list must correspond to - -- the account index of that particular account. - initialize :: BlockHash -> BlockHeight -> [AccountAddress] -> m () - - -- | Check whether the ‘AccountMap’ is initialized. - -- Returns @Just BlockHash@ if the 'AccountMap' is initialized, - -- the ‘BlockHash’ indicates the last finalized block for the 'AccountMap'. - -- Returns @Nothing@ if the account map is not initialized. - isInitialized :: m (Maybe (BlockHash, BlockHeight)) - -- | Adds accounts present in the provided difference maps to the lmdb store. -- The argument is a list as multiple blocks can be finalized at the same time. -- Implementations should update the last finalized block pointer. @@ -263,10 +254,16 @@ closeDatabase dbHandlers = runInBoundThread $ mdb_env_close $ dbHandlers ^. stor -- ** Monad implementation newtype AccountMapStoreMonad m a = AccountMapStoreMonad {runAccountMapStoreMonad :: m a} - deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadLogger) via m + deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadLogger, MonadState s, MonadReader r) via m deriving (MonadTrans) via IdentityT -deriving instance (MonadReader r m) => MonadReader r (AccountMapStoreMonad m) +deriving via (MGSTrans AccountMapStoreMonad m) instance GSTypes.BlockStateTypes (AccountMapStoreMonad m) + +-- deriving via (MGSTrans AccountMapStoreMonad m) instance (BlockStateQuery m) => BlockStateQuery (AccountMapStoreMonad m) +deriving via (MGSTrans AccountMapStoreMonad m) instance (ContractStateOperations m) => ContractStateOperations (AccountMapStoreMonad m) + +-- deriving via (MGSTrans AccountMapStoreMonad m) instance (AccountOperations m) => AccountOperations (AccountMapStoreMonad m) +deriving via (MGSTrans AccountMapStoreMonad m) instance (ModuleQuery m) => ModuleQuery (AccountMapStoreMonad m) -- | Run a read-only transaction. asReadTransaction :: (MonadIO m, MonadReader r m, HasDatabaseHandlers r) => (DatabaseHandlers -> MDB_txn -> IO a) -> AccountMapStoreMonad m a @@ -296,6 +293,35 @@ asWriteTransaction t = do (LMDB_Error _ _ (Right MDB_MAP_FULL)) -> Just () _ -> Nothing +-- | Initialize the account map with the provided account addresses. +-- +-- Before calling this function, then it MUST be checked that the database is not already +-- initialized via 'isInitialized'. +-- +-- Post condition: The provided list of account addresses MUST be in ascending order of their +-- respective 'AccountIndex'. +initialize :: (MonadIO m, MonadLogger m) => BlockHash -> BlockHeight -> [AccountAddress] -> DatabaseHandlers -> m () +initialize lfbHash lfbHeight accounts = runReaderT (runAccountMapStoreMonad initStore) + where + initStore = asWriteTransaction $ \dbh txn -> do + forM_ + (zip accounts [0 ..]) + ( \(accAddr, accIndex) -> do + storeRecord txn (dbh ^. accountMapStore) (accountAddressToPrefixAccountAddress accAddr) accIndex + ) + storeRecord txn (dbh ^. metadataStore) lfbKey (lfbHash, lfbHeight) + +-- | Check if the database is initialized. +-- If the database is initialized then the function will return +-- @Just (BlockHash, BlockHeight)@ for the last finalized block. +-- If the database has not yet been initialized via 'initialize' then +-- this function will return @Nothing@. +isInitialized :: (MonadIO m) => DatabaseHandlers -> m (Maybe (BlockHash, BlockHeight)) +isInitialized dbh = + liftIO $ transaction (dbh ^. storeEnv) True $ \txn -> getLfb txn + where + getLfb txn = loadRecord txn (dbh ^. metadataStore) lfbKey + instance ( MonadReader r m, HasDatabaseHandlers r, @@ -304,15 +330,6 @@ instance ) => MonadAccountMapStore (AccountMapStoreMonad m) where - initialize lfbHash lfbHeight accounts = asWriteTransaction $ \dbh txn -> do - forM_ - (zip accounts [0 ..]) - ( \(accAddr, accIndex) -> do - storeRecord txn (dbh ^. accountMapStore) (accountAddressToPrefixAccountAddress accAddr) accIndex - ) - storeRecord txn (dbh ^. metadataStore) lfbKey (lfbHash, lfbHeight) - isInitialized = asReadTransaction $ \dbh txn -> - loadRecord txn (dbh ^. metadataStore) lfbKey insert lfbHash lfbHeight differenceMaps = asWriteTransaction $ \dbh txn -> do forM_ differenceMaps (doInsert dbh txn) where diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 4b16f46a04..5f3c7a5286 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -80,7 +80,7 @@ data Accounts (pv :: ProtocolVersion) = Accounts -- | A constraint that ensures a monad @m@ supports the persistent account operations. -- This essentially requires that the monad support 'MonadBlobStore', and 'MonadCache' for --- the account cache. +-- the account cache and 'MonadAccountMapStore' for the persistent account map. type SupportsPersistentAccount pv m = ( IsProtocolVersion pv, MonadBlobStore m, @@ -153,7 +153,7 @@ fromList = foldlM insert emptyAccounts insert accounts account = snd <$> putNewAccount account accounts -- | Determine if an account with the given address exists. -exists :: (IsProtocolVersion pv, LMDBAccountMap.MonadAccountMapStore m) => AccountAddress -> Accounts pv -> m Bool +exists :: (SupportsPersistentAccount pv m) => AccountAddress -> Accounts pv -> m Bool exists addr accts = isJust <$> getAccountIndex addr accts -- | Retrieve an account with the given address. @@ -183,7 +183,7 @@ getAccountIndex addr Accounts{..} = case DiffMap.lookup addr accountDifferenceMa -- | Retrieve an account and its index from a given address. -- Returns @Nothing@ if no such account exists. -getAccountWithIndex :: (SupportsPersistentAccount pv m, LMDBAccountMap.MonadAccountMapStore m) => AccountAddress -> Accounts pv -> m (Maybe (AccountIndex, PersistentAccount (AccountVersionFor pv))) +getAccountWithIndex :: (SupportsPersistentAccount pv m) => AccountAddress -> Accounts pv -> m (Maybe (AccountIndex, PersistentAccount (AccountVersionFor pv))) getAccountWithIndex addr Accounts{..} = LMDBAccountMap.lookup addr >>= \case Nothing -> return Nothing @@ -195,7 +195,7 @@ indexedAccount ai Accounts{..} = L.lookup ai accountTable -- | Retrieve an account with the given address. -- An account with the address is required to exist. -unsafeGetAccount :: (SupportsPersistentAccount pv m, LMDBAccountMap.MonadAccountMapStore m) => AccountAddress -> Accounts pv -> m (PersistentAccount (AccountVersionFor pv)) +unsafeGetAccount :: (SupportsPersistentAccount pv m) => AccountAddress -> Accounts pv -> m (PersistentAccount (AccountVersionFor pv)) unsafeGetAccount addr accts = getAccount addr accts <&> \case Just acct -> acct @@ -204,7 +204,7 @@ unsafeGetAccount addr accts = -- | Check whether the given account address would clash with any existing account address. -- The meaning of "clash" depends on the protocol version. -- todo: remove this ? exists would suffice. -addressWouldClash :: (IsProtocolVersion pv, MonadBlobStore m, LMDBAccountMap.MonadAccountMapStore m) => AccountAddress -> Accounts pv -> m Bool +addressWouldClash :: (SupportsPersistentAccount pv m) => AccountAddress -> Accounts pv -> m Bool addressWouldClash = exists -- | Check that an account registration ID is not already on the chain. diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 62509c0f0b..60e59b683c 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiWayIf #-} @@ -44,6 +45,7 @@ import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import Concordium.GlobalState.BakerInfo import Concordium.GlobalState.BlockState import Concordium.GlobalState.CapitalDistribution +import Concordium.GlobalState.Classes import qualified Concordium.GlobalState.ContractStateV1 as StateV1 import Concordium.GlobalState.Parameters import Concordium.GlobalState.Persistent.Account @@ -87,7 +89,6 @@ import Concordium.Utils.BinarySearch import Concordium.Utils.Serialization import Concordium.Utils.Serialization.Put import qualified Concordium.Wasm as Wasm - import qualified Control.Monad.Except as MTL import Control.Monad.Reader import qualified Control.Monad.State.Strict as MTL @@ -3343,8 +3344,6 @@ instance (PersistentState av pv r m) => MonadBlobStore (PutH (PersistentBlockSta instance (PersistentState av pv r m) => Cache.MonadCache (AccountCache av) (PersistentBlockStateMonad pv r m) instance (PersistentState av pv r m) => Cache.MonadCache Modules.ModuleCache (PersistentBlockStateMonad pv r m) -instance (PersistentState av pv r m) => LMDBAccountMap.MonadAccountMapStore (PersistentBlockStateMonad pv r m) - type instance BlockStatePointer (PersistentBlockState pv) = BlobRef (BlockStatePointers pv) type instance BlockStatePointer (HashedPersistentBlockState pv) = BlobRef (BlockStatePointers pv) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs index 2ddcaf464b..8869d7920e 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs @@ -12,6 +12,7 @@ -- and `TreeStateMonad` effectively adding persistence to the tree state. module Concordium.GlobalState.Persistent.TreeState where +import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import Concordium.GlobalState.Block import Concordium.GlobalState.BlockMonads import Concordium.GlobalState.BlockPointer @@ -77,6 +78,10 @@ data InitException | DatabaseInvariantViolation !String | -- | The database version is not correct. IncorrectDatabaseVersion !String + | -- | Cannot get read/write permissions for the account map file. + AccountMapPermissionError + | -- | The account map does not match the last finalized block. + AccountMapMismatch {ieAccountMapLfb :: !BlockHash, ieTsLfb :: !BlockHash} deriving (Show, Typeable) instance Exception InitException where @@ -90,6 +95,8 @@ instance Exception InitException where displayException (DatabaseInvariantViolation err) = "Database invariant violation: " ++ err displayException (IncorrectDatabaseVersion err) = "Incorrect database version: " ++ err + displayException AccountMapPermissionError = "Cannot get read and write permissions for the account map file." + displayException AccountMapMismatch{..} = "The lfb of the account map " <> show ieAccountMapLfb <> " does not match tree state lfb: " <> show ieTsLfb logExceptionAndThrowTS :: (MonadLogger m, MonadIO m, Exception e) => e -> m a logExceptionAndThrowTS = logExceptionAndThrow TreeState @@ -234,7 +241,9 @@ data SkovPersistentData (pv :: ProtocolVersion) = SkovPersistentData -- If we only had the one state implementation this would not be necessary, and we could simply -- return the value in the 'updateRegenesis' function. However as it is, it is challenging to properly -- specify the types of these values due to the way the relevant types are parameterized. - _nextGenesisInitialState :: !(Maybe (PBS.HashedPersistentBlockState pv)) + _nextGenesisInitialState :: !(Maybe (PBS.HashedPersistentBlockState pv)), + -- | Account map directory + _accountMapDb :: !LMDBAccountMap.DatabaseHandlers } makeLenses ''SkovPersistentData @@ -248,6 +257,9 @@ instance -- | Initial skov data with default runtime parameters (block size = 10MB). initialSkovPersistentDataDefault :: (IsProtocolVersion pv, MonadIO m) => + -- | Tree state directory + FilePath -> + -- | Account map directory FilePath -> GenesisConfiguration -> PBS.HashedPersistentBlockState pv -> @@ -267,6 +279,8 @@ initialSkovPersistentData :: RuntimeParameters -> -- | Tree state directory FilePath -> + -- | Account map directory + FilePath -> -- | Genesis data GenesisConfiguration -> -- | Genesis state @@ -284,11 +298,15 @@ initialSkovPersistentData :: -- documentation of the 'PendingTransactionTable' for details. Maybe PendingTransactionTable -> m (SkovPersistentData pv) -initialSkovPersistentData rp treeStateDir gd genState serState genTT mPending = do +initialSkovPersistentData rp treeStateDir accountMapDir gd genState serState genTT mPending = do gb <- makeGenesisPersistentBlockPointer gd genState let gbh = bpHash gb gbfin = FinalizationRecord 0 gbh emptyFinalizationProof 0 initialDb <- liftIO $ initializeDatabase gb serState treeStateDir + accountMapDb <- liftIO $ LMDBAccountMap.openDatabase accountMapDir + LMDBAccountMap.isInitialized accountMapDb >>= \case + Nothing -> undefined -- todo: call 'initialize' for initializing the lmdb database. + Just (lfbHash, lfbHeight) -> undefined -- todo; check that the it's consistent with what is recorded in the tree state return SkovPersistentData { _blockTable = emptyBlockTable, @@ -307,7 +325,8 @@ initialSkovPersistentData rp treeStateDir gd genState serState genTT mPending = _runtimeParameters = rp, _treeStateDirectory = treeStateDir, _db = initialDb, - _nextGenesisInitialState = Nothing + _nextGenesisInitialState = Nothing, + _accountMapDb = accountMapDb } -------------------------------------------------------------------------------- @@ -324,11 +343,15 @@ checkExistingDatabase :: FilePath -> -- | Block state file FilePath -> + -- | Account map path + FilePath -> m Bool -checkExistingDatabase treeStateDir blockStateFile = do +checkExistingDatabase treeStateDir blockStateFile accountMapDir = do let treeStateFile = treeStateDir "data.mdb" + let accountMapFile = accountMapDir "data.mdb" bsPathEx <- liftIO $ doesPathExist blockStateFile tsPathEx <- liftIO $ doesPathExist treeStateFile + amPathEx <- liftIO $ doesPathExist accountMapFile -- Check whether a path is a normal file that is readable and writable let checkRWFile :: FilePath -> InitException -> m () @@ -347,13 +370,14 @@ checkExistingDatabase treeStateDir blockStateFile = do unless (readable perms && writable perms) $ do logExceptionAndThrowTS exc - -- if both files exist we check whether they are both readable and writable. + -- if all files exist we check whether they are both readable and writable. -- In case only one of them exists we raise an appropriate exception. We don't want to delete any data. if - | bsPathEx && tsPathEx -> do + | bsPathEx && tsPathEx && amPathEx -> do -- check whether it is a normal file and whether we have the right permissions checkRWFile blockStateFile BlockStatePermissionError checkRWFile treeStateFile TreeStatePermissionError + checkRWFile accountMapFile AccountMapPermissionError mapM_ (logEvent TreeState LLTrace) ["Existing database found.", "TreeState filepath: " ++ show blockStateFile, "BlockState filepath: " ++ show treeStateFile] return True | bsPathEx -> do @@ -364,6 +388,10 @@ checkExistingDatabase treeStateDir blockStateFile = do logEvent GlobalState LLWarning "Tree state database exists, but block state file does not. Deleting the tree state database." liftIO . removeDirectoryRecursive $ treeStateDir return False + | amPathEx -> do + logEvent GlobalState LLWarning "Account map database exists, but block state file does not. Deleting the tree state database." + liftIO . removeDirectoryRecursive $ accountMapDir + return False | otherwise -> return False @@ -392,9 +420,11 @@ loadSkovPersistentData :: RuntimeParameters -> -- | Tree state directory FilePath -> + -- | Account map directory + FilePath -> PBS.PersistentBlockStateContext pv -> LogIO (SkovPersistentData pv) -loadSkovPersistentData rp _treeStateDirectory pbsc = do +loadSkovPersistentData rp _treeStateDirectory accountMapDir pbsc = do -- we open the environment first. -- It might be that the database is bigger than the default environment size. -- This seems to not be an issue while we only read from the database, @@ -427,6 +457,22 @@ loadSkovPersistentData rp _treeStateDirectory pbsc = do _ -> logExceptionAndThrowTS (DatabaseInvariantViolation "Block at height 0 is not a genesis block.") -- Get the last finalized block. _lastFinalized <- liftIO (makeBlockPointer lfStoredBlock) + + -- Check whether the account map is already setup. + -- If not then populate it now with the last finalized block, + -- otherwise check if the current one matches the last finalized block + -- of the tree state. + -- todo: factor this out. + _accountMapDb <- liftIO $ LMDBAccountMap.openDatabase accountMapDir + LMDBAccountMap.isInitialized _accountMapDb >>= \case + Nothing -> do + accounts <- runReaderT (PBS.runPersistentBlockStateMonad (getAccountList $ _bpState _lastFinalized)) pbsc + LMDBAccountMap.initialize (bpHash _lastFinalized) (bpHeight _lastFinalized) accounts _accountMapDb + Just (lfbHash, _) -> do + let tsLfbHash = bpHash _lastFinalized + when (lfbHash /= tsLfbHash) $ + logExceptionAndThrowTS $ + AccountMapMismatch lfbHash tsLfbHash return SkovPersistentData { _possiblyPendingTable = HM.empty, diff --git a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs index c9d871395e..838e77763f 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs @@ -31,6 +31,7 @@ import Concordium.GlobalState (GlobalStateInitException (..)) import Concordium.GlobalState.BlockMonads import Concordium.GlobalState.BlockState +import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import Concordium.GlobalState.Parameters hiding (getChainParameters) import Concordium.GlobalState.Persistent.Account import Concordium.GlobalState.Persistent.BlobStore @@ -167,8 +168,10 @@ data SkovV1Context (pv :: ProtocolVersion) m = SkovV1Context _vcBakerContext :: !BakerContext, -- | Blob store and caches used by the block state storage. _vcPersistentBlockStateContext :: !(PersistentBlockStateContext pv), - -- | In-memory low-level tree state database. + -- | low-level tree state database. _vcDisk :: !(DatabaseHandlers pv), + -- | Persistent account map + _vcAccountMap :: !LMDBAccountMap.DatabaseHandlers, -- | Handler functions. _vcHandlers :: !(HandlerContext pv m), -- | A function for unlifting @'SkovV1T' pv m@ into the 'IO' monad. @@ -328,7 +331,9 @@ data GlobalStateConfig = GlobalStateConfig -- | Path to the tree state directory. gscTreeStateDirectory :: !FilePath, -- | Path to the block state file. - gscBlockStateFile :: !FilePath + gscBlockStateFile :: !FilePath, + -- | Path to the account map directory + gscAccountMapDirectory :: !FilePath } -- | Context used by the 'InitMonad'. @@ -460,7 +465,7 @@ initialiseExistingSkovV1 :: LogIO (Maybe (ExistingSkov pv m)) initialiseExistingSkovV1 bakerCtx handlerCtx unliftSkov GlobalStateConfig{..} = do logEvent Skov LLDebug "Attempting to use existing global state." - existingDB <- checkExistingDatabase gscTreeStateDirectory gscBlockStateFile + existingDB <- checkExistingDatabase gscTreeStateDirectory gscBlockStateFile gscAccountMapDirectory if existingDB then do pbscAccountCache <- liftIO $ newAccountCache (rpAccountsCacheSize gscRuntimeParameters) @@ -492,6 +497,7 @@ initialiseExistingSkovV1 bakerCtx handlerCtx unliftSkov GlobalStateConfig{..} = { _vcBakerContext = bakerCtx, _vcPersistentBlockStateContext = pbsc, _vcDisk = lldb, + _vcAccountMap = undefined, -- TODO: Fill in _vcHandlers = handlerCtx, _skovV1TUnliftIO = unliftSkov }, From 7802c7fb8b7cbd3ffd0442ec3ad809b766906705 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Thu, 5 Oct 2023 12:12:55 +0200 Subject: [PATCH 08/92] ... --- .../GlobalState/AccountMap/DifferenceMap.hs | 5 +- .../Concordium/GlobalState/AccountMap/LMDB.hs | 35 +++++--- .../GlobalState/Persistent/Accounts.hs | 89 +++++++++++-------- .../GlobalState/Persistent/BlockState.hs | 15 ++-- .../GlobalState/Persistent/TreeState.hs | 8 +- .../src/Concordium/KonsensusV1/SkovMonad.hs | 15 ++++ 6 files changed, 102 insertions(+), 65 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index b1603cc5a8..cdafdc7005 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} -- | The 'DifferenceMap' stores accounts have been created in a non-finalized block. -- When a block is being finalized then the assoicated 'DifferenceMap' must be written -- to disk via 'Concordium.GlobalState.AccountMap.LMDB.insert'. @@ -5,6 +6,7 @@ module Concordium.GlobalState.AccountMap.DifferenceMap where import qualified Data.List as List import Prelude hiding (lookup) +import Lens.Micro.Platform import Concordium.Types @@ -24,7 +26,8 @@ data DifferenceMap = DifferenceMap -- then the parent map is @Nothing@ as the LMDB account map -- should be consulted instead. dmParentMap :: !(Maybe DifferenceMap) - } + } deriving (Eq, Show) +makeClassy ''DifferenceMap -- | Create a new empty 'DifferenceMap' based on either a finalized block (in which case -- the @dmNextAccountIndex@ must be provided explicitly or in case that the parent block is diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index 4f62a969e3..099bc51891 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -31,6 +31,8 @@ -- * Only finalized accounts are present in the ‘AccountMap’ module Concordium.GlobalState.AccountMap.LMDB where +import Control.Monad.Trans.Writer +import Control.Monad.Trans.Except import Control.Concurrent import Control.Monad.Catch import Control.Monad.IO.Class @@ -43,15 +45,15 @@ import qualified Data.Serialize as S import Database.LMDB.Raw import Lens.Micro.Platform import System.Directory +import Prelude hiding (lookup) +import Data.Kind (Type) -import Concordium.GlobalState.AccountMap.DifferenceMap -import Concordium.GlobalState.BlockState +import qualified Data.FixedByteString as FBS +import Concordium.GlobalState.AccountMap.DifferenceMap (DifferenceMap(..)) import Concordium.GlobalState.Classes import Concordium.GlobalState.LMDB.Helpers -import qualified Concordium.GlobalState.Types as GSTypes import Concordium.Logger import Concordium.Types -import qualified Data.FixedByteString as FBS -- * Exceptions @@ -64,7 +66,8 @@ instance Exception DatabaseInvariantViolation where "Database invariant violation: " ++ show reason --- | The interface to the LMDB account map to use under normal operation. +-- | Monad for inserting and looking up accounts in the account map +-- backed by an LMDB database. -- For more information, refer to the module documentation. -- -- An implementation should ensure atomicity of operations. @@ -85,6 +88,16 @@ class (Monad m) => MonadAccountMapStore m where -- and returns @Nothing@ if the account was not present. lookup :: AccountAddress -> m (Maybe AccountIndex) +instance (Monad (t m), MonadTrans t, MonadAccountMapStore m) => MonadAccountMapStore (MGSTrans t m) where + insert bh height = lift . insert bh height + lookup = lift . lookup + {-# INLINE insert #-} + {-# INLINE lookup #-} + +deriving via (MGSTrans (StateT s) m) instance (MonadAccountMapStore m) => MonadAccountMapStore (StateT s m) +deriving via (MGSTrans (ExceptT e) m) instance (MonadAccountMapStore m) => MonadAccountMapStore (ExceptT e m) +deriving via (MGSTrans (WriterT w) m) instance (Monoid w, MonadAccountMapStore m) => MonadAccountMapStore (WriterT w m) + -- * Database stores -- | Store that yields the last finalized block from the perspective @@ -253,17 +266,11 @@ closeDatabase :: DatabaseHandlers -> IO () closeDatabase dbHandlers = runInBoundThread $ mdb_env_close $ dbHandlers ^. storeEnv . seEnv -- ** Monad implementation -newtype AccountMapStoreMonad m a = AccountMapStoreMonad {runAccountMapStoreMonad :: m a} - deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadLogger, MonadState s, MonadReader r) via m +-- The 'AccountMapStoreMonad' acquires the 'DatabaseHandlers' via a reader context. +newtype AccountMapStoreMonad (m :: Type -> Type) (a :: Type) = AccountMapStoreMonad {runAccountMapStoreMonad :: m a} + deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadLogger, MonadReader r) via m deriving (MonadTrans) via IdentityT -deriving via (MGSTrans AccountMapStoreMonad m) instance GSTypes.BlockStateTypes (AccountMapStoreMonad m) - --- deriving via (MGSTrans AccountMapStoreMonad m) instance (BlockStateQuery m) => BlockStateQuery (AccountMapStoreMonad m) -deriving via (MGSTrans AccountMapStoreMonad m) instance (ContractStateOperations m) => ContractStateOperations (AccountMapStoreMonad m) - --- deriving via (MGSTrans AccountMapStoreMonad m) instance (AccountOperations m) => AccountOperations (AccountMapStoreMonad m) -deriving via (MGSTrans AccountMapStoreMonad m) instance (ModuleQuery m) => ModuleQuery (AccountMapStoreMonad m) -- | Run a read-only transaction. asReadTransaction :: (MonadIO m, MonadReader r m, HasDatabaseHandlers r) => (DatabaseHandlers -> MDB_txn -> IO a) -> AccountMapStoreMonad m a diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 5f3c7a5286..bf2105ef1f 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -1,4 +1,6 @@ {-# LANGUAGE BangPatterns #-} +-- here because of the 'SupportsPersistentAccount' constraint is a bit too coarse right now. +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} @@ -12,13 +14,14 @@ module Concordium.GlobalState.Persistent.Accounts where -import Control.Monad +import Control.Monad.State import Data.Foldable (foldlM) import qualified Data.Map.Strict as Map import Data.Maybe import Data.Serialize import Lens.Micro.Platform +import Concordium.Utils import Concordium.GlobalState.Persistent.Account import Concordium.GlobalState.Persistent.BlobStore import Concordium.GlobalState.Persistent.Cache @@ -70,14 +73,25 @@ import Concordium.Types.HashableTo -- hence the current solution was chosen. Caching by account index (probably with an LRU strategy) -- would likely be a more effective strategy over all. data Accounts (pv :: ProtocolVersion) = Accounts - { -- | Accounts that has been created since the last finalized block. - accountDifferenceMap :: !DiffMap.DifferenceMap, - -- | Hashed Merkle-tree of the accounts + { -- | Hashed Merkle-tree of the accounts accountTable :: !(LFMBTree' AccountIndex HashedBufferedRef (AccountRef (AccountVersionFor pv))), -- | Persisted representation of the map from registration ids to account indices. accountRegIdHistory :: !(Trie.TrieN UnbufferedFix ID.RawCredentialRegistrationID AccountIndex) } +-- todo doc +data AccountsAndDiffMap (pv :: ProtocolVersion) = AccountsAndDiffMap + { -- | The persistent accounts and what is stored on disk. + aadAccounts :: !(Accounts pv), + -- | An in-memory difference map used keeping track of accounts + -- added in live blocks. + -- This is 'Nothing' If the block is finalized. + aadDiffMap :: !(Maybe DiffMap.DifferenceMap) + } + +instance (IsProtocolVersion pv) => Show (AccountsAndDiffMap pv) where + show aad = show (aadAccounts aad) <> show (aadDiffMap aad) + -- | A constraint that ensures a monad @m@ supports the persistent account operations. -- This essentially requires that the monad support 'MonadBlobStore', and 'MonadCache' for -- the account cache and 'MonadAccountMapStore' for the persistent account map. @@ -101,10 +115,7 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where let newAccounts = Accounts { accountTable = accountTable', - accountRegIdHistory = regIdHistory', - -- Carry over the difference map. The difference map is persisted - -- when the block is finalized. - accountDifferenceMap = accountDifferenceMap + accountRegIdHistory = regIdHistory' } return (pTable >> pRegIdHistory, newAccounts) load = do @@ -113,8 +124,6 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where return $ do accountTable <- maccountTable accountRegIdHistory <- mrRIH - -- Empty diff map is ok when loading an old block as lookups will just go through the LMDB database. - let accountDifferenceMap = DiffMap.empty . AccountIndex $ L.size accountTable return $ Accounts{..} instance (SupportsPersistentAccount pv m, av ~ AccountVersionFor pv) => Cacheable1 m (Accounts pv) (PersistentAccount av) where @@ -124,15 +133,15 @@ instance (SupportsPersistentAccount pv m, av ~ AccountVersionFor pv) => Cacheabl accts{accountTable = acctTable} emptyAccounts :: Accounts pv -emptyAccounts = Accounts (DiffMap.empty $ AccountIndex 0) L.empty Trie.empty +emptyAccounts = Accounts L.empty Trie.empty -- | Add a new account. Returns @Just idx@ if the new account is fresh, i.e., the address does not exist, -- or @Nothing@ in case the account already exists. In the latter case there is no change to the accounts structure. -putNewAccount :: (SupportsPersistentAccount pv m) => PersistentAccount (AccountVersionFor pv) -> Accounts pv -> m (Maybe AccountIndex, Accounts pv) +putNewAccount :: (SupportsPersistentAccount pv m, MonadState DiffMap.DifferenceMap m) => PersistentAccount (AccountVersionFor pv) -> Accounts pv -> m (Maybe AccountIndex, Accounts pv) putNewAccount !acct accts0 = do addr <- accountCanonicalAddress acct -- check whether the account is in the difference map. - case DiffMap.lookup addr (accountDifferenceMap accts0) of + gets (DiffMap.lookup addr) >>= \case Just _ -> return (Nothing, accts0) Nothing -> do -- Check whether the account is present in a finalized block. @@ -140,25 +149,25 @@ putNewAccount !acct accts0 = do if isNothing existingAccountId then do (_, newAccountTable) <- L.append acct (accountTable accts0) - let accountDifferenceMap' = DiffMap.addAccount addr acctIndex (accountDifferenceMap accts0) - return (Just acctIndex, accts0{accountTable = newAccountTable, accountDifferenceMap = accountDifferenceMap'}) + DiffMap.differenceMap %=! DiffMap.addAccount addr acctIndex + return (Just acctIndex, accts0{accountTable = newAccountTable}) else return (Nothing, accts0) where acctIndex = fromIntegral $ L.size (accountTable accts0) -- | Construct an 'Accounts' from a list of accounts. Inserted in the order of the list. -fromList :: (SupportsPersistentAccount pv m) => [PersistentAccount (AccountVersionFor pv)] -> m (Accounts pv) +fromList :: (SupportsPersistentAccount pv m, MonadState DiffMap.DifferenceMap m) => [PersistentAccount (AccountVersionFor pv)] -> m (Accounts pv) fromList = foldlM insert emptyAccounts where insert accounts account = snd <$> putNewAccount account accounts -- | Determine if an account with the given address exists. -exists :: (SupportsPersistentAccount pv m) => AccountAddress -> Accounts pv -> m Bool -exists addr accts = isJust <$> getAccountIndex addr accts +exists :: (SupportsPersistentAccount pv m, MonadState DiffMap.DifferenceMap m) => AccountAddress -> m Bool +exists addr = isJust <$> getAccountIndex addr -- | Retrieve an account with the given address. -- Returns @Nothing@ if no such account exists. -getAccount :: (SupportsPersistentAccount pv m, LMDBAccountMap.MonadAccountMapStore m) => AccountAddress -> Accounts pv -> m (Maybe (PersistentAccount (AccountVersionFor pv))) +getAccount :: (SupportsPersistentAccount pv m) => AccountAddress -> Accounts pv -> m (Maybe (PersistentAccount (AccountVersionFor pv))) getAccount addr Accounts{..} = LMDBAccountMap.lookup addr >>= \case Nothing -> return Nothing @@ -173,8 +182,8 @@ getAccountByCredId cid accs@Accounts{..} = Just ai -> fmap (ai,) <$> indexedAccount ai accs -- | Get the account at a given index (if any). -getAccountIndex :: (IsProtocolVersion pv, LMDBAccountMap.MonadAccountMapStore m) => AccountAddress -> Accounts pv -> m (Maybe AccountIndex) -getAccountIndex addr Accounts{..} = case DiffMap.lookup addr accountDifferenceMap of +getAccountIndex :: (IsProtocolVersion pv, LMDBAccountMap.MonadAccountMapStore m) => AccountAddress -> AccountsAndDiffMap pv -> m (Maybe AccountIndex) +getAccountIndex addr _ = gets (DiffMap.lookup addr) >>= \case Just accIdx -> return $ Just accIdx Nothing -> LMDBAccountMap.lookup addr >>= \case @@ -201,12 +210,6 @@ unsafeGetAccount addr accts = Just acct -> acct Nothing -> error $ "unsafeGetAccount: Account " ++ show addr ++ " does not exist." --- | Check whether the given account address would clash with any existing account address. --- The meaning of "clash" depends on the protocol version. --- todo: remove this ? exists would suffice. -addressWouldClash :: (SupportsPersistentAccount pv m) => AccountAddress -> Accounts pv -> m Bool -addressWouldClash = exists - -- | Check that an account registration ID is not already on the chain. -- See the foundation (Section 4.2) for why this is necessary. -- Return @Just ai@ if the registration ID already exists, and @ai@ is the index of the account it is or was associated with. @@ -238,9 +241,16 @@ loadRegIds accts = Trie.toMap (accountRegIdHistory accts) -- -- This should not be used to alter the address of an account (which is -- disallowed). -updateAccounts :: (SupportsPersistentAccount pv m) => (PersistentAccount (AccountVersionFor pv) -> m (a, PersistentAccount (AccountVersionFor pv))) -> AccountAddress -> Accounts pv -> m (Maybe (AccountIndex, a), Accounts pv) -updateAccounts fupd addr a0@Accounts{..} = - case DiffMap.lookup addr accountDifferenceMap of +updateAccounts :: + (SupportsPersistentAccount pv m) + => + (PersistentAccount (AccountVersionFor pv) -> + m (a, PersistentAccount (AccountVersionFor pv))) -> + AccountAddress -> + AccountsAndDiffMap pv -> + m (Maybe (AccountIndex, a), AccountsAndDiffMap pv) +updateAccounts fupd addr a@AccountsAndDiffMap{aadAccounts = a0@Accounts{..},..} = + case DiffMap.lookup addr aadDiffMap of Nothing -> LMDBAccountMap.lookup addr >>= \case Nothing -> return (Nothing, a0) @@ -250,7 +260,7 @@ updateAccounts fupd addr a0@Accounts{..} = update ai = L.update fupd ai accountTable >>= \case Nothing -> return (Nothing, a0) - Just (res, act') -> return (Just (ai, res), a0{accountTable = act'}) + Just (res, act') -> return (Just (ai, res), a{aadAccounts = a0{accountTable = act'}}) -- | Perform an update to an account with the given index. -- Does nothing (returning @Nothing@) if the account does not exist. @@ -302,16 +312,17 @@ migrateAccounts :: SupportsPersistentAccount pv (t m) ) => StateMigrationParameters oldpv pv -> - Accounts oldpv -> - t m (Accounts pv) -migrateAccounts migration Accounts{..} = do + AccountsAndDiffMap oldpv -> + t m (AccountsAndDiffMap pv) +migrateAccounts migration AccountsAndDiffMap{aadAccounts = Accounts{..}} = do newAccountTable <- L.migrateLFMBTree (migrateHashedCachedRef' (migratePersistentAccount migration)) accountTable -- The account registration IDs are not cached. There is a separate cache -- that is purely in-memory and just copied over. newAccountRegIds <- Trie.migrateUnbufferedTrieN return accountRegIdHistory return $! - Accounts - { accountTable = newAccountTable, - accountRegIdHistory = newAccountRegIds, - accountDifferenceMap = DiffMap.empty . AccountIndex $ L.size newAccountTable - } + AccountsAndDiffMap { + aadAccounts = Accounts + { accountTable = newAccountTable, + accountRegIdHistory = newAccountRegIds + }, + aadDiffMap = Nothing} diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 60e59b683c..0e49a4b09d 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -45,7 +45,6 @@ import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import Concordium.GlobalState.BakerInfo import Concordium.GlobalState.BlockState import Concordium.GlobalState.CapitalDistribution -import Concordium.GlobalState.Classes import qualified Concordium.GlobalState.ContractStateV1 as StateV1 import Concordium.GlobalState.Parameters import Concordium.GlobalState.Persistent.Account @@ -736,7 +735,7 @@ emptyTransactionOutcomes Proxy = case transactionOutcomesVersion @(TransactionOu -- those components themselves should be parametrised by the protocol -- version. data BlockStatePointers (pv :: ProtocolVersion) = BlockStatePointers - { bspAccounts :: !(Accounts.Accounts pv), + { bspAccounts :: !(Accounts.AccountsAndDiffMap pv), bspInstances :: !(Instances.Instances pv), bspModules :: !(HashedBufferedRef Modules.Modules), bspBank :: !(Hashed Rewards.BankStatus), @@ -3331,7 +3330,7 @@ type PersistentState av pv r m = AccountVersionFor pv ~ av, Cache.HasCache (AccountCache av) r, Cache.HasCache Modules.ModuleCache r, - LMDBAccountMap.MonadAccountMapStore m + LMDBAccountMap.HasDatabaseHandlers r ) instance MonadTrans (PersistentBlockStateMonad pv r) where @@ -3344,6 +3343,12 @@ instance (PersistentState av pv r m) => MonadBlobStore (PutH (PersistentBlockSta instance (PersistentState av pv r m) => Cache.MonadCache (AccountCache av) (PersistentBlockStateMonad pv r m) instance (PersistentState av pv r m) => Cache.MonadCache Modules.ModuleCache (PersistentBlockStateMonad pv r m) +-- todo: derive it. +instance (PersistentState av pv r m) => LMDBAccountMap.MonadAccountMapStore (PersistentBlockStateMonad pv r m) where + lookup = undefined + insert = undefined + + type instance BlockStatePointer (PersistentBlockState pv) = BlobRef (BlockStatePointers pv) type instance BlockStatePointer (HashedPersistentBlockState pv) = BlobRef (BlockStatePointers pv) @@ -3464,7 +3469,7 @@ instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateOperatio bsoGetAccountIndex = doGetAccountIndex bsoGetAccountByIndex = doGetAccountByIndex bsoGetInstance = doGetInstance - bsoAddressWouldClash = doAddressWouldClash + bsoAddressWouldClash = doGetAccountExists bsoRegIdExists = doRegIdExists bsoCreateAccount = doCreateAccount bsoPutNewInstance = doPutNewInstance @@ -3662,7 +3667,7 @@ migrateBlockPointers migration BlockStatePointers{..} = do return $! BlockStatePointers - { bspAccounts = newAccounts, + { bspAccounts = Accounts.AccountsAndDiffMap newAccounts Nothing, bspInstances = newInstances, bspModules = newModules, bspBank = newBank, diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs index 8869d7920e..9e818d7126 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs @@ -242,7 +242,7 @@ data SkovPersistentData (pv :: ProtocolVersion) = SkovPersistentData -- return the value in the 'updateRegenesis' function. However as it is, it is challenging to properly -- specify the types of these values due to the way the relevant types are parameterized. _nextGenesisInitialState :: !(Maybe (PBS.HashedPersistentBlockState pv)), - -- | Account map directory + -- | Account map db _accountMapDb :: !LMDBAccountMap.DatabaseHandlers } @@ -378,7 +378,7 @@ checkExistingDatabase treeStateDir blockStateFile accountMapDir = do checkRWFile blockStateFile BlockStatePermissionError checkRWFile treeStateFile TreeStatePermissionError checkRWFile accountMapFile AccountMapPermissionError - mapM_ (logEvent TreeState LLTrace) ["Existing database found.", "TreeState filepath: " ++ show blockStateFile, "BlockState filepath: " ++ show treeStateFile] + mapM_ (logEvent TreeState LLTrace) ["Existing database found.", "TreeState filepath: " ++ show blockStateFile, "BlockState filepath: " ++ show treeStateFile ++ "AccountMap filepath: " ++ accountMapFile] return True | bsPathEx -> do logEvent GlobalState LLWarning "Block state file exists, but tree state database does not. Deleting the block state file." @@ -388,10 +388,6 @@ checkExistingDatabase treeStateDir blockStateFile accountMapDir = do logEvent GlobalState LLWarning "Tree state database exists, but block state file does not. Deleting the tree state database." liftIO . removeDirectoryRecursive $ treeStateDir return False - | amPathEx -> do - logEvent GlobalState LLWarning "Account map database exists, but block state file does not. Deleting the tree state database." - liftIO . removeDirectoryRecursive $ accountMapDir - return False | otherwise -> return False diff --git a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs index 838e77763f..c0638f08d0 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs @@ -206,6 +206,9 @@ instance HasBakerContext (SkovV1Context pv m) where instance HasDatabaseHandlers (SkovV1Context pv m) pv where databaseHandlers = vcDisk +instance LMDBAccountMap.HasDatabaseHandlers (SkovV1Context pv m) where + databaseHandlers = vcAccountMap + instance (MonadTrans (SkovV1T pv)) where lift = SkovV1T . lift @@ -265,6 +268,18 @@ deriving via ) => LowLevel.MonadTreeStateStore (SkovV1T pv m) +deriving via + (LMDBAccountMap.AccountMapStoreMonad r (InnerSkovV1T pv m)) + instance + ( IsProtocolVersion pv, + MonadIO m, + MonadCatch m, + MonadLogger m + ) => + LMDBAccountMap.MonadAccountMapStore (SkovV1T pv m) + + + instance (Monad m) => MonadBroadcast (SkovV1T pv m) where sendTimeoutMessage tm = do handler <- view sendTimeoutHandler From 3bcdf32dc4c8b9bb77fbf688d605240f8df27b3a Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Fri, 6 Oct 2023 14:25:49 +0200 Subject: [PATCH 09/92] Refactorings. --- .../GlobalState/AccountMap/DifferenceMap.hs | 26 ++- .../Concordium/GlobalState/AccountMap/LMDB.hs | 14 +- .../GlobalState/Persistent/Accounts.hs | 156 ++++++++++-------- .../GlobalState/Persistent/Bakers.hs | 2 +- .../GlobalState/Persistent/BlockState.hs | 52 +++--- .../src/Concordium/KonsensusV1/SkovMonad.hs | 18 +- 6 files changed, 140 insertions(+), 128 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index cdafdc7005..07a3997f13 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -1,12 +1,13 @@ {-# LANGUAGE TemplateHaskell #-} + -- | The 'DifferenceMap' stores accounts have been created in a non-finalized block. -- When a block is being finalized then the assoicated 'DifferenceMap' must be written -- to disk via 'Concordium.GlobalState.AccountMap.LMDB.insert'. module Concordium.GlobalState.AccountMap.DifferenceMap where import qualified Data.List as List -import Prelude hiding (lookup) import Lens.Micro.Platform +import Prelude hiding (lookup) import Concordium.Types @@ -19,25 +20,23 @@ data DifferenceMap = DifferenceMap -- Note. The list is in descending order of the 'AccountIndex'. -- TODO: Use Ordered set or a sequence instead? dmAccounts :: ![(AccountAddress, AccountIndex)], - -- | Next available account index. - dmNextAccountIndex :: !AccountIndex, -- | Parent map of non-finalized blocks. -- In other words, if the parent block is finalized, -- then the parent map is @Nothing@ as the LMDB account map -- should be consulted instead. dmParentMap :: !(Maybe DifferenceMap) - } deriving (Eq, Show) + } + deriving (Eq, Show) + makeClassy ''DifferenceMap --- | Create a new empty 'DifferenceMap' based on either a finalized block (in which case --- the @dmNextAccountIndex@ must be provided explicitly or in case that the parent block is --- not yet finalized then that map is supplied. -empty :: AccountIndex -> DifferenceMap -empty nextAccountIndex = +-- | Create a new empty 'DifferenceMap' based on the difference map of +-- the parent. +empty :: DifferenceMap -> DifferenceMap +empty parentDifferenceMap = DifferenceMap { dmAccounts = [], - dmNextAccountIndex = nextAccountIndex, - dmParentMap = Nothing + dmParentMap = Just parentDifferenceMap } -- | Check if an account exists in the difference map or any of the parent @@ -56,10 +55,9 @@ lookup addr DifferenceMap{..} = -- | Insert an account into the difference and return @Just AccountIndex@ if the -- account was added and @Nothing@ if it was already present. -- --- If a an account was succesfully added the 'dmNextAccountIndex' is being incremented by one. +-- If an account was succesfully added the 'dmNextAccountIndex' is being incremented by one. addAccount :: AccountAddress -> AccountIndex -> DifferenceMap -> DifferenceMap addAccount addr accIndex diffMap = diffMap - { dmAccounts = (addr, accIndex) : dmAccounts diffMap, - dmNextAccountIndex = 1 + dmNextAccountIndex diffMap + { dmAccounts = (addr, accIndex) : dmAccounts diffMap } diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index 099bc51891..acc2671023 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -31,29 +31,29 @@ -- * Only finalized accounts are present in the ‘AccountMap’ module Concordium.GlobalState.AccountMap.LMDB where -import Control.Monad.Trans.Writer -import Control.Monad.Trans.Except import Control.Concurrent import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Identity import Control.Monad.Reader import Control.Monad.State +import Control.Monad.Trans.Except +import Control.Monad.Trans.Writer import qualified Data.ByteString as BS import Data.Data (Data, Typeable) +import Data.Kind (Type) import qualified Data.Serialize as S import Database.LMDB.Raw import Lens.Micro.Platform import System.Directory import Prelude hiding (lookup) -import Data.Kind (Type) -import qualified Data.FixedByteString as FBS -import Concordium.GlobalState.AccountMap.DifferenceMap (DifferenceMap(..)) +import Concordium.GlobalState.AccountMap.DifferenceMap (DifferenceMap (..)) import Concordium.GlobalState.Classes import Concordium.GlobalState.LMDB.Helpers import Concordium.Logger import Concordium.Types +import qualified Data.FixedByteString as FBS -- * Exceptions @@ -89,7 +89,7 @@ class (Monad m) => MonadAccountMapStore m where lookup :: AccountAddress -> m (Maybe AccountIndex) instance (Monad (t m), MonadTrans t, MonadAccountMapStore m) => MonadAccountMapStore (MGSTrans t m) where - insert bh height = lift . insert bh height + insert bh height = lift . insert bh height lookup = lift . lookup {-# INLINE insert #-} {-# INLINE lookup #-} @@ -266,12 +266,12 @@ closeDatabase :: DatabaseHandlers -> IO () closeDatabase dbHandlers = runInBoundThread $ mdb_env_close $ dbHandlers ^. storeEnv . seEnv -- ** Monad implementation + -- The 'AccountMapStoreMonad' acquires the 'DatabaseHandlers' via a reader context. newtype AccountMapStoreMonad (m :: Type -> Type) (a :: Type) = AccountMapStoreMonad {runAccountMapStoreMonad :: m a} deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadLogger, MonadReader r) via m deriving (MonadTrans) via IdentityT - -- | Run a read-only transaction. asReadTransaction :: (MonadIO m, MonadReader r m, HasDatabaseHandlers r) => (DatabaseHandlers -> MDB_txn -> IO a) -> AccountMapStoreMonad m a asReadTransaction t = do diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index bf2105ef1f..d4f00a8d7b 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE BangPatterns #-} -- here because of the 'SupportsPersistentAccount' constraint is a bit too coarse right now. {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} @@ -21,7 +21,6 @@ import Data.Maybe import Data.Serialize import Lens.Micro.Platform -import Concordium.Utils import Concordium.GlobalState.Persistent.Account import Concordium.GlobalState.Persistent.BlobStore import Concordium.GlobalState.Persistent.Cache @@ -90,7 +89,7 @@ data AccountsAndDiffMap (pv :: ProtocolVersion) = AccountsAndDiffMap } instance (IsProtocolVersion pv) => Show (AccountsAndDiffMap pv) where - show aad = show (aadAccounts aad) <> show (aadDiffMap aad) + show aad = "Accounts: " <> show (aadAccounts aad) <> "DiffMap: " <> show (aadDiffMap aad) -- | A constraint that ensures a monad @m@ supports the persistent account operations. -- This essentially requires that the monad support 'MonadBlobStore', and 'MonadCache' for @@ -105,17 +104,21 @@ type SupportsPersistentAccount pv m = instance (IsProtocolVersion pv) => Show (Accounts pv) where show a = show (accountTable a) -instance (SupportsPersistentAccount pv m) => MHashableTo m H.Hash (Accounts pv) where - getHashM Accounts{..} = getHashM accountTable +instance (SupportsPersistentAccount pv m) => MHashableTo m H.Hash (AccountsAndDiffMap pv) where + getHashM AccountsAndDiffMap{..} = getHashM $ accountTable aadAccounts -instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where - storeUpdate Accounts{..} = do +instance (SupportsPersistentAccount pv m) => BlobStorable m (AccountsAndDiffMap pv) where + storeUpdate AccountsAndDiffMap{aadAccounts = Accounts{..}} = do (pTable, accountTable') <- storeUpdate accountTable (pRegIdHistory, regIdHistory') <- storeUpdate accountRegIdHistory let newAccounts = - Accounts - { accountTable = accountTable', - accountRegIdHistory = regIdHistory' + AccountsAndDiffMap + { aadAccounts = + Accounts + { accountTable = accountTable', + accountRegIdHistory = regIdHistory' + }, + aadDiffMap = Nothing } return (pTable >> pRegIdHistory, newAccounts) load = do @@ -124,46 +127,55 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where return $ do accountTable <- maccountTable accountRegIdHistory <- mrRIH - return $ Accounts{..} + return $ AccountsAndDiffMap{aadAccounts = Accounts{..}, aadDiffMap = Nothing} -instance (SupportsPersistentAccount pv m, av ~ AccountVersionFor pv) => Cacheable1 m (Accounts pv) (PersistentAccount av) where - liftCache cch accts@Accounts{..} = do +instance (SupportsPersistentAccount pv m, av ~ AccountVersionFor pv) => Cacheable1 m (AccountsAndDiffMap pv) (PersistentAccount av) where + liftCache cch aad@AccountsAndDiffMap{aadAccounts = accts@Accounts{..}} = do acctTable <- liftCache (liftCache @_ @(HashedCachedRef (AccountCache av) (PersistentAccount av)) cch) accountTable return - accts{accountTable = acctTable} + aad{aadAccounts = accts{accountTable = acctTable}} emptyAccounts :: Accounts pv emptyAccounts = Accounts L.empty Trie.empty +-- | Creates an empty 'AccountsAndDifferenceMap' +-- If the 'AccountsAndDifferenceMap' is created when thawing a block state (i.e. for creating a new block) +-- then the 'AccountsAndDifferenceMap' of the successor block must be provided. +-- On the other hand when loading the accounts in order to support a query, then +-- simply pass in 'Nothing'. +emptyAcocuntsAndDiffMap :: Maybe (AccountsAndDiffMap pv) -> AccountsAndDiffMap pv +emptyAcocuntsAndDiffMap Nothing = AccountsAndDiffMap emptyAccounts Nothing +emptyAcocuntsAndDiffMap (Just successor) = AccountsAndDiffMap emptyAccounts $ DiffMap.empty <$> aadDiffMap successor + -- | Add a new account. Returns @Just idx@ if the new account is fresh, i.e., the address does not exist, -- or @Nothing@ in case the account already exists. In the latter case there is no change to the accounts structure. -putNewAccount :: (SupportsPersistentAccount pv m, MonadState DiffMap.DifferenceMap m) => PersistentAccount (AccountVersionFor pv) -> Accounts pv -> m (Maybe AccountIndex, Accounts pv) -putNewAccount !acct accts0 = do +putNewAccount :: (SupportsPersistentAccount pv m) => PersistentAccount (AccountVersionFor pv) -> AccountsAndDiffMap pv -> m (Maybe AccountIndex, AccountsAndDiffMap pv) +putNewAccount !acct a0@AccountsAndDiffMap{aadAccounts = accts0@Accounts{..}, ..} = do addr <- accountCanonicalAddress acct - -- check whether the account is in the difference map. - gets (DiffMap.lookup addr) >>= \case - Just _ -> return (Nothing, accts0) + -- Check whether the account is in a non-finalized block. + case DiffMap.lookup addr =<< aadDiffMap of + Just _ -> return (Nothing, a0) Nothing -> do -- Check whether the account is present in a finalized block. existingAccountId <- LMDBAccountMap.lookup addr if isNothing existingAccountId then do - (_, newAccountTable) <- L.append acct (accountTable accts0) - DiffMap.differenceMap %=! DiffMap.addAccount addr acctIndex - return (Just acctIndex, accts0{accountTable = newAccountTable}) - else return (Nothing, accts0) + (_, newAccountTable) <- L.append acct accountTable + let dm1 = DiffMap.addAccount addr acctIndex <$> aadDiffMap + return (Just acctIndex, a0{aadAccounts = accts0{accountTable = newAccountTable}, aadDiffMap = dm1}) + else return (Nothing, a0) where - acctIndex = fromIntegral $ L.size (accountTable accts0) + acctIndex = fromIntegral $ L.size accountTable -- | Construct an 'Accounts' from a list of accounts. Inserted in the order of the list. -fromList :: (SupportsPersistentAccount pv m, MonadState DiffMap.DifferenceMap m) => [PersistentAccount (AccountVersionFor pv)] -> m (Accounts pv) -fromList = foldlM insert emptyAccounts +fromList :: (SupportsPersistentAccount pv m) => [PersistentAccount (AccountVersionFor pv)] -> m (AccountsAndDiffMap pv) +fromList = foldlM insert $ emptyAcocuntsAndDiffMap Nothing where insert accounts account = snd <$> putNewAccount account accounts -- | Determine if an account with the given address exists. -exists :: (SupportsPersistentAccount pv m, MonadState DiffMap.DifferenceMap m) => AccountAddress -> m Bool -exists addr = isJust <$> getAccountIndex addr +exists :: (SupportsPersistentAccount pv m) => AccountAddress -> AccountsAndDiffMap pv -> m Bool +exists addr accts = isJust <$> getAccountIndex addr accts -- | Retrieve an account with the given address. -- Returns @Nothing@ if no such account exists. @@ -175,15 +187,15 @@ getAccount addr Accounts{..} = -- | Retrieve an account associated with the given credential registration ID. -- Returns @Nothing@ if no such account exists. -getAccountByCredId :: (SupportsPersistentAccount pv m) => ID.RawCredentialRegistrationID -> Accounts pv -> m (Maybe (AccountIndex, PersistentAccount (AccountVersionFor pv))) -getAccountByCredId cid accs@Accounts{..} = - Trie.lookup cid accountRegIdHistory >>= \case +getAccountByCredId :: (SupportsPersistentAccount pv m) => ID.RawCredentialRegistrationID -> AccountsAndDiffMap pv -> m (Maybe (AccountIndex, PersistentAccount (AccountVersionFor pv))) +getAccountByCredId cid accs@AccountsAndDiffMap{..} = + Trie.lookup cid (accountRegIdHistory aadAccounts) >>= \case Nothing -> return Nothing Just ai -> fmap (ai,) <$> indexedAccount ai accs -- | Get the account at a given index (if any). getAccountIndex :: (IsProtocolVersion pv, LMDBAccountMap.MonadAccountMapStore m) => AccountAddress -> AccountsAndDiffMap pv -> m (Maybe AccountIndex) -getAccountIndex addr _ = gets (DiffMap.lookup addr) >>= \case +getAccountIndex addr AccountsAndDiffMap{..} = case DiffMap.lookup addr =<< aadDiffMap of Just accIdx -> return $ Just accIdx Nothing -> LMDBAccountMap.lookup addr >>= \case @@ -192,40 +204,44 @@ getAccountIndex addr _ = gets (DiffMap.lookup addr) >>= \case -- | Retrieve an account and its index from a given address. -- Returns @Nothing@ if no such account exists. -getAccountWithIndex :: (SupportsPersistentAccount pv m) => AccountAddress -> Accounts pv -> m (Maybe (AccountIndex, PersistentAccount (AccountVersionFor pv))) -getAccountWithIndex addr Accounts{..} = +getAccountWithIndex :: (SupportsPersistentAccount pv m) => AccountAddress -> AccountsAndDiffMap pv -> m (Maybe (AccountIndex, PersistentAccount (AccountVersionFor pv))) +getAccountWithIndex addr AccountsAndDiffMap{..} = LMDBAccountMap.lookup addr >>= \case Nothing -> return Nothing - Just ai -> fmap (ai,) <$> L.lookup ai accountTable + Just ai -> fmap (ai,) <$> L.lookup ai (accountTable aadAccounts) -- | Retrieve the account at a given index. -indexedAccount :: (SupportsPersistentAccount pv m) => AccountIndex -> Accounts pv -> m (Maybe (PersistentAccount (AccountVersionFor pv))) -indexedAccount ai Accounts{..} = L.lookup ai accountTable +indexedAccount :: (SupportsPersistentAccount pv m) => AccountIndex -> AccountsAndDiffMap pv -> m (Maybe (PersistentAccount (AccountVersionFor pv))) +indexedAccount ai AccountsAndDiffMap{..} = L.lookup ai (accountTable aadAccounts) -- | Retrieve an account with the given address. -- An account with the address is required to exist. -unsafeGetAccount :: (SupportsPersistentAccount pv m) => AccountAddress -> Accounts pv -> m (PersistentAccount (AccountVersionFor pv)) -unsafeGetAccount addr accts = - getAccount addr accts <&> \case +unsafeGetAccount :: (SupportsPersistentAccount pv m) => AccountAddress -> AccountsAndDiffMap pv -> m (PersistentAccount (AccountVersionFor pv)) +unsafeGetAccount addr AccountsAndDiffMap{..} = + getAccount addr aadAccounts <&> \case Just acct -> acct Nothing -> error $ "unsafeGetAccount: Account " ++ show addr ++ " does not exist." -- | Check that an account registration ID is not already on the chain. -- See the foundation (Section 4.2) for why this is necessary. -- Return @Just ai@ if the registration ID already exists, and @ai@ is the index of the account it is or was associated with. -regIdExists :: (MonadBlobStore m) => ID.CredentialRegistrationID -> Accounts pv -> m (Maybe AccountIndex) -regIdExists rid accts = Trie.lookup (ID.toRawCredRegId rid) (accountRegIdHistory accts) +regIdExists :: (MonadBlobStore m) => ID.CredentialRegistrationID -> AccountsAndDiffMap pv -> m (Maybe AccountIndex) +regIdExists rid accts = Trie.lookup (ID.toRawCredRegId rid) (accountRegIdHistory $ aadAccounts accts) -- | Record an account registration ID as used. -recordRegId :: (MonadBlobStore m) => ID.CredentialRegistrationID -> AccountIndex -> Accounts pv -> m (Accounts pv) +recordRegId :: (MonadBlobStore m) => ID.CredentialRegistrationID -> AccountIndex -> AccountsAndDiffMap pv -> m (AccountsAndDiffMap pv) recordRegId rid idx accts0 = do - accountRegIdHistory' <- Trie.insert (ID.toRawCredRegId rid) idx (accountRegIdHistory accts0) + accountRegIdHistory' <- Trie.insert (ID.toRawCredRegId rid) idx (accountRegIdHistory (aadAccounts accts0)) return $! accts0 - { accountRegIdHistory = accountRegIdHistory' + { aadAccounts = + Accounts + { accountTable = accountTable $ aadAccounts accts0, + accountRegIdHistory = accountRegIdHistory' + } } -recordRegIds :: (MonadBlobStore m) => [(ID.CredentialRegistrationID, AccountIndex)] -> Accounts pv -> m (Accounts pv) +recordRegIds :: (MonadBlobStore m) => [(ID.CredentialRegistrationID, AccountIndex)] -> AccountsAndDiffMap pv -> m (AccountsAndDiffMap pv) recordRegIds rids accts0 = foldM (\accts (cid, idx) -> recordRegId cid idx accts) accts0 rids -- | Get the account registration ids map. This loads the entire map from the blob store, and so @@ -242,15 +258,15 @@ loadRegIds accts = Trie.toMap (accountRegIdHistory accts) -- This should not be used to alter the address of an account (which is -- disallowed). updateAccounts :: - (SupportsPersistentAccount pv m) - => - (PersistentAccount (AccountVersionFor pv) -> - m (a, PersistentAccount (AccountVersionFor pv))) -> + (SupportsPersistentAccount pv m) => + ( PersistentAccount (AccountVersionFor pv) -> + m (a, PersistentAccount (AccountVersionFor pv)) + ) -> AccountAddress -> AccountsAndDiffMap pv -> m (Maybe (AccountIndex, a), AccountsAndDiffMap pv) -updateAccounts fupd addr a@AccountsAndDiffMap{aadAccounts = a0@Accounts{..},..} = - case DiffMap.lookup addr aadDiffMap of +updateAccounts fupd addr a0@AccountsAndDiffMap{aadAccounts = accs0@Accounts{..}, ..} = + case DiffMap.lookup addr =<< aadDiffMap of Nothing -> LMDBAccountMap.lookup addr >>= \case Nothing -> return (Nothing, a0) @@ -260,39 +276,39 @@ updateAccounts fupd addr a@AccountsAndDiffMap{aadAccounts = a0@Accounts{..},..} update ai = L.update fupd ai accountTable >>= \case Nothing -> return (Nothing, a0) - Just (res, act') -> return (Just (ai, res), a{aadAccounts = a0{accountTable = act'}}) + Just (res, act') -> return (Just (ai, res), a0{aadAccounts = accs0{accountTable = act'}}) -- | Perform an update to an account with the given index. -- Does nothing (returning @Nothing@) if the account does not exist. -- This should not be used to alter the address of an account (which is -- disallowed). -updateAccountsAtIndex :: (SupportsPersistentAccount pv m) => (PersistentAccount (AccountVersionFor pv) -> m (a, PersistentAccount (AccountVersionFor pv))) -> AccountIndex -> Accounts pv -> m (Maybe a, Accounts pv) -updateAccountsAtIndex fupd ai a0@Accounts{..} = +updateAccountsAtIndex :: (SupportsPersistentAccount pv m) => (PersistentAccount (AccountVersionFor pv) -> m (a, PersistentAccount (AccountVersionFor pv))) -> AccountIndex -> AccountsAndDiffMap pv -> m (Maybe a, AccountsAndDiffMap pv) +updateAccountsAtIndex fupd ai a0@AccountsAndDiffMap{aadAccounts = accs0@Accounts{..}} = L.update fupd ai accountTable >>= \case Nothing -> return (Nothing, a0) - Just (res, act') -> return (Just res, a0{accountTable = act'}) + Just (res, act') -> return (Just res, a0{aadAccounts = accs0{accountTable = act'}}) -- | Perform an update to an account with the given index. -- Does nothing if the account does not exist. -- This should not be used to alter the address of an account (which is -- disallowed). -updateAccountsAtIndex' :: (SupportsPersistentAccount pv m) => (PersistentAccount (AccountVersionFor pv) -> m (PersistentAccount (AccountVersionFor pv))) -> AccountIndex -> Accounts pv -> m (Accounts pv) +updateAccountsAtIndex' :: (SupportsPersistentAccount pv m) => (PersistentAccount (AccountVersionFor pv) -> m (PersistentAccount (AccountVersionFor pv))) -> AccountIndex -> AccountsAndDiffMap pv -> m (AccountsAndDiffMap pv) updateAccountsAtIndex' fupd ai = fmap snd . updateAccountsAtIndex fupd' ai where fupd' = fmap ((),) . fupd -- | Get a list of all account addresses. -- TODO: This is probably not good enough, revise or at least test. -accountAddresses :: (SupportsPersistentAccount pv m) => Accounts pv -> m [AccountAddress] +accountAddresses :: (SupportsPersistentAccount pv m) => AccountsAndDiffMap pv -> m [AccountAddress] accountAddresses accounts = do - accs <- (L.toAscList . accountTable) accounts + accs <- (L.toAscList . accountTable) (aadAccounts accounts) mapM accountCanonicalAddress accs -- | Serialize accounts in V0 format. -serializeAccounts :: (SupportsPersistentAccount pv m, MonadPut m) => GlobalContext -> Accounts pv -> m () -serializeAccounts cryptoParams accts = do - liftPut $ putWord64be $ L.size (accountTable accts) - L.mmap_ (serializeAccount cryptoParams) (accountTable accts) +serializeAccounts :: (SupportsPersistentAccount pv m, MonadPut m) => GlobalContext -> AccountsAndDiffMap pv -> m () +serializeAccounts cryptoParams AccountsAndDiffMap{..} = do + liftPut $ putWord64be $ L.size (accountTable aadAccounts) + L.mmap_ (serializeAccount cryptoParams) (accountTable aadAccounts) -- | Fold over the account table in ascending order of account index. foldAccounts :: (SupportsPersistentAccount pv m) => (a -> PersistentAccount (AccountVersionFor pv) -> m a) -> a -> Accounts pv -> m a @@ -320,9 +336,11 @@ migrateAccounts migration AccountsAndDiffMap{aadAccounts = Accounts{..}} = do -- that is purely in-memory and just copied over. newAccountRegIds <- Trie.migrateUnbufferedTrieN return accountRegIdHistory return $! - AccountsAndDiffMap { - aadAccounts = Accounts - { accountTable = newAccountTable, - accountRegIdHistory = newAccountRegIds - }, - aadDiffMap = Nothing} + AccountsAndDiffMap + { aadAccounts = + Accounts + { accountTable = newAccountTable, + accountRegIdHistory = newAccountRegIds + }, + aadDiffMap = Nothing + } diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Bakers.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Bakers.hs index 3bcfc848c5..67ee79dc0c 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Bakers.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Bakers.hs @@ -391,7 +391,7 @@ migratePersistentActiveBakers :: ) => StateMigrationParameters oldpv pv -> -- | Already migrated accounts. - Accounts.Accounts pv -> + Accounts.AccountsAndDiffMap pv -> PersistentActiveBakers (AccountVersionFor oldpv) -> t m (PersistentActiveBakers (AccountVersionFor pv)) migratePersistentActiveBakers migration accounts PersistentActiveBakers{..} = do diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 0e49a4b09d..a4cede21a1 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -184,7 +184,7 @@ migratePersistentBirkParameters :: SupportsPersistentAccount pv (t m) ) => StateMigrationParameters oldpv pv -> - Accounts.Accounts pv -> + Accounts.AccountsAndDiffMap pv -> PersistentBirkParameters oldpv -> t m (PersistentBirkParameters pv) migratePersistentBirkParameters migration accounts PersistentBirkParameters{..} = do @@ -931,7 +931,7 @@ emptyBlockState bspBirkParameters cryptParams keysCollection chainParams = do bsp <- makeBufferedRef $ BlockStatePointers - { bspAccounts = Accounts.emptyAccounts, + { bspAccounts = Accounts.emptyAcocuntsAndDiffMap Nothing, bspInstances = Instances.emptyInstances, bspModules = modules, bspBank = makeHashed Rewards.emptyBankStatus, @@ -1439,9 +1439,9 @@ doAddBaker pbs ai ba@BakerAdd{..} = do redelegatePassive :: forall pv m. (SupportsPersistentAccount pv m, PVSupportsDelegation pv) => - Accounts.Accounts pv -> + Accounts.AccountsAndDiffMap pv -> DelegatorId -> - m (Accounts.Accounts pv) + m (Accounts.AccountsAndDiffMap pv) redelegatePassive accounts (DelegatorId accId) = Accounts.updateAccountsAtIndex' (setAccountDelegationTarget Transactions.DelegatePassive) @@ -2232,11 +2232,6 @@ doAccountList pbs = do bsp <- loadPBS pbs Accounts.accountAddresses (bspAccounts bsp) -doAddressWouldClash :: (SupportsPersistentState pv m) => PersistentBlockState pv -> AccountAddress -> m Bool -doAddressWouldClash pbs addr = do - bsp <- loadPBS pbs - Accounts.addressWouldClash addr (bspAccounts bsp) - doRegIdExists :: (SupportsPersistentState pv m) => PersistentBlockState pv -> ID.CredentialRegistrationID -> m Bool doRegIdExists pbs regid = do bsp <- loadPBS pbs @@ -2790,9 +2785,9 @@ doProcessReleaseSchedule pbs ts = do else do let processAccountP1 :: (RSAccountRef pv ~ AccountAddress) => - (Accounts.Accounts pv, ReleaseSchedule pv) -> + (Accounts.AccountsAndDiffMap pv, ReleaseSchedule pv) -> RSAccountRef pv -> - m (Accounts.Accounts pv, ReleaseSchedule pv) + m (Accounts.AccountsAndDiffMap pv, ReleaseSchedule pv) processAccountP1 (accs, rs) addr = do (reAdd, accs') <- Accounts.updateAccounts (unlockAccountReleases ts) addr accs rs' <- case reAdd of @@ -2802,9 +2797,9 @@ doProcessReleaseSchedule pbs ts = do return (accs', rs') processAccountP5 :: (RSAccountRef pv ~ AccountIndex) => - (Accounts.Accounts pv, ReleaseSchedule pv) -> + (Accounts.AccountsAndDiffMap pv, ReleaseSchedule pv) -> RSAccountRef pv -> - m (Accounts.Accounts pv, ReleaseSchedule pv) + m (Accounts.AccountsAndDiffMap pv, ReleaseSchedule pv) processAccountP5 (accs, rs) ai = do (reAdd, accs') <- Accounts.updateAccountsAtIndex (unlockAccountReleases ts) ai accs rs' <- case reAdd of @@ -2812,7 +2807,7 @@ doProcessReleaseSchedule pbs ts = do Just Nothing -> return rs Nothing -> error "processReleaseSchedule: scheduled release for invalid account index" return (accs', rs') - processAccount :: (Accounts.Accounts pv, ReleaseSchedule pv) -> RSAccountRef pv -> m (Accounts.Accounts pv, ReleaseSchedule pv) + processAccount :: (Accounts.AccountsAndDiffMap pv, ReleaseSchedule pv) -> RSAccountRef pv -> m (Accounts.AccountsAndDiffMap pv, ReleaseSchedule pv) processAccount = case protocolVersion @pv of SP1 -> processAccountP1 SP2 -> processAccountP1 @@ -3119,7 +3114,7 @@ doProcessPendingChanges persistentBS isEffective = do -- an entry for a particular pool. processDelegators :: PersistentActiveDelegators (AccountVersionFor pv) -> - MTL.StateT (Accounts.Accounts pv) m (PersistentActiveDelegators (AccountVersionFor pv)) + MTL.StateT (Accounts.AccountsAndDiffMap pv) m (PersistentActiveDelegators (AccountVersionFor pv)) processDelegators (PersistentActiveDelegatorsV1 dset _) = do (newDlgs, newAmt) <- MTL.runWriterT $ Trie.filterKeysM processDelegator dset return (PersistentActiveDelegatorsV1 newDlgs newAmt) @@ -3127,7 +3122,7 @@ doProcessPendingChanges persistentBS isEffective = do -- Update the delegator on an account if its cooldown has expired. -- This only updates the account table, and not the active bakers index. -- This also 'MTL.tell's the (updated) staked amount of the account. - processDelegator :: DelegatorId -> MTL.WriterT Amount (MTL.StateT (Accounts.Accounts pv) m) Bool + processDelegator :: DelegatorId -> MTL.WriterT Amount (MTL.StateT (Accounts.AccountsAndDiffMap pv) m) Bool processDelegator (DelegatorId accId) = do accounts <- MTL.get Accounts.indexedAccount accId accounts >>= \case @@ -3141,7 +3136,7 @@ doProcessPendingChanges persistentBS isEffective = do updateAccountDelegator :: AccountIndex -> PersistentAccount (AccountVersionFor pv) -> - MTL.WriterT Amount (MTL.StateT (Accounts.Accounts pv) m) Bool + MTL.WriterT Amount (MTL.StateT (Accounts.AccountsAndDiffMap pv) m) Bool updateAccountDelegator accId acct = accountDelegator acct >>= \case Just BaseAccounts.AccountDelegationV1{..} -> do @@ -3162,7 +3157,7 @@ doProcessPendingChanges persistentBS isEffective = do -- Remove a delegator from an account. -- This only affects the account, and does not affect the active bakers index. - removeDelegatorStake :: AccountIndex -> MTL.StateT (Accounts.Accounts pv) m () + removeDelegatorStake :: AccountIndex -> MTL.StateT (Accounts.AccountsAndDiffMap pv) m () removeDelegatorStake accId = do accounts <- MTL.get newAccounts <- Accounts.updateAccountsAtIndex' removeAccountStaking accId accounts @@ -3174,7 +3169,7 @@ doProcessPendingChanges persistentBS isEffective = do reduceDelegatorStake :: AccountIndex -> Amount -> - MTL.StateT (Accounts.Accounts pv) m () + MTL.StateT (Accounts.AccountsAndDiffMap pv) m () reduceDelegatorStake accId newAmt = do accounts <- MTL.get let updAcc = setAccountStake newAmt >=> setAccountStakePendingChange BaseAccounts.NoChange @@ -3189,7 +3184,7 @@ doProcessPendingChanges persistentBS isEffective = do processBakers :: BakerIdTrieMap (AccountVersionFor pv) -> MTL.StateT - (Accounts.Accounts pv, AggregationKeySet, PersistentActiveDelegators (AccountVersionFor pv)) + (Accounts.AccountsAndDiffMap pv, AggregationKeySet, PersistentActiveDelegators (AccountVersionFor pv)) m (BakerIdTrieMap (AccountVersionFor pv), Amount) processBakers = MTL.runWriterT . Trie.alterMapM processBaker @@ -3204,7 +3199,7 @@ doProcessPendingChanges persistentBS isEffective = do PersistentActiveDelegators (AccountVersionFor pv) -> MTL.WriterT Amount - (MTL.StateT (Accounts.Accounts pv, AggregationKeySet, PersistentActiveDelegators (AccountVersionFor pv)) m) + (MTL.StateT (Accounts.AccountsAndDiffMap pv, AggregationKeySet, PersistentActiveDelegators (AccountVersionFor pv)) m) (Trie.Alteration (PersistentActiveDelegators (AccountVersionFor pv))) processBaker bid@(BakerId accId) oldDelegators = do accts0 <- use _1 @@ -3251,7 +3246,7 @@ doProcessPendingChanges persistentBS isEffective = do BakerId -> AccountBaker av -> PersistentActiveDelegators (AccountVersionFor pv) -> - MTL.StateT (Accounts.Accounts pv, AggregationKeySet, PersistentActiveDelegators (AccountVersionFor pv)) m () + MTL.StateT (Accounts.AccountsAndDiffMap pv, AggregationKeySet, PersistentActiveDelegators (AccountVersionFor pv)) m () removeBaker (BakerId accId) acctBkr (PersistentActiveDelegatorsV1 dset dcapital) = do accounts0 <- use _1 -- Update the baker's account to have no delegation @@ -3273,7 +3268,7 @@ doProcessPendingChanges persistentBS isEffective = do reduceBakerStake :: BakerId -> Amount -> - MTL.StateT (Accounts.Accounts pv, a, b) m () + MTL.StateT (Accounts.AccountsAndDiffMap pv, a, b) m () reduceBakerStake (BakerId accId) newAmt = do let updAcc = setAccountStake newAmt >=> setAccountStakePendingChange BaseAccounts.NoChange accounts <- use _1 @@ -3348,7 +3343,6 @@ instance (PersistentState av pv r m) => LMDBAccountMap.MonadAccountMapStore (Per lookup = undefined insert = undefined - type instance BlockStatePointer (PersistentBlockState pv) = BlobRef (BlockStatePointers pv) type instance BlockStatePointer (HashedPersistentBlockState pv) = BlobRef (BlockStatePointers pv) @@ -3539,8 +3533,12 @@ instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateOperatio bsoIsProtocolUpdateEffective = doIsProtocolUpdateEffective instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateStorage (PersistentBlockStateMonad pv r m) where - thawBlockState HashedPersistentBlockState{..} = - liftIO $ newIORef =<< readIORef hpbsPointers + thawBlockState a@HashedPersistentBlockState{..} = do + bufferedPtrs <- liftIO $ readIORef hpbsPointers + ptrs0 <- loadBufferedRef bufferedPtrs + ptrs1 <- makeBufferedRef ptrs0{bspAccounts = Accounts.emptyAcocuntsAndDiffMap $ Just $ bspAccounts ptrs0} + ioref <- liftIO $ newIORef ptrs1 -- todo fix this. If a blobref already exists then carry this over. + return ioref freezeBlockState pbs = hashBlockState pbs @@ -3667,7 +3665,7 @@ migrateBlockPointers migration BlockStatePointers{..} = do return $! BlockStatePointers - { bspAccounts = Accounts.AccountsAndDiffMap newAccounts Nothing, + { bspAccounts = newAccounts, bspInstances = newInstances, bspModules = newModules, bspBank = newBank, diff --git a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs index c0638f08d0..cfe76eae9e 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs @@ -269,16 +269,14 @@ deriving via LowLevel.MonadTreeStateStore (SkovV1T pv m) deriving via - (LMDBAccountMap.AccountMapStoreMonad r (InnerSkovV1T pv m)) - instance - ( IsProtocolVersion pv, - MonadIO m, - MonadCatch m, - MonadLogger m - ) => - LMDBAccountMap.MonadAccountMapStore (SkovV1T pv m) - - + (LMDBAccountMap.AccountMapStoreMonad r (InnerSkovV1T pv m)) + instance + ( IsProtocolVersion pv, + MonadIO m, + MonadCatch m, + MonadLogger m + ) => + LMDBAccountMap.MonadAccountMapStore (SkovV1T pv m) instance (Monad m) => MonadBroadcast (SkovV1T pv m) where sendTimeoutMessage tm = do From 998212a99e847712214274a490a605feeb6808d2 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Mon, 9 Oct 2023 16:02:51 +0200 Subject: [PATCH 10/92] ... --- .../src/Concordium/GlobalState.hs | 4 ++ .../Concordium/GlobalState/AccountMap/LMDB.hs | 11 ++++-- .../GlobalState/Persistent/BlockState.hs | 23 ++++++----- .../GlobalState/Persistent/Genesis.hs | 6 +-- .../GlobalState/Persistent/TreeState.hs | 38 ++----------------- 5 files changed, 33 insertions(+), 49 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState.hs b/concordium-consensus/src/Concordium/GlobalState.hs index e91971883d..22bf0d92e3 100644 --- a/concordium-consensus/src/Concordium/GlobalState.hs +++ b/concordium-consensus/src/Concordium/GlobalState.hs @@ -25,6 +25,7 @@ import Concordium.GlobalState.Persistent.Genesis import Concordium.GlobalState.Persistent.TreeState import Concordium.Logger import Concordium.Types.ProtocolVersion +import Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap -- | Configuration that uses the disk implementation for both the tree state -- and the block state @@ -74,6 +75,7 @@ initialiseExistingGlobalState _ GlobalStateConfig{..} = do pbscAccountCache <- newAccountCache (rpAccountsCacheSize dtdbRuntimeParameters) pbscModuleCache <- Modules.newModuleCache (rpModulesCacheSize dtdbRuntimeParameters) pbscBlobStore <- loadBlobStore dtdbBlockStateFile + pbscAccountMap <- liftIO $ LMDBAccountMap.openDatabase dtdAccountMapDirectory let pbsc = PersistentBlockStateContext{..} skovData <- runLoggerT (loadSkovPersistentData dtdbRuntimeParameters dtdbTreeStateDirectory dtdAccountMapDirectory pbsc) logm @@ -114,6 +116,7 @@ migrateExistingState GlobalStateConfig{..} oldPbsc oldState migration genData = pbscBlobStore <- liftIO $ createBlobStore dtdbBlockStateFile pbscAccountCache <- liftIO $ newAccountCache (rpAccountsCacheSize dtdbRuntimeParameters) pbscModuleCache <- liftIO $ Modules.newModuleCache (rpModulesCacheSize dtdbRuntimeParameters) + pbscAccountMap <- liftIO $ LMDBAccountMap.openDatabase accountMapDir let pbsc = PersistentBlockStateContext{..} newInitialBlockState <- flip runBlobStoreT oldPbsc . flip runBlobStoreT pbsc $ do case _nextGenesisInitialState oldState of @@ -145,6 +148,7 @@ initialiseNewGlobalState genData GlobalStateConfig{..} = do pbscBlobStore <- liftIO $ createBlobStore dtdbBlockStateFile pbscAccountCache <- liftIO $ newAccountCache (rpAccountsCacheSize dtdbRuntimeParameters) pbscModuleCache <- liftIO $ Modules.newModuleCache (rpModulesCacheSize dtdbRuntimeParameters) + pbscAccountMap <- liftIO $ LMDBAccountMap.openDatabase accountMapDir let pbsc = PersistentBlockStateContext{..} let initGS = do logEvent GlobalState LLTrace "Creating persistent global state" diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index acc2671023..3f1c488c3f 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -36,9 +36,9 @@ import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Identity import Control.Monad.Reader -import Control.Monad.State +import Control.Monad.State.Strict import Control.Monad.Trans.Except -import Control.Monad.Trans.Writer +import Control.Monad.Trans.Writer.Strict import qualified Data.ByteString as BS import Data.Data (Data, Typeable) import Data.Kind (Type) @@ -54,6 +54,7 @@ import Concordium.GlobalState.LMDB.Helpers import Concordium.Logger import Concordium.Types import qualified Data.FixedByteString as FBS +import Concordium.Utils.Serialization.Put -- * Exceptions @@ -98,6 +99,10 @@ deriving via (MGSTrans (StateT s) m) instance (MonadAccountMapStore m) => MonadA deriving via (MGSTrans (ExceptT e) m) instance (MonadAccountMapStore m) => MonadAccountMapStore (ExceptT e m) deriving via (MGSTrans (WriterT w) m) instance (Monoid w, MonadAccountMapStore m) => MonadAccountMapStore (WriterT w m) +instance (MonadAccountMapStore m) => MonadAccountMapStore (PutT m) where + insert bh height = lift . insert bh height + lookup = lift . lookup + -- * Database stores -- | Store that yields the last finalized block from the perspective @@ -267,7 +272,7 @@ closeDatabase dbHandlers = runInBoundThread $ mdb_env_close $ dbHandlers ^. stor -- ** Monad implementation --- The 'AccountMapStoreMonad' acquires the 'DatabaseHandlers' via a reader context. +-- | The 'AccountMapStoreMonad' for interacting with the LMDB database. newtype AccountMapStoreMonad (m :: Type -> Type) (a :: Type) = AccountMapStoreMonad {runAccountMapStoreMonad :: m a} deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadLogger, MonadReader r) via m deriving (MonadTrans) via IdentityT diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index a4cede21a1..083ce0efe6 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -3290,9 +3290,14 @@ data PersistentBlockStateContext pv = PersistentBlockStateContext -- | Cache used for caching accounts. pbscAccountCache :: !(AccountCache (AccountVersionFor pv)), -- | Cache used for caching modules. - pbscModuleCache :: !Modules.ModuleCache + pbscModuleCache :: !Modules.ModuleCache, + -- | LMDB account map + pbscAccountMap :: !LMDBAccountMap.DatabaseHandlers } +instance LMDBAccountMap.HasDatabaseHandlers (PersistentBlockStateContext pv) where + databaseHandlers x u = undefined -- todo implement + instance HasBlobStore (PersistentBlockStateContext av) where blobStore = bscBlobStore . pbscBlobStore blobLoadCallback = bscLoadCallback . pbscBlobStore @@ -3313,7 +3318,7 @@ withNewAccountCache :: (MonadIO m) => Int -> BlobStoreT (PersistentBlockStateCon withNewAccountCache size bsm = do ac <- liftIO $ newAccountCache size mc <- liftIO $ Modules.newModuleCache 100 - alterBlobStoreT (\bs -> PersistentBlockStateContext bs ac mc) bsm + alterBlobStoreT (\bs -> PersistentBlockStateContext bs ac mc undefined) bsm newtype PersistentBlockStateMonad (pv :: ProtocolVersion) (r :: Type) (m :: Type -> Type) (a :: Type) = PersistentBlockStateMonad {runPersistentBlockStateMonad :: m a} deriving (Functor, Applicative, Monad, MonadIO, MonadReader r, MonadLogger, TimeMonad, MTL.MonadState s) @@ -3338,10 +3343,11 @@ instance (PersistentState av pv r m) => MonadBlobStore (PutH (PersistentBlockSta instance (PersistentState av pv r m) => Cache.MonadCache (AccountCache av) (PersistentBlockStateMonad pv r m) instance (PersistentState av pv r m) => Cache.MonadCache Modules.ModuleCache (PersistentBlockStateMonad pv r m) --- todo: derive it. -instance (PersistentState av pv r m) => LMDBAccountMap.MonadAccountMapStore (PersistentBlockStateMonad pv r m) where - lookup = undefined - insert = undefined +instance (PersistentState av pv r m, r ~ PersistentBlockStateContext pv) => LMDBAccountMap.MonadAccountMapStore (PersistentBlockStateMonad pv r m) where + insert bh height = undefined -- + lookup accAddr = do + accountMapHandlers <- asks pbscAccountMap + return undefined type instance BlockStatePointer (PersistentBlockState pv) = BlobRef (BlockStatePointers pv) type instance BlockStatePointer (HashedPersistentBlockState pv) = BlobRef (BlockStatePointers pv) @@ -3533,12 +3539,11 @@ instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateOperatio bsoIsProtocolUpdateEffective = doIsProtocolUpdateEffective instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateStorage (PersistentBlockStateMonad pv r m) where - thawBlockState a@HashedPersistentBlockState{..} = do + thawBlockState HashedPersistentBlockState{..} = do bufferedPtrs <- liftIO $ readIORef hpbsPointers ptrs0 <- loadBufferedRef bufferedPtrs ptrs1 <- makeBufferedRef ptrs0{bspAccounts = Accounts.emptyAcocuntsAndDiffMap $ Just $ bspAccounts ptrs0} - ioref <- liftIO $ newIORef ptrs1 -- todo fix this. If a blobref already exists then carry this over. - return ioref + liftIO $ newIORef ptrs1 -- todo fix this. If a blobref already exists then carry this over. freezeBlockState pbs = hashBlockState pbs diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Genesis.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Genesis.hs index 73a6f7bc20..02ff923cd8 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Genesis.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Genesis.hs @@ -223,7 +223,7 @@ buildGenesisBlockState vcgp GenesisData.GenesisState{..} = do bsp <- Blob.refMakeFlushed $ BS.BlockStatePointers - { bspAccounts = agsAllAccounts, + { bspAccounts = Accounts.AccountsAndDiffMap agsAllAccounts Nothing, bspInstances = Instances.emptyInstances, bspModules = modules, bspBank = Types.makeHashed $ Rewards.makeGenesisBankStatus agsTotal, @@ -258,7 +258,7 @@ buildGenesisBlockState vcgp GenesisData.GenesisState{..} = do genesisChainParameters genesisAccount -- Insert the account - (maybeIndex, nextAccounts0) <- Accounts.putNewAccount persistentAccount $ agsAllAccounts state + (maybeIndex, nextAccounts0) <- Accounts.putNewAccount persistentAccount $ Accounts.AccountsAndDiffMap (agsAllAccounts state) Nothing nextAccounts <- case maybeIndex of Nothing -> MTL.throwError "Duplicate account address in genesis accounts." Just ai -> @@ -267,7 +267,7 @@ buildGenesisBlockState vcgp GenesisData.GenesisState{..} = do in Accounts.recordRegIds newRegIds nextAccounts0 let !nextTotalAmount = agsTotal state + GenesisData.gaBalance genesisAccount - let !updatedState = state{agsAllAccounts = nextAccounts, agsTotal = nextTotalAmount} + let !updatedState = state{agsAllAccounts = Accounts.aadAccounts nextAccounts, agsTotal = nextTotalAmount} case GenesisData.gaBaker genesisAccount of Just baker@GenesisData.GenesisBaker{..} -> do diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs index 9e818d7126..d70c33655c 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs @@ -12,7 +12,6 @@ -- and `TreeStateMonad` effectively adding persistence to the tree state. module Concordium.GlobalState.Persistent.TreeState where -import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import Concordium.GlobalState.Block import Concordium.GlobalState.BlockMonads import Concordium.GlobalState.BlockPointer @@ -241,9 +240,7 @@ data SkovPersistentData (pv :: ProtocolVersion) = SkovPersistentData -- If we only had the one state implementation this would not be necessary, and we could simply -- return the value in the 'updateRegenesis' function. However as it is, it is challenging to properly -- specify the types of these values due to the way the relevant types are parameterized. - _nextGenesisInitialState :: !(Maybe (PBS.HashedPersistentBlockState pv)), - -- | Account map db - _accountMapDb :: !LMDBAccountMap.DatabaseHandlers + _nextGenesisInitialState :: !(Maybe (PBS.HashedPersistentBlockState pv)) } makeLenses ''SkovPersistentData @@ -259,8 +256,6 @@ initialSkovPersistentDataDefault :: (IsProtocolVersion pv, MonadIO m) => -- | Tree state directory FilePath -> - -- | Account map directory - FilePath -> GenesisConfiguration -> PBS.HashedPersistentBlockState pv -> -- | How to serialize the block state reference for inclusion in the table. @@ -279,8 +274,6 @@ initialSkovPersistentData :: RuntimeParameters -> -- | Tree state directory FilePath -> - -- | Account map directory - FilePath -> -- | Genesis data GenesisConfiguration -> -- | Genesis state @@ -298,15 +291,11 @@ initialSkovPersistentData :: -- documentation of the 'PendingTransactionTable' for details. Maybe PendingTransactionTable -> m (SkovPersistentData pv) -initialSkovPersistentData rp treeStateDir accountMapDir gd genState serState genTT mPending = do +initialSkovPersistentData rp treeStateDir gd genState serState genTT mPending = do gb <- makeGenesisPersistentBlockPointer gd genState let gbh = bpHash gb gbfin = FinalizationRecord 0 gbh emptyFinalizationProof 0 initialDb <- liftIO $ initializeDatabase gb serState treeStateDir - accountMapDb <- liftIO $ LMDBAccountMap.openDatabase accountMapDir - LMDBAccountMap.isInitialized accountMapDb >>= \case - Nothing -> undefined -- todo: call 'initialize' for initializing the lmdb database. - Just (lfbHash, lfbHeight) -> undefined -- todo; check that the it's consistent with what is recorded in the tree state return SkovPersistentData { _blockTable = emptyBlockTable, @@ -325,8 +314,7 @@ initialSkovPersistentData rp treeStateDir accountMapDir gd genState serState gen _runtimeParameters = rp, _treeStateDirectory = treeStateDir, _db = initialDb, - _nextGenesisInitialState = Nothing, - _accountMapDb = accountMapDb + _nextGenesisInitialState = Nothing } -------------------------------------------------------------------------------- @@ -416,11 +404,9 @@ loadSkovPersistentData :: RuntimeParameters -> -- | Tree state directory FilePath -> - -- | Account map directory - FilePath -> PBS.PersistentBlockStateContext pv -> LogIO (SkovPersistentData pv) -loadSkovPersistentData rp _treeStateDirectory accountMapDir pbsc = do +loadSkovPersistentData rp _treeStateDirectory pbsc = do -- we open the environment first. -- It might be that the database is bigger than the default environment size. -- This seems to not be an issue while we only read from the database, @@ -453,22 +439,6 @@ loadSkovPersistentData rp _treeStateDirectory accountMapDir pbsc = do _ -> logExceptionAndThrowTS (DatabaseInvariantViolation "Block at height 0 is not a genesis block.") -- Get the last finalized block. _lastFinalized <- liftIO (makeBlockPointer lfStoredBlock) - - -- Check whether the account map is already setup. - -- If not then populate it now with the last finalized block, - -- otherwise check if the current one matches the last finalized block - -- of the tree state. - -- todo: factor this out. - _accountMapDb <- liftIO $ LMDBAccountMap.openDatabase accountMapDir - LMDBAccountMap.isInitialized _accountMapDb >>= \case - Nothing -> do - accounts <- runReaderT (PBS.runPersistentBlockStateMonad (getAccountList $ _bpState _lastFinalized)) pbsc - LMDBAccountMap.initialize (bpHash _lastFinalized) (bpHeight _lastFinalized) accounts _accountMapDb - Just (lfbHash, _) -> do - let tsLfbHash = bpHash _lastFinalized - when (lfbHash /= tsLfbHash) $ - logExceptionAndThrowTS $ - AccountMapMismatch lfbHash tsLfbHash return SkovPersistentData { _possiblyPendingTable = HM.empty, From 122fd885a306f918b5d7892c4feb4ce7231f53d2 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Tue, 10 Oct 2023 14:56:11 +0200 Subject: [PATCH 11/92] Some work. --- .../src/Concordium/GlobalState.hs | 47 +++++++++---------- .../Concordium/GlobalState/AccountMap/LMDB.hs | 5 +- .../GlobalState/Persistent/Accounts.hs | 1 + .../GlobalState/Persistent/BlockState.hs | 30 ++++++------ .../GlobalState/Persistent/TreeState.hs | 12 ++--- .../src/Concordium/KonsensusV1/SkovMonad.hs | 2 +- .../src/Concordium/KonsensusV1/TestMonad.hs | 5 ++ .../Concordium/Skov/MonadImplementations.hs | 13 +++++ 8 files changed, 67 insertions(+), 48 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState.hs b/concordium-consensus/src/Concordium/GlobalState.hs index 22bf0d92e3..97d617c93b 100644 --- a/concordium-consensus/src/Concordium/GlobalState.hs +++ b/concordium-consensus/src/Concordium/GlobalState.hs @@ -72,14 +72,14 @@ initialiseExistingGlobalState _ GlobalStateConfig{..} = do then do logm <- ask liftIO $ do - pbscAccountCache <- newAccountCache (rpAccountsCacheSize dtdbRuntimeParameters) - pbscModuleCache <- Modules.newModuleCache (rpModulesCacheSize dtdbRuntimeParameters) - pbscBlobStore <- loadBlobStore dtdbBlockStateFile - pbscAccountMap <- liftIO $ LMDBAccountMap.openDatabase dtdAccountMapDirectory + _pbscAccountCache <- newAccountCache (rpAccountsCacheSize dtdbRuntimeParameters) + _pbscModuleCache <- Modules.newModuleCache (rpModulesCacheSize dtdbRuntimeParameters) + _pbscBlobStore <- loadBlobStore dtdbBlockStateFile + _pbscAccountMap <- liftIO $ LMDBAccountMap.openDatabase dtdAccountMapDirectory let pbsc = PersistentBlockStateContext{..} skovData <- - runLoggerT (loadSkovPersistentData dtdbRuntimeParameters dtdbTreeStateDirectory dtdAccountMapDirectory pbsc) logm - `onException` closeBlobStore pbscBlobStore + runLoggerT (loadSkovPersistentData dtdbRuntimeParameters dtdbTreeStateDirectory pbsc) logm + `onException` closeBlobStore _pbscBlobStore return (Just (pbsc, skovData)) else return Nothing @@ -113,31 +113,30 @@ migrateExistingState :: -- | The return value is the context and state for the new chain. LogIO (GSContext pv, GSState pv) migrateExistingState GlobalStateConfig{..} oldPbsc oldState migration genData = do - pbscBlobStore <- liftIO $ createBlobStore dtdbBlockStateFile - pbscAccountCache <- liftIO $ newAccountCache (rpAccountsCacheSize dtdbRuntimeParameters) - pbscModuleCache <- liftIO $ Modules.newModuleCache (rpModulesCacheSize dtdbRuntimeParameters) - pbscAccountMap <- liftIO $ LMDBAccountMap.openDatabase accountMapDir + _pbscBlobStore <- liftIO $ createBlobStore dtdbBlockStateFile + _pbscAccountCache <- liftIO $ newAccountCache (rpAccountsCacheSize dtdbRuntimeParameters) + _pbscModuleCache <- liftIO $ Modules.newModuleCache (rpModulesCacheSize dtdbRuntimeParameters) + _pbscAccountMap <- liftIO $ LMDBAccountMap.openDatabase dtdAccountMapDirectory let pbsc = PersistentBlockStateContext{..} newInitialBlockState <- flip runBlobStoreT oldPbsc . flip runBlobStoreT pbsc $ do case _nextGenesisInitialState oldState of Nothing -> error "Precondition violation. Migration called in state without initial block state." - Just initState -> do - newState <- migratePersistentBlockState migration (hpbsPointers initState) - Concordium.GlobalState.Persistent.BlockState.hashBlockState newState + Just initState -> undefined -- todo +-- newState <- migratePersistentBlockState migration (hpbsPointers initState) +-- Concordium.GlobalState.Persistent.BlockState.hashBlockState newState let initGS = do ser <- saveBlockState newInitialBlockState initialSkovPersistentData dtdbRuntimeParameters dtdbTreeStateDirectory - dtdAccountMapDirectory (regenesisConfiguration genData) newInitialBlockState ser (_transactionTable oldState) (Just (_pendingTransactions oldState)) isd <- - runReaderT (runPersistentBlockStateMonad initGS) pbsc - `onException` liftIO (destroyBlobStore pbscBlobStore) + runReaderT (LMDBAccountMap.runAccountMapStoreMonad (runPersistentBlockStateMonad initGS)) pbsc + `onException` liftIO (destroyBlobStore _pbscBlobStore) return (pbsc, isd) -- | Initialise new global state with the given genesis. If the state already @@ -145,10 +144,10 @@ migrateExistingState GlobalStateConfig{..} oldPbsc oldState migration genData = -- on the generated state, as this will establish the necessary invariants. initialiseNewGlobalState :: (IsProtocolVersion pv, IsConsensusV0 pv) => GenesisData pv -> GlobalStateConfig -> LogIO (GSContext pv, GSState pv) initialiseNewGlobalState genData GlobalStateConfig{..} = do - pbscBlobStore <- liftIO $ createBlobStore dtdbBlockStateFile - pbscAccountCache <- liftIO $ newAccountCache (rpAccountsCacheSize dtdbRuntimeParameters) - pbscModuleCache <- liftIO $ Modules.newModuleCache (rpModulesCacheSize dtdbRuntimeParameters) - pbscAccountMap <- liftIO $ LMDBAccountMap.openDatabase accountMapDir + _pbscBlobStore <- liftIO $ createBlobStore dtdbBlockStateFile + _pbscAccountCache <- liftIO $ newAccountCache (rpAccountsCacheSize dtdbRuntimeParameters) + _pbscModuleCache <- liftIO $ Modules.newModuleCache (rpModulesCacheSize dtdbRuntimeParameters) + _pbscAccountMap <- liftIO $ LMDBAccountMap.openDatabase dtdAccountMapDirectory let pbsc = PersistentBlockStateContext{..} let initGS = do logEvent GlobalState LLTrace "Creating persistent global state" @@ -159,10 +158,10 @@ initialiseNewGlobalState genData GlobalStateConfig{..} = do logEvent GlobalState LLTrace "Writing persistent global state" ser <- saveBlockState pbs logEvent GlobalState LLTrace "Creating persistent global state context" - initialSkovPersistentData dtdbRuntimeParameters dtdbTreeStateDirectory dtdAccountMapDirectory (genesisConfiguration genData) pbs ser genTT Nothing + initialSkovPersistentData dtdbRuntimeParameters dtdbTreeStateDirectory (genesisConfiguration genData) pbs ser genTT Nothing isd <- - runReaderT (runPersistentBlockStateMonad initGS) pbsc - `onException` liftIO (destroyBlobStore pbscBlobStore) + runReaderT (LMDBAccountMap.runAccountMapStoreMonad (runPersistentBlockStateMonad initGS)) pbsc + `onException` liftIO (destroyBlobStore _pbscBlobStore) return (pbsc, isd) -- | Either initialise an existing state, or if it does not exist, initialise a new one with the given genesis. @@ -180,5 +179,5 @@ activateGlobalState _ = activateSkovPersistentData -- | Shutdown the global state. shutdownGlobalState :: SProtocolVersion pv -> GSContext pv -> GSState pv -> IO () shutdownGlobalState _ PersistentBlockStateContext{..} st = do - closeBlobStore pbscBlobStore + closeBlobStore _pbscBlobStore closeSkovPersistentData st diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index 3f1c488c3f..1654428218 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -48,6 +48,7 @@ import Lens.Micro.Platform import System.Directory import Prelude hiding (lookup) +import Concordium.TimeMonad import Concordium.GlobalState.AccountMap.DifferenceMap (DifferenceMap (..)) import Concordium.GlobalState.Classes import Concordium.GlobalState.LMDB.Helpers @@ -274,9 +275,11 @@ closeDatabase dbHandlers = runInBoundThread $ mdb_env_close $ dbHandlers ^. stor -- | The 'AccountMapStoreMonad' for interacting with the LMDB database. newtype AccountMapStoreMonad (m :: Type -> Type) (a :: Type) = AccountMapStoreMonad {runAccountMapStoreMonad :: m a} - deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadLogger, MonadReader r) via m + deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadLogger, MonadReader r, MonadState s, TimeMonad) via m deriving (MonadTrans) via IdentityT +deriving instance (MonadProtocolVersion m) => MonadProtocolVersion (AccountMapStoreMonad m) + -- | Run a read-only transaction. asReadTransaction :: (MonadIO m, MonadReader r m, HasDatabaseHandlers r) => (DatabaseHandlers -> MDB_txn -> IO a) -> AccountMapStoreMonad m a asReadTransaction t = do diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index d4f00a8d7b..c34562c57e 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -100,6 +100,7 @@ type SupportsPersistentAccount pv m = MonadCache (AccountCache (AccountVersionFor pv)) m, LMDBAccountMap.MonadAccountMapStore m ) + instance (IsProtocolVersion pv) => Show (Accounts pv) where show a = show (accountTable a) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 083ce0efe6..445de2e218 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -3286,28 +3286,29 @@ doSetRewardAccounts pbs rewards = do -- | Context that supports the persistent block state. data PersistentBlockStateContext pv = PersistentBlockStateContext { -- | The 'BlobStore' used for storing the persistent state. - pbscBlobStore :: !BlobStore, + _pbscBlobStore :: !BlobStore, -- | Cache used for caching accounts. - pbscAccountCache :: !(AccountCache (AccountVersionFor pv)), + _pbscAccountCache :: !(AccountCache (AccountVersionFor pv)), -- | Cache used for caching modules. - pbscModuleCache :: !Modules.ModuleCache, + _pbscModuleCache :: !Modules.ModuleCache, -- | LMDB account map - pbscAccountMap :: !LMDBAccountMap.DatabaseHandlers + _pbscAccountMap :: !LMDBAccountMap.DatabaseHandlers } +makeLenses ''PersistentBlockStateContext instance LMDBAccountMap.HasDatabaseHandlers (PersistentBlockStateContext pv) where - databaseHandlers x u = undefined -- todo implement + databaseHandlers = pbscAccountMap instance HasBlobStore (PersistentBlockStateContext av) where - blobStore = bscBlobStore . pbscBlobStore - blobLoadCallback = bscLoadCallback . pbscBlobStore - blobStoreCallback = bscStoreCallback . pbscBlobStore + blobStore = bscBlobStore . _pbscBlobStore + blobLoadCallback = bscLoadCallback . _pbscBlobStore + blobStoreCallback = bscStoreCallback . _pbscBlobStore instance (AccountVersionFor pv ~ av) => Cache.HasCache (AccountCache av) (PersistentBlockStateContext pv) where - projectCache = pbscAccountCache + projectCache = _pbscAccountCache instance Cache.HasCache Modules.ModuleCache (PersistentBlockStateContext pv) where - projectCache = pbscModuleCache + projectCache = _pbscModuleCache instance (IsProtocolVersion pv) => MonadProtocolVersion (BlobStoreT (PersistentBlockStateContext pv) m) where type MPV (BlobStoreT (PersistentBlockStateContext pv) m) = pv @@ -3330,7 +3331,8 @@ type PersistentState av pv r m = AccountVersionFor pv ~ av, Cache.HasCache (AccountCache av) r, Cache.HasCache Modules.ModuleCache r, - LMDBAccountMap.HasDatabaseHandlers r + LMDBAccountMap.HasDatabaseHandlers r, + MonadLogger m ) instance MonadTrans (PersistentBlockStateMonad pv r) where @@ -3343,11 +3345,7 @@ instance (PersistentState av pv r m) => MonadBlobStore (PutH (PersistentBlockSta instance (PersistentState av pv r m) => Cache.MonadCache (AccountCache av) (PersistentBlockStateMonad pv r m) instance (PersistentState av pv r m) => Cache.MonadCache Modules.ModuleCache (PersistentBlockStateMonad pv r m) -instance (PersistentState av pv r m, r ~ PersistentBlockStateContext pv) => LMDBAccountMap.MonadAccountMapStore (PersistentBlockStateMonad pv r m) where - insert bh height = undefined -- - lookup accAddr = do - accountMapHandlers <- asks pbscAccountMap - return undefined +deriving via (LMDBAccountMap.AccountMapStoreMonad m) instance (MonadIO m, MonadLogger m, MonadReader r m, LMDBAccountMap.HasDatabaseHandlers r) => LMDBAccountMap.MonadAccountMapStore (PersistentBlockStateMonad pv r m) type instance BlockStatePointer (PersistentBlockState pv) = BlobRef (BlockStatePointers pv) type instance BlockStatePointer (HashedPersistentBlockState pv) = BlobRef (BlockStatePointers pv) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs index d70c33655c..20ff4b3b9a 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs @@ -428,17 +428,17 @@ 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 lfStoredBlock) -- Get the genesis block. genStoredBlock <- maybe (logExceptionAndThrowTS GenesisBlockNotInDataBaseError) return =<< liftIO (getFirstBlock _db) - _genesisBlockPointer <- liftIO $ makeBlockPointer genStoredBlock + _genesisBlockPointer <- makeBlockPointer genStoredBlock _genesisData <- case _bpBlock _genesisBlockPointer of GenesisBlock gd' -> return gd' _ -> logExceptionAndThrowTS (DatabaseInvariantViolation "Block at height 0 is not a genesis block.") -- Get the last finalized block. - _lastFinalized <- liftIO (makeBlockPointer lfStoredBlock) + _lastFinalized <- makeBlockPointer lfStoredBlock return SkovPersistentData { _possiblyPendingTable = HM.empty, @@ -458,7 +458,7 @@ loadSkovPersistentData rp _treeStateDirectory pbsc = do .. } where - makeBlockPointer :: StoredBlock pv (TS.BlockStatePointer (PBS.PersistentBlockState pv)) -> IO (PersistentBlockPointer pv (PBS.HashedPersistentBlockState pv)) + makeBlockPointer :: StoredBlock pv (TS.BlockStatePointer (PBS.PersistentBlockState pv)) -> LogIO (PersistentBlockPointer pv (PBS.HashedPersistentBlockState pv)) makeBlockPointer StoredBlock{..} = do let stateHashM = case sbBlock of GenesisBlock{} -> Nothing @@ -466,8 +466,8 @@ loadSkovPersistentData rp _treeStateDirectory pbsc = do bstate <- runReaderT (PBS.runPersistentBlockStateMonad (loadBlockState stateHashM sbState)) pbsc makeBlockPointerFromPersistentBlock sbBlock bstate sbInfo isBlockStateCorrupted :: StoredBlock pv (TS.BlockStatePointer (PBS.PersistentBlockState pv)) -> IO Bool - isBlockStateCorrupted block = - not <$> runBlobStoreT (isValidBlobRef (sbState block)) pbsc + isBlockStateCorrupted block = undefined -- todo +-- not <$> runBlobStoreT (isValidBlobRef (sbState block)) pbsc -- | Activate the state and make it usable for use by consensus. This concretely -- means that the block state for the last finalized block is cached, and that diff --git a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs index cfe76eae9e..32a97ec164 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs @@ -269,7 +269,7 @@ deriving via LowLevel.MonadTreeStateStore (SkovV1T pv m) deriving via - (LMDBAccountMap.AccountMapStoreMonad r (InnerSkovV1T pv m)) + (LMDBAccountMap.AccountMapStoreMonad (InnerSkovV1T pv m)) instance ( IsProtocolVersion pv, MonadIO m, diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs index 3bd15d6f7f..9c6fc8f550 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs @@ -48,6 +48,8 @@ import Concordium.KonsensusV1.Types import Concordium.TimerMonad (Timeout, TimerMonad (..)) import Concordium.Types.HashableTo import Concordium.Types.Parameters hiding (getChainParameters) +import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap + -- | Context used for running the 'TestMonad'. data TestContext (pv :: ProtocolVersion) = TestContext @@ -77,6 +79,9 @@ instance Cache.HasCache Module.ModuleCache (TestContext pv) where instance HasMemoryLLDB pv (TestContext pv) where theMemoryLLDB = _tcMemoryLLDB +instance LMDBAccountMap.HasDatabaseHandlers (TestContext pv) where + databaseHandlers = databaseHandlers . _tcPersistentBlockStateContext + -- | State used for running the 'TestMonad'. data TestState pv = TestState { -- | The 'SkovData'. diff --git a/concordium-consensus/src/Concordium/Skov/MonadImplementations.hs b/concordium-consensus/src/Concordium/Skov/MonadImplementations.hs index 926560d606..6bd5d1e1a2 100644 --- a/concordium-consensus/src/Concordium/Skov/MonadImplementations.hs +++ b/concordium-consensus/src/Concordium/Skov/MonadImplementations.hs @@ -49,6 +49,7 @@ import Concordium.Skov.Monad as Skov import Concordium.Skov.Update import Concordium.TimeMonad import Concordium.TimerMonad +import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap -- | Monad that provides: IO, logging, the operation monads of global state and the SkovQueryMonad. newtype GlobalStateM pv a = GlobalStateM @@ -523,10 +524,17 @@ instance (c ~ SkovConfig pv finconfig handlerconfig, AccountVersionFor pv ~ av) instance (c ~ SkovConfig pv finconfig handlerconfig) => HasCache ModuleCache (SkovTContext h (SkovContext c)) where projectCache = projectCache . srContext + +instance (c ~ SkovConfig pv finconfig handlerconfig) => LMDBAccountMap.HasDatabaseHandlers (SkovContext c) where + databaseHandlers = undefined -- todo LMDBAccountMap.databaseHandlers . scGSContext + +instance (c ~ SkovConfig pv finconfig handlerconfig) => LMDBAccountMap.HasDatabaseHandlers (SkovTContext h (SkovContext c)) where + databaseHandlers = undefined -- todo LMDBAccountMap.databaseHandlers . srContext deriving instance ( IsProtocolVersion pv, MonadIO m, + MonadLogger m, c ~ SkovConfig pv finconfig handlerconfig ) => BlockStateQuery (SkovT pv h c m) @@ -534,6 +542,7 @@ deriving instance deriving instance ( MonadIO m, IsProtocolVersion pv, + MonadLogger m, c ~ SkovConfig pv finconfig handlerconfig ) => AccountOperations (SkovT pv h c m) @@ -541,6 +550,7 @@ deriving instance deriving instance ( MonadIO m, IsProtocolVersion pv, + MonadLogger m, c ~ SkovConfig pv finconfig handlerconfig ) => ContractStateOperations (SkovT pv h c m) @@ -548,6 +558,7 @@ deriving instance deriving instance ( MonadIO m, IsProtocolVersion pv, + MonadLogger m, c ~ SkovConfig pv finconfig handlerconfig ) => ModuleQuery (SkovT pv h c m) @@ -555,6 +566,7 @@ deriving instance deriving instance ( IsProtocolVersion pv, MonadIO m, + MonadLogger m, c ~ SkovConfig pv finconfig handlerconfig ) => BlockStateOperations (SkovT pv h c m) @@ -562,6 +574,7 @@ deriving instance deriving instance ( IsProtocolVersion pv, MonadIO m, + MonadLogger m, c ~ SkovConfig pv finconfig handlerconfig ) => BlockStateStorage (SkovT pv h c m) From 741916bc357ba6fa0190151e545ae65e8483354f Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Wed, 11 Oct 2023 16:40:40 +0200 Subject: [PATCH 12/92] Delete accounts that was created as part of certified blocks from accountmap when rolling back certified blocks. --- .../Concordium/GlobalState/AccountMap/LMDB.hs | 13 ++++++++-- .../GlobalState/Persistent/BlobStore.hs | 7 +++--- .../GlobalState/Persistent/BlockState.hs | 20 ++++++++++++---- .../KonsensusV1/Consensus/Finality.hs | 1 - .../src/Concordium/KonsensusV1/TestMonad.hs | 11 +++++---- .../KonsensusV1/TreeState/LowLevel/LMDB.hs | 24 ++++++++++++++++++- 6 files changed, 59 insertions(+), 17 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index 1654428218..842fea96ef 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -28,7 +28,7 @@ -- initialized on startup via the existing ‘PersistentAccountMap’. -- -- Invariants: --- * Only finalized accounts are present in the ‘AccountMap’ +-- * Only accounts that are in either certified or finalized blocks are present in the ‘AccountMap’ module Concordium.GlobalState.AccountMap.LMDB where import Control.Concurrent @@ -75,7 +75,7 @@ instance Exception DatabaseInvariantViolation where -- An implementation should ensure atomicity of operations. -- -- Invariants: --- * All accounts in the store are finalized. +-- * All accounts in the store are either finalized or "certified". class (Monad m) => MonadAccountMapStore m where -- | Adds accounts present in the provided difference maps to the lmdb store. -- The argument is a list as multiple blocks can be finalized at the same time. @@ -90,11 +90,17 @@ class (Monad m) => MonadAccountMapStore m where -- and returns @Nothing@ if the account was not present. lookup :: AccountAddress -> m (Maybe AccountIndex) + -- | Delete an account from the underlying lmdb store. + -- This should only be done when rolling back certified blocks. + delete :: AccountAddress -> m Bool + instance (Monad (t m), MonadTrans t, MonadAccountMapStore m) => MonadAccountMapStore (MGSTrans t m) where insert bh height = lift . insert bh height lookup = lift . lookup + delete = lift . delete {-# INLINE insert #-} {-# INLINE lookup #-} + {-# INLINE delete #-} deriving via (MGSTrans (StateT s) m) instance (MonadAccountMapStore m) => MonadAccountMapStore (StateT s m) deriving via (MGSTrans (ExceptT e) m) instance (MonadAccountMapStore m) => MonadAccountMapStore (ExceptT e m) @@ -103,6 +109,7 @@ deriving via (MGSTrans (WriterT w) m) instance (Monoid w, MonadAccountMapStore m instance (MonadAccountMapStore m) => MonadAccountMapStore (PutT m) where insert bh height = lift . insert bh height lookup = lift . lookup + delete = lift . delete -- * Database stores @@ -361,3 +368,5 @@ instance lookup accAddr = asReadTransaction $ \dbh txn -> loadRecord txn (dbh ^. accountMapStore) $ accountAddressToPrefixAccountAddress accAddr + delete accAddr = asWriteTransaction $ \dbh txn -> + deleteRecord txn (dbh ^. accountMapStore) $ accountAddressToPrefixAccountAddress accAddr diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs index 1043385db5..f7a59f7021 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs @@ -10,7 +10,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- FIXME: GHC 9.2.5 reports that `MonadBlobStore m` is a redundant constraint in a @@ -172,7 +171,7 @@ import Concordium.GlobalState.Account import Concordium.GlobalState.Basic.BlockState.PoolRewards import Concordium.GlobalState.CapitalDistribution import qualified Concordium.GlobalState.Parameters as Parameters -import Concordium.Logger (MonadLogger) +import Concordium.Logger (MonadLogger, LogIO) import Concordium.Types import Concordium.Types.Accounts import qualified Concordium.Types.AnonymityRevokers as ARS @@ -309,8 +308,8 @@ destroyBlobStore bs@BlobStore{..} = do -- The given FilePath is a directory where the temporary blob -- store will be created. -- The blob store file is deleted afterwards. -runBlobStoreTemp :: FilePath -> BlobStoreM a -> IO a -runBlobStoreTemp dir a = bracket openf closef usef +runBlobStoreTemp :: FilePath -> BlobStoreM a -> LogIO a +runBlobStoreTemp dir a = liftIO $ bracket openf closef usef where openf = openBinaryTempFile dir "blb.dat" closef (tempFP, h) = do diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 445de2e218..8fe8c9bebc 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -31,7 +31,7 @@ module Concordium.GlobalState.Persistent.BlockState ( PersistentState, BlockRewardDetails (..), PersistentBlockStateMonad (..), - withNewAccountCache, + withNewAccountCacheAndLMDBAccountMap, cacheState, cacheStateAndGetTransactionTable, migratePersistentBlockState, @@ -3315,11 +3315,15 @@ instance (IsProtocolVersion pv) => MonadProtocolVersion (BlobStoreT (PersistentB -- | Create a new account cache of the specified size for running the given monadic operation by -- extending the 'BlobStore' context to a 'PersistentBlockStateContext'. -withNewAccountCache :: (MonadIO m) => Int -> BlobStoreT (PersistentBlockStateContext pv) m a -> BlobStoreT BlobStore m a -withNewAccountCache size bsm = do +-- todo fix doc. +withNewAccountCacheAndLMDBAccountMap :: (MonadIO m) => Int -> FilePath -> BlobStoreT (PersistentBlockStateContext pv) m a -> BlobStoreT BlobStore m a +withNewAccountCacheAndLMDBAccountMap size lmdbAccountMapDir bsm = do ac <- liftIO $ newAccountCache size mc <- liftIO $ Modules.newModuleCache 100 - alterBlobStoreT (\bs -> PersistentBlockStateContext bs ac mc undefined) bsm + lmdbAccMap <- liftIO $ LMDBAccountMap.openDatabase lmdbAccountMapDir + res <- alterBlobStoreT (\bs -> PersistentBlockStateContext bs ac mc lmdbAccMap) bsm + liftIO $ LMDBAccountMap.closeDatabase lmdbAccMap + return res newtype PersistentBlockStateMonad (pv :: ProtocolVersion) (r :: Type) (m :: Type -> Type) (a :: Type) = PersistentBlockStateMonad {runPersistentBlockStateMonad :: m a} deriving (Functor, Applicative, Monad, MonadIO, MonadReader r, MonadLogger, TimeMonad, MTL.MonadState s) @@ -3560,6 +3564,14 @@ instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateStorage (!inner', !ref) <- flushBufferedRef inner liftIO $ writeIORef hpbsPointers inner' flushStore + -- todo: Write the the Account DifferenceMap to the LMDBAccountMap. + -- Note that for consensus version 1 this approach will write + -- accounts to the lmdb account map as blocks becomes certified also. + -- To support roll backs of certified blocks then, + -- accounts created in the rolled back blocks must be deleted from + -- the lmdb account map (these will be added again as the certified blocks + -- are potentially being executed once again) + -- This should be OK as roll backs happens under rare circumstances. return ref loadBlockState hpbsHashM ref = do diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs index b03d02bdf1..cd70777262 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs @@ -295,7 +295,6 @@ processFinalizationHelper newFinalizedBlock newFinalizationEntry mCertifiedBlock -- Archive the state of the last finalized block and all newly finalized blocks -- excluding the new last finalized block. mapM_ (archiveBlockState . bpState) (init (oldLastFinalized : prFinalized)) - -- TODO!: Record the accounts created in the finalized blocks in the LMDB database. -- Remove the blocks from the live block table. markLiveBlocksFinal prFinalized -- Finalize the transactions in the in-memory transaction table. diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs index 9c6fc8f550..6dd12f3789 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs @@ -80,7 +80,7 @@ instance HasMemoryLLDB pv (TestContext pv) where theMemoryLLDB = _tcMemoryLLDB instance LMDBAccountMap.HasDatabaseHandlers (TestContext pv) where - databaseHandlers = databaseHandlers . _tcPersistentBlockStateContext + databaseHandlers = undefined -- todo LMDBAccountMap.databaseHandlers . _tcPersistentBlockStateContext -- | State used for running the 'TestMonad'. data TestState pv = TestState @@ -115,7 +115,7 @@ type TestWrite pv = [TestEvent pv] -- Hence the 'PersistentBlockStateMonadHelper' transformer is using this monad -- as is the 'TestMonad' -- This makes it possible to easily derive the required instances via the 'PersistentBlockStateMonad'. -type InnerTestMonad (pv :: ProtocolVersion) = RWST (TestContext pv) (TestWrite pv) (TestState pv) IO +type InnerTestMonad (pv :: ProtocolVersion) = RWST (TestContext pv) (TestWrite pv) (TestState pv) LogIO -- | This type is used to derive instances of various block state classes for 'TestMonad'. type PersistentBlockStateMonadHelper pv = @@ -136,6 +136,7 @@ newtype TestMonad (pv :: ProtocolVersion) a = TestMonad {runTestMonad' :: (Inner (BlockStateTypes, ContractStateOperations, ModuleQuery) via (PersistentBlockStateMonadHelper pv) + makeLenses ''TestContext makeLenses ''TestState @@ -149,9 +150,9 @@ genesisCore = case protocolVersion @pv of -- | Run an operation in the 'TestMonad' with the given baker, time and genesis data. -- This sets up a temporary blob store for the block state that is deleted after use. -runTestMonad :: (IsConsensusV1 pv, IsProtocolVersion pv) => BakerContext -> UTCTime -> GenesisData pv -> TestMonad pv a -> IO a +runTestMonad :: (IsConsensusV1 pv, IsProtocolVersion pv) => BakerContext -> UTCTime -> GenesisData pv -> TestMonad pv a -> LogIO a runTestMonad _tcBakerContext _tcCurrentTime genData (TestMonad a) = - runBlobStoreTemp "." $ withNewAccountCache 1000 $ do + runBlobStoreTemp "." $ withNewAccountCacheAndLMDBAccountMap 1000 "." $ do (genState, genStateRef, initTT, genTimeoutBase, genEpochBakers) <- runPersistentBlockStateMonad $ do genesisState genData >>= \case Left e -> error e @@ -205,7 +206,7 @@ runTestMonad _tcBakerContext _tcCurrentTime genData (TestMonad a) = let ctx = TestContext{..} let _tsPendingTimers = Map.empty let st = TestState{..} - fst <$> liftIO (evalRWST a ctx st) + undefined -- todo fst <$> liftIO (evalRWST a ctx st) -- Instances that are required for the 'TestMonad'. deriving via diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs index e2173d135f..c869b60f8a 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs @@ -31,9 +31,11 @@ import Database.LMDB.Raw import Lens.Micro.Platform import System.Directory +import Concordium.ID.Types import Concordium.Common.Version import qualified Concordium.Crypto.SHA256 as Hash import Concordium.Logger +import Concordium.Types.Transactions import Concordium.Types import Concordium.Types.HashableTo @@ -41,6 +43,7 @@ import Concordium.GlobalState.LMDB.Helpers import Concordium.KonsensusV1.TreeState.LowLevel import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types +import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap -- * Exceptions @@ -480,6 +483,8 @@ newtype DiskLLDBM (pv :: ProtocolVersion) m a = DiskLLDBM {runDiskLLDBM :: m a} deriving instance (MonadReader r m) => MonadReader r (DiskLLDBM pv m) +deriving via (LMDBAccountMap.AccountMapStoreMonad m) instance (MonadLogger m, MonadIO m, MonadReader r m, LMDBAccountMap.HasDatabaseHandlers r) => LMDBAccountMap.MonadAccountMapStore (DiskLLDBM pv m) + instance (IsProtocolVersion pv) => MonadProtocolVersion (DiskLLDBM pv m) where type MPV (DiskLLDBM pv m) = pv @@ -716,6 +721,7 @@ rollBackBlocksUntil :: ( IsProtocolVersion pv, MonadReader r m, HasDatabaseHandlers r pv, + LMDBAccountMap.HasDatabaseHandlers r, MonadIO m, MonadCatch m, MonadLogger m @@ -756,6 +762,15 @@ rollBackBlocksUntil checkState = do Nothing -> return (0, bestState) Just (Left e) -> throwM . DatabaseRecoveryFailure $ e Just (Right (_, qc)) -> checkCertifiedWithQC lastFinRound bestState 0 qc + -- Delete an account in the LMDB account map store if the block item created a new account. + deleteAccountFromLMDB bi = case bi of + WithMetadata{wmdData = CredentialDeployment{biCred = AccountCreation{..}}} -> + case credential of + (InitialACWP InitialCredentialDeploymentInfo{..}) -> + LMDBAccountMap.delete $ initialCredentialAccountAddress icdiValues + (NormalACWP CredentialDeploymentInformation{..}) -> + LMDBAccountMap.delete $ credentialAccountAddress cdiValues + _ -> return True -- Given the round and QC for a certified block, check that the block's state can be -- loaded, and then iterate for the previous round. checkCertifiedWithQC :: @@ -786,6 +801,11 @@ rollBackBlocksUntil checkState = do count (qcRound qc - 1) else do + -- delete any accounts created in this block in the LMDB account map. + forM_ (blockTransactions block) $ \bi -> do + deleted <- deleteAccountFromLMDB bi + unless deleted $ + throwM . DatabaseInvariantViolation $ "Account for deletion not present in LMDB account map" -- Delete the block and the QC asWriteTransaction $ \dbh txn -> do void $ @@ -846,6 +866,7 @@ rollBackBlocksUntil checkState = do return count -- Roll back finalized blocks until the last explicitly finalized block where the state -- check passes. + -- Note, that we do not need to delete accounts in the LMDB account map as rollFinalized count lastFin = do when (blockRound lastFin == 0) $ throwM . DatabaseRecoveryFailure $ @@ -879,7 +900,8 @@ rollBackBlocksUntil checkState = do let finHash = getHash fin _ <- deleteRecord txn (dbh ^. blockStore) finHash _ <- deleteRecord txn (dbh ^. finalizedBlockIndex) (blockHeight fin) - forM_ (blockTransactions fin) $ + + forM_ (blockTransactions fin) $ deleteRecord txn (dbh ^. transactionStatusStore) . getHash mparent <- loadRecord txn (dbh ^. blockStore) (blockParent block) case mparent of From ed1d714fdcb2bb408c6b35aca6e537c40e7985a4 Mon Sep 17 00:00:00 2001 From: Thomas Dinsdale-Young Date: Thu, 12 Oct 2023 12:44:28 +0200 Subject: [PATCH 13/92] TestMonad. --- .../GlobalState/Persistent/BlobStore.hs | 34 +++++++++++-------- .../GlobalState/Persistent/BlockState.hs | 1 + .../src/Concordium/KonsensusV1/SkovMonad.hs | 8 ++--- .../src/Concordium/KonsensusV1/TestMonad.hs | 29 +++++++--------- 4 files changed, 37 insertions(+), 35 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs index f7a59f7021..b928a7f3ed 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs @@ -171,7 +171,7 @@ import Concordium.GlobalState.Account import Concordium.GlobalState.Basic.BlockState.PoolRewards import Concordium.GlobalState.CapitalDistribution import qualified Concordium.GlobalState.Parameters as Parameters -import Concordium.Logger (MonadLogger, LogIO) +import Concordium.Logger (LogIO, MonadLogger) import Concordium.Types import Concordium.Types.Accounts import qualified Concordium.Types.AnonymityRevokers as ARS @@ -308,24 +308,30 @@ destroyBlobStore bs@BlobStore{..} = do -- The given FilePath is a directory where the temporary blob -- store will be created. -- The blob store file is deleted afterwards. -runBlobStoreTemp :: FilePath -> BlobStoreM a -> LogIO a -runBlobStoreTemp dir a = liftIO $ bracket openf closef usef +runBlobStoreTemp :: forall m a. (MonadIO m, MonadCatch.MonadMask m) => FilePath -> BlobStoreT BlobStore m a -> m a +runBlobStoreTemp dir a = MonadCatch.bracket openf closef usef where - openf = openBinaryTempFile dir "blb.dat" - closef (tempFP, h) = do + openf = liftIO $ openBinaryTempFile dir "blb.dat" + closef (tempFP, h) = liftIO $ do hClose h performGC removeFile tempFP `catch` (\(_ :: IOException) -> return ()) + usef :: (FilePath, Handle) -> m a usef (fp, h) = do - mv <- newMVar (BlobHandle h True 0) - mmap <- newIORef BS.empty - let bscBlobStore = BlobStoreAccess mv fp mmap - (bscLoadCallback, bscStoreCallback) <- mkCallbacksFromBlobStore bscBlobStore - res <- runBlobStoreM a BlobStore{..} - _ <- takeMVar mv - writeIORef mmap BS.empty - freeCallbacks bscLoadCallback bscStoreCallback - return res + bs <- liftIO $ do + mv <- newMVar (BlobHandle h True 0) + mmap <- newIORef BS.empty + let bscBlobStore = BlobStoreAccess mv fp mmap + (bscLoadCallback, bscStoreCallback) <- mkCallbacksFromBlobStore bscBlobStore + return BlobStore{..} + res <- runBlobStoreT a bs + liftIO $ do + let BlobStore{..} = bs + BlobStoreAccess mv _ mmap = bscBlobStore + _ <- takeMVar mv + writeIORef mmap BS.empty + freeCallbacks bscLoadCallback bscStoreCallback + return res -- | Truncate the blob store after the blob stored at the given offset. The blob should not be -- corrupted (i.e., its size header should be readable, and its size should match the size header). diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 8fe8c9bebc..b2166645a1 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -3294,6 +3294,7 @@ data PersistentBlockStateContext pv = PersistentBlockStateContext -- | LMDB account map _pbscAccountMap :: !LMDBAccountMap.DatabaseHandlers } + makeLenses ''PersistentBlockStateContext instance LMDBAccountMap.HasDatabaseHandlers (PersistentBlockStateContext pv) where diff --git a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs index 32a97ec164..df758f0f6a 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs @@ -481,9 +481,9 @@ initialiseExistingSkovV1 bakerCtx handlerCtx unliftSkov GlobalStateConfig{..} = existingDB <- checkExistingDatabase gscTreeStateDirectory gscBlockStateFile gscAccountMapDirectory if existingDB then do - pbscAccountCache <- liftIO $ newAccountCache (rpAccountsCacheSize gscRuntimeParameters) - pbscModuleCache <- liftIO $ Modules.newModuleCache (rpModulesCacheSize gscRuntimeParameters) - pbscBlobStore <- liftIO $ loadBlobStore gscBlockStateFile + _pbscAccountCache <- liftIO $ newAccountCache (rpAccountsCacheSize gscRuntimeParameters) + _pbscModuleCache <- liftIO $ Modules.newModuleCache (rpModulesCacheSize gscRuntimeParameters) + _pbscBlobStore <- liftIO $ loadBlobStore gscBlockStateFile let pbsc = PersistentBlockStateContext{..} let initWithLLDB lldb = do checkDatabaseVersion lldb @@ -497,7 +497,7 @@ initialiseExistingSkovV1 bakerCtx handlerCtx unliftSkov GlobalStateConfig{..} = "Could not load state for " ++ show rollCount ++ " blocks. Truncating block state database." - liftIO $ truncateBlobStore (bscBlobStore . PBS.pbscBlobStore $ pbsc) bestState + liftIO $ truncateBlobStore (bscBlobStore . PBS._pbscBlobStore $ pbsc) bestState let initContext = InitContext pbsc lldb (initialSkovData, effectiveProtocolUpdate) <- runInitMonad diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs index 6dd12f3789..c2cd38ef09 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs @@ -25,6 +25,7 @@ import Concordium.Types import qualified Concordium.Genesis.Data.BaseV1 as BaseV1 import qualified Concordium.Genesis.Data.P6 as P6 +import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import Concordium.GlobalState.BlockState import Concordium.GlobalState.Parameters ( GenesisData (GDP6), @@ -48,8 +49,6 @@ import Concordium.KonsensusV1.Types import Concordium.TimerMonad (Timeout, TimerMonad (..)) import Concordium.Types.HashableTo import Concordium.Types.Parameters hiding (getChainParameters) -import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap - -- | Context used for running the 'TestMonad'. data TestContext (pv :: ProtocolVersion) = TestContext @@ -60,9 +59,7 @@ data TestContext (pv :: ProtocolVersion) = TestContext -- | In-memory low-level tree state database. _tcMemoryLLDB :: !(IORef (LowLevelDB pv)), -- | The current time (reported by 'currentTime'). - _tcCurrentTime :: !UTCTime, - -- | Callback to use for logging. - _tcLogger :: !(LogMethod (TestMonad pv)) + _tcCurrentTime :: !UTCTime } instance HasBlobStore (TestContext pv) where @@ -80,7 +77,9 @@ instance HasMemoryLLDB pv (TestContext pv) where theMemoryLLDB = _tcMemoryLLDB instance LMDBAccountMap.HasDatabaseHandlers (TestContext pv) where - databaseHandlers = undefined -- todo LMDBAccountMap.databaseHandlers . _tcPersistentBlockStateContext + databaseHandlers = + lens _tcPersistentBlockStateContext (\s v -> s{_tcPersistentBlockStateContext = v}) + . LMDBAccountMap.databaseHandlers -- | State used for running the 'TestMonad'. data TestState pv = TestState @@ -131,12 +130,11 @@ type PersistentBlockStateMonadHelper pv = -- 'MonadConsensusEvent'. -- The state is 'TestState', which includes the 'SkovData' and a map of the pending timer events. newtype TestMonad (pv :: ProtocolVersion) a = TestMonad {runTestMonad' :: (InnerTestMonad pv) a} - deriving newtype (Functor, Applicative, Monad, MonadReader (TestContext pv), MonadIO, MonadThrow, MonadWriter (TestWrite pv)) + deriving newtype (Functor, Applicative, Monad, MonadReader (TestContext pv), MonadIO, MonadThrow, MonadWriter (TestWrite pv), MonadLogger) deriving (BlockStateTypes, ContractStateOperations, ModuleQuery) via (PersistentBlockStateMonadHelper pv) - makeLenses ''TestContext makeLenses ''TestState @@ -150,9 +148,9 @@ genesisCore = case protocolVersion @pv of -- | Run an operation in the 'TestMonad' with the given baker, time and genesis data. -- This sets up a temporary blob store for the block state that is deleted after use. -runTestMonad :: (IsConsensusV1 pv, IsProtocolVersion pv) => BakerContext -> UTCTime -> GenesisData pv -> TestMonad pv a -> LogIO a +runTestMonad :: (IsConsensusV1 pv, IsProtocolVersion pv) => BakerContext -> UTCTime -> GenesisData pv -> TestMonad pv a -> IO a runTestMonad _tcBakerContext _tcCurrentTime genData (TestMonad a) = - runBlobStoreTemp "." $ withNewAccountCacheAndLMDBAccountMap 1000 "." $ do + runLog $ runBlobStoreTemp "." $ withNewAccountCacheAndLMDBAccountMap 1000 "." $ do (genState, genStateRef, initTT, genTimeoutBase, genEpochBakers) <- runPersistentBlockStateMonad $ do genesisState genData >>= \case Left e -> error e @@ -202,11 +200,13 @@ runTestMonad _tcBakerContext _tcCurrentTime genData (TestMonad a) = liftIO . newIORef $! initialLowLevelDB genStoredBlock (_tsSkovData ^. persistentRoundStatus) _tcPersistentBlockStateContext <- ask - let _tcLogger src lvl msg = liftIO $ putStrLn $ "[" ++ show lvl ++ "] " ++ show src ++ ": " ++ msg let ctx = TestContext{..} let _tsPendingTimers = Map.empty let st = TestState{..} - undefined -- todo fst <$> liftIO (evalRWST a ctx st) + fst <$> lift (evalRWST a ctx st) + where + logger src lvl msg = putStrLn $ "[" ++ show lvl ++ "] " ++ show src ++ ": " ++ msg + runLog = flip runLoggerT logger -- Instances that are required for the 'TestMonad'. deriving via @@ -270,11 +270,6 @@ instance MonadConsensusEvent (TestMonad pv) where onBlock = tell . (: []) . OnBlock . bpBlock onFinalize fe _ = tell [OnFinalize fe] -instance MonadLogger (TestMonad pv) where - logEvent src lvl msg = do - logger <- view tcLogger - logger src lvl msg - -- | Get the currently-pending timers. getPendingTimers :: TestMonad pv (Map.Map Integer (Timeout, TestMonad pv ())) getPendingTimers = TestMonad (gets _tsPendingTimers) From 488e741f8a90a6c11e8689cac51c0147eabdecc7 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Thu, 12 Oct 2023 15:53:22 +0200 Subject: [PATCH 14/92] Cleanup. --- .../src/Concordium/GlobalState.hs | 32 +++---- .../GlobalState/Persistent/BlobStore.hs | 2 +- .../GlobalState/Persistent/BlockState.hs | 22 +++-- .../GlobalState/Persistent/TreeState.hs | 6 +- .../KonsensusV1/Consensus/Finality.hs | 1 - .../src/Concordium/KonsensusV1/SkovMonad.hs | 84 ++++++++++++------- .../KonsensusV1/TreeState/LowLevel/LMDB.hs | 4 +- .../Concordium/Skov/MonadImplementations.hs | 4 +- 8 files changed, 88 insertions(+), 67 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState.hs b/concordium-consensus/src/Concordium/GlobalState.hs index 97d617c93b..e49263a588 100644 --- a/concordium-consensus/src/Concordium/GlobalState.hs +++ b/concordium-consensus/src/Concordium/GlobalState.hs @@ -72,14 +72,14 @@ initialiseExistingGlobalState _ GlobalStateConfig{..} = do then do logm <- ask liftIO $ do - _pbscAccountCache <- newAccountCache (rpAccountsCacheSize dtdbRuntimeParameters) - _pbscModuleCache <- Modules.newModuleCache (rpModulesCacheSize dtdbRuntimeParameters) - _pbscBlobStore <- loadBlobStore dtdbBlockStateFile - _pbscAccountMap <- liftIO $ LMDBAccountMap.openDatabase dtdAccountMapDirectory + pbscAccountCache <- newAccountCache (rpAccountsCacheSize dtdbRuntimeParameters) + pbscModuleCache <- Modules.newModuleCache (rpModulesCacheSize dtdbRuntimeParameters) + pbscBlobStore <- loadBlobStore dtdbBlockStateFile + pbscAccountMap <- liftIO $ LMDBAccountMap.openDatabase dtdAccountMapDirectory let pbsc = PersistentBlockStateContext{..} skovData <- runLoggerT (loadSkovPersistentData dtdbRuntimeParameters dtdbTreeStateDirectory pbsc) logm - `onException` closeBlobStore _pbscBlobStore + `onException` closeBlobStore pbscBlobStore return (Just (pbsc, skovData)) else return Nothing @@ -113,10 +113,10 @@ migrateExistingState :: -- | The return value is the context and state for the new chain. LogIO (GSContext pv, GSState pv) migrateExistingState GlobalStateConfig{..} oldPbsc oldState migration genData = do - _pbscBlobStore <- liftIO $ createBlobStore dtdbBlockStateFile - _pbscAccountCache <- liftIO $ newAccountCache (rpAccountsCacheSize dtdbRuntimeParameters) - _pbscModuleCache <- liftIO $ Modules.newModuleCache (rpModulesCacheSize dtdbRuntimeParameters) - _pbscAccountMap <- liftIO $ LMDBAccountMap.openDatabase dtdAccountMapDirectory + pbscBlobStore <- liftIO $ createBlobStore dtdbBlockStateFile + pbscAccountCache <- liftIO $ newAccountCache (rpAccountsCacheSize dtdbRuntimeParameters) + pbscModuleCache <- liftIO $ Modules.newModuleCache (rpModulesCacheSize dtdbRuntimeParameters) + pbscAccountMap <- liftIO $ LMDBAccountMap.openDatabase dtdAccountMapDirectory let pbsc = PersistentBlockStateContext{..} newInitialBlockState <- flip runBlobStoreT oldPbsc . flip runBlobStoreT pbsc $ do case _nextGenesisInitialState oldState of @@ -136,7 +136,7 @@ migrateExistingState GlobalStateConfig{..} oldPbsc oldState migration genData = (Just (_pendingTransactions oldState)) isd <- runReaderT (LMDBAccountMap.runAccountMapStoreMonad (runPersistentBlockStateMonad initGS)) pbsc - `onException` liftIO (destroyBlobStore _pbscBlobStore) + `onException` liftIO (destroyBlobStore pbscBlobStore) return (pbsc, isd) -- | Initialise new global state with the given genesis. If the state already @@ -144,10 +144,10 @@ migrateExistingState GlobalStateConfig{..} oldPbsc oldState migration genData = -- on the generated state, as this will establish the necessary invariants. initialiseNewGlobalState :: (IsProtocolVersion pv, IsConsensusV0 pv) => GenesisData pv -> GlobalStateConfig -> LogIO (GSContext pv, GSState pv) initialiseNewGlobalState genData GlobalStateConfig{..} = do - _pbscBlobStore <- liftIO $ createBlobStore dtdbBlockStateFile - _pbscAccountCache <- liftIO $ newAccountCache (rpAccountsCacheSize dtdbRuntimeParameters) - _pbscModuleCache <- liftIO $ Modules.newModuleCache (rpModulesCacheSize dtdbRuntimeParameters) - _pbscAccountMap <- liftIO $ LMDBAccountMap.openDatabase dtdAccountMapDirectory + pbscBlobStore <- liftIO $ createBlobStore dtdbBlockStateFile + pbscAccountCache <- liftIO $ newAccountCache (rpAccountsCacheSize dtdbRuntimeParameters) + pbscModuleCache <- liftIO $ Modules.newModuleCache (rpModulesCacheSize dtdbRuntimeParameters) + pbscAccountMap <- liftIO $ LMDBAccountMap.openDatabase dtdAccountMapDirectory let pbsc = PersistentBlockStateContext{..} let initGS = do logEvent GlobalState LLTrace "Creating persistent global state" @@ -161,7 +161,7 @@ initialiseNewGlobalState genData GlobalStateConfig{..} = do initialSkovPersistentData dtdbRuntimeParameters dtdbTreeStateDirectory (genesisConfiguration genData) pbs ser genTT Nothing isd <- runReaderT (LMDBAccountMap.runAccountMapStoreMonad (runPersistentBlockStateMonad initGS)) pbsc - `onException` liftIO (destroyBlobStore _pbscBlobStore) + `onException` liftIO (destroyBlobStore pbscBlobStore) return (pbsc, isd) -- | Either initialise an existing state, or if it does not exist, initialise a new one with the given genesis. @@ -179,5 +179,5 @@ activateGlobalState _ = activateSkovPersistentData -- | Shutdown the global state. shutdownGlobalState :: SProtocolVersion pv -> GSContext pv -> GSState pv -> IO () shutdownGlobalState _ PersistentBlockStateContext{..} st = do - closeBlobStore _pbscBlobStore + closeBlobStore pbscBlobStore closeSkovPersistentData st diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs index b928a7f3ed..6bfd6ab8e5 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs @@ -171,7 +171,7 @@ import Concordium.GlobalState.Account import Concordium.GlobalState.Basic.BlockState.PoolRewards import Concordium.GlobalState.CapitalDistribution import qualified Concordium.GlobalState.Parameters as Parameters -import Concordium.Logger (LogIO, MonadLogger) +import Concordium.Logger (MonadLogger) import Concordium.Types import Concordium.Types.Accounts import qualified Concordium.Types.AnonymityRevokers as ARS diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index b2166645a1..e0ba935c98 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -3286,30 +3286,28 @@ doSetRewardAccounts pbs rewards = do -- | Context that supports the persistent block state. data PersistentBlockStateContext pv = PersistentBlockStateContext { -- | The 'BlobStore' used for storing the persistent state. - _pbscBlobStore :: !BlobStore, + pbscBlobStore :: !BlobStore, -- | Cache used for caching accounts. - _pbscAccountCache :: !(AccountCache (AccountVersionFor pv)), + pbscAccountCache :: !(AccountCache (AccountVersionFor pv)), -- | Cache used for caching modules. - _pbscModuleCache :: !Modules.ModuleCache, + pbscModuleCache :: !Modules.ModuleCache, -- | LMDB account map - _pbscAccountMap :: !LMDBAccountMap.DatabaseHandlers + pbscAccountMap :: !LMDBAccountMap.DatabaseHandlers } -makeLenses ''PersistentBlockStateContext - instance LMDBAccountMap.HasDatabaseHandlers (PersistentBlockStateContext pv) where - databaseHandlers = pbscAccountMap + databaseHandlers = lens pbscAccountMap (\s v -> s{pbscAccountMap = v}) instance HasBlobStore (PersistentBlockStateContext av) where - blobStore = bscBlobStore . _pbscBlobStore - blobLoadCallback = bscLoadCallback . _pbscBlobStore - blobStoreCallback = bscStoreCallback . _pbscBlobStore + blobStore = bscBlobStore . pbscBlobStore + blobLoadCallback = bscLoadCallback . pbscBlobStore + blobStoreCallback = bscStoreCallback . pbscBlobStore instance (AccountVersionFor pv ~ av) => Cache.HasCache (AccountCache av) (PersistentBlockStateContext pv) where - projectCache = _pbscAccountCache + projectCache = pbscAccountCache instance Cache.HasCache Modules.ModuleCache (PersistentBlockStateContext pv) where - projectCache = _pbscModuleCache + projectCache = pbscModuleCache instance (IsProtocolVersion pv) => MonadProtocolVersion (BlobStoreT (PersistentBlockStateContext pv) m) where type MPV (BlobStoreT (PersistentBlockStateContext pv) m) = pv diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs index 20ff4b3b9a..3c3bb060b7 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs @@ -428,7 +428,7 @@ 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 lfStoredBlock) -- Get the genesis block. genStoredBlock <- maybe (logExceptionAndThrowTS GenesisBlockNotInDataBaseError) return @@ -466,8 +466,8 @@ loadSkovPersistentData rp _treeStateDirectory pbsc = do bstate <- runReaderT (PBS.runPersistentBlockStateMonad (loadBlockState stateHashM sbState)) pbsc makeBlockPointerFromPersistentBlock sbBlock bstate sbInfo isBlockStateCorrupted :: StoredBlock pv (TS.BlockStatePointer (PBS.PersistentBlockState pv)) -> IO Bool - isBlockStateCorrupted block = undefined -- todo --- not <$> runBlobStoreT (isValidBlobRef (sbState block)) pbsc + isBlockStateCorrupted block = + not <$> runBlobStoreT (isValidBlobRef (sbState block)) pbsc -- | Activate the state and make it usable for use by consensus. This concretely -- means that the block state for the last finalized block is cached, and that diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs index cd70777262..b80c07c056 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs @@ -22,7 +22,6 @@ import Concordium.Types.SeedState import Concordium.Utils import Concordium.Genesis.Data.BaseV1 -import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import Concordium.GlobalState.BlockState import qualified Concordium.GlobalState.Persistent.BlockState as PBS import Concordium.GlobalState.Statistics diff --git a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs index df758f0f6a..63dc3b7c39 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs @@ -73,8 +73,8 @@ type PersistentBlockStateMonadHelper pv m = -- -- * @MonadReader (SkovV1Context pv m)@, where the 'SkovV1Context' implements 'HasBlobStore', -- @'Cache.HasCache' ('AccountCache' (AccountVersionFor pv))@, --- @'Cache.HasCache' 'Modules.ModuleCache'@, 'HasHandlerContext', 'HasBakerContext', and --- 'HasDatabaseHandlers'. +-- @'Cache.HasCache' 'Modules.ModuleCache'@, 'HasHandlerContext', 'HasBakerContext', +-- 'HasDatabaseHandlers' and 'LMDBAccountMap.HasDatabaseHandlers. -- -- * @MonadState ('SkovData' pv)@. -- @@ -170,8 +170,6 @@ data SkovV1Context (pv :: ProtocolVersion) m = SkovV1Context _vcPersistentBlockStateContext :: !(PersistentBlockStateContext pv), -- | low-level tree state database. _vcDisk :: !(DatabaseHandlers pv), - -- | Persistent account map - _vcAccountMap :: !LMDBAccountMap.DatabaseHandlers, -- | Handler functions. _vcHandlers :: !(HandlerContext pv m), -- | A function for unlifting @'SkovV1T' pv m@ into the 'IO' monad. @@ -190,6 +188,9 @@ instance (AccountVersionFor pv ~ av) => Cache.HasCache (AccountCache av) (SkovV1 instance Cache.HasCache Modules.ModuleCache (SkovV1Context pv m) where projectCache = Cache.projectCache . _vcPersistentBlockStateContext +instance LMDBAccountMap.HasDatabaseHandlers (SkovV1Context pv m) where + databaseHandlers = lens _vcPersistentBlockStateContext (\s v -> s{_vcPersistentBlockStateContext = v}) . LMDBAccountMap.databaseHandlers + -- Note, these template haskell splices go here because of staging restrictions. -- '_skovV1TUnliftIO' creates a cyclic dependency between 'SkovV1Context' and 'SkovV1T'. -- The above instances are required by deriving via instances attached to the 'SkovV1T' definition. @@ -206,9 +207,6 @@ instance HasBakerContext (SkovV1Context pv m) where instance HasDatabaseHandlers (SkovV1Context pv m) pv where databaseHandlers = vcDisk -instance LMDBAccountMap.HasDatabaseHandlers (SkovV1Context pv m) where - databaseHandlers = vcAccountMap - instance (MonadTrans (SkovV1T pv)) where lift = SkovV1T . lift @@ -236,27 +234,27 @@ instance (Monad m) => MonadState (SkovData pv) (SkovV1T pv m) where deriving via (PersistentBlockStateMonadHelper pv m) instance - (IsProtocolVersion pv) => MonadProtocolVersion (SkovV1T pv m) + (IsProtocolVersion pv, MonadLogger m) => MonadProtocolVersion (SkovV1T pv m) deriving via (PersistentBlockStateMonadHelper pv m) instance - (IsProtocolVersion pv, MonadIO m) => AccountOperations (SkovV1T pv m) + (IsProtocolVersion pv, MonadIO m, MonadLogger m) => AccountOperations (SkovV1T pv m) deriving via (PersistentBlockStateMonadHelper pv m) instance - (IsProtocolVersion pv, MonadIO m) => BlockStateQuery (SkovV1T pv m) + (IsProtocolVersion pv, MonadIO m, MonadLogger m) => BlockStateQuery (SkovV1T pv m) deriving via (PersistentBlockStateMonadHelper pv m) instance - (IsProtocolVersion pv, MonadIO m) => BlockStateOperations (SkovV1T pv m) + (IsProtocolVersion pv, MonadIO m, MonadLogger m) => BlockStateOperations (SkovV1T pv m) deriving via (PersistentBlockStateMonadHelper pv m) instance - (IsProtocolVersion pv, MonadIO m) => BlockStateStorage (SkovV1T pv m) + (IsProtocolVersion pv, MonadIO m, MonadLogger m) => BlockStateStorage (SkovV1T pv m) deriving via (DiskLLDBM pv (InnerSkovV1T pv m)) @@ -353,7 +351,7 @@ data GlobalStateConfig = GlobalStateConfig data InitContext pv = InitContext { -- | Blob store and caches used by the block state storage. _icPersistentBlockStateContext :: !(PersistentBlockStateContext pv), - -- | In-memory low-level tree state database. + -- | low-level tree state database. _icDatabaseHandlers :: !(DatabaseHandlers pv) } @@ -373,6 +371,9 @@ instance Cache.HasCache Modules.ModuleCache (InitContext pv) where instance HasDatabaseHandlers (InitContext pv) pv where databaseHandlers = icDatabaseHandlers +instance LMDBAccountMap.HasDatabaseHandlers (InitContext pv) where + databaseHandlers = icPersistentBlockStateContext . LMDBAccountMap.databaseHandlers + -- | Inner type of 'InitMonad'. type InnerInitMonad pv = ReaderT (InitContext pv) LogIO @@ -411,7 +412,8 @@ newtype InitMonad pv a = InitMonad {runInitMonad' :: InnerInitMonad pv a} ContractStateOperations, ModuleQuery, MonadBlobStore, - Cache.MonadCache Modules.ModuleCache + Cache.MonadCache Modules.ModuleCache, + LMDBAccountMap.MonadAccountMapStore ) via (PersistentBlockStateMonad pv (InitContext pv) (InnerInitMonad pv)) @@ -464,6 +466,22 @@ data ExistingSkov pv m = ExistingSkov esProtocolUpdate :: !(Maybe ProtocolUpdate) } +-- | Internal type used for deriving 'HasDatabaseHandlers' and 'LMDBAccountMap.HasDatabaseHandlers' +-- used for computations where both lmdb databases are required. +data LMDBDatabases pv = LMDBDatabases + { -- | the skov lmdb database + _lmdbSkovLmdb :: !(DatabaseHandlers pv), + -- | the account map lmdb database + _lmdbDSAccMap :: !LMDBAccountMap.DatabaseHandlers + } +makeLenses ''LMDBDatabases + +instance HasDatabaseHandlers (LMDBDatabases pv) pv where + databaseHandlers = lmdbSkovLmdb + +instance LMDBAccountMap.HasDatabaseHandlers (LMDBDatabases pv) where + databaseHandlers = lmdbDSAccMap + -- | Load an existing SkovV1 state. -- Returns 'Nothing' if there is no database to load. -- May throw a 'TreeStateInvariantViolation' if a database invariant violation occurs when @@ -481,24 +499,25 @@ initialiseExistingSkovV1 bakerCtx handlerCtx unliftSkov GlobalStateConfig{..} = existingDB <- checkExistingDatabase gscTreeStateDirectory gscBlockStateFile gscAccountMapDirectory if existingDB then do - _pbscAccountCache <- liftIO $ newAccountCache (rpAccountsCacheSize gscRuntimeParameters) - _pbscModuleCache <- liftIO $ Modules.newModuleCache (rpModulesCacheSize gscRuntimeParameters) - _pbscBlobStore <- liftIO $ loadBlobStore gscBlockStateFile - let pbsc = PersistentBlockStateContext{..} - let initWithLLDB lldb = do - checkDatabaseVersion lldb + pbsc <- liftIO $ do + pbscAccountCache <- newAccountCache (rpAccountsCacheSize gscRuntimeParameters) + pbscModuleCache <- Modules.newModuleCache (rpModulesCacheSize gscRuntimeParameters) + pbscBlobStore <- loadBlobStore gscBlockStateFile + pbscAccountMap <- LMDBAccountMap.openDatabase gscAccountMapDirectory + return PersistentBlockStateContext{..} + let initWithLLDB skovLldb = do + checkDatabaseVersion skovLldb let checkBlockState bs = runBlobStoreT (isValidBlobRef bs) pbsc (rollCount, bestState) <- - runReaderT - (runDiskLLDBM $ rollBackBlocksUntil checkBlockState) - lldb + flip runReaderT (LMDBDatabases skovLldb $ pbscAccountMap pbsc) $ + (LMDBAccountMap.runAccountMapStoreMonad . runDiskLLDBM) (rollBackBlocksUntil checkBlockState) when (rollCount > 0) $ do logEvent Skov LLWarning $ "Could not load state for " ++ show rollCount ++ " blocks. Truncating block state database." - liftIO $ truncateBlobStore (bscBlobStore . PBS._pbscBlobStore $ pbsc) bestState - let initContext = InitContext pbsc lldb + liftIO $ truncateBlobStore (bscBlobStore . PBS.pbscBlobStore $ pbsc) bestState + let initContext = InitContext pbsc skovLldb (initialSkovData, effectiveProtocolUpdate) <- runInitMonad (loadSkovData gscRuntimeParameters (rollCount > 0)) @@ -509,8 +528,7 @@ initialiseExistingSkovV1 bakerCtx handlerCtx unliftSkov GlobalStateConfig{..} = SkovV1Context { _vcBakerContext = bakerCtx, _vcPersistentBlockStateContext = pbsc, - _vcDisk = lldb, - _vcAccountMap = undefined, -- TODO: Fill in + _vcDisk = skovLldb, _vcHandlers = handlerCtx, _skovV1TUnliftIO = unliftSkov }, @@ -529,7 +547,7 @@ initialiseExistingSkovV1 bakerCtx handlerCtx unliftSkov GlobalStateConfig{..} = let initWithBlockState = do (lldb :: DatabaseHandlers pv) <- liftIO $ openDatabase gscTreeStateDirectory initWithLLDB lldb `onException` liftIO (closeDatabase lldb) - initWithBlockState `onException` liftIO (closeBlobStore pbscBlobStore) + initWithBlockState `onException` liftIO (closeBlobStore $ pbscBlobStore pbsc) else do logEvent Skov LLDebug "No existing global state." return Nothing @@ -680,9 +698,12 @@ migrateSkovV1 :: migrateSkovV1 regenesis migration gsConfig@GlobalStateConfig{..} oldPbsc oldBlockState bakerCtx handlerCtx unliftSkov migrateTT migratePTT = do pbsc@PersistentBlockStateContext{..} <- newPersistentBlockStateContext gsConfig logEvent GlobalState LLDebug "Migrating existing global state." - newInitialBlockState <- flip runBlobStoreT oldPbsc . flip runBlobStoreT pbsc $ do - newState <- migratePersistentBlockState migration $ hpbsPointers oldBlockState - hashBlockState newState + newInitialBlockState <- + flip runBlobStoreT oldPbsc . flip runBlobStoreT pbsc . + flip runReaderT (flip LMDBAccountMap.runAccountMapStoreMonad oldPbsc) . + flip runReaderT (flip LMDBAccountMap.runAccountMapStoreMonad pbsc) $ do + newState <- migratePersistentBlockState migration $ hpbsPointers oldBlockState + hashBlockState newState let initGS :: InitMonad pv (SkovData pv) initGS = do @@ -738,4 +759,5 @@ newPersistentBlockStateContext GlobalStateConfig{..} = liftIO $ do pbscBlobStore <- createBlobStore gscBlockStateFile pbscAccountCache <- newAccountCache $ rpAccountsCacheSize gscRuntimeParameters pbscModuleCache <- Modules.newModuleCache $ rpModulesCacheSize gscRuntimeParameters + pbscAccountMap <- LMDBAccountMap.openDatabase gscAccountMapDirectory return PersistentBlockStateContext{..} diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs index c869b60f8a..6048b90470 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs @@ -483,7 +483,9 @@ newtype DiskLLDBM (pv :: ProtocolVersion) m a = DiskLLDBM {runDiskLLDBM :: m a} deriving instance (MonadReader r m) => MonadReader r (DiskLLDBM pv m) -deriving via (LMDBAccountMap.AccountMapStoreMonad m) instance (MonadLogger m, MonadIO m, MonadReader r m, LMDBAccountMap.HasDatabaseHandlers r) => LMDBAccountMap.MonadAccountMapStore (DiskLLDBM pv m) +deriving via (LMDBAccountMap.AccountMapStoreMonad m) + instance (MonadLogger m, MonadIO m, MonadReader r m, LMDBAccountMap.HasDatabaseHandlers r) + => LMDBAccountMap.MonadAccountMapStore (DiskLLDBM pv m) instance (IsProtocolVersion pv) => MonadProtocolVersion (DiskLLDBM pv m) where type MPV (DiskLLDBM pv m) = pv diff --git a/concordium-consensus/src/Concordium/Skov/MonadImplementations.hs b/concordium-consensus/src/Concordium/Skov/MonadImplementations.hs index 6bd5d1e1a2..4e8e9e3dc2 100644 --- a/concordium-consensus/src/Concordium/Skov/MonadImplementations.hs +++ b/concordium-consensus/src/Concordium/Skov/MonadImplementations.hs @@ -526,10 +526,10 @@ instance (c ~ SkovConfig pv finconfig handlerconfig) => HasCache ModuleCache (Sk projectCache = projectCache . srContext instance (c ~ SkovConfig pv finconfig handlerconfig) => LMDBAccountMap.HasDatabaseHandlers (SkovContext c) where - databaseHandlers = undefined -- todo LMDBAccountMap.databaseHandlers . scGSContext + databaseHandlers = lens scGSContext (\s v -> s{scGSContext = v}) . LMDBAccountMap.databaseHandlers instance (c ~ SkovConfig pv finconfig handlerconfig) => LMDBAccountMap.HasDatabaseHandlers (SkovTContext h (SkovContext c)) where - databaseHandlers = undefined -- todo LMDBAccountMap.databaseHandlers . srContext + databaseHandlers = lens srContext (\s v -> s{srContext = v}) . LMDBAccountMap.databaseHandlers deriving instance ( IsProtocolVersion pv, From 7651ca526505bc2d17390ffb97486d150f3f81b1 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Fri, 13 Oct 2023 13:36:12 +0200 Subject: [PATCH 15/92] Cleanup some stuff. --- .../src/Concordium/GlobalState.hs | 21 ++++++++++--------- .../GlobalState/Persistent/BlobStore.hs | 12 ++++++++++- .../GlobalState/Persistent/BlockState.hs | 20 ++++++++++-------- .../GlobalState/Persistent/TreeState.hs | 8 +++---- .../src/Concordium/KonsensusV1/SkovMonad.hs | 20 +++++++++--------- 5 files changed, 47 insertions(+), 34 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState.hs b/concordium-consensus/src/Concordium/GlobalState.hs index e49263a588..24cbec37c3 100644 --- a/concordium-consensus/src/Concordium/GlobalState.hs +++ b/concordium-consensus/src/Concordium/GlobalState.hs @@ -113,17 +113,18 @@ migrateExistingState :: -- | The return value is the context and state for the new chain. LogIO (GSContext pv, GSState pv) migrateExistingState GlobalStateConfig{..} oldPbsc oldState migration genData = do - pbscBlobStore <- liftIO $ createBlobStore dtdbBlockStateFile - pbscAccountCache <- liftIO $ newAccountCache (rpAccountsCacheSize dtdbRuntimeParameters) - pbscModuleCache <- liftIO $ Modules.newModuleCache (rpModulesCacheSize dtdbRuntimeParameters) - pbscAccountMap <- liftIO $ LMDBAccountMap.openDatabase dtdAccountMapDirectory - let pbsc = PersistentBlockStateContext{..} + pbsc <- liftIO $ do + pbscBlobStore <- createBlobStore dtdbBlockStateFile + pbscAccountCache <- newAccountCache (rpAccountsCacheSize dtdbRuntimeParameters) + pbscModuleCache <- Modules.newModuleCache (rpModulesCacheSize dtdbRuntimeParameters) + pbscAccountMap <- LMDBAccountMap.openDatabase dtdAccountMapDirectory + return $ PersistentBlockStateContext{..} newInitialBlockState <- flip runBlobStoreT oldPbsc . flip runBlobStoreT pbsc $ do case _nextGenesisInitialState oldState of Nothing -> error "Precondition violation. Migration called in state without initial block state." - Just initState -> undefined -- todo --- newState <- migratePersistentBlockState migration (hpbsPointers initState) --- Concordium.GlobalState.Persistent.BlockState.hashBlockState newState + Just initState -> do + newState <- migratePersistentBlockState migration (hpbsPointers initState) + Concordium.GlobalState.Persistent.BlockState.hashBlockState newState let initGS = do ser <- saveBlockState newInitialBlockState initialSkovPersistentData @@ -135,8 +136,8 @@ migrateExistingState GlobalStateConfig{..} oldPbsc oldState migration genData = (_transactionTable oldState) (Just (_pendingTransactions oldState)) isd <- - runReaderT (LMDBAccountMap.runAccountMapStoreMonad (runPersistentBlockStateMonad initGS)) pbsc - `onException` liftIO (destroyBlobStore pbscBlobStore) + runReaderT (runPersistentBlockStateMonad initGS) pbsc + `onException` liftIO (destroyBlobStore (pbscBlobStore pbsc)) return (pbsc, isd) -- | Initialise new global state with the given genesis. If the state already diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs index 6bfd6ab8e5..ebc8c597d6 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs @@ -183,6 +183,7 @@ import Concordium.Wasm import qualified Concordium.Crypto.SHA256 as H import Concordium.Types.HashableTo +import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap -- | A @BlobRef a@ represents an offset on a file, at -- which a value of type @a@ is stored. @@ -592,7 +593,7 @@ type SupportMigration m t = (MonadBlobStore m, MonadTrans t, MonadBlobStore (t m -- based on the context (rather than lifting). newtype BlobStoreT (r :: Type) (m :: Type -> Type) (a :: Type) = BlobStoreT {runBlobStoreT :: r -> m a} deriving - (Functor, Applicative, Monad, MonadReader r, MonadIO, MonadFail, MonadLogger, MonadCatch.MonadThrow, MonadCatch.MonadCatch) + (Functor, Applicative, Monad, MonadReader r, MonadIO, MonadFail, MonadLogger, MonadCatch.MonadThrow, MonadCatch.MonadCatch, MonadCatch.MonadMask) via (ReaderT r m) deriving (MonadTrans) @@ -600,6 +601,15 @@ newtype BlobStoreT (r :: Type) (m :: Type -> Type) (a :: Type) = BlobStoreT {run instance (HasBlobStore r, MonadIO m) => MonadBlobStore (BlobStoreT r m) + +-- TODO either create or derive some instance for this. +instance + (MonadIO m, MonadLogger m, MonadReader r m, LMDBAccountMap.HasDatabaseHandlers r) + => LMDBAccountMap.MonadAccountMapStore (BlobStoreT r m) where + insert = undefined + lookup = undefined + delete = undefined + -- | Apply a given function to modify the context of a 'BlobStoreT' operation. alterBlobStoreT :: (r1 -> r2) -> BlobStoreT r2 m a -> BlobStoreT r1 m a alterBlobStoreT f (BlobStoreT a) = BlobStoreT (a . f) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index e0ba935c98..331c2d97f5 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -41,6 +41,7 @@ module Concordium.GlobalState.Persistent.BlockState ( import qualified Concordium.Crypto.SHA256 as H import qualified Concordium.Genesis.Data.P6 as P6 import Concordium.GlobalState.Account hiding (addIncomingEncryptedAmount, addToSelfEncryptedAmount) +import qualified Control.Monad.Catch as MonadCatch import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import Concordium.GlobalState.BakerInfo import Concordium.GlobalState.BlockState @@ -3315,17 +3316,18 @@ instance (IsProtocolVersion pv) => MonadProtocolVersion (BlobStoreT (PersistentB -- | Create a new account cache of the specified size for running the given monadic operation by -- extending the 'BlobStore' context to a 'PersistentBlockStateContext'. -- todo fix doc. -withNewAccountCacheAndLMDBAccountMap :: (MonadIO m) => Int -> FilePath -> BlobStoreT (PersistentBlockStateContext pv) m a -> BlobStoreT BlobStore m a -withNewAccountCacheAndLMDBAccountMap size lmdbAccountMapDir bsm = do - ac <- liftIO $ newAccountCache size - mc <- liftIO $ Modules.newModuleCache 100 - lmdbAccMap <- liftIO $ LMDBAccountMap.openDatabase lmdbAccountMapDir - res <- alterBlobStoreT (\bs -> PersistentBlockStateContext bs ac mc lmdbAccMap) bsm - liftIO $ LMDBAccountMap.closeDatabase lmdbAccMap - return res +withNewAccountCacheAndLMDBAccountMap :: (MonadIO m, MonadCatch.MonadMask m) => Int -> FilePath -> BlobStoreT (PersistentBlockStateContext pv) m a -> BlobStoreT BlobStore m a +withNewAccountCacheAndLMDBAccountMap size lmdbAccountMapDir bsm = MonadCatch.bracket openLmdbAccMap closeLmdbAccMap runAction + where + openLmdbAccMap = liftIO $ LMDBAccountMap.openDatabase lmdbAccountMapDir + closeLmdbAccMap handlers = liftIO $ LMDBAccountMap.closeDatabase handlers + runAction lmdbAccMap = do + ac <- liftIO $ newAccountCache size + mc <- liftIO $ Modules.newModuleCache 100 + alterBlobStoreT (\bs -> PersistentBlockStateContext bs ac mc lmdbAccMap) bsm newtype PersistentBlockStateMonad (pv :: ProtocolVersion) (r :: Type) (m :: Type -> Type) (a :: Type) = PersistentBlockStateMonad {runPersistentBlockStateMonad :: m a} - deriving (Functor, Applicative, Monad, MonadIO, MonadReader r, MonadLogger, TimeMonad, MTL.MonadState s) + deriving (Functor, Applicative, Monad, MonadIO, MonadReader r, MonadLogger, TimeMonad, MTL.MonadState s, MonadCatch.MonadCatch, MonadCatch.MonadThrow) type PersistentState av pv r m = ( MonadIO m, diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs index 3c3bb060b7..6f69eb6383 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs @@ -422,7 +422,7 @@ loadSkovPersistentData rp _treeStateDirectory pbsc = do -- Unroll the treestate if the last finalized blockstate is corrupted. If the last finalized -- blockstate is not corrupted, the treestate is unchanged. - unrollTreeStateWhile _db (liftIO . isBlockStateCorrupted) >>= \case + unrollTreeStateWhile _db isBlockStateCorrupted >>= \case Left e -> logExceptionAndThrowTS . DatabaseInvariantViolation $ "The block state database is corrupt. Recovery attempt failed: " <> e @@ -465,9 +465,9 @@ loadSkovPersistentData rp _treeStateDirectory pbsc = do NormalBlock bb -> Just $ bbStateHash bb bstate <- runReaderT (PBS.runPersistentBlockStateMonad (loadBlockState stateHashM sbState)) pbsc makeBlockPointerFromPersistentBlock sbBlock bstate sbInfo - isBlockStateCorrupted :: StoredBlock pv (TS.BlockStatePointer (PBS.PersistentBlockState pv)) -> IO Bool - isBlockStateCorrupted block = - not <$> runBlobStoreT (isValidBlobRef (sbState block)) pbsc + isBlockStateCorrupted :: StoredBlock pv (TS.BlockStatePointer (PBS.PersistentBlockState pv)) -> LogIO Bool + isBlockStateCorrupted block = + not <$> runReaderT (PBS.runPersistentBlockStateMonad (isValidBlobRef (sbState block))) pbsc -- | Activate the state and make it usable for use by consensus. This concretely -- means that the block state for the last finalized block is cached, and that diff --git a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs index 63dc3b7c39..9f14f8f3a2 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs @@ -507,7 +507,7 @@ initialiseExistingSkovV1 bakerCtx handlerCtx unliftSkov GlobalStateConfig{..} = return PersistentBlockStateContext{..} let initWithLLDB skovLldb = do checkDatabaseVersion skovLldb - let checkBlockState bs = runBlobStoreT (isValidBlobRef bs) pbsc + let checkBlockState bs = runReaderT (PBS.runPersistentBlockStateMonad (isValidBlobRef bs)) pbsc (rollCount, bestState) <- flip runReaderT (LMDBDatabases skovLldb $ pbscAccountMap pbsc) $ (LMDBAccountMap.runAccountMapStoreMonad . runDiskLLDBM) (rollBackBlocksUntil checkBlockState) @@ -698,23 +698,23 @@ migrateSkovV1 :: migrateSkovV1 regenesis migration gsConfig@GlobalStateConfig{..} oldPbsc oldBlockState bakerCtx handlerCtx unliftSkov migrateTT migratePTT = do pbsc@PersistentBlockStateContext{..} <- newPersistentBlockStateContext gsConfig logEvent GlobalState LLDebug "Migrating existing global state." - newInitialBlockState <- - flip runBlobStoreT oldPbsc . flip runBlobStoreT pbsc . - flip runReaderT (flip LMDBAccountMap.runAccountMapStoreMonad oldPbsc) . - flip runReaderT (flip LMDBAccountMap.runAccountMapStoreMonad pbsc) $ do + let newInitialBlockState :: InitMonad pv (HashedPersistentBlockState pv) + newInitialBlockState = do + flip runBlobStoreT oldPbsc . flip runBlobStoreT pbsc $ do newState <- migratePersistentBlockState migration $ hpbsPointers oldBlockState hashBlockState newState let initGS :: InitMonad pv (SkovData pv) initGS = do - stateRef <- saveBlockState newInitialBlockState - chainParams <- getChainParameters newInitialBlockState - genEpochBakers <- genesisEpochBakers newInitialBlockState - let genMeta = regenesisMetadata (getHash newInitialBlockState) regenesis + newState <- newInitialBlockState + stateRef <- saveBlockState newState + chainParams <- getChainParameters newState + genEpochBakers <- genesisEpochBakers newState + let genMeta = regenesisMetadata (getHash newState) regenesis let genTimeoutDuration = chainParams ^. cpConsensusParameters . cpTimeoutParameters . tpTimeoutBase let !initSkovData = - mkInitialSkovData gscRuntimeParameters genMeta newInitialBlockState genTimeoutDuration genEpochBakers migrateTT migratePTT + mkInitialSkovData gscRuntimeParameters genMeta newState genTimeoutDuration genEpochBakers migrateTT migratePTT let storedGenesis = LowLevel.StoredBlock { stbStatePointer = stateRef, From cab1ce95eb3fe41a1108ec8d42371155eb7bf69c Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Fri, 13 Oct 2023 14:14:20 +0200 Subject: [PATCH 16/92] fix compilation errors.. --- concordium-consensus/src/Concordium/External.hs | 2 ++ .../src/Concordium/GlobalState/Persistent/BlobStore.hs | 10 +++------- concordium-consensus/src/Concordium/MultiVersion.hs | 6 ++++-- .../test-runners/deterministic/Main.hs | 5 +++-- 4 files changed, 12 insertions(+), 11 deletions(-) diff --git a/concordium-consensus/src/Concordium/External.hs b/concordium-consensus/src/Concordium/External.hs index cc68be03d9..4a625fbd82 100644 --- a/concordium-consensus/src/Concordium/External.hs +++ b/concordium-consensus/src/Concordium/External.hs @@ -270,6 +270,8 @@ toStartResult = GenesisBlockIncorrect _ -> 9 DatabaseInvariantViolation _ -> 10 IncorrectDatabaseVersion _ -> 11 + AccountMapPermissionError -> 12 + AccountMapMismatch{} -> 13 -- | Catch exceptions which may occur at start up and return an appropriate exit code. handleStartExceptions :: LogMethod IO -> IO StartResult -> IO Int64 diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs index ebc8c597d6..9b4f2ae7d9 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs @@ -602,13 +602,9 @@ newtype BlobStoreT (r :: Type) (m :: Type -> Type) (a :: Type) = BlobStoreT {run instance (HasBlobStore r, MonadIO m) => MonadBlobStore (BlobStoreT r m) --- TODO either create or derive some instance for this. -instance - (MonadIO m, MonadLogger m, MonadReader r m, LMDBAccountMap.HasDatabaseHandlers r) - => LMDBAccountMap.MonadAccountMapStore (BlobStoreT r m) where - insert = undefined - lookup = undefined - delete = undefined +deriving via (LMDBAccountMap.AccountMapStoreMonad (BlobStoreT r m)) instance + (MonadIO m, MonadLogger m, LMDBAccountMap.HasDatabaseHandlers r) + => LMDBAccountMap.MonadAccountMapStore (BlobStoreT r m) -- | Apply a given function to modify the context of a 'BlobStoreT' operation. alterBlobStoreT :: (r1 -> r2) -> BlobStoreT r2 m a -> BlobStoreT r1 m a diff --git a/concordium-consensus/src/Concordium/MultiVersion.hs b/concordium-consensus/src/Concordium/MultiVersion.hs index d7ec452d45..fe15d56f5a 100644 --- a/concordium-consensus/src/Concordium/MultiVersion.hs +++ b/concordium-consensus/src/Concordium/MultiVersion.hs @@ -195,7 +195,8 @@ globalStateConfig DiskStateConfig{..} rtp gi _ = ( GlobalStateConfig { dtdbRuntimeParameters = rtp, dtdbTreeStateDirectory = stateBasePath ("treestate-" ++ show gi), - dtdbBlockStateFile = stateBasePath ("blockstate-" ++ show gi) <.> "dat" + dtdbBlockStateFile = stateBasePath ("blockstate-" ++ show gi) <.> "dat", + dtdAccountMapDirectory = stateBasePath "accountmap" } ) @@ -209,7 +210,8 @@ globalStateConfigV1 DiskStateConfig{..} rtp gi = ( SkovV1.GlobalStateConfig { gscRuntimeParameters = rtp, gscTreeStateDirectory = stateBasePath ("treestate-" ++ show gi), - gscBlockStateFile = stateBasePath ("blockstate-" ++ show gi) <.> "dat" + gscBlockStateFile = stateBasePath ("blockstate-" ++ show gi) <.> "dat", + gscAccountMapDirectory = stateBasePath "accountmap" } ) diff --git a/concordium-consensus/test-runners/deterministic/Main.hs b/concordium-consensus/test-runners/deterministic/Main.hs index cff7496f6b..728995b8d7 100644 --- a/concordium-consensus/test-runners/deterministic/Main.hs +++ b/concordium-consensus/test-runners/deterministic/Main.hs @@ -68,8 +68,8 @@ type PV = 'P5 -- | Construct the global state configuration. -- Can be customised if changing the configuration. -makeGlobalStateConfig :: RuntimeParameters -> FilePath -> FilePath -> IO GlobalStateConfig -makeGlobalStateConfig rt treeStateDir blockStateFile = return $ GlobalStateConfig rt treeStateDir blockStateFile +makeGlobalStateConfig :: RuntimeParameters -> FilePath -> FilePath -> FilePath -> IO GlobalStateConfig +makeGlobalStateConfig rt treeStateDir blockStateFile accMapDirectory = return $ GlobalStateConfig rt treeStateDir blockStateFile accMapDirectory {- type TreeConfig = PairGSConfig MemoryTreeMemoryBlockConfig DiskTreeDiskBlockConfig @@ -316,6 +316,7 @@ initialState numAccts = do defaultRuntimeParameters{rpAccountsCacheSize = 5000} ("data/treestate-" ++ show now ++ "-" ++ show bakerId) ("data/blockstate-" ++ show now ++ "-" ++ show bakerId ++ ".dat") + ("data/accountmap-" ++ show now ++ "-" ++ show bakerId ++ ".dat") let finconfig = ActiveFinalization (FinalizationInstance (bakerSignKey _bsIdentity) (bakerElectionKey _bsIdentity) (bakerAggregationKey _bsIdentity)) hconfig = NoHandler From 40ecace5d76a11aeae90786d7f01fc2646864b99 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Fri, 13 Oct 2023 14:36:47 +0200 Subject: [PATCH 17/92] fix test. --- .../GlobalState/Persistent/BlockState.hs | 6 +++++- .../GlobalStateTests/AccountReleaseScheduleTest.hs | 14 +++++++++++--- 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 331c2d97f5..eff49e5d34 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -38,6 +38,8 @@ module Concordium.GlobalState.Persistent.BlockState ( SupportsPersistentState, ) where +import System.Directory (removeDirectory) +import Control.Exception import qualified Concordium.Crypto.SHA256 as H import qualified Concordium.Genesis.Data.P6 as P6 import Concordium.GlobalState.Account hiding (addIncomingEncryptedAmount, addToSelfEncryptedAmount) @@ -3320,7 +3322,9 @@ withNewAccountCacheAndLMDBAccountMap :: (MonadIO m, MonadCatch.MonadMask m) => I withNewAccountCacheAndLMDBAccountMap size lmdbAccountMapDir bsm = MonadCatch.bracket openLmdbAccMap closeLmdbAccMap runAction where openLmdbAccMap = liftIO $ LMDBAccountMap.openDatabase lmdbAccountMapDir - closeLmdbAccMap handlers = liftIO $ LMDBAccountMap.closeDatabase handlers + closeLmdbAccMap handlers = liftIO $ do + LMDBAccountMap.closeDatabase handlers + removeDirectory lmdbAccountMapDir `catch` (\(_ :: IOException) -> return ()) runAction lmdbAccMap = do ac <- liftIO $ newAccountCache size mc <- liftIO $ Modules.newModuleCache 100 diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/AccountReleaseScheduleTest.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/AccountReleaseScheduleTest.hs index 4f727481ee..d629ed4cb8 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/AccountReleaseScheduleTest.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/AccountReleaseScheduleTest.hs @@ -7,6 +7,7 @@ module GlobalStateTests.AccountReleaseScheduleTest (tests) where +import Concordium.Logger import Concordium.GlobalState.Account import Concordium.GlobalState.Basic.BlockState.AccountReleaseSchedule import qualified Concordium.GlobalState.Basic.BlockState.AccountReleaseScheduleV1 as TARSV1 @@ -37,11 +38,17 @@ import Test.QuickCheck -- | Protocol version. type PV = 'P5 +newtype NoLoggerT m a = NoLoggerT {runNoLoggerT :: m a} + deriving (Functor, Applicative, Monad, MonadIO, MonadReader r) + +instance (Monad m) => MonadLogger (NoLoggerT m) where + logEvent _ _ _ = return () + type ThisMonadConcrete pv = PBS.PersistentBlockStateMonad pv (PBS.PersistentBlockStateContext pv) - (BlobStoreM' (PBS.PersistentBlockStateContext pv)) + (NoLoggerT (BlobStoreM' (PBS.PersistentBlockStateContext pv))) --------------------------------- Test values ---------------------------------- @@ -122,8 +129,9 @@ tests = do describe "GlobalState.AccountReleaseScheduleTest" $ specify "correct releases" $ runBlobStoreTemp "." $ - PBS.withNewAccountCache 1_000 $ - PBS.runPersistentBlockStateMonad testing + PBS.withNewAccountCacheAndLMDBAccountMap 1_000 "accmap" $ + runNoLoggerT $ + PBS.runPersistentBlockStateMonad testing ------------------------------------ Checks ------------------------------------ From 6b1be8d0bacc92fe8031ab4852a8e3002f946196 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Sun, 15 Oct 2023 20:19:22 +0200 Subject: [PATCH 18/92] A few changes to Accounts test. --- .../globalstate/GlobalStateTests/Accounts.hs | 28 +++++++++++++------ 1 file changed, 19 insertions(+), 9 deletions(-) diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs index 9ba4ff3407..29f2bdfd99 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs @@ -28,7 +28,6 @@ import Control.Monad hiding (fail) import Data.Either import qualified Data.FixedByteString as FBS import qualified Data.Map.Strict as Map -import qualified Data.Map.Strict as OrdMap import Data.Serialize as S import qualified Data.Set as Set import Lens.Micro.Platform @@ -43,6 +42,7 @@ import Control.Monad.IO.Class import qualified Basic.AccountTable as BAT import qualified Basic.Accounts as B +import qualified Concordium.GlobalState.AccountMap.DifferenceMap as DiffMap type PV = 'P5 @@ -58,14 +58,24 @@ checkBinaryM bop x y sbop sx sy = do satisfied <- bop x y unless satisfied $ liftIO $ assertFailure $ "Not satisfied: " ++ sx ++ " (" ++ show x ++ ") " ++ sbop ++ " " ++ show y ++ " (" ++ sy ++ ")" --- | Check that a 'B.Accounts' and a 'P.Accounts' are equivalent. --- That is, they have the same account map, account table, and set of +-- | Helper function for getting accounts (potentially also parent maps) for a 'DiffMap.DifferenceMap'. +differenceMapToMap :: Maybe DiffMap.DifferenceMap -> Map.Map AccountAddress AccountIndex +differenceMapToMap Nothing = Map.empty +differenceMapToMap (Just diffMap) = Map.fromList $ go diffMap [] + where + go :: DiffMap.DifferenceMap -> [(AccountAddress, AccountIndex)] -> [(AccountAddress, AccountIndex)] + go (DiffMap.DifferenceMap accs Nothing) accum = accum ++ accs + go (DiffMap.DifferenceMap accs (Just parentMap)) accum = go parentMap $! accum ++ accs + +-- | Check that a 'B.Accounts' and a 'P.AccountsAndDiffMap' are equivalent. +-- That is, they have the same account table, and set of -- use registration ids. -checkEquivalent :: (MonadBlobStore m, MonadFail m, MonadCache (PA.AccountCache (AccountVersionFor PV)) m) => B.Accounts PV -> P.Accounts PV -> m () -checkEquivalent ba pa = do - pam <- AccountMap.toMap (P.accountMap pa) +checkEquivalent :: (MonadBlobStore m, MonadFail m, MonadCache (PA.AccountCache (AccountVersionFor PV)) m) => B.Accounts PV -> P.AccountsAndDiffMap PV -> m () +checkEquivalent ba paAndDiffMap = do + let pam = differenceMapToMap $ P.aadDiffMap paAndDiffMap checkBinary (==) (AccountMap.toMapPure (B.accountMap ba)) pam "==" "Basic account map" "Persistent account map" let bat = BAT.toList (B.accountTable ba) + let pa = P.aadAccounts paAndDiffMap pat <- L.toAscPairList (P.accountTable pa) bpat <- mapM (_2 PA.toTransientAccount) pat checkBinary (==) bat bpat "==" "Basic account table (as list)" "Persistent account table (as list)" @@ -88,7 +98,7 @@ data AccountAction randomizeAccount :: AccountAddress -> ID.CredentialPublicKeys -> Gen (Account (AccountVersionFor PV)) randomizeAccount _accountAddress _accountVerificationKeys = do - let vfKey = snd . head $ OrdMap.toAscList (ID.credKeys _accountVerificationKeys) + let vfKey = snd . head $ Map.toAscList (ID.credKeys _accountVerificationKeys) let cred = dummyCredential dummyCryptographicParameters _accountAddress vfKey dummyMaxValidTo dummyCreatedAt let a0 = newAccount dummyCryptographicParameters _accountAddress cred nonce <- Nonce <$> arbitrary @@ -104,7 +114,7 @@ randomActions = sized (ra Set.empty Map.empty) randAccount = do address <- ID.AccountAddress . FBS.pack <$> vector ID.accountAddressSize n <- choose (1, 255) - credKeys <- OrdMap.fromList . zip [0 ..] . map Sig.correspondingVerifyKey <$> replicateM n genSigSchemeKeyPair + credKeys <- Map.fromList . zip [0 ..] . map Sig.correspondingVerifyKey <$> replicateM n genSigSchemeKeyPair credThreshold <- fromIntegral <$> choose (1, n) return (ID.CredentialPublicKeys{..}, address) ra _ _ 0 = return [] @@ -178,7 +188,7 @@ randomActions = sized (ra Set.empty Map.empty) (rid, ai) <- elements (Map.toList rids) (RecordRegId rid ai :) <$> ra s rids (n - 1) -runAccountAction :: (MonadBlobStore m, MonadIO m, MonadCache (PA.AccountCache (AccountVersionFor PV)) m) => AccountAction -> (B.Accounts PV, P.Accounts PV) -> m (B.Accounts PV, P.Accounts PV) +runAccountAction :: (MonadBlobStore m, MonadIO m, MonadCache (PA.AccountCache (AccountVersionFor PV)) m) => AccountAction -> (B.Accounts PV, P.AccountsAndDiffMap PV) -> m (B.Accounts PV, P.Accounts PV) runAccountAction (PutAccount acct) (ba, pa) = do let ba' = B.putNewAccount acct ba pAcct <- PA.makePersistentAccount acct From 27e6e1da86455807af9c4b475a1e10d61e3fbc81 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Mon, 16 Oct 2023 13:07:32 +0200 Subject: [PATCH 19/92] Test fixes. --- .../GlobalState/Persistent/Accounts.hs | 19 +++++++++----- .../ConcordiumTests/FinalizationRecover.hs | 2 +- .../KonsensusV1/TransactionProcessingTest.hs | 26 ++++++++++++++----- .../ConcordiumTests/PassiveFinalization.hs | 2 +- .../ReceiveTransactionsTest.hs | 6 ++--- .../tests/consensus/ConcordiumTests/Update.hs | 2 +- .../globalstate/GlobalStateTests/Accounts.hs | 23 +++++++++++----- .../GlobalStateTests/PersistentTreeState.hs | 2 +- .../globalstate/GlobalStateTests/Trie.hs | 10 +++---- .../globalstate/GlobalStateTests/Updates.hs | 17 ++++++++---- 10 files changed, 72 insertions(+), 37 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index c34562c57e..290f5175be 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -180,11 +180,16 @@ exists addr accts = isJust <$> getAccountIndex addr accts -- | Retrieve an account with the given address. -- Returns @Nothing@ if no such account exists. -getAccount :: (SupportsPersistentAccount pv m) => AccountAddress -> Accounts pv -> m (Maybe (PersistentAccount (AccountVersionFor pv))) -getAccount addr Accounts{..} = - LMDBAccountMap.lookup addr >>= \case - Nothing -> return Nothing - Just ai -> L.lookup ai accountTable +getAccount :: (SupportsPersistentAccount pv m) => AccountAddress -> AccountsAndDiffMap pv -> m (Maybe (PersistentAccount (AccountVersionFor pv))) +getAccount addr AccountsAndDiffMap{..} = + case DiffMap.lookup addr =<< aadDiffMap of + Just ai -> fetchFromTable ai + Nothing -> + LMDBAccountMap.lookup addr >>= \case + Nothing -> return Nothing + Just ai -> fetchFromTable ai + where + fetchFromTable accIndex = L.lookup accIndex $ accountTable aadAccounts -- | Retrieve an account associated with the given credential registration ID. -- Returns @Nothing@ if no such account exists. @@ -218,8 +223,8 @@ indexedAccount ai AccountsAndDiffMap{..} = L.lookup ai (accountTable aadAccounts -- | Retrieve an account with the given address. -- An account with the address is required to exist. unsafeGetAccount :: (SupportsPersistentAccount pv m) => AccountAddress -> AccountsAndDiffMap pv -> m (PersistentAccount (AccountVersionFor pv)) -unsafeGetAccount addr AccountsAndDiffMap{..} = - getAccount addr aadAccounts <&> \case +unsafeGetAccount addr accountsAndDiffMap = + getAccount addr accountsAndDiffMap <&> \case Just acct -> acct Nothing -> error $ "unsafeGetAccount: Account " ++ show addr ++ " does not exist." diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/FinalizationRecover.hs b/concordium-consensus/tests/consensus/ConcordiumTests/FinalizationRecover.hs index eb45e74cbd..eb52875627 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/FinalizationRecover.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/FinalizationRecover.hs @@ -37,7 +37,7 @@ dummyArs :: AnonymityRevokers dummyArs = emptyAnonymityRevokers makeGlobalStateConfig :: FilePath -> RuntimeParameters -> GlobalStateConfig -makeGlobalStateConfig tempDir rt = GlobalStateConfig rt tempDir (tempDir "data" <.> "blob") +makeGlobalStateConfig tempDir rt = GlobalStateConfig rt tempDir (tempDir "data" <.> "blob") (tempDir "accountmap") genesis :: Word -> (GenesisData PV, [(BakerIdentity, FullBakerInfo)], Amount) genesis nBakers = diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs index 444bf35ac1..5b06d8b0c5 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs @@ -5,6 +5,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} -- | This module tests processing of transactions for consensus V1. -- The tests included here does not differentiate between the individual @@ -35,6 +36,7 @@ import System.Random import Test.HUnit import Test.Hspec +import Concordium.Logger import Concordium.Common.Version import Concordium.Crypto.DummyData import qualified Concordium.Crypto.SignatureScheme as SigScheme @@ -128,6 +130,15 @@ instance (MonadReader r m) => MonadReader r (FixedTimeT m) where ask = lift ask local f (FixedTime k) = FixedTime $ local f . k +newtype NoLoggerT m a = NoLoggerT {runNoLoggerT :: m a} + deriving (Functor, Applicative, Monad, MonadIO, MonadReader r, MonadFail) + +instance (Monad m) => MonadLogger (NoLoggerT m) where + logEvent _ _ _ = return () + +deriving instance (TimeMonad m) => TimeMonad (NoLoggerT m) +deriving instance (MonadState s m) => MonadState s (NoLoggerT m) + -- | A test monad that is suitable for testing transaction processing -- as it derives the required capabilities. -- I.e. 'BlockStateQuery' is supported via the 'PersistentBlockStateMonad and a 'MonadState' over the 'SkovData pv'. @@ -137,10 +148,10 @@ type MyTestMonad = ( PersistentBlockStateMonad 'P6 (PersistentBlockStateContext 'P6) - ( StateT + (NoLoggerT ( StateT (SkovData 'P6) (FixedTimeT (BlobStoreM' (PersistentBlockStateContext 'P6))) - ) + )) ) -- | Run an action within the 'MyTestMonad'. @@ -152,15 +163,18 @@ type MyTestMonad = runMyTestMonad :: IdentityProviders -> UTCTime -> MyTestMonad a -> IO (a, SkovData 'P6) runMyTestMonad idps time action = do runBlobStoreTemp "." $ - withNewAccountCache 1_000 $ do - initState <- runPersistentBlockStateMonad initialData - runDeterministic (runStateT (runPersistentBlockStateMonad (runAccountNonceQueryT action)) initState) time + withNewAccountCacheAndLMDBAccountMap 1_000 "accountmap" $ do + initState <- runNoLoggerT $ runPersistentBlockStateMonad initialData + flip runDeterministic time $ + flip runStateT initState $ + runNoLoggerT $ + runPersistentBlockStateMonad $ runAccountNonceQueryT action where initialData :: PersistentBlockStateMonad 'P6 (PersistentBlockStateContext 'P6) - (BlobStoreM' (PersistentBlockStateContext 'P6)) + (NoLoggerT (BlobStoreM' (PersistentBlockStateContext 'P6))) (SkovData 'P6) initialData = do (bs, _) <- diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/PassiveFinalization.hs b/concordium-consensus/tests/consensus/ConcordiumTests/PassiveFinalization.hs index 11f50d6b03..4eb0f56d60 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/PassiveFinalization.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/PassiveFinalization.hs @@ -370,7 +370,7 @@ createInitStates additionalFinMembers = do let fininst = FinalizationInstance (bakerSignKey bid) (bakerElectionKey bid) (bakerAggregationKey bid) config = SkovConfig - (GlobalStateConfig defaultRuntimeParameters tempDir (tempDir "data" <.> "blob")) + (GlobalStateConfig defaultRuntimeParameters tempDir (tempDir "data" <.> "blob") (tempDir "accountmap")) (ActiveFinalization fininst) NoHandler (initCtx, initState) <- runSilentLogger (initialiseSkov gen config) diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/ReceiveTransactionsTest.hs b/concordium-consensus/tests/consensus/ConcordiumTests/ReceiveTransactionsTest.hs index 0092b94de1..679f5fba64 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/ReceiveTransactionsTest.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/ReceiveTransactionsTest.hs @@ -243,8 +243,8 @@ runTestSkovQueryMonad' :: TestSkovQueryMonad a -> UTCTime -> GenesisData PV -> I runTestSkovQueryMonad' act time gd = do withTempDirectory "." "treestate" $ \tsDir -> do Blob.runBlobStoreTemp "." $ - BS.withNewAccountCache 1000 $ do - initState <- runPersistentBlockStateMonad $ initialData tsDir + BS.withNewAccountCacheAndLMDBAccountMap 1000 "accountmap" $ do + initState <- runNoLoggerT $ runPersistentBlockStateMonad $ initialData tsDir runDeterministic (runNoLoggerT (runStateT (runPersistentBlockStateMonad . runPersistentTreeStateMonad . runSkovQueryMonad $ act) initState)) time where initialData :: @@ -252,7 +252,7 @@ runTestSkovQueryMonad' act time gd = do BS.PersistentBlockStateMonad PV (BS.PersistentBlockStateContext PV) - (Blob.BlobStoreM' (BS.PersistentBlockStateContext PV)) + (NoLoggerT (Blob.BlobStoreM' (BS.PersistentBlockStateContext PV))) TestSkovState initialData tsDir = do (bs, genTT) <- diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/Update.hs b/concordium-consensus/tests/consensus/ConcordiumTests/Update.hs index 92a2effa1b..5289ccf5b7 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/Update.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/Update.hs @@ -135,7 +135,7 @@ createInitStates dir = do let fininst = FinalizationInstance (bakerSignKey bid) (bakerElectionKey bid) (bakerAggregationKey bid) config = SkovConfig - (GlobalStateConfig defaultRuntimeParameters (dir uni) (dir uni <.> "dat")) + (GlobalStateConfig defaultRuntimeParameters (dir uni) (dir uni <.> "dat") (dir uni <.> "accountmap")) (ActiveFinalization fininst) NoHandler (initCtx, initState) <- runSilentLogger (initialiseSkov gen config) diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs index 29f2bdfd99..201c1cd124 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs @@ -5,6 +5,8 @@ module GlobalStateTests.Accounts where +import Concordium.Logger +import Control.Monad.Reader import Concordium.Crypto.DummyData import Concordium.Crypto.FFIDataTypes import qualified Concordium.Crypto.SHA256 as H @@ -24,7 +26,6 @@ import qualified Concordium.ID.Types as ID import Concordium.Types import Concordium.Types.HashableTo import Control.Exception (bracket) -import Control.Monad hiding (fail) import Data.Either import qualified Data.FixedByteString as FBS import qualified Data.Map.Strict as Map @@ -38,14 +39,21 @@ import Test.Hspec import Test.QuickCheck import Prelude hiding (fail) -import Control.Monad.IO.Class - import qualified Basic.AccountTable as BAT import qualified Basic.Accounts as B import qualified Concordium.GlobalState.AccountMap.DifferenceMap as DiffMap +import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap type PV = 'P5 + +newtype NoLoggerT m a = NoLoggerT {runNoLoggerT :: m a} + deriving (Functor, Applicative, Monad, MonadIO, MonadReader r, MonadFail) + +instance (Monad m) => MonadLogger (NoLoggerT m) where + logEvent _ _ _ = return () + + assertRight :: Either String a -> Assertion assertRight (Left e) = assertFailure e assertRight _ = return () @@ -188,7 +196,7 @@ randomActions = sized (ra Set.empty Map.empty) (rid, ai) <- elements (Map.toList rids) (RecordRegId rid ai :) <$> ra s rids (n - 1) -runAccountAction :: (MonadBlobStore m, MonadIO m, MonadCache (PA.AccountCache (AccountVersionFor PV)) m) => AccountAction -> (B.Accounts PV, P.AccountsAndDiffMap PV) -> m (B.Accounts PV, P.Accounts PV) +runAccountAction :: (LMDBAccountMap.MonadAccountMapStore m, MonadBlobStore m, MonadIO m, MonadCache (PA.AccountCache (AccountVersionFor PV)) m) => AccountAction -> (B.Accounts PV, P.AccountsAndDiffMap PV) -> m (B.Accounts PV, P.AccountsAndDiffMap PV) runAccountAction (PutAccount acct) (ba, pa) = do let ba' = B.putNewAccount acct ba pAcct <- PA.makePersistentAccount acct @@ -241,13 +249,13 @@ emptyTest :: SpecWith (PersistentBlockStateContext PV) emptyTest = it "empty" $ runBlobStoreM - (checkEquivalent B.emptyAccounts P.emptyAccounts :: BlobStoreM' (PersistentBlockStateContext PV) ()) + (checkEquivalent B.emptyAccounts (P.emptyAcocuntsAndDiffMap Nothing) :: BlobStoreM' (PersistentBlockStateContext PV) ()) actionTest :: Word -> SpecWith (PersistentBlockStateContext PV) actionTest lvl = it "account actions" $ \bs -> withMaxSuccess (100 * fromIntegral lvl) $ property $ do acts <- randomActions - return $ ioProperty $ flip runBlobStoreM bs $ do - (ba, pa) <- foldM (flip runAccountAction) (B.emptyAccounts, P.emptyAccounts) acts + return $ ioProperty $ runNoLoggerT $ flip runBlobStoreT bs $ do + (ba, pa) <- foldM (flip runAccountAction) (B.emptyAccounts, P.emptyAcocuntsAndDiffMap Nothing) acts checkEquivalent ba pa tests :: Word -> Spec @@ -260,6 +268,7 @@ tests lvl = describe "GlobalStateTests.Accounts" pbscBlobStore <- createBlobStore (dir "blockstate.dat") pbscAccountCache <- PA.newAccountCache 100 pbscModuleCache <- M.newModuleCache 100 + pbscAccountMap <- LMDBAccountMap.openDatabase (dir "accountmap") return PersistentBlockStateContext{..} ) (closeBlobStore . pbscBlobStore) diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/PersistentTreeState.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/PersistentTreeState.hs index 16a7010a63..20f09abfd7 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/PersistentTreeState.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/PersistentTreeState.hs @@ -76,7 +76,7 @@ createGlobalState dbDir = do let n = 3 genesis = makeTestingGenesisDataP5 now n 1 1 dummyFinalizationCommitteeMaxSize dummyCryptographicParameters emptyIdentityProviders emptyAnonymityRevokers maxBound dummyKeyCollection dummyChainParameters - config = GlobalStateConfig defaultRuntimeParameters dbDir (dbDir "blockstate" <.> "dat") + config = GlobalStateConfig defaultRuntimeParameters dbDir (dbDir "blockstate" <.> "dat") (dbDir "accountmap") (x, y) <- runSilentLogger $ initialiseGlobalState genesis config return (x, y) diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/Trie.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/Trie.hs index e21fb2be77..b0535210ea 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/Trie.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/Trie.hs @@ -4,7 +4,6 @@ module GlobalStateTests.Trie where -import Control.Monad.IO.Class import Data.Serialize import Data.Word @@ -50,8 +49,8 @@ testUpdateBranchNull = forAll genBranchList $ \v i -> tests :: Spec tests = describe "GlobalStateTests.Trie" $ do - it "simple test" $ - runBlobStoreTemp "." $ do + it "simple test" $ do + r <- runBlobStoreTemp "." $ do let e = Trie.empty :: Trie.TrieN BufferedFix Word64 (SerializeStorable String) e0 <- Trie.insert 27 (SerStore "Hello") e e1 <- Trie.insert 13 (SerStore "World") e0 @@ -64,8 +63,9 @@ tests = describe "GlobalStateTests.Trie" $ do -- the bytestring it was serialized to. Left _ -> error "loadRes should be Right" (e2' :: Trie.TrieN BufferedFix Word64 (SerializeStorable String)) <- me2' - r <- Trie.lookup 27 e2' - liftIO $ r `shouldBe` Just (SerStore "Hello") + res <- Trie.lookup 27 e2' + return res + r `shouldBe` Just (SerStore "Hello") it "branchesFromToList" $ withMaxSuccess 10000 testBranchesFromToList it "branchAtFromList" $ withMaxSuccess 10000 testBranchAtFromList it "updateBranchSome" $ withMaxSuccess 10000 testUpdateBranchSome diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/Updates.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/Updates.hs index 1f45b7e961..1bda2f536b 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/Updates.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/Updates.hs @@ -3,7 +3,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} - module GlobalStateTests.Updates (tests) where {- What I want to test: @@ -32,6 +31,7 @@ import Data.Maybe (fromJust) import Lens.Micro.Platform import Test.Hspec +import Concordium.Logger import Concordium.Common.Time import qualified Concordium.Crypto.BlockSignature as BlockSig import qualified Concordium.Crypto.BlsSignature as Bls @@ -52,13 +52,19 @@ import Test.HUnit (assertEqual) -- -- -------------------------------------------------------------------------------- +newtype NoLoggerT m a = NoLoggerT {runNoLoggerT :: m a} + deriving (Functor, Applicative, Monad, MonadIO, MonadReader r, MonadFail) + +instance (Monad m) => MonadLogger (NoLoggerT m) where + logEvent _ _ _ = return () + type PV = 'P5 type ThisMonadConcrete pv = - PBS.PersistentBlockStateMonad + (PBS.PersistentBlockStateMonad pv (PBS.PersistentBlockStateContext pv) - (BlobStoreM' (PBS.PersistentBlockStateContext pv)) + (NoLoggerT (BlobStoreM' (PBS.PersistentBlockStateContext pv)))) -------------------------------------------------------------------------------- -- -- @@ -333,8 +339,9 @@ tests = do wtdgs s t = specify s $ runBlobStoreTemp "." $ - PBS.withNewAccountCache 1_000 $ - PBS.runPersistentBlockStateMonad t + PBS.withNewAccountCacheAndLMDBAccountMap 1_000 "accountmap" $ + runNoLoggerT $ + PBS.runPersistentBlockStateMonad t describe "GlobalState.Updates - BakerStakeThreshold" $ do wtdgs "not enough stake - must fail" testing1 wtdgs "enough stake >decrease> not enough - must fail" testing2'1 From 5ec32317238c2db602294b58361f8c41f4790025 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Wed, 18 Oct 2023 13:50:07 +0200 Subject: [PATCH 20/92] Tests for the LMDB account map and other fixes. --- .../src/Concordium/GlobalState.hs | 2 +- .../GlobalState/AccountMap/DifferenceMap.hs | 10 +- .../Concordium/GlobalState/AccountMap/LMDB.hs | 65 +++------- .../GlobalState/Persistent/Accounts.hs | 8 +- .../GlobalState/Persistent/BlobStore.hs | 11 +- .../GlobalState/Persistent/BlockState.hs | 8 +- .../src/Concordium/KonsensusV1/SkovMonad.hs | 9 +- .../KonsensusV1/TreeState/LowLevel/LMDB.hs | 42 ++++--- .../Concordium/Skov/MonadImplementations.hs | 6 +- .../KonsensusV1/TransactionProcessingTest.hs | 17 +-- .../AccountReleaseScheduleTest.hs | 2 +- .../globalstate/GlobalStateTests/Accounts.hs | 6 +- .../GlobalStateTests/LMDBAccountMap.hs | 119 ++++++++++++++++++ .../globalstate/GlobalStateTests/Updates.hs | 10 +- .../tests/globalstate/Spec.hs | 2 + .../tests/scheduler/SchedulerTests/Helpers.hs | 28 +++-- .../tests/scheduler/SchedulerTests/Payday.hs | 2 +- 17 files changed, 231 insertions(+), 116 deletions(-) create mode 100644 concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs diff --git a/concordium-consensus/src/Concordium/GlobalState.hs b/concordium-consensus/src/Concordium/GlobalState.hs index 24cbec37c3..c0516e3cb2 100644 --- a/concordium-consensus/src/Concordium/GlobalState.hs +++ b/concordium-consensus/src/Concordium/GlobalState.hs @@ -15,6 +15,7 @@ import Control.Monad.Reader.Class import Control.Monad.Trans.Reader hiding (ask) import Data.Proxy +import Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import Concordium.GlobalState.BlockState import Concordium.GlobalState.Parameters import Concordium.GlobalState.Persistent.Account (newAccountCache) @@ -25,7 +26,6 @@ import Concordium.GlobalState.Persistent.Genesis import Concordium.GlobalState.Persistent.TreeState import Concordium.Logger import Concordium.Types.ProtocolVersion -import Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap -- | Configuration that uses the disk implementation for both the tree state -- and the block state diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index 07a3997f13..1a94138d5a 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -30,6 +30,14 @@ data DifferenceMap = DifferenceMap makeClassy ''DifferenceMap +-- | Gather all accounts from the provided 'DifferenceMap' and its parent maps. +allAccounts :: DifferenceMap -> [(AccountAddress, AccountIndex)] +allAccounts dmap = go (Just dmap) [] + where + go :: Maybe DifferenceMap -> [(AccountAddress, AccountIndex)] -> [(AccountAddress, AccountIndex)] + go Nothing accum = accum + go (Just DifferenceMap{..}) accum = go dmParentMap $! dmAccounts ++ accum + -- | Create a new empty 'DifferenceMap' based on the difference map of -- the parent. empty :: DifferenceMap -> DifferenceMap @@ -54,8 +62,6 @@ lookup addr DifferenceMap{..} = -- | Insert an account into the difference and return @Just AccountIndex@ if the -- account was added and @Nothing@ if it was already present. --- --- If an account was succesfully added the 'dmNextAccountIndex' is being incremented by one. addAccount :: AccountAddress -> AccountIndex -> DifferenceMap -> DifferenceMap addAccount addr accIndex diffMap = diffMap diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index 842fea96ef..8daff4579e 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -4,8 +4,6 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} --- Here because of the MonadReader instance for AccountMapStoreMonad --- Revise this. {-# LANGUAGE UndecidableInstances #-} -- | This module exposes an account map backed by a LMDB database. @@ -48,14 +46,13 @@ import Lens.Micro.Platform import System.Directory import Prelude hiding (lookup) -import Concordium.TimeMonad -import Concordium.GlobalState.AccountMap.DifferenceMap (DifferenceMap (..)) import Concordium.GlobalState.Classes import Concordium.GlobalState.LMDB.Helpers import Concordium.Logger +import Concordium.TimeMonad import Concordium.Types -import qualified Data.FixedByteString as FBS import Concordium.Utils.Serialization.Put +import qualified Data.FixedByteString as FBS -- * Exceptions @@ -76,31 +73,21 @@ instance Exception DatabaseInvariantViolation where -- -- Invariants: -- * All accounts in the store are either finalized or "certified". +-- * The class (Monad m) => MonadAccountMapStore m where - -- | Adds accounts present in the provided difference maps to the lmdb store. - -- The argument is a list as multiple blocks can be finalized at the same time. - -- Implementations should update the last finalized block pointer. - -- - -- Postcondition: The list of 'AccountMapDifferenceMap' MUST be provided in - -- ascending order of the block height. - insert :: BlockHash -> BlockHeight -> [DifferenceMap] -> m () + -- | Adds the accounts to the underlying store. + insert :: BlockHash -> BlockHeight -> [(AccountAddress, AccountIndex)] -> m () -- | Looks up the ‘AccountIndex’ for the provided ‘AccountAddress’. -- Returns @Just AccountIndex@ if the account is present in the ‘AccountMap’ -- and returns @Nothing@ if the account was not present. lookup :: AccountAddress -> m (Maybe AccountIndex) - -- | Delete an account from the underlying lmdb store. - -- This should only be done when rolling back certified blocks. - delete :: AccountAddress -> m Bool - instance (Monad (t m), MonadTrans t, MonadAccountMapStore m) => MonadAccountMapStore (MGSTrans t m) where insert bh height = lift . insert bh height lookup = lift . lookup - delete = lift . delete {-# INLINE insert #-} {-# INLINE lookup #-} - {-# INLINE delete #-} deriving via (MGSTrans (StateT s) m) instance (MonadAccountMapStore m) => MonadAccountMapStore (StateT s m) deriving via (MGSTrans (ExceptT e) m) instance (MonadAccountMapStore m) => MonadAccountMapStore (ExceptT e m) @@ -109,7 +96,6 @@ deriving via (MGSTrans (WriterT w) m) instance (Monoid w, MonadAccountMapStore m instance (MonadAccountMapStore m) => MonadAccountMapStore (PutT m) where insert bh height = lift . insert bh height lookup = lift . lookup - delete = lift . delete -- * Database stores @@ -315,24 +301,6 @@ asWriteTransaction t = do (LMDB_Error _ _ (Right MDB_MAP_FULL)) -> Just () _ -> Nothing --- | Initialize the account map with the provided account addresses. --- --- Before calling this function, then it MUST be checked that the database is not already --- initialized via 'isInitialized'. --- --- Post condition: The provided list of account addresses MUST be in ascending order of their --- respective 'AccountIndex'. -initialize :: (MonadIO m, MonadLogger m) => BlockHash -> BlockHeight -> [AccountAddress] -> DatabaseHandlers -> m () -initialize lfbHash lfbHeight accounts = runReaderT (runAccountMapStoreMonad initStore) - where - initStore = asWriteTransaction $ \dbh txn -> do - forM_ - (zip accounts [0 ..]) - ( \(accAddr, accIndex) -> do - storeRecord txn (dbh ^. accountMapStore) (accountAddressToPrefixAccountAddress accAddr) accIndex - ) - storeRecord txn (dbh ^. metadataStore) lfbKey (lfbHash, lfbHeight) - -- | Check if the database is initialized. -- If the database is initialized then the function will return -- @Just (BlockHash, BlockHeight)@ for the last finalized block. @@ -344,6 +312,16 @@ isInitialized dbh = where getLfb txn = loadRecord txn (dbh ^. metadataStore) lfbKey +-- | Perform an unsafe roll back of the LMDB store. +-- This function deletes the provided accounts from the store and sets the last finalized block +-- to the provided hash and height. +unsafeRollback :: (MonadIO m, MonadLogger m, MonadReader r m, HasDatabaseHandlers r) => [AccountAddress] -> BlockHash -> BlockHeight -> m () +unsafeRollback accounts lfbHash lfbHeight = do + handlers <- ask + flip runReaderT handlers $ runAccountMapStoreMonad $ asWriteTransaction $ \dbh txn -> do + forM_ accounts $ \accAddr -> deleteRecord txn (dbh ^. accountMapStore) $ accountAddressToPrefixAccountAddress accAddr + storeReplaceRecord txn (dbh ^. metadataStore) lfbKey (lfbHash, lfbHeight) + instance ( MonadReader r m, HasDatabaseHandlers r, @@ -352,21 +330,14 @@ instance ) => MonadAccountMapStore (AccountMapStoreMonad m) where - insert lfbHash lfbHeight differenceMaps = asWriteTransaction $ \dbh txn -> do - forM_ differenceMaps (doInsert dbh txn) + insert lfbHash lfbHeight differenceMap = asWriteTransaction $ \dbh txn -> doInsert dbh txn differenceMap where - doInsert dbh txn DifferenceMap{..} = do - forM_ dmAccounts $ \(accAddr, expectedAccIndex) -> do + doInsert dbh txn accounts = do + forM_ accounts $ \(accAddr, accIndex) -> do let addr = accountAddressToPrefixAccountAddress accAddr - accIndex <- AccountIndex . subtract 1 <$> databaseSize txn (dbh ^. accountMapStore) - when (accIndex /= expectedAccIndex) $ - throwM . DatabaseInvariantViolation $ - "The actual account index " <> show accIndex <> "did not match the expected one " <> show expectedAccIndex storeRecord txn (dbh ^. accountMapStore) addr accIndex storeReplaceRecord txn (dbh ^. metadataStore) lfbKey (lfbHash, lfbHeight) return $ Just accIndex lookup accAddr = asReadTransaction $ \dbh txn -> loadRecord txn (dbh ^. accountMapStore) $ accountAddressToPrefixAccountAddress accAddr - delete accAddr = asWriteTransaction $ \dbh txn -> - deleteRecord txn (dbh ^. accountMapStore) $ accountAddressToPrefixAccountAddress accAddr diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 290f5175be..d6570b2796 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -100,7 +100,6 @@ type SupportsPersistentAccount pv m = MonadCache (AccountCache (AccountVersionFor pv)) m, LMDBAccountMap.MonadAccountMapStore m ) - instance (IsProtocolVersion pv) => Show (Accounts pv) where show a = show (accountTable a) @@ -155,7 +154,10 @@ putNewAccount !acct a0@AccountsAndDiffMap{aadAccounts = accts0@Accounts{..}, ..} addr <- accountCanonicalAddress acct -- Check whether the account is in a non-finalized block. case DiffMap.lookup addr =<< aadDiffMap of + -- The account is already present in the difference map. Just _ -> return (Nothing, a0) + -- The account is not present in the difference map so we will have to + -- check in the LMDB account map. Nothing -> do -- Check whether the account is present in a finalized block. existingAccountId <- LMDBAccountMap.lookup addr @@ -184,7 +186,7 @@ getAccount :: (SupportsPersistentAccount pv m) => AccountAddress -> AccountsAndD getAccount addr AccountsAndDiffMap{..} = case DiffMap.lookup addr =<< aadDiffMap of Just ai -> fetchFromTable ai - Nothing -> + Nothing -> LMDBAccountMap.lookup addr >>= \case Nothing -> return Nothing Just ai -> fetchFromTable ai @@ -223,7 +225,7 @@ indexedAccount ai AccountsAndDiffMap{..} = L.lookup ai (accountTable aadAccounts -- | Retrieve an account with the given address. -- An account with the address is required to exist. unsafeGetAccount :: (SupportsPersistentAccount pv m) => AccountAddress -> AccountsAndDiffMap pv -> m (PersistentAccount (AccountVersionFor pv)) -unsafeGetAccount addr accountsAndDiffMap = +unsafeGetAccount addr accountsAndDiffMap = getAccount addr accountsAndDiffMap <&> \case Just acct -> acct Nothing -> error $ "unsafeGetAccount: Account " ++ show addr ++ " does not exist." diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs index 9b4f2ae7d9..953b4e216f 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlobStore.hs @@ -182,8 +182,8 @@ import Concordium.Types.Updates import Concordium.Wasm import qualified Concordium.Crypto.SHA256 as H -import Concordium.Types.HashableTo import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap +import Concordium.Types.HashableTo -- | A @BlobRef a@ represents an offset on a file, at -- which a value of type @a@ is stored. @@ -601,10 +601,11 @@ newtype BlobStoreT (r :: Type) (m :: Type -> Type) (a :: Type) = BlobStoreT {run instance (HasBlobStore r, MonadIO m) => MonadBlobStore (BlobStoreT r m) - -deriving via (LMDBAccountMap.AccountMapStoreMonad (BlobStoreT r m)) instance - (MonadIO m, MonadLogger m, LMDBAccountMap.HasDatabaseHandlers r) - => LMDBAccountMap.MonadAccountMapStore (BlobStoreT r m) +deriving via + (LMDBAccountMap.AccountMapStoreMonad (BlobStoreT r m)) + instance + (MonadIO m, MonadLogger m, LMDBAccountMap.HasDatabaseHandlers r) => + LMDBAccountMap.MonadAccountMapStore (BlobStoreT r m) -- | Apply a given function to modify the context of a 'BlobStoreT' operation. alterBlobStoreT :: (r1 -> r2) -> BlobStoreT r2 m a -> BlobStoreT r1 m a diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index eff49e5d34..bf723afa7b 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -38,12 +38,9 @@ module Concordium.GlobalState.Persistent.BlockState ( SupportsPersistentState, ) where -import System.Directory (removeDirectory) -import Control.Exception import qualified Concordium.Crypto.SHA256 as H import qualified Concordium.Genesis.Data.P6 as P6 import Concordium.GlobalState.Account hiding (addIncomingEncryptedAmount, addToSelfEncryptedAmount) -import qualified Control.Monad.Catch as MonadCatch import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import Concordium.GlobalState.BakerInfo import Concordium.GlobalState.BlockState @@ -91,6 +88,8 @@ import Concordium.Utils.BinarySearch import Concordium.Utils.Serialization import Concordium.Utils.Serialization.Put import qualified Concordium.Wasm as Wasm +import Control.Exception +import qualified Control.Monad.Catch as MonadCatch import qualified Control.Monad.Except as MTL import Control.Monad.Reader import qualified Control.Monad.State.Strict as MTL @@ -106,6 +105,7 @@ import qualified Data.Set as Set import qualified Data.Vector as Vec import Data.Word import Lens.Micro.Platform +import System.Directory (removeDirectory) -- * Birk parameters @@ -3325,7 +3325,7 @@ withNewAccountCacheAndLMDBAccountMap size lmdbAccountMapDir bsm = MonadCatch.bra closeLmdbAccMap handlers = liftIO $ do LMDBAccountMap.closeDatabase handlers removeDirectory lmdbAccountMapDir `catch` (\(_ :: IOException) -> return ()) - runAction lmdbAccMap = do + runAction lmdbAccMap = do ac <- liftIO $ newAccountCache size mc <- liftIO $ Modules.newModuleCache 100 alterBlobStoreT (\bs -> PersistentBlockStateContext bs ac mc lmdbAccMap) bsm diff --git a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs index 9f14f8f3a2..eaba9dbf3d 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs @@ -474,6 +474,7 @@ data LMDBDatabases pv = LMDBDatabases -- | the account map lmdb database _lmdbDSAccMap :: !LMDBAccountMap.DatabaseHandlers } + makeLenses ''LMDBDatabases instance HasDatabaseHandlers (LMDBDatabases pv) pv where @@ -510,7 +511,7 @@ initialiseExistingSkovV1 bakerCtx handlerCtx unliftSkov GlobalStateConfig{..} = let checkBlockState bs = runReaderT (PBS.runPersistentBlockStateMonad (isValidBlobRef bs)) pbsc (rollCount, bestState) <- flip runReaderT (LMDBDatabases skovLldb $ pbscAccountMap pbsc) $ - (LMDBAccountMap.runAccountMapStoreMonad . runDiskLLDBM) (rollBackBlocksUntil checkBlockState) + (LMDBAccountMap.runAccountMapStoreMonad . runDiskLLDBM) (rollBackBlocksUntil checkBlockState) when (rollCount > 0) $ do logEvent Skov LLWarning $ "Could not load state for " @@ -700,9 +701,9 @@ migrateSkovV1 regenesis migration gsConfig@GlobalStateConfig{..} oldPbsc oldBloc logEvent GlobalState LLDebug "Migrating existing global state." let newInitialBlockState :: InitMonad pv (HashedPersistentBlockState pv) newInitialBlockState = do - flip runBlobStoreT oldPbsc . flip runBlobStoreT pbsc $ do - newState <- migratePersistentBlockState migration $ hpbsPointers oldBlockState - hashBlockState newState + flip runBlobStoreT oldPbsc . flip runBlobStoreT pbsc $ do + newState <- migratePersistentBlockState migration $ hpbsPointers oldBlockState + hashBlockState newState let initGS :: InitMonad pv (SkovData pv) initGS = do diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs index 6048b90470..47820b82cc 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs @@ -26,24 +26,25 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Data.Data import Data.List (intercalate) +import Data.Maybe (mapMaybe) import qualified Data.Serialize as S import Database.LMDB.Raw import Lens.Micro.Platform import System.Directory -import Concordium.ID.Types import Concordium.Common.Version import qualified Concordium.Crypto.SHA256 as Hash +import Concordium.ID.Types import Concordium.Logger -import Concordium.Types.Transactions import Concordium.Types import Concordium.Types.HashableTo +import Concordium.Types.Transactions +import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import Concordium.GlobalState.LMDB.Helpers import Concordium.KonsensusV1.TreeState.LowLevel import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types -import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap -- * Exceptions @@ -483,9 +484,11 @@ newtype DiskLLDBM (pv :: ProtocolVersion) m a = DiskLLDBM {runDiskLLDBM :: m a} deriving instance (MonadReader r m) => MonadReader r (DiskLLDBM pv m) -deriving via (LMDBAccountMap.AccountMapStoreMonad m) - instance (MonadLogger m, MonadIO m, MonadReader r m, LMDBAccountMap.HasDatabaseHandlers r) - => LMDBAccountMap.MonadAccountMapStore (DiskLLDBM pv m) +deriving via + (LMDBAccountMap.AccountMapStoreMonad m) + instance + (MonadLogger m, MonadIO m, MonadReader r m, LMDBAccountMap.HasDatabaseHandlers r) => + LMDBAccountMap.MonadAccountMapStore (DiskLLDBM pv m) instance (IsProtocolVersion pv) => MonadProtocolVersion (DiskLLDBM pv m) where type MPV (DiskLLDBM pv m) = pv @@ -764,15 +767,15 @@ rollBackBlocksUntil checkState = do Nothing -> return (0, bestState) Just (Left e) -> throwM . DatabaseRecoveryFailure $ e Just (Right (_, qc)) -> checkCertifiedWithQC lastFinRound bestState 0 qc - -- Delete an account in the LMDB account map store if the block item created a new account. - deleteAccountFromLMDB bi = case bi of + -- Get the account address of a creadential deployment. + getAccountAddressFromDeployment bi = case bi of WithMetadata{wmdData = CredentialDeployment{biCred = AccountCreation{..}}} -> case credential of (InitialACWP InitialCredentialDeploymentInfo{..}) -> - LMDBAccountMap.delete $ initialCredentialAccountAddress icdiValues + Just $ initialCredentialAccountAddress icdiValues (NormalACWP CredentialDeploymentInformation{..}) -> - LMDBAccountMap.delete $ credentialAccountAddress cdiValues - _ -> return True + Just $ credentialAccountAddress cdiValues + _ -> Nothing -- Given the round and QC for a certified block, check that the block's state can be -- loaded, and then iterate for the previous round. checkCertifiedWithQC :: @@ -804,10 +807,13 @@ rollBackBlocksUntil checkState = do (qcRound qc - 1) else do -- delete any accounts created in this block in the LMDB account map. - forM_ (blockTransactions block) $ \bi -> do - deleted <- deleteAccountFromLMDB bi - unless deleted $ - throwM . DatabaseInvariantViolation $ "Account for deletion not present in LMDB account map" + + let accountsToDelete = mapMaybe getAccountAddressFromDeployment (blockTransactions block) + let (parentBlockHash, parentBlockHeight) = case blockBakedData block of + Present b -> (blockParent b, blockHeight block - 1) + -- The block is the genesis block and thus we do not roll back further. + Absent -> (getHash block, blockHeight block) + void $ LMDBAccountMap.unsafeRollback accountsToDelete parentBlockHash parentBlockHeight -- Delete the block and the QC asWriteTransaction $ \dbh txn -> do void $ @@ -868,7 +874,7 @@ rollBackBlocksUntil checkState = do return count -- Roll back finalized blocks until the last explicitly finalized block where the state -- check passes. - -- Note, that we do not need to delete accounts in the LMDB account map as + -- Note, that we do not need to delete accounts in the LMDB account map as rollFinalized count lastFin = do when (blockRound lastFin == 0) $ throwM . DatabaseRecoveryFailure $ @@ -902,8 +908,8 @@ rollBackBlocksUntil checkState = do let finHash = getHash fin _ <- deleteRecord txn (dbh ^. blockStore) finHash _ <- deleteRecord txn (dbh ^. finalizedBlockIndex) (blockHeight fin) - - forM_ (blockTransactions fin) $ + + forM_ (blockTransactions fin) $ deleteRecord txn (dbh ^. transactionStatusStore) . getHash mparent <- loadRecord txn (dbh ^. blockStore) (blockParent block) case mparent of diff --git a/concordium-consensus/src/Concordium/Skov/MonadImplementations.hs b/concordium-consensus/src/Concordium/Skov/MonadImplementations.hs index 4e8e9e3dc2..c52abccab8 100644 --- a/concordium-consensus/src/Concordium/Skov/MonadImplementations.hs +++ b/concordium-consensus/src/Concordium/Skov/MonadImplementations.hs @@ -31,6 +31,7 @@ import Concordium.Afgjort.Finalize import Concordium.Afgjort.Finalize.Types import Concordium.Afgjort.Monad import Concordium.GlobalState +import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import Concordium.GlobalState.BlockMonads import Concordium.GlobalState.BlockState import Concordium.GlobalState.Finalization @@ -49,7 +50,6 @@ import Concordium.Skov.Monad as Skov import Concordium.Skov.Update import Concordium.TimeMonad import Concordium.TimerMonad -import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap -- | Monad that provides: IO, logging, the operation monads of global state and the SkovQueryMonad. newtype GlobalStateM pv a = GlobalStateM @@ -524,12 +524,12 @@ instance (c ~ SkovConfig pv finconfig handlerconfig, AccountVersionFor pv ~ av) instance (c ~ SkovConfig pv finconfig handlerconfig) => HasCache ModuleCache (SkovTContext h (SkovContext c)) where projectCache = projectCache . srContext - + instance (c ~ SkovConfig pv finconfig handlerconfig) => LMDBAccountMap.HasDatabaseHandlers (SkovContext c) where databaseHandlers = lens scGSContext (\s v -> s{scGSContext = v}) . LMDBAccountMap.databaseHandlers instance (c ~ SkovConfig pv finconfig handlerconfig) => LMDBAccountMap.HasDatabaseHandlers (SkovTContext h (SkovContext c)) where - databaseHandlers = lens srContext (\s v -> s{srContext = v}) . LMDBAccountMap.databaseHandlers + databaseHandlers = lens srContext (\s v -> s{srContext = v}) . LMDBAccountMap.databaseHandlers deriving instance ( IsProtocolVersion pv, diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs index 5b06d8b0c5..eec7a1e120 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs @@ -2,10 +2,10 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -- | This module tests processing of transactions for consensus V1. -- The tests included here does not differentiate between the individual @@ -36,7 +36,6 @@ import System.Random import Test.HUnit import Test.Hspec -import Concordium.Logger import Concordium.Common.Version import Concordium.Crypto.DummyData import qualified Concordium.Crypto.SignatureScheme as SigScheme @@ -53,6 +52,7 @@ import Concordium.GlobalState.Persistent.BlockState import Concordium.GlobalState.Persistent.Genesis (genesisState) import Concordium.GlobalState.TransactionTable import Concordium.ID.Types (randomAccountAddress) +import Concordium.Logger import Concordium.Scheduler.DummyData import Concordium.TimeMonad import qualified Concordium.TransactionVerification as TVer @@ -148,10 +148,12 @@ type MyTestMonad = ( PersistentBlockStateMonad 'P6 (PersistentBlockStateContext 'P6) - (NoLoggerT ( StateT - (SkovData 'P6) - (FixedTimeT (BlobStoreM' (PersistentBlockStateContext 'P6))) - )) + ( NoLoggerT + ( StateT + (SkovData 'P6) + (FixedTimeT (BlobStoreM' (PersistentBlockStateContext 'P6))) + ) + ) ) -- | Run an action within the 'MyTestMonad'. @@ -168,7 +170,8 @@ runMyTestMonad idps time action = do flip runDeterministic time $ flip runStateT initState $ runNoLoggerT $ - runPersistentBlockStateMonad $ runAccountNonceQueryT action + runPersistentBlockStateMonad $ + runAccountNonceQueryT action where initialData :: PersistentBlockStateMonad diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/AccountReleaseScheduleTest.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/AccountReleaseScheduleTest.hs index d629ed4cb8..ab401d35d8 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/AccountReleaseScheduleTest.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/AccountReleaseScheduleTest.hs @@ -7,7 +7,6 @@ module GlobalStateTests.AccountReleaseScheduleTest (tests) where -import Concordium.Logger import Concordium.GlobalState.Account import Concordium.GlobalState.Basic.BlockState.AccountReleaseSchedule import qualified Concordium.GlobalState.Basic.BlockState.AccountReleaseScheduleV1 as TARSV1 @@ -15,6 +14,7 @@ import Concordium.GlobalState.BlockState import Concordium.GlobalState.DummyData import Concordium.GlobalState.Persistent.BlobStore import qualified Concordium.GlobalState.Persistent.BlockState as PBS +import Concordium.Logger import Concordium.Scheduler.DummyData import Concordium.Types import Control.Monad diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs index 201c1cd124..6d2c5a25f7 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs @@ -5,8 +5,6 @@ module GlobalStateTests.Accounts where -import Concordium.Logger -import Control.Monad.Reader import Concordium.Crypto.DummyData import Concordium.Crypto.FFIDataTypes import qualified Concordium.Crypto.SHA256 as H @@ -23,9 +21,11 @@ import Concordium.GlobalState.Persistent.Cache (MonadCache) import qualified Concordium.GlobalState.Persistent.LFMBTree as L import Concordium.ID.DummyData import qualified Concordium.ID.Types as ID +import Concordium.Logger import Concordium.Types import Concordium.Types.HashableTo import Control.Exception (bracket) +import Control.Monad.Reader import Data.Either import qualified Data.FixedByteString as FBS import qualified Data.Map.Strict as Map @@ -46,14 +46,12 @@ import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap type PV = 'P5 - newtype NoLoggerT m a = NoLoggerT {runNoLoggerT :: m a} deriving (Functor, Applicative, Monad, MonadIO, MonadReader r, MonadFail) instance (Monad m) => MonadLogger (NoLoggerT m) where logEvent _ _ _ = return () - assertRight :: Either String a -> Assertion assertRight (Left e) = assertFailure e assertRight _ = return () diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs new file mode 100644 index 0000000000..d3af381243 --- /dev/null +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs @@ -0,0 +1,119 @@ +-- | Tests for the LMDB account map +-- This module tests the following: +-- * Accounts can be inserted. +-- * Accounts can be looked up. +-- * Accounts can be rolled back. +{-# LANGUAGE OverloadedStrings #-} +-- Tests of the LMDB account map related operations. +module GlobalStateTests.LMDBAccountMap where + +import Prelude hiding (lookup) +import Control.Monad.Reader +import System.IO.Temp +import Control.Exception (bracket) +import System.Random + +import qualified Concordium.Crypto.SHA256 as Hash +import Concordium.Logger +import Concordium.Types +import Concordium.ID.Types (randomAccountAddress) + +import Concordium.GlobalState.AccountMap.LMDB + +import Test.Hspec +import Test.HUnit + +-- | Create a pair consisting of an account address and an account index based on the provided seed. +dummyPair :: Int -> (AccountAddress, AccountIndex) +dummyPair seed = (fst $ randomAccountAddress (mkStdGen seed), AccountIndex $ fromIntegral seed) + +-- | A dummy block hash +dummyBlockHash :: BlockHash +dummyBlockHash = BlockHash $ Hash.hash "a dummy block hash" + +-- | Another dummy block hash +anotherDummyBlockHash :: BlockHash +anotherDummyBlockHash = BlockHash $ Hash.hash "another dummy block hash" + +-- | Helper function for running a test in a context which has access to a temporary lmdb store. +runTest :: + String -> + AccountMapStoreMonad (ReaderT DatabaseHandlers LogIO) a -> + IO a +runTest dirName action = withTempDirectory "" dirName $ \path -> + bracket + (makeDatabaseHandlers path False 1000 :: IO (DatabaseHandlers)) + closeDatabase + (\dbhandlers -> runSilentLogger $ runReaderT (runAccountMapStoreMonad action) dbhandlers) + +-- | Test that a database is not initialized. +testCheckNotInitialized :: Assertion +testCheckNotInitialized = runTest "notinitialized" $ do + dbh <- ask + liftIO $ do + mMetadata <- isInitialized dbh + assertEqual "Database should not have been initialized" Nothing mMetadata + +-- | Test that a database is initialized. +testCheckDbInitialized :: Assertion +testCheckDbInitialized = runTest "initialized" $ do + -- initialize the database + void $ insert dummyBlockHash (BlockHeight 1) [dummyPair 1] + dbh <- ask + liftIO $ do + isInitialized dbh >>= \case + Nothing -> assertFailure "database should have been initialized" + Just (blockHash, blockHeight) -> liftIO $ do + assertEqual "block hash should correspond to the one used when last inserting" dummyBlockHash blockHash + assertEqual "block height should correspond to the one used when last inserting" (BlockHeight 1) blockHeight + +-- | Test that inserts a set of accounts and afterwards asserts that they are present. +testInsertAndLookupAccounts :: Assertion +testInsertAndLookupAccounts = runTest "insertandlookups" $ do + let accounts = [acc | acc <- dummyPair <$> [1..42]] + void $ insert dummyBlockHash (BlockHeight 1) accounts + + forM_ accounts $ \(accAddr, accIndex) -> do + lookup accAddr >>= \case + Nothing -> liftIO $ assertFailure $ "account was not present " <> show accAddr <> " account index " <> show accIndex + Just foundAccountIndex -> liftIO $ assertEqual "account indices should be the same" accIndex foundAccountIndex + +-- | Test that inserting twice will yield the most recent block. +testMetadataIsUpdated :: Assertion +testMetadataIsUpdated = runTest "metadataupdated" $ do + -- initialize the database + void $ insert dummyBlockHash (BlockHeight 1) [dummyPair 1] + void $ insert anotherDummyBlockHash (BlockHeight 2) [dummyPair 2] + dbh <- ask + liftIO $ do + isInitialized dbh >>= \case + Nothing -> assertFailure "database should have been initialized" + Just (blockHash, blockHeight) -> liftIO $ do + assertEqual "block hash should correspond to the one used when last inserting" anotherDummyBlockHash blockHash + assertEqual "block height should correspond to the one used when last inserting" (BlockHeight 2) blockHeight + +-- | Test that accounts can be rolled back i.e. deleted from the LMDB store and that +-- the metadata is updated also. +testRollback :: Assertion +testRollback = runTest "rollback" $ do + -- initialize the database. + void $ insert dummyBlockHash (BlockHeight 1) [dummyPair 1] + void $ insert anotherDummyBlockHash (BlockHeight 2) [dummyPair 2] + -- roll back one block. + lookup (fst $ dummyPair 2) >>= \case + Nothing -> liftIO $ assertFailure "account should be present" + Just _ -> do + void $ unsafeRollback [(fst $ dummyPair 2)] dummyBlockHash (BlockHeight 1) + lookup (fst $ dummyPair 2) >>= \case + Just _ -> liftIO $ assertFailure "account should have been deleted" + Nothing -> lookup (fst $ dummyPair 1) >>= \case + Nothing -> liftIO $ assertFailure "Accounts from first block should still remain in the lmdb store" + Just accIdx -> liftIO $ assertEqual "The account index of the first account should be the same" (snd $ dummyPair 1) accIdx + +tests :: Spec +tests = describe "AccountMap.LMDB" $ do + it "Test checking db is not initialized" testCheckNotInitialized + it "Test checking db is initialized" testCheckDbInitialized + it "Test inserts and lookups" testInsertAndLookupAccounts + it "Test metadata is updated when accounts are added" testMetadataIsUpdated + it "Test rollback accounts" testRollback diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/Updates.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/Updates.hs index 1bda2f536b..3749a68876 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/Updates.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/Updates.hs @@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} + module GlobalStateTests.Updates (tests) where {- What I want to test: @@ -31,7 +32,6 @@ import Data.Maybe (fromJust) import Lens.Micro.Platform import Test.Hspec -import Concordium.Logger import Concordium.Common.Time import qualified Concordium.Crypto.BlockSignature as BlockSig import qualified Concordium.Crypto.BlsSignature as Bls @@ -42,6 +42,7 @@ import Concordium.GlobalState.BakerInfo import qualified Concordium.GlobalState.Persistent.BlockState.Updates as PU import Concordium.ID.DummyData import Concordium.ID.Parameters +import Concordium.Logger import Concordium.Types.DummyData import Concordium.Types.SeedState (initialSeedStateV0) import Test.HUnit (assertEqual) @@ -61,10 +62,11 @@ instance (Monad m) => MonadLogger (NoLoggerT m) where type PV = 'P5 type ThisMonadConcrete pv = - (PBS.PersistentBlockStateMonad + ( PBS.PersistentBlockStateMonad pv (PBS.PersistentBlockStateContext pv) - (NoLoggerT (BlobStoreM' (PBS.PersistentBlockStateContext pv)))) + (NoLoggerT (BlobStoreM' (PBS.PersistentBlockStateContext pv))) + ) -------------------------------------------------------------------------------- -- -- @@ -340,7 +342,7 @@ tests = do specify s $ runBlobStoreTemp "." $ PBS.withNewAccountCacheAndLMDBAccountMap 1_000 "accountmap" $ - runNoLoggerT $ + runNoLoggerT $ PBS.runPersistentBlockStateMonad t describe "GlobalState.Updates - BakerStakeThreshold" $ do wtdgs "not enough stake - must fail" testing1 diff --git a/concordium-consensus/tests/globalstate/Spec.hs b/concordium-consensus/tests/globalstate/Spec.hs index 99d997f2ad..861af79fb9 100644 --- a/concordium-consensus/tests/globalstate/Spec.hs +++ b/concordium-consensus/tests/globalstate/Spec.hs @@ -13,6 +13,7 @@ import qualified GlobalStateTests.EnduringDataFlags (tests) import qualified GlobalStateTests.FinalizationSerializationSpec (tests) import qualified GlobalStateTests.Instances (tests) import qualified GlobalStateTests.LFMBTree (tests) +import qualified GlobalStateTests.LMDBAccountMap (tests) import qualified GlobalStateTests.PersistentTreeState (tests) import qualified GlobalStateTests.Trie (tests) import qualified GlobalStateTests.UpdateQueues (tests) @@ -47,3 +48,4 @@ main = atLevel $ \lvl -> hspec $ do GlobalStateTests.EnduringDataFlags.tests GlobalStateTests.BlobStore.tests GlobalStateTests.UpdateQueues.tests + GlobalStateTests.LMDBAccountMap.tests diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs b/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs index 5ca5d2fc28..e8c3dc1618 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} @@ -38,6 +39,7 @@ import qualified Concordium.Wasm as Wasm import qualified Concordium.Common.Time as Time import qualified Concordium.Cost as Cost +import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import qualified Concordium.GlobalState.BlockState as BS import qualified Concordium.GlobalState.DummyData as DummyData import qualified Concordium.GlobalState.Persistent.Account as BS @@ -84,19 +86,15 @@ newtype PersistentBSM pv a = PersistentBSM BS.PersistentBlockStateMonad pv (BS.PersistentBlockStateContext pv) - (Blob.BlobStoreM' (BS.PersistentBlockStateContext pv)) + (Blob.BlobStoreT (BS.PersistentBlockStateContext pv) LogIO) a } deriving ( Applicative, Functor, Monad, - BS.ContractStateOperations, - BS.ModuleQuery, BlockStateTypes, - Blob.MonadBlobStore, - MonadIO, - MonadCache BS.ModuleCache + MonadIO ) deriving instance (Types.IsProtocolVersion pv) => BS.AccountOperations (PersistentBSM pv) @@ -104,6 +102,11 @@ deriving instance (Types.IsProtocolVersion pv) => BS.BlockStateOperations (Persi deriving instance (Types.IsProtocolVersion pv) => BS.BlockStateQuery (PersistentBSM pv) deriving instance (Types.IsProtocolVersion pv) => Types.MonadProtocolVersion (PersistentBSM pv) deriving instance (Types.IsProtocolVersion pv) => BS.BlockStateStorage (PersistentBSM pv) +deriving instance (Types.IsProtocolVersion pv) => BS.ModuleQuery (PersistentBSM pv) +deriving instance (Types.IsProtocolVersion pv) => BS.ContractStateOperations (PersistentBSM pv) +deriving instance (Types.IsProtocolVersion pv) => Blob.MonadBlobStore (PersistentBSM pv) +deriving instance (Types.IsProtocolVersion pv) => MonadCache BS.ModuleCache (PersistentBSM pv) +deriving instance (Types.IsProtocolVersion pv) => LMDBAccountMap.MonadAccountMapStore (PersistentBSM pv) deriving instance (Types.AccountVersionFor pv ~ av) => @@ -163,19 +166,20 @@ createTestBlockStateWithAccountsM accounts = -- | Run test block state computation provided an account cache size. -- The module cache size is 100. -- --- This function creates a temporary file for the blobstore, which is removed right after the +-- This function creates temporary files for the blobstore and account map. These are removed right after the -- running the computation, meaning the result of the computation should not retain any references -- and should be fully evaluated. runTestBlockStateWithCacheSize :: Int -> PersistentBSM pv a -> IO a runTestBlockStateWithCacheSize cacheSize computation = - Blob.runBlobStoreTemp "." $ - BS.withNewAccountCache cacheSize $ - BS.runPersistentBlockStateMonad $ - _runPersistentBSM computation + runSilentLogger $ + Blob.runBlobStoreTemp "." $ + BS.withNewAccountCacheAndLMDBAccountMap cacheSize "accountmap" $ + BS.runPersistentBlockStateMonad $ + _runPersistentBSM computation -- | Run test block state computation with a account cache size and module cache size of 100. -- --- This function creates a temporary file for the blobstore, which is removed right after the +-- This function creates a temporary files for the blobstore and account map. These are removed right after the -- running the computation, meaning the result of the computation should not retain any references -- and should be fully evaluated. runTestBlockState :: PersistentBSM pv a -> IO a diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/Payday.hs b/concordium-consensus/tests/scheduler/SchedulerTests/Payday.hs index bf130b1050..e2062e786f 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/Payday.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/Payday.hs @@ -338,7 +338,7 @@ createGlobalState :: (IsProtocolVersion pv, IsConsensusV0 pv) => FilePath -> IO createGlobalState dbDir = do let n = 5 - config = GlobalStateConfig defaultRuntimeParameters dbDir (dbDir "blockstate" <.> "dat") + config = GlobalStateConfig defaultRuntimeParameters dbDir (dbDir "blockstate" <.> "dat") (dbDir "accountmap") (x, y) <- runSilentLogger $ initialiseGlobalState (genesis n ^. _1) config return (x, y) From ed147c9cfa7e32ea99528607dd3c541ff3416a89 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Wed, 18 Oct 2023 16:14:40 +0200 Subject: [PATCH 21/92] Tests for DifferenceMap. --- .../GlobalState/AccountMap/DifferenceMap.hs | 14 ++--- .../GlobalState/Persistent/Accounts.hs | 6 +-- .../GlobalStateTests/DifferenceMap.hs | 51 +++++++++++++++++++ .../tests/globalstate/Spec.hs | 2 + 4 files changed, 63 insertions(+), 10 deletions(-) create mode 100644 concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index 1a94138d5a..3bc519037f 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -31,8 +31,8 @@ data DifferenceMap = DifferenceMap makeClassy ''DifferenceMap -- | Gather all accounts from the provided 'DifferenceMap' and its parent maps. -allAccounts :: DifferenceMap -> [(AccountAddress, AccountIndex)] -allAccounts dmap = go (Just dmap) [] +flatten :: DifferenceMap -> [(AccountAddress, AccountIndex)] +flatten dmap = go (Just dmap) [] where go :: Maybe DifferenceMap -> [(AccountAddress, AccountIndex)] -> [(AccountAddress, AccountIndex)] go Nothing accum = accum @@ -40,11 +40,11 @@ allAccounts dmap = go (Just dmap) [] -- | Create a new empty 'DifferenceMap' based on the difference map of -- the parent. -empty :: DifferenceMap -> DifferenceMap -empty parentDifferenceMap = +empty :: Maybe DifferenceMap -> DifferenceMap +empty mParentDifferenceMap = DifferenceMap { dmAccounts = [], - dmParentMap = Just parentDifferenceMap + dmParentMap = mParentDifferenceMap } -- | Check if an account exists in the difference map or any of the parent @@ -62,8 +62,8 @@ lookup addr DifferenceMap{..} = -- | Insert an account into the difference and return @Just AccountIndex@ if the -- account was added and @Nothing@ if it was already present. -addAccount :: AccountAddress -> AccountIndex -> DifferenceMap -> DifferenceMap -addAccount addr accIndex diffMap = +insert :: AccountAddress -> AccountIndex -> DifferenceMap -> DifferenceMap +insert addr accIndex diffMap = diffMap { dmAccounts = (addr, accIndex) : dmAccounts diffMap } diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index d6570b2796..f4e20ac404 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -84,7 +84,7 @@ data AccountsAndDiffMap (pv :: ProtocolVersion) = AccountsAndDiffMap aadAccounts :: !(Accounts pv), -- | An in-memory difference map used keeping track of accounts -- added in live blocks. - -- This is 'Nothing' If the block is finalized. + -- This is 'Nothing' If the block is persisted. aadDiffMap :: !(Maybe DiffMap.DifferenceMap) } @@ -145,7 +145,7 @@ emptyAccounts = Accounts L.empty Trie.empty -- simply pass in 'Nothing'. emptyAcocuntsAndDiffMap :: Maybe (AccountsAndDiffMap pv) -> AccountsAndDiffMap pv emptyAcocuntsAndDiffMap Nothing = AccountsAndDiffMap emptyAccounts Nothing -emptyAcocuntsAndDiffMap (Just successor) = AccountsAndDiffMap emptyAccounts $ DiffMap.empty <$> aadDiffMap successor +emptyAcocuntsAndDiffMap (Just successor) = AccountsAndDiffMap emptyAccounts $ Just (DiffMap.empty $ aadDiffMap successor) -- | Add a new account. Returns @Just idx@ if the new account is fresh, i.e., the address does not exist, -- or @Nothing@ in case the account already exists. In the latter case there is no change to the accounts structure. @@ -164,7 +164,7 @@ putNewAccount !acct a0@AccountsAndDiffMap{aadAccounts = accts0@Accounts{..}, ..} if isNothing existingAccountId then do (_, newAccountTable) <- L.append acct accountTable - let dm1 = DiffMap.addAccount addr acctIndex <$> aadDiffMap + let dm1 = DiffMap.insert addr acctIndex <$> aadDiffMap return (Just acctIndex, a0{aadAccounts = accts0{accountTable = newAccountTable}, aadDiffMap = dm1}) else return (Nothing, a0) where diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs new file mode 100644 index 0000000000..67bbf013b0 --- /dev/null +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE BangPatterns #-} +-- | A module that tests the functionality of the 'DiffMap.DifferenceMap'. +-- * Insert and lookup operations. +-- * Flattening the 'DiffMap.DifferenceMap'. +module GlobalStateTests.DifferenceMap where + +import Concordium.Types +import Concordium.ID.Types (randomAccountAddress) +import System.Random + +import qualified Concordium.GlobalState.AccountMap.DifferenceMap as DiffMap + +import Test.Hspec +import Test.HUnit +import Test.QuickCheck + +-- | Create a pair consisting of an account address and an account index based on the provided seed. +dummyPair :: Int -> (AccountAddress, AccountIndex) +dummyPair seed = (fst $ randomAccountAddress (mkStdGen seed), AccountIndex $ fromIntegral seed) + +-- | Test that accounts can be inserted and looked up in the 'DiffMap.DifferenceMap'. +testInsertAccount :: Assertion +testInsertAccount = do + let diffMap = DiffMap.insert (fst acc) (snd acc) $ DiffMap.empty Nothing + case DiffMap.lookup (fst acc) diffMap of + Nothing -> assertFailure "account should be present in diff map" + Just accIdx -> assertEqual "account should be there" (snd acc) accIdx + where + acc = dummyPair 1 + +-- | Test for getting all accounts in a 'DiffMap.DifferenceMap'. +testInsertAccountsAndRetrieveAll :: Assertion +testInsertAccountsAndRetrieveAll = do + let allAccounts = DiffMap.flatten $ mkDiffMaps 42 + if length allAccounts /= 42*43 + then assertFailure $ "Unexpected number of accounts in difference maps: " <> show (length allAccounts) + else pure () + where + -- create a difference map with n parents and n accounts at each layer, so n+1 difference maps in total. + mkDiffMaps n = go n n $ DiffMap.empty Nothing + where + go 0 _ accum = accum + go childCount numAccounts !accum = + let dmAccounts = [pair | pair <- dummyPair <$> [0..numAccounts]] + dmParentMap = Just $ go (childCount - 1) numAccounts $ DiffMap.empty $ Just accum + in DiffMap.DifferenceMap {..} + +tests :: Spec +tests = describe "AccountMap.DifferenceMap" $ do + it "Test insert account" testInsertAccount + it "Test retrieve all accounts from difference maps" testInsertAccountsAndRetrieveAll diff --git a/concordium-consensus/tests/globalstate/Spec.hs b/concordium-consensus/tests/globalstate/Spec.hs index 861af79fb9..2d5c41dbdf 100644 --- a/concordium-consensus/tests/globalstate/Spec.hs +++ b/concordium-consensus/tests/globalstate/Spec.hs @@ -18,6 +18,7 @@ import qualified GlobalStateTests.PersistentTreeState (tests) import qualified GlobalStateTests.Trie (tests) import qualified GlobalStateTests.UpdateQueues (tests) import qualified GlobalStateTests.Updates (tests) +import qualified GlobalStateTests.DifferenceMap (tests) import System.Environment import Test.Hspec @@ -49,3 +50,4 @@ main = atLevel $ \lvl -> hspec $ do GlobalStateTests.BlobStore.tests GlobalStateTests.UpdateQueues.tests GlobalStateTests.LMDBAccountMap.tests + GlobalStateTests.DifferenceMap.tests From d71b486eb91fa5878eda2d57f5f24f369a35b8f4 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Wed, 18 Oct 2023 16:15:35 +0200 Subject: [PATCH 22/92] Formatting. --- .../GlobalStateTests/DifferenceMap.hs | 23 +++++++------- .../GlobalStateTests/LMDBAccountMap.hs | 31 ++++++++++--------- .../tests/globalstate/Spec.hs | 2 +- 3 files changed, 30 insertions(+), 26 deletions(-) diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs index 67bbf013b0..ffaee6d7e6 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs @@ -1,17 +1,18 @@ {-# LANGUAGE BangPatterns #-} + -- | A module that tests the functionality of the 'DiffMap.DifferenceMap'. -- * Insert and lookup operations. -- * Flattening the 'DiffMap.DifferenceMap'. module GlobalStateTests.DifferenceMap where -import Concordium.Types import Concordium.ID.Types (randomAccountAddress) +import Concordium.Types import System.Random import qualified Concordium.GlobalState.AccountMap.DifferenceMap as DiffMap -import Test.Hspec import Test.HUnit +import Test.Hspec import Test.QuickCheck -- | Create a pair consisting of an account address and an account index based on the provided seed. @@ -32,20 +33,20 @@ testInsertAccount = do testInsertAccountsAndRetrieveAll :: Assertion testInsertAccountsAndRetrieveAll = do let allAccounts = DiffMap.flatten $ mkDiffMaps 42 - if length allAccounts /= 42*43 - then assertFailure $ "Unexpected number of accounts in difference maps: " <> show (length allAccounts) + if length allAccounts /= 42 * 43 + then assertFailure $ "Unexpected number of accounts in difference maps: " <> show (length allAccounts) else pure () where -- create a difference map with n parents and n accounts at each layer, so n+1 difference maps in total. mkDiffMaps n = go n n $ DiffMap.empty Nothing where - go 0 _ accum = accum - go childCount numAccounts !accum = - let dmAccounts = [pair | pair <- dummyPair <$> [0..numAccounts]] - dmParentMap = Just $ go (childCount - 1) numAccounts $ DiffMap.empty $ Just accum - in DiffMap.DifferenceMap {..} + go 0 _ accum = accum + go childCount numAccounts !accum = + let dmAccounts = [pair | pair <- dummyPair <$> [0 .. numAccounts]] + dmParentMap = Just $ go (childCount - 1) numAccounts $ DiffMap.empty $ Just accum + in DiffMap.DifferenceMap{..} tests :: Spec tests = describe "AccountMap.DifferenceMap" $ do - it "Test insert account" testInsertAccount - it "Test retrieve all accounts from difference maps" testInsertAccountsAndRetrieveAll + it "Test insert account" testInsertAccount + it "Test retrieve all accounts from difference maps" testInsertAccountsAndRetrieveAll diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs index d3af381243..8491381fd0 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs @@ -1,27 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- Tests of the LMDB account map related operations. + -- | Tests for the LMDB account map -- This module tests the following: -- * Accounts can be inserted. -- * Accounts can be looked up. -- * Accounts can be rolled back. -{-# LANGUAGE OverloadedStrings #-} --- Tests of the LMDB account map related operations. module GlobalStateTests.LMDBAccountMap where -import Prelude hiding (lookup) +import Control.Exception (bracket) import Control.Monad.Reader import System.IO.Temp -import Control.Exception (bracket) import System.Random +import Prelude hiding (lookup) import qualified Concordium.Crypto.SHA256 as Hash +import Concordium.ID.Types (randomAccountAddress) import Concordium.Logger import Concordium.Types -import Concordium.ID.Types (randomAccountAddress) import Concordium.GlobalState.AccountMap.LMDB -import Test.Hspec import Test.HUnit +import Test.Hspec -- | Create a pair consisting of an account address and an account index based on the provided seed. dummyPair :: Int -> (AccountAddress, AccountIndex) @@ -37,7 +39,7 @@ anotherDummyBlockHash = BlockHash $ Hash.hash "another dummy block hash" -- | Helper function for running a test in a context which has access to a temporary lmdb store. runTest :: - String -> + String -> AccountMapStoreMonad (ReaderT DatabaseHandlers LogIO) a -> IO a runTest dirName action = withTempDirectory "" dirName $ \path -> @@ -66,11 +68,11 @@ testCheckDbInitialized = runTest "initialized" $ do Just (blockHash, blockHeight) -> liftIO $ do assertEqual "block hash should correspond to the one used when last inserting" dummyBlockHash blockHash assertEqual "block height should correspond to the one used when last inserting" (BlockHeight 1) blockHeight - + -- | Test that inserts a set of accounts and afterwards asserts that they are present. testInsertAndLookupAccounts :: Assertion testInsertAndLookupAccounts = runTest "insertandlookups" $ do - let accounts = [acc | acc <- dummyPair <$> [1..42]] + let accounts = [acc | acc <- dummyPair <$> [1 .. 42]] void $ insert dummyBlockHash (BlockHeight 1) accounts forM_ accounts $ \(accAddr, accIndex) -> do @@ -102,14 +104,15 @@ testRollback = runTest "rollback" $ do -- roll back one block. lookup (fst $ dummyPair 2) >>= \case Nothing -> liftIO $ assertFailure "account should be present" - Just _ -> do + Just _ -> do void $ unsafeRollback [(fst $ dummyPair 2)] dummyBlockHash (BlockHeight 1) lookup (fst $ dummyPair 2) >>= \case Just _ -> liftIO $ assertFailure "account should have been deleted" - Nothing -> lookup (fst $ dummyPair 1) >>= \case - Nothing -> liftIO $ assertFailure "Accounts from first block should still remain in the lmdb store" - Just accIdx -> liftIO $ assertEqual "The account index of the first account should be the same" (snd $ dummyPair 1) accIdx - + Nothing -> + lookup (fst $ dummyPair 1) >>= \case + Nothing -> liftIO $ assertFailure "Accounts from first block should still remain in the lmdb store" + Just accIdx -> liftIO $ assertEqual "The account index of the first account should be the same" (snd $ dummyPair 1) accIdx + tests :: Spec tests = describe "AccountMap.LMDB" $ do it "Test checking db is not initialized" testCheckNotInitialized diff --git a/concordium-consensus/tests/globalstate/Spec.hs b/concordium-consensus/tests/globalstate/Spec.hs index 2d5c41dbdf..9b83df6211 100644 --- a/concordium-consensus/tests/globalstate/Spec.hs +++ b/concordium-consensus/tests/globalstate/Spec.hs @@ -9,6 +9,7 @@ import qualified GlobalStateTests.Accounts (tests) import qualified GlobalStateTests.BlobStore (tests) import qualified GlobalStateTests.BlockHash (tests) import qualified GlobalStateTests.Cache (tests) +import qualified GlobalStateTests.DifferenceMap (tests) import qualified GlobalStateTests.EnduringDataFlags (tests) import qualified GlobalStateTests.FinalizationSerializationSpec (tests) import qualified GlobalStateTests.Instances (tests) @@ -18,7 +19,6 @@ import qualified GlobalStateTests.PersistentTreeState (tests) import qualified GlobalStateTests.Trie (tests) import qualified GlobalStateTests.UpdateQueues (tests) import qualified GlobalStateTests.Updates (tests) -import qualified GlobalStateTests.DifferenceMap (tests) import System.Environment import Test.Hspec From bab9433f84e85bf1aa0ef9c8ade468844e74e640 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Fri, 20 Oct 2023 10:32:54 +0200 Subject: [PATCH 23/92] Cleanup and make sure that new Accounts backed by lmdb works as basic one. --- .../GlobalState/AccountMap/DifferenceMap.hs | 58 ++++---- .../Concordium/GlobalState/AccountMap/LMDB.hs | 139 +++++++----------- .../Concordium/GlobalState/LMDB/Helpers.hs | 22 ++- .../GlobalState/Persistent/Accounts.hs | 78 +++++----- .../GlobalState/Persistent/BlockState.hs | 17 +-- .../GlobalState/Persistent/Genesis.hs | 10 +- .../KonsensusV1/TreeState/LowLevel/LMDB.hs | 6 +- .../globalstate/GlobalStateTests/Accounts.hs | 50 ++----- .../GlobalStateTests/DifferenceMap.hs | 53 ++++--- .../GlobalStateTests/LMDBAccountMap.hs | 90 ++++++------ 10 files changed, 235 insertions(+), 288 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index 3bc519037f..93cd32efd2 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -1,13 +1,11 @@ -{-# LANGUAGE TemplateHaskell #-} - +{-# LANGUAGE BangPatterns #-} -- | The 'DifferenceMap' stores accounts have been created in a non-finalized block. -- When a block is being finalized then the assoicated 'DifferenceMap' must be written -- to disk via 'Concordium.GlobalState.AccountMap.LMDB.insert'. module Concordium.GlobalState.AccountMap.DifferenceMap where -import qualified Data.List as List -import Lens.Micro.Platform import Prelude hiding (lookup) +import qualified Data.Map.Strict as Map import Concordium.Types @@ -15,55 +13,51 @@ import Concordium.Types -- a block identified by a 'BlockHash' and its associated 'BlockHeight'. -- The difference map only contains accounds that was added since the '_dmParentMap'. data DifferenceMap = DifferenceMap - { -- | Accounts added to the chain in the - -- block 'amdmLfbHash'. - -- Note. The list is in descending order of the 'AccountIndex'. - -- TODO: Use Ordered set or a sequence instead? - dmAccounts :: ![(AccountAddress, AccountIndex)], + { -- | Accounts added in a block. + dmAccounts :: !(Map.Map AccountAddress AccountIndex), -- | Parent map of non-finalized blocks. -- In other words, if the parent block is finalized, - -- then the parent map is @Nothing@ as the LMDB account map + -- then the parent map is @Notnhing@ as the LMDB account map -- should be consulted instead. dmParentMap :: !(Maybe DifferenceMap) } deriving (Eq, Show) -makeClassy ''DifferenceMap - -- | Gather all accounts from the provided 'DifferenceMap' and its parent maps. -flatten :: DifferenceMap -> [(AccountAddress, AccountIndex)] -flatten dmap = go (Just dmap) [] +-- Accounts are returned in ascending order of their 'AccountIndex'. +flatten :: DifferenceMap -> Map.Map AccountAddress AccountIndex +flatten dmap = go (Just dmap) Map.empty where - go :: Maybe DifferenceMap -> [(AccountAddress, AccountIndex)] -> [(AccountAddress, AccountIndex)] + go :: Maybe DifferenceMap -> Map.Map AccountAddress AccountIndex -> Map.Map AccountAddress AccountIndex go Nothing accum = accum - go (Just DifferenceMap{..}) accum = go dmParentMap $! dmAccounts ++ accum + go (Just DifferenceMap{..}) !accum = go dmParentMap $ dmAccounts `Map.union` accum -- | Create a new empty 'DifferenceMap' based on the difference map of -- the parent. empty :: Maybe DifferenceMap -> DifferenceMap empty mParentDifferenceMap = DifferenceMap - { dmAccounts = [], + { dmAccounts = Map.empty, dmParentMap = mParentDifferenceMap } --- | Check if an account exists in the difference map or any of the parent +-- | Lookup an account in the difference map or any of the parent -- difference maps. -- Returns @Just AccountIndex@ if the account is present and -- otherwise @Nothing@. --- Note. It is up to the caller to check whether the account exists in the last finalized block. lookup :: AccountAddress -> DifferenceMap -> Maybe AccountIndex -lookup addr DifferenceMap{..} = - case List.lookup addr dmAccounts of - Nothing -> case dmParentMap of - Nothing -> Nothing - Just parentMap -> lookup addr parentMap - Just idx -> Just idx - --- | Insert an account into the difference and return @Just AccountIndex@ if the --- account was added and @Nothing@ if it was already present. +lookup addr = check + where + check DifferenceMap{..} = case Map.lookupGE k dmAccounts of + Nothing -> check =<< dmParentMap + Just (foundAccAddr, accIdx) -> + if checkEquivalence foundAccAddr + then Just accIdx + else Nothing + k = createAlias addr 0 + checkEquivalence found = accountAddressEmbed k == accountAddressEmbed found + +-- | Insert an account into the difference map. +-- Note that it is up to the caller to ensure only the canonical 'AccountAddress' is added. insert :: AccountAddress -> AccountIndex -> DifferenceMap -> DifferenceMap -insert addr accIndex diffMap = - diffMap - { dmAccounts = (addr, accIndex) : dmAccounts diffMap - } +insert addr accIndex m = m{dmAccounts = Map.insert addr accIndex $ dmAccounts m} diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index 8daff4579e..e046216fbd 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -7,13 +7,12 @@ {-# LANGUAGE UndecidableInstances #-} -- | This module exposes an account map backed by a LMDB database. --- The ‘AccountMap’ is a simple key/value store where the keys consists --- of the first 29 bytes of an ‘AccountAddress’ and the values are the --- associated ‘AccountIndex’. +-- The ‘AccountMap’ is a simple key/value store where the keys consists of the +-- canonical 'AccountAddress' and the values are the assoicated 'AccountIndex'. -- --- The LMDB account map only stores finalized accounts. --- Non finalized accounts are being kept in a 'DifferenceMap' which --- is being written to this LMDB account map when a block is finalized. +-- The LMDB account map only stores accounts that are persisted (created in a certified or finalized block). +-- Non certified/finalized accounts are being kept in a 'DifferenceMap' which +-- is being written to this LMDB account map when a block is being persisted. -- -- As opposed to the account table of the block state this database does not -- include historical data i.e., the state of this database is from the perspective @@ -38,13 +37,13 @@ import Control.Monad.State.Strict import Control.Monad.Trans.Except import Control.Monad.Trans.Writer.Strict import qualified Data.ByteString as BS -import Data.Data (Data, Typeable) +import qualified Data.FixedByteString as FBS +import Data.Data (Typeable) import Data.Kind (Type) -import qualified Data.Serialize as S import Database.LMDB.Raw import Lens.Micro.Platform import System.Directory -import Prelude hiding (lookup) +import Prelude hiding (lookup, all) import Concordium.GlobalState.Classes import Concordium.GlobalState.LMDB.Helpers @@ -52,7 +51,6 @@ import Concordium.Logger import Concordium.TimeMonad import Concordium.Types import Concordium.Utils.Serialization.Put -import qualified Data.FixedByteString as FBS -- * Exceptions @@ -76,85 +74,50 @@ instance Exception DatabaseInvariantViolation where -- * The class (Monad m) => MonadAccountMapStore m where -- | Adds the accounts to the underlying store. - insert :: BlockHash -> BlockHeight -> [(AccountAddress, AccountIndex)] -> m () + insert :: [(AccountAddress, AccountIndex)] -> m () - -- | Looks up the ‘AccountIndex’ for the provided ‘AccountAddress’. + -- | Looks up the ‘AccountIndex’ for the provided ‘AccountAddress’ by using the + -- equivalence class 'AccountAddressEq'. -- Returns @Just AccountIndex@ if the account is present in the ‘AccountMap’ -- and returns @Nothing@ if the account was not present. lookup :: AccountAddress -> m (Maybe AccountIndex) + -- | Return all the canonical addresses of accounts present + -- in the store. + all :: m [(AccountAddress, AccountIndex)] + instance (Monad (t m), MonadTrans t, MonadAccountMapStore m) => MonadAccountMapStore (MGSTrans t m) where - insert bh height = lift . insert bh height + insert = lift . insert lookup = lift . lookup + all = lift all {-# INLINE insert #-} {-# INLINE lookup #-} + {-# INLINE all #-} deriving via (MGSTrans (StateT s) m) instance (MonadAccountMapStore m) => MonadAccountMapStore (StateT s m) deriving via (MGSTrans (ExceptT e) m) instance (MonadAccountMapStore m) => MonadAccountMapStore (ExceptT e m) deriving via (MGSTrans (WriterT w) m) instance (Monoid w, MonadAccountMapStore m) => MonadAccountMapStore (WriterT w m) instance (MonadAccountMapStore m) => MonadAccountMapStore (PutT m) where - insert bh height = lift . insert bh height + insert = lift . insert lookup = lift . lookup + all = lift all -- * Database stores --- | Store that yields the last finalized block from the perspective --- of the lmdb database. -newtype MetadataStore = MetadataStore MDB_dbi' - --- | Name of the 'MetadataStore' -metadataStoreName :: String -metadataStoreName = "metadata" - -- | Store that retains the account address -> account index mappings. newtype AccountMapStore = AccountMapStore MDB_dbi' accountMapStoreName :: String accountMapStoreName = "accounts" --- | We only store the first 29 bytes of the account address --- as these uniquely determine the account. --- The remaining 3 bytes of an account address are used for the --- account aliasing feature. -prefixAccountAddressSize :: Int -prefixAccountAddressSize = 29 - -data PrefixAccountAddressSize - deriving (Data, Typeable) - -instance FBS.FixedLength PrefixAccountAddressSize where - fixedLength _ = prefixAccountAddressSize - --- | The prefix account address which is used as keys in the underlying store. -newtype PrefixAccountAddress = PrefixAccountAddress (FBS.FixedByteString PrefixAccountAddressSize) - -instance S.Serialize PrefixAccountAddress where - put (PrefixAccountAddress addr) = S.putByteString $ FBS.toByteString addr - get = PrefixAccountAddress . FBS.fromByteString <$> S.getByteString prefixAccountAddressSize - --- | Create a 'PrefixAccountAddress' from the supplied 'AccountAddress'. --- The 'PrefixAccountAddress' is the first 29 bytes of the original 'AccountAddress'. -accountAddressToPrefixAccountAddress :: AccountAddress -> PrefixAccountAddress -accountAddressToPrefixAccountAddress (AccountAddress afbs) = toPrefixAccountAddress $ FBS.toByteString afbs - where - toPrefixAccountAddress = PrefixAccountAddress . FBS.fromByteString . first29Bytes - first29Bytes = BS.take prefixAccountAddressSize - instance MDBDatabase AccountMapStore where - type DBKey AccountMapStore = PrefixAccountAddress + type DBKey AccountMapStore = AccountAddress type DBValue AccountMapStore = AccountIndex -lfbKey :: DBKey MetadataStore -lfbKey = "lfb" - -instance MDBDatabase MetadataStore where - type DBKey MetadataStore = BS.ByteString - type DBValue MetadataStore = (BlockHash, BlockHeight) data DatabaseHandlers = DatabaseHandlers { _storeEnv :: !StoreEnv, - _metadataStore :: !MetadataStore, _accountMapStore :: !AccountMapStore } makeClassy ''DatabaseHandlers @@ -244,12 +207,6 @@ makeDatabaseHandlers accountMapDir readOnly initSize = do txn (Just accountMapStoreName) [MDB_CREATE | not readOnly] - _metadataStore <- - MetadataStore - <$> mdb_dbi_open' - txn - (Just metadataStoreName) - [MDB_CREATE | not readOnly] return DatabaseHandlers{..} -- | Initialize database handlers in ReadWrite mode. @@ -301,26 +258,28 @@ asWriteTransaction t = do (LMDB_Error _ _ (Right MDB_MAP_FULL)) -> Just () _ -> Nothing --- | Check if the database is initialized. +-- | Check if the database is initialized (i.e. whether any accounts are present in the map). -- If the database is initialized then the function will return --- @Just (BlockHash, BlockHeight)@ for the last finalized block. --- If the database has not yet been initialized via 'initialize' then --- this function will return @Nothing@. -isInitialized :: (MonadIO m) => DatabaseHandlers -> m (Maybe (BlockHash, BlockHeight)) -isInitialized dbh = - liftIO $ transaction (dbh ^. storeEnv) True $ \txn -> getLfb txn - where - getLfb txn = loadRecord txn (dbh ^. metadataStore) lfbKey +-- @True@ and otherwise @False@. +isInitialized :: (MonadIO m) => DatabaseHandlers -> m Bool +isInitialized dbh = liftIO $ transaction (dbh ^. storeEnv) True $ \txn -> (/= 0) <$> databaseSize txn (dbh ^. accountMapStore) -- | Perform an unsafe roll back of the LMDB store. -- This function deletes the provided accounts from the store and sets the last finalized block -- to the provided hash and height. -unsafeRollback :: (MonadIO m, MonadLogger m, MonadReader r m, HasDatabaseHandlers r) => [AccountAddress] -> BlockHash -> BlockHeight -> m () -unsafeRollback accounts lfbHash lfbHeight = do +-- +-- It is to be considered unsafe as it does not +unsafeRollback :: (MonadIO m, MonadLogger m, MonadReader r m, HasDatabaseHandlers r) => [AccountAddress] -> m () +unsafeRollback accounts = do handlers <- ask flip runReaderT handlers $ runAccountMapStoreMonad $ asWriteTransaction $ \dbh txn -> do - forM_ accounts $ \accAddr -> deleteRecord txn (dbh ^. accountMapStore) $ accountAddressToPrefixAccountAddress accAddr - storeReplaceRecord txn (dbh ^. metadataStore) lfbKey (lfbHash, lfbHeight) + forM_ accounts $ \accAddr -> deleteRecord txn (dbh ^. accountMapStore) accAddr + +-- | When looking up accounts we perform a prefix search as we +-- store the canonical account addresses in the lmdb store and we +-- need to be able to lookup account aliases. +prefixAccountAddressSize :: Int +prefixAccountAddressSize = 29 instance ( MonadReader r m, @@ -330,14 +289,28 @@ instance ) => MonadAccountMapStore (AccountMapStoreMonad m) where - insert lfbHash lfbHeight differenceMap = asWriteTransaction $ \dbh txn -> doInsert dbh txn differenceMap + insert differenceMap = asWriteTransaction $ \dbh txn -> doInsert dbh txn differenceMap where doInsert dbh txn accounts = do forM_ accounts $ \(accAddr, accIndex) -> do - let addr = accountAddressToPrefixAccountAddress accAddr - storeRecord txn (dbh ^. accountMapStore) addr accIndex - storeReplaceRecord txn (dbh ^. metadataStore) lfbKey (lfbHash, lfbHeight) + storeRecord txn (dbh ^. accountMapStore) accAddr accIndex return $ Just accIndex - lookup accAddr = asReadTransaction $ \dbh txn -> - loadRecord txn (dbh ^. accountMapStore) $ accountAddressToPrefixAccountAddress accAddr + lookup a@(AccountAddress accAddr) = asReadTransaction $ \dbh txn -> + withCursor txn (dbh ^. accountMapStore) $ \cursor -> do + withMDB_val accLookupKey $ \k -> do + getCursor (CursorMoveTo k) cursor >>= \case + Nothing -> return Nothing + Just (Left err) -> throwM $ DatabaseInvariantViolation err + Just (Right (foundAccAddr, accIdx)) -> + if checkEquivalence a foundAccAddr + then return $ Just accIdx + else return Nothing + where + -- The key to use for looking up an account. + -- We do a prefix lookup on the first 29 bytes of the account address as + -- the last 3 bytes are reserved for aliases. + accLookupKey = BS.take prefixAccountAddressSize $ FBS.toByteString accAddr + checkEquivalence x y = accountAddressEmbed x == accountAddressEmbed y + + all = asReadTransaction $ \dbh txn -> loadAll txn (dbh ^. accountMapStore) diff --git a/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs b/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs index d96530778f..22597d2f0e 100644 --- a/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs +++ b/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs @@ -43,6 +43,7 @@ module Concordium.GlobalState.LMDB.Helpers ( -- * Low level operations. byteStringFromMDB_val, unsafeByteStringFromMDB_val, + withMDB_val ) where @@ -415,11 +416,17 @@ data CursorMove CursorNext | -- | Move to the previous key CursorPrevious + | -- | Move to key greater than or equal to provided key. + CursorMoveTo MDB_val -- | Move a cursor and read the key and value at the new location. getPrimitiveCursor :: CursorMove -> PrimitiveCursor -> IO (Maybe (MDB_val, MDB_val)) getPrimitiveCursor movement PrimitiveCursor{..} = do - res <- mdb_cursor_get' moveOp pcCursor pcKeyPtr pcValPtr + res <- case mKey of + Nothing -> mdb_cursor_get' moveOp pcCursor pcKeyPtr pcValPtr + Just k -> do + poke pcKeyPtr k + mdb_cursor_get' moveOp pcCursor pcKeyPtr pcValPtr if res then do key <- peek pcKeyPtr @@ -427,12 +434,13 @@ getPrimitiveCursor movement PrimitiveCursor{..} = do return $ Just (key, val) else return Nothing where - moveOp = case movement of - CursorCurrent -> MDB_GET_CURRENT - CursorFirst -> MDB_FIRST - CursorLast -> MDB_LAST - CursorNext -> MDB_NEXT - CursorPrevious -> MDB_PREV + (moveOp, mKey) = case movement of + CursorCurrent -> (MDB_GET_CURRENT, Nothing) + CursorFirst -> (MDB_FIRST, Nothing) + CursorLast -> (MDB_LAST, Nothing) + CursorNext -> (MDB_NEXT, Nothing) + CursorPrevious -> (MDB_PREV, Nothing) + CursorMoveTo k -> (MDB_SET_RANGE, Just k) -- | Move a cursor to a specified key. movePrimitiveCursor :: MDB_val -> PrimitiveCursor -> IO (Maybe MDB_val) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index f4e20ac404..fa1d1129a0 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -19,7 +19,6 @@ import Data.Foldable (foldlM) import qualified Data.Map.Strict as Map import Data.Maybe import Data.Serialize -import Lens.Micro.Platform import Concordium.GlobalState.Persistent.Account import Concordium.GlobalState.Persistent.BlobStore @@ -78,14 +77,19 @@ data Accounts (pv :: ProtocolVersion) = Accounts accountRegIdHistory :: !(Trie.TrieN UnbufferedFix ID.RawCredentialRegistrationID AccountIndex) } --- todo doc +-- | An 'Accounts' with an assoicated ' DiffMap.DifferenceMap'. +-- The 'DiffMap.DifferenceMap' includes a mapping @AccountAddress -> AccountIndex@ for accounts +-- which have been added to a block which have not been persisted yet (certified or finalized). +-- +-- For blocks which have been persisted the 'DiffMap.DifferenceMap' is @Nothing@ as potential new +-- accounts have been written to the lmdb account map. data AccountsAndDiffMap (pv :: ProtocolVersion) = AccountsAndDiffMap { -- | The persistent accounts and what is stored on disk. aadAccounts :: !(Accounts pv), -- | An in-memory difference map used keeping track of accounts -- added in live blocks. - -- This is 'Nothing' If the block is persisted. - aadDiffMap :: !(Maybe DiffMap.DifferenceMap) + -- This is empty for a frozen block state. + aadDiffMap :: !DiffMap.DifferenceMap } instance (IsProtocolVersion pv) => Show (AccountsAndDiffMap pv) where @@ -108,9 +112,10 @@ instance (SupportsPersistentAccount pv m) => MHashableTo m H.Hash (AccountsAndDi getHashM AccountsAndDiffMap{..} = getHashM $ accountTable aadAccounts instance (SupportsPersistentAccount pv m) => BlobStorable m (AccountsAndDiffMap pv) where - storeUpdate AccountsAndDiffMap{aadAccounts = Accounts{..}} = do + storeUpdate AccountsAndDiffMap{aadAccounts = Accounts{..},..} = do (pTable, accountTable') <- storeUpdate accountTable (pRegIdHistory, regIdHistory') <- storeUpdate accountRegIdHistory + LMDBAccountMap.insert (Map.toList $ DiffMap.flatten aadDiffMap) let newAccounts = AccountsAndDiffMap { aadAccounts = @@ -118,7 +123,7 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (AccountsAndDiffMap { accountTable = accountTable', accountRegIdHistory = regIdHistory' }, - aadDiffMap = Nothing + aadDiffMap = DiffMap.empty $ Just aadDiffMap } return (pTable >> pRegIdHistory, newAccounts) load = do @@ -127,7 +132,7 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (AccountsAndDiffMap return $ do accountTable <- maccountTable accountRegIdHistory <- mrRIH - return $ AccountsAndDiffMap{aadAccounts = Accounts{..}, aadDiffMap = Nothing} + return $ AccountsAndDiffMap{aadAccounts = Accounts{..}, aadDiffMap = DiffMap.empty Nothing} instance (SupportsPersistentAccount pv m, av ~ AccountVersionFor pv) => Cacheable1 m (AccountsAndDiffMap pv) (PersistentAccount av) where liftCache cch aad@AccountsAndDiffMap{aadAccounts = accts@Accounts{..}} = do @@ -138,14 +143,14 @@ instance (SupportsPersistentAccount pv m, av ~ AccountVersionFor pv) => Cacheabl emptyAccounts :: Accounts pv emptyAccounts = Accounts L.empty Trie.empty --- | Creates an empty 'AccountsAndDifferenceMap' +-- | Creates an empty 'AccountsAndDifferenceMap'. -- If the 'AccountsAndDifferenceMap' is created when thawing a block state (i.e. for creating a new block) -- then the 'AccountsAndDifferenceMap' of the successor block must be provided. -- On the other hand when loading the accounts in order to support a query, then -- simply pass in 'Nothing'. -emptyAcocuntsAndDiffMap :: Maybe (AccountsAndDiffMap pv) -> AccountsAndDiffMap pv -emptyAcocuntsAndDiffMap Nothing = AccountsAndDiffMap emptyAccounts Nothing -emptyAcocuntsAndDiffMap (Just successor) = AccountsAndDiffMap emptyAccounts $ Just (DiffMap.empty $ aadDiffMap successor) +emptyAccountsAndDiffMap :: Maybe (AccountsAndDiffMap pv) -> AccountsAndDiffMap pv +emptyAccountsAndDiffMap Nothing = AccountsAndDiffMap emptyAccounts $ DiffMap.empty Nothing +emptyAccountsAndDiffMap (Just successor) = AccountsAndDiffMap emptyAccounts $ DiffMap.empty (Just $ aadDiffMap successor) -- | Add a new account. Returns @Just idx@ if the new account is fresh, i.e., the address does not exist, -- or @Nothing@ in case the account already exists. In the latter case there is no change to the accounts structure. @@ -153,7 +158,7 @@ putNewAccount :: (SupportsPersistentAccount pv m) => PersistentAccount (AccountV putNewAccount !acct a0@AccountsAndDiffMap{aadAccounts = accts0@Accounts{..}, ..} = do addr <- accountCanonicalAddress acct -- Check whether the account is in a non-finalized block. - case DiffMap.lookup addr =<< aadDiffMap of + case DiffMap.lookup addr aadDiffMap of -- The account is already present in the difference map. Just _ -> return (Nothing, a0) -- The account is not present in the difference map so we will have to @@ -163,16 +168,14 @@ putNewAccount !acct a0@AccountsAndDiffMap{aadAccounts = accts0@Accounts{..}, ..} existingAccountId <- LMDBAccountMap.lookup addr if isNothing existingAccountId then do - (_, newAccountTable) <- L.append acct accountTable - let dm1 = DiffMap.insert addr acctIndex <$> aadDiffMap - return (Just acctIndex, a0{aadAccounts = accts0{accountTable = newAccountTable}, aadDiffMap = dm1}) + (accIdx, newAccountTable) <- L.append acct accountTable + let dm1 = DiffMap.insert addr accIdx aadDiffMap + return (Just accIdx, a0{aadAccounts = accts0{accountTable = newAccountTable}, aadDiffMap = dm1}) else return (Nothing, a0) - where - acctIndex = fromIntegral $ L.size accountTable -- | Construct an 'Accounts' from a list of accounts. Inserted in the order of the list. fromList :: (SupportsPersistentAccount pv m) => [PersistentAccount (AccountVersionFor pv)] -> m (AccountsAndDiffMap pv) -fromList = foldlM insert $ emptyAcocuntsAndDiffMap Nothing +fromList = foldlM insert $ emptyAccountsAndDiffMap Nothing where insert accounts account = snd <$> putNewAccount account accounts @@ -184,7 +187,7 @@ exists addr accts = isJust <$> getAccountIndex addr accts -- Returns @Nothing@ if no such account exists. getAccount :: (SupportsPersistentAccount pv m) => AccountAddress -> AccountsAndDiffMap pv -> m (Maybe (PersistentAccount (AccountVersionFor pv))) getAccount addr AccountsAndDiffMap{..} = - case DiffMap.lookup addr =<< aadDiffMap of + case DiffMap.lookup addr aadDiffMap of Just ai -> fetchFromTable ai Nothing -> LMDBAccountMap.lookup addr >>= \case @@ -203,12 +206,13 @@ getAccountByCredId cid accs@AccountsAndDiffMap{..} = -- | Get the account at a given index (if any). getAccountIndex :: (IsProtocolVersion pv, LMDBAccountMap.MonadAccountMapStore m) => AccountAddress -> AccountsAndDiffMap pv -> m (Maybe AccountIndex) -getAccountIndex addr AccountsAndDiffMap{..} = case DiffMap.lookup addr =<< aadDiffMap of - Just accIdx -> return $ Just accIdx - Nothing -> - LMDBAccountMap.lookup addr >>= \case - Nothing -> return Nothing - Just accIdx -> return $ Just accIdx +getAccountIndex addr AccountsAndDiffMap{..} = + case DiffMap.lookup addr aadDiffMap of + Just accIdx -> return $ Just accIdx + Nothing -> + LMDBAccountMap.lookup addr >>= \case + Nothing -> return Nothing + Just accIdx -> return $ Just accIdx -- | Retrieve an account and its index from a given address. -- Returns @Nothing@ if no such account exists. @@ -222,14 +226,6 @@ getAccountWithIndex addr AccountsAndDiffMap{..} = indexedAccount :: (SupportsPersistentAccount pv m) => AccountIndex -> AccountsAndDiffMap pv -> m (Maybe (PersistentAccount (AccountVersionFor pv))) indexedAccount ai AccountsAndDiffMap{..} = L.lookup ai (accountTable aadAccounts) --- | Retrieve an account with the given address. --- An account with the address is required to exist. -unsafeGetAccount :: (SupportsPersistentAccount pv m) => AccountAddress -> AccountsAndDiffMap pv -> m (PersistentAccount (AccountVersionFor pv)) -unsafeGetAccount addr accountsAndDiffMap = - getAccount addr accountsAndDiffMap <&> \case - Just acct -> acct - Nothing -> error $ "unsafeGetAccount: Account " ++ show addr ++ " does not exist." - -- | Check that an account registration ID is not already on the chain. -- See the foundation (Section 4.2) for why this is necessary. -- Return @Just ai@ if the registration ID already exists, and @ai@ is the index of the account it is or was associated with. @@ -274,7 +270,7 @@ updateAccounts :: AccountsAndDiffMap pv -> m (Maybe (AccountIndex, a), AccountsAndDiffMap pv) updateAccounts fupd addr a0@AccountsAndDiffMap{aadAccounts = accs0@Accounts{..}, ..} = - case DiffMap.lookup addr =<< aadDiffMap of + case DiffMap.lookup addr aadDiffMap of Nothing -> LMDBAccountMap.lookup addr >>= \case Nothing -> return (Nothing, a0) @@ -305,12 +301,16 @@ updateAccountsAtIndex' fupd ai = fmap snd . updateAccountsAtIndex fupd' ai where fupd' = fmap ((),) . fupd +-- | Get a list of all account addresses and their assoicated account indices. +allAccountAddressesAndIndices :: (SupportsPersistentAccount pv m) => AccountsAndDiffMap pv -> m [(AccountAddress, AccountIndex)] +allAccountAddressesAndIndices accounts = do + allPersistedAccounts <- LMDBAccountMap.all + let inMemAccounts = Map.toList $ DiffMap.flatten $ aadDiffMap accounts + return $ allPersistedAccounts ++ inMemAccounts + -- | Get a list of all account addresses. --- TODO: This is probably not good enough, revise or at least test. accountAddresses :: (SupportsPersistentAccount pv m) => AccountsAndDiffMap pv -> m [AccountAddress] -accountAddresses accounts = do - accs <- (L.toAscList . accountTable) (aadAccounts accounts) - mapM accountCanonicalAddress accs +accountAddresses accounts = map fst <$> allAccountAddressesAndIndices accounts -- | Serialize accounts in V0 format. serializeAccounts :: (SupportsPersistentAccount pv m, MonadPut m) => GlobalContext -> AccountsAndDiffMap pv -> m () @@ -350,5 +350,5 @@ migrateAccounts migration AccountsAndDiffMap{aadAccounts = Accounts{..}} = do { accountTable = newAccountTable, accountRegIdHistory = newAccountRegIds }, - aadDiffMap = Nothing + aadDiffMap = DiffMap.empty Nothing } diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index bf723afa7b..f67c8a5f8b 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -934,7 +934,7 @@ emptyBlockState bspBirkParameters cryptParams keysCollection chainParams = do bsp <- makeBufferedRef $ BlockStatePointers - { bspAccounts = Accounts.emptyAcocuntsAndDiffMap Nothing, + { bspAccounts = Accounts.emptyAccountsAndDiffMap Nothing, bspInstances = Instances.emptyInstances, bspModules = modules, bspBank = makeHashed Rewards.emptyBankStatus, @@ -3546,11 +3546,8 @@ instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateOperatio bsoIsProtocolUpdateEffective = doIsProtocolUpdateEffective instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateStorage (PersistentBlockStateMonad pv r m) where - thawBlockState HashedPersistentBlockState{..} = do - bufferedPtrs <- liftIO $ readIORef hpbsPointers - ptrs0 <- loadBufferedRef bufferedPtrs - ptrs1 <- makeBufferedRef ptrs0{bspAccounts = Accounts.emptyAcocuntsAndDiffMap $ Just $ bspAccounts ptrs0} - liftIO $ newIORef ptrs1 -- todo fix this. If a blobref already exists then carry this over. + thawBlockState HashedPersistentBlockState{..} = + liftIO $ newIORef =<< readIORef hpbsPointers freezeBlockState pbs = hashBlockState pbs @@ -3569,14 +3566,6 @@ instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateStorage (!inner', !ref) <- flushBufferedRef inner liftIO $ writeIORef hpbsPointers inner' flushStore - -- todo: Write the the Account DifferenceMap to the LMDBAccountMap. - -- Note that for consensus version 1 this approach will write - -- accounts to the lmdb account map as blocks becomes certified also. - -- To support roll backs of certified blocks then, - -- accounts created in the rolled back blocks must be deleted from - -- the lmdb account map (these will be added again as the certified blocks - -- are potentially being executed once again) - -- This should be OK as roll backs happens under rare circumstances. return ref loadBlockState hpbsHashM ref = do diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Genesis.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Genesis.hs index 02ff923cd8..7ef9ebd46c 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Genesis.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Genesis.hs @@ -86,7 +86,7 @@ data VersionedCoreGenesisParameters (pv :: Types.ProtocolVersion) where -- It is then used to construct the initial block state from genesis. data AccumGenesisState pv = AccumGenesisState { -- | Tracking all the accounts. - agsAllAccounts :: !(Accounts.Accounts pv), + agsAllAccounts :: !(Accounts.AccountsAndDiffMap pv), -- | Collection of the IDs of the active bakers. agsBakerIds :: !(Bakers.BakerIdTrieMap (Types.AccountVersionFor pv)), -- | Collection of the aggregation keys of the active bakers. @@ -113,7 +113,7 @@ data AccumGenesisState pv = AccumGenesisState initialAccumGenesisState :: AccumGenesisState pv initialAccumGenesisState = AccumGenesisState - { agsAllAccounts = Accounts.emptyAccounts, + { agsAllAccounts = Accounts.emptyAccountsAndDiffMap Nothing, agsBakerIds = Trie.empty, agsBakerKeys = Trie.empty, agsTotal = 0, @@ -223,7 +223,7 @@ buildGenesisBlockState vcgp GenesisData.GenesisState{..} = do bsp <- Blob.refMakeFlushed $ BS.BlockStatePointers - { bspAccounts = Accounts.AccountsAndDiffMap agsAllAccounts Nothing, + { bspAccounts = agsAllAccounts, bspInstances = Instances.emptyInstances, bspModules = modules, bspBank = Types.makeHashed $ Rewards.makeGenesisBankStatus agsTotal, @@ -258,7 +258,7 @@ buildGenesisBlockState vcgp GenesisData.GenesisState{..} = do genesisChainParameters genesisAccount -- Insert the account - (maybeIndex, nextAccounts0) <- Accounts.putNewAccount persistentAccount $ Accounts.AccountsAndDiffMap (agsAllAccounts state) Nothing + (maybeIndex, nextAccounts0) <- Accounts.putNewAccount persistentAccount (agsAllAccounts state) nextAccounts <- case maybeIndex of Nothing -> MTL.throwError "Duplicate account address in genesis accounts." Just ai -> @@ -267,7 +267,7 @@ buildGenesisBlockState vcgp GenesisData.GenesisState{..} = do in Accounts.recordRegIds newRegIds nextAccounts0 let !nextTotalAmount = agsTotal state + GenesisData.gaBalance genesisAccount - let !updatedState = state{agsAllAccounts = Accounts.aadAccounts nextAccounts, agsTotal = nextTotalAmount} + let !updatedState = state{agsAllAccounts = nextAccounts, agsTotal = nextTotalAmount} case GenesisData.gaBaker genesisAccount of Just baker@GenesisData.GenesisBaker{..} -> do diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs index 47820b82cc..2661ec0633 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs @@ -809,11 +809,7 @@ rollBackBlocksUntil checkState = do -- delete any accounts created in this block in the LMDB account map. let accountsToDelete = mapMaybe getAccountAddressFromDeployment (blockTransactions block) - let (parentBlockHash, parentBlockHeight) = case blockBakedData block of - Present b -> (blockParent b, blockHeight block - 1) - -- The block is the genesis block and thus we do not roll back further. - Absent -> (getHash block, blockHeight block) - void $ LMDBAccountMap.unsafeRollback accountsToDelete parentBlockHash parentBlockHeight + void $ LMDBAccountMap.unsafeRollback accountsToDelete -- Delete the block and the QC asWriteTransaction $ \dbh txn -> do void $ diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs index 6d2c5a25f7..4232e68c04 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-# OPTIONS_GHC -Wno-deprecations #-} module GlobalStateTests.Accounts where @@ -64,31 +66,21 @@ checkBinaryM bop x y sbop sx sy = do satisfied <- bop x y unless satisfied $ liftIO $ assertFailure $ "Not satisfied: " ++ sx ++ " (" ++ show x ++ ") " ++ sbop ++ " " ++ show y ++ " (" ++ sy ++ ")" --- | Helper function for getting accounts (potentially also parent maps) for a 'DiffMap.DifferenceMap'. -differenceMapToMap :: Maybe DiffMap.DifferenceMap -> Map.Map AccountAddress AccountIndex -differenceMapToMap Nothing = Map.empty -differenceMapToMap (Just diffMap) = Map.fromList $ go diffMap [] - where - go :: DiffMap.DifferenceMap -> [(AccountAddress, AccountIndex)] -> [(AccountAddress, AccountIndex)] - go (DiffMap.DifferenceMap accs Nothing) accum = accum ++ accs - go (DiffMap.DifferenceMap accs (Just parentMap)) accum = go parentMap $! accum ++ accs - -- | Check that a 'B.Accounts' and a 'P.AccountsAndDiffMap' are equivalent. --- That is, they have the same account table, and set of +-- That is, they have the same account map, account table, and set of -- use registration ids. -checkEquivalent :: (MonadBlobStore m, MonadFail m, MonadCache (PA.AccountCache (AccountVersionFor PV)) m) => B.Accounts PV -> P.AccountsAndDiffMap PV -> m () -checkEquivalent ba paAndDiffMap = do - let pam = differenceMapToMap $ P.aadDiffMap paAndDiffMap - checkBinary (==) (AccountMap.toMapPure (B.accountMap ba)) pam "==" "Basic account map" "Persistent account map" +checkEquivalent :: (P.SupportsPersistentAccount PV m, av ~ AccountVersionFor PV) => B.Accounts PV -> P.AccountsAndDiffMap PV -> m () +checkEquivalent ba pa@P.AccountsAndDiffMap{..} = do + addrsAndIndices <- P.allAccountAddressesAndIndices pa + checkBinary (==) (AccountMap.toMapPure (B.accountMap ba)) (Map.fromList addrsAndIndices) "==" "Basic account map" "Persistent account map" let bat = BAT.toList (B.accountTable ba) - let pa = P.aadAccounts paAndDiffMap - pat <- L.toAscPairList (P.accountTable pa) + pat <- L.toAscPairList (P.accountTable aadAccounts) bpat <- mapM (_2 PA.toTransientAccount) pat checkBinary (==) bat bpat "==" "Basic account table (as list)" "Persistent account table (as list)" let bath = getHash (B.accountTable ba) :: H.Hash - path <- getHashM (P.accountTable pa) + path <- getHashM (P.accountTable aadAccounts) checkBinary (==) bath path "==" "Basic account table hash" "Persistent account table hash" - pregids <- P.loadRegIds pa + pregids <- P.loadRegIds aadAccounts checkBinary (==) (B.accountRegIds ba) pregids "==" "Basic registration ids" "Persistent registration ids" data AccountAction @@ -96,7 +88,6 @@ data AccountAction | Exists AccountAddress | GetAccount AccountAddress | UpdateAccount AccountAddress (Account (AccountVersionFor PV) -> Account (AccountVersionFor PV)) - | UnsafeGetAccount AccountAddress | RegIdExists ID.CredentialRegistrationID | RecordRegId ID.CredentialRegistrationID AccountIndex | FlushPersistent @@ -138,7 +129,7 @@ randomActions = sized (ra Set.empty Map.empty) ++ if null s then [] else - [exExAcc, getExAcc, unsafeGetExAcc, updateExAcc] + [exExAcc, getExAcc, updateExAcc] ++ if null rids then [] else [exExReg, recExReg] where fresh x @@ -176,9 +167,6 @@ randomActions = sized (ra Set.empty Map.empty) if (vk, addr) `Set.member` s then ra s rids n else (UpdateAccount addr upd :) <$> ra s rids (n - 1) - unsafeGetExAcc = do - (_, addr) <- elements (Set.toList s) - (UnsafeGetAccount addr :) <$> ra s rids (n - 1) exRandReg = do rid <- randomCredential (RegIdExists rid :) <$> ra s rids (n - 1) @@ -194,7 +182,7 @@ randomActions = sized (ra Set.empty Map.empty) (rid, ai) <- elements (Map.toList rids) (RecordRegId rid ai :) <$> ra s rids (n - 1) -runAccountAction :: (LMDBAccountMap.MonadAccountMapStore m, MonadBlobStore m, MonadIO m, MonadCache (PA.AccountCache (AccountVersionFor PV)) m) => AccountAction -> (B.Accounts PV, P.AccountsAndDiffMap PV) -> m (B.Accounts PV, P.AccountsAndDiffMap PV) +runAccountAction :: (P.SupportsPersistentAccount PV m, av ~ AccountVersionFor PV) => AccountAction -> (B.Accounts PV, P.AccountsAndDiffMap PV) -> m (B.Accounts PV, P.AccountsAndDiffMap PV) runAccountAction (PutAccount acct) (ba, pa) = do let ba' = B.putNewAccount acct ba pAcct <- PA.makePersistentAccount acct @@ -220,12 +208,6 @@ runAccountAction (UpdateAccount addr upd) (ba, pa) = do PA.makePersistentAccount $ f bAcc (_, pa') <- P.updateAccounts (fmap ((),) . liftP upd) addr pa return (ba', pa') -runAccountAction (UnsafeGetAccount addr) (ba, pa) = do - let bacct = B.unsafeGetAccount addr ba - pacct <- P.unsafeGetAccount addr pa - bpacct <- PA.toTransientAccount pacct - checkBinary (==) bacct bpacct "==" "account in basic" "account in persistent" - return (ba, pa) runAccountAction FlushPersistent (ba, pa) = do (_, pa') <- storeUpdate pa return (ba, pa') @@ -245,15 +227,15 @@ runAccountAction (RecordRegId rid ai) (ba, pa) = do emptyTest :: SpecWith (PersistentBlockStateContext PV) emptyTest = - it "empty" $ - runBlobStoreM - (checkEquivalent B.emptyAccounts (P.emptyAcocuntsAndDiffMap Nothing) :: BlobStoreM' (PersistentBlockStateContext PV) ()) + it "empty" $ \bs -> + runNoLoggerT $ flip runBlobStoreT bs $ + (checkEquivalent B.emptyAccounts (P.emptyAccountsAndDiffMap Nothing) :: BlobStoreT (PersistentBlockStateContext PV) (NoLoggerT IO) ()) actionTest :: Word -> SpecWith (PersistentBlockStateContext PV) actionTest lvl = it "account actions" $ \bs -> withMaxSuccess (100 * fromIntegral lvl) $ property $ do acts <- randomActions return $ ioProperty $ runNoLoggerT $ flip runBlobStoreT bs $ do - (ba, pa) <- foldM (flip runAccountAction) (B.emptyAccounts, P.emptyAcocuntsAndDiffMap Nothing) acts + (ba, pa) <- foldM (flip runAccountAction) (B.emptyAccounts, P.emptyAccountsAndDiffMap @PV Nothing) acts checkEquivalent ba pa tests :: Word -> Spec diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs index ffaee6d7e6..8be818b70b 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs @@ -8,45 +8,54 @@ module GlobalStateTests.DifferenceMap where import Concordium.ID.Types (randomAccountAddress) import Concordium.Types import System.Random +import Control.Monad (when) +import qualified Data.Map.Strict as Map import qualified Concordium.GlobalState.AccountMap.DifferenceMap as DiffMap import Test.HUnit import Test.Hspec -import Test.QuickCheck -- | Create a pair consisting of an account address and an account index based on the provided seed. dummyPair :: Int -> (AccountAddress, AccountIndex) dummyPair seed = (fst $ randomAccountAddress (mkStdGen seed), AccountIndex $ fromIntegral seed) --- | Test that accounts can be inserted and looked up in the 'DiffMap.DifferenceMap'. -testInsertAccount :: Assertion -testInsertAccount = do - let diffMap = DiffMap.insert (fst acc) (snd acc) $ DiffMap.empty Nothing +-- | Test that an account can be inserted and looked up in the 'DiffMap.DifferenceMap'. +testInsertLookupAccount :: Assertion +testInsertLookupAccount = do + let diffMap = uncurry DiffMap.insert acc $ DiffMap.empty Nothing case DiffMap.lookup (fst acc) diffMap of Nothing -> assertFailure "account should be present in diff map" Just accIdx -> assertEqual "account should be there" (snd acc) accIdx where acc = dummyPair 1 --- | Test for getting all accounts in a 'DiffMap.DifferenceMap'. -testInsertAccountsAndRetrieveAll :: Assertion -testInsertAccountsAndRetrieveAll = do - let allAccounts = DiffMap.flatten $ mkDiffMaps 42 - if length allAccounts /= 42 * 43 - then assertFailure $ "Unexpected number of accounts in difference maps: " <> show (length allAccounts) - else pure () +testLookups :: Assertion +testLookups = do + let diffMap1 = uncurry DiffMap.insert (dummyPair 1) $ DiffMap.empty Nothing + diffMap2 = uncurry DiffMap.insert (dummyPair 2) (DiffMap.empty $ Just diffMap1) + diffMap3 = uncurry DiffMap.insert (dummyPair 3) (DiffMap.empty $ Just diffMap2) + checkExists (dummyPair 1) diffMap1 + checkExists (dummyPair 1) diffMap2 + checkExists (dummyPair 2) diffMap2 + checkExists (dummyPair 1) diffMap3 + checkExists (dummyPair 2) diffMap3 + checkExists (dummyPair 3) diffMap3 where - -- create a difference map with n parents and n accounts at each layer, so n+1 difference maps in total. - mkDiffMaps n = go n n $ DiffMap.empty Nothing - where - go 0 _ accum = accum - go childCount numAccounts !accum = - let dmAccounts = [pair | pair <- dummyPair <$> [0 .. numAccounts]] - dmParentMap = Just $ go (childCount - 1) numAccounts $ DiffMap.empty $ Just accum - in DiffMap.DifferenceMap{..} + checkExists pair diffMap = + case DiffMap.lookup (fst pair) diffMap of + Nothing -> assertFailure "account should be present" + Just accIdx -> assertEqual "wrong account index" (snd pair) accIdx + +testFlatten :: Assertion +testFlatten = do + let diffMap1 = uncurry DiffMap.insert (dummyPair 1) $ DiffMap.empty Nothing + diffMap2 = uncurry DiffMap.insert (dummyPair 2) (DiffMap.empty $ Just diffMap1) + diffMap3 = uncurry DiffMap.insert (dummyPair 3) (DiffMap.empty $ Just diffMap2) + assertEqual "accounts should be the same" (Map.fromList (map dummyPair [1..3])) $ DiffMap.flatten diffMap3 tests :: Spec tests = describe "AccountMap.DifferenceMap" $ do - it "Test insert account" testInsertAccount - it "Test retrieve all accounts from difference maps" testInsertAccountsAndRetrieveAll + it "Test insert and lookup account" testInsertLookupAccount + it "test lookups" testLookups + it "Test flatten" testFlatten diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs index 8491381fd0..3dade37c00 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs @@ -13,14 +13,13 @@ import Control.Exception (bracket) import Control.Monad.Reader import System.IO.Temp import System.Random -import Prelude hiding (lookup) +import Data.Maybe (isJust) -import qualified Concordium.Crypto.SHA256 as Hash import Concordium.ID.Types (randomAccountAddress) import Concordium.Logger import Concordium.Types -import Concordium.GlobalState.AccountMap.LMDB +import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import Test.HUnit import Test.Hspec @@ -29,87 +28,83 @@ import Test.Hspec dummyPair :: Int -> (AccountAddress, AccountIndex) dummyPair seed = (fst $ randomAccountAddress (mkStdGen seed), AccountIndex $ fromIntegral seed) --- | A dummy block hash -dummyBlockHash :: BlockHash -dummyBlockHash = BlockHash $ Hash.hash "a dummy block hash" - --- | Another dummy block hash -anotherDummyBlockHash :: BlockHash -anotherDummyBlockHash = BlockHash $ Hash.hash "another dummy block hash" - -- | Helper function for running a test in a context which has access to a temporary lmdb store. runTest :: String -> - AccountMapStoreMonad (ReaderT DatabaseHandlers LogIO) a -> + LMDBAccountMap.AccountMapStoreMonad (ReaderT LMDBAccountMap.DatabaseHandlers LogIO) a -> IO a runTest dirName action = withTempDirectory "" dirName $ \path -> bracket - (makeDatabaseHandlers path False 1000 :: IO (DatabaseHandlers)) - closeDatabase - (\dbhandlers -> runSilentLogger $ runReaderT (runAccountMapStoreMonad action) dbhandlers) + (LMDBAccountMap.makeDatabaseHandlers path False 1000 :: IO LMDBAccountMap.DatabaseHandlers) + LMDBAccountMap.closeDatabase + (\dbh -> runSilentLogger $ runReaderT (LMDBAccountMap.runAccountMapStoreMonad action) dbh) -- | Test that a database is not initialized. testCheckNotInitialized :: Assertion testCheckNotInitialized = runTest "notinitialized" $ do dbh <- ask - liftIO $ do - mMetadata <- isInitialized dbh - assertEqual "Database should not have been initialized" Nothing mMetadata + liftIO (assertBool "database should not have been initialized" =<< not <$> LMDBAccountMap.isInitialized dbh) -- | Test that a database is initialized. testCheckDbInitialized :: Assertion testCheckDbInitialized = runTest "initialized" $ do -- initialize the database - void $ insert dummyBlockHash (BlockHeight 1) [dummyPair 1] + void $ LMDBAccountMap.insert [dummyPair 1] dbh <- ask - liftIO $ do - isInitialized dbh >>= \case - Nothing -> assertFailure "database should have been initialized" - Just (blockHash, blockHeight) -> liftIO $ do - assertEqual "block hash should correspond to the one used when last inserting" dummyBlockHash blockHash - assertEqual "block height should correspond to the one used when last inserting" (BlockHeight 1) blockHeight + liftIO (assertBool "database should have been initialized" =<< LMDBAccountMap.isInitialized dbh) -- | Test that inserts a set of accounts and afterwards asserts that they are present. testInsertAndLookupAccounts :: Assertion testInsertAndLookupAccounts = runTest "insertandlookups" $ do - let accounts = [acc | acc <- dummyPair <$> [1 .. 42]] - void $ insert dummyBlockHash (BlockHeight 1) accounts + let accounts = dummyPair <$> [1 .. 42] + void $ LMDBAccountMap.insert accounts forM_ accounts $ \(accAddr, accIndex) -> do - lookup accAddr >>= \case + LMDBAccountMap.lookup accAddr >>= \case Nothing -> liftIO $ assertFailure $ "account was not present " <> show accAddr <> " account index " <> show accIndex Just foundAccountIndex -> liftIO $ assertEqual "account indices should be the same" accIndex foundAccountIndex --- | Test that inserting twice will yield the most recent block. -testMetadataIsUpdated :: Assertion -testMetadataIsUpdated = runTest "metadataupdated" $ do +-- | Test for looking up an account via an alias +testLookupAccountViaAlias :: Assertion +testLookupAccountViaAlias = runTest "lookupviaalias" $ do -- initialize the database - void $ insert dummyBlockHash (BlockHeight 1) [dummyPair 1] - void $ insert anotherDummyBlockHash (BlockHeight 2) [dummyPair 2] - dbh <- ask - liftIO $ do - isInitialized dbh >>= \case - Nothing -> assertFailure "database should have been initialized" - Just (blockHash, blockHeight) -> liftIO $ do - assertEqual "block hash should correspond to the one used when last inserting" anotherDummyBlockHash blockHash - assertEqual "block height should correspond to the one used when last inserting" (BlockHeight 2) blockHeight + void $ LMDBAccountMap.insert [acc] + LMDBAccountMap.lookup (createAlias (fst acc) 42) >>= \case + Nothing -> liftIO $ assertFailure "account could not be looked up via alias" + Just accIndex -> liftIO $ assertEqual "account indices should match" (snd acc) accIndex + where + acc = dummyPair 1 + + +-- | Test for retrieving all accounts present in the LMDB store. +testGetAllAccounts :: Assertion +testGetAllAccounts = runTest "allaccounts" $ do + -- initialize the database + void $ LMDBAccountMap.insert $ dummyPair <$> [0..42] + void $ LMDBAccountMap.insert $ dummyPair <$> [42..84] + allAccounts <- LMDBAccountMap.all + when (length allAccounts /= 85) $ + liftIO $ assertFailure $ "unexpected number of accounts: " <> (show . length) allAccounts <> " should be " <> show (85 :: Int) + forM_ (dummyPair <$> [0..84]) $ \(accAddr, _) -> do + isPresent <- isJust <$> LMDBAccountMap.lookup accAddr + liftIO $ assertBool "account should be present" isPresent -- | Test that accounts can be rolled back i.e. deleted from the LMDB store and that -- the metadata is updated also. testRollback :: Assertion testRollback = runTest "rollback" $ do -- initialize the database. - void $ insert dummyBlockHash (BlockHeight 1) [dummyPair 1] - void $ insert anotherDummyBlockHash (BlockHeight 2) [dummyPair 2] + void $ LMDBAccountMap.insert [dummyPair 1] + void $ LMDBAccountMap.insert [dummyPair 2] -- roll back one block. - lookup (fst $ dummyPair 2) >>= \case + LMDBAccountMap.lookup (fst $ dummyPair 2) >>= \case Nothing -> liftIO $ assertFailure "account should be present" Just _ -> do - void $ unsafeRollback [(fst $ dummyPair 2)] dummyBlockHash (BlockHeight 1) - lookup (fst $ dummyPair 2) >>= \case + void $ LMDBAccountMap.unsafeRollback [fst $ dummyPair 2] + LMDBAccountMap.lookup (fst $ dummyPair 2) >>= \case Just _ -> liftIO $ assertFailure "account should have been deleted" Nothing -> - lookup (fst $ dummyPair 1) >>= \case + LMDBAccountMap.lookup (fst $ dummyPair 1) >>= \case Nothing -> liftIO $ assertFailure "Accounts from first block should still remain in the lmdb store" Just accIdx -> liftIO $ assertEqual "The account index of the first account should be the same" (snd $ dummyPair 1) accIdx @@ -118,5 +113,6 @@ tests = describe "AccountMap.LMDB" $ do it "Test checking db is not initialized" testCheckNotInitialized it "Test checking db is initialized" testCheckDbInitialized it "Test inserts and lookups" testInsertAndLookupAccounts - it "Test metadata is updated when accounts are added" testMetadataIsUpdated + it "Test getting all accounts" testGetAllAccounts + it "Test looking up account via alias" testLookupAccountViaAlias it "Test rollback accounts" testRollback From 4a7fcf2ed010e911c614e536cf82382a359259b1 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Fri, 20 Oct 2023 15:18:31 +0200 Subject: [PATCH 24/92] Fix globalstate tests. --- .../GlobalState/Persistent/Accounts.hs | 26 +++-------- .../GlobalState/Persistent/BlockState.hs | 11 +++-- concordium-consensus/tests/consensus/Spec.hs | 44 +++++++++---------- .../AccountReleaseScheduleTest.hs | 9 ++-- .../globalstate/GlobalStateTests/Accounts.hs | 3 -- .../tests/scheduler/SchedulerTests/Helpers.hs | 7 ++- 6 files changed, 44 insertions(+), 56 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index fa1d1129a0..a03b8ae0ff 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -144,10 +144,7 @@ emptyAccounts :: Accounts pv emptyAccounts = Accounts L.empty Trie.empty -- | Creates an empty 'AccountsAndDifferenceMap'. --- If the 'AccountsAndDifferenceMap' is created when thawing a block state (i.e. for creating a new block) --- then the 'AccountsAndDifferenceMap' of the successor block must be provided. --- On the other hand when loading the accounts in order to support a query, then --- simply pass in 'Nothing'. +-- The difference map will inherit the difference map of the provided provided 'AccountsAndDiffMap' if supplied. emptyAccountsAndDiffMap :: Maybe (AccountsAndDiffMap pv) -> AccountsAndDiffMap pv emptyAccountsAndDiffMap Nothing = AccountsAndDiffMap emptyAccounts $ DiffMap.empty Nothing emptyAccountsAndDiffMap (Just successor) = AccountsAndDiffMap emptyAccounts $ DiffMap.empty (Just $ aadDiffMap successor) @@ -157,21 +154,12 @@ emptyAccountsAndDiffMap (Just successor) = AccountsAndDiffMap emptyAccounts $ Di putNewAccount :: (SupportsPersistentAccount pv m) => PersistentAccount (AccountVersionFor pv) -> AccountsAndDiffMap pv -> m (Maybe AccountIndex, AccountsAndDiffMap pv) putNewAccount !acct a0@AccountsAndDiffMap{aadAccounts = accts0@Accounts{..}, ..} = do addr <- accountCanonicalAddress acct - -- Check whether the account is in a non-finalized block. - case DiffMap.lookup addr aadDiffMap of - -- The account is already present in the difference map. - Just _ -> return (Nothing, a0) - -- The account is not present in the difference map so we will have to - -- check in the LMDB account map. - Nothing -> do - -- Check whether the account is present in a finalized block. - existingAccountId <- LMDBAccountMap.lookup addr - if isNothing existingAccountId - then do - (accIdx, newAccountTable) <- L.append acct accountTable - let dm1 = DiffMap.insert addr accIdx aadDiffMap - return (Just accIdx, a0{aadAccounts = accts0{accountTable = newAccountTable}, aadDiffMap = dm1}) - else return (Nothing, a0) + exists addr a0 >>= \case + True -> return (Nothing, a0) + False -> do + (accIdx, newAccountTable) <- L.append acct accountTable + let newDiffMap = DiffMap.insert addr accIdx aadDiffMap + return (Just accIdx, a0{aadAccounts = accts0{accountTable = newAccountTable}, aadDiffMap = newDiffMap}) -- | Construct an 'Accounts' from a list of accounts. Inserted in the order of the list. fromList :: (SupportsPersistentAccount pv m) => [PersistentAccount (AccountVersionFor pv)] -> m (AccountsAndDiffMap pv) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index f67c8a5f8b..78a919f507 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -105,7 +105,7 @@ import qualified Data.Set as Set import qualified Data.Vector as Vec import Data.Word import Lens.Micro.Platform -import System.Directory (removeDirectory) +import System.Directory (removeDirectoryRecursive) -- * Birk parameters @@ -871,6 +871,7 @@ bspPoolRewards bsp = case bspRewardDetails bsp of BlockRewardDetailsV1 pr -> pr -- | An initial 'HashedPersistentBlockState', which may be used for testing purposes. +{-# WARNING initialPersistentState "should only be used for testing" #-} initialPersistentState :: (SupportsPersistentState pv m) => SeedState (SeedStateVersionFor pv) -> @@ -892,7 +893,6 @@ initialPersistentState seedState cryptoParams accounts ips ars keysCollection ch updates <- refMake =<< initialUpdates keysCollection chainParams releaseSchedule <- emptyReleaseSchedule red <- emptyBlockRewardDetails - bsp <- makeBufferedRef $ BlockStatePointers @@ -3315,16 +3315,15 @@ instance Cache.HasCache Modules.ModuleCache (PersistentBlockStateContext pv) whe instance (IsProtocolVersion pv) => MonadProtocolVersion (BlobStoreT (PersistentBlockStateContext pv) m) where type MPV (BlobStoreT (PersistentBlockStateContext pv) m) = pv --- | Create a new account cache of the specified size for running the given monadic operation by +-- | Create a new account cache of the specified size and a temporary 'LMDBAccountMap' for running the given monadic operation by -- extending the 'BlobStore' context to a 'PersistentBlockStateContext'. --- todo fix doc. withNewAccountCacheAndLMDBAccountMap :: (MonadIO m, MonadCatch.MonadMask m) => Int -> FilePath -> BlobStoreT (PersistentBlockStateContext pv) m a -> BlobStoreT BlobStore m a withNewAccountCacheAndLMDBAccountMap size lmdbAccountMapDir bsm = MonadCatch.bracket openLmdbAccMap closeLmdbAccMap runAction where openLmdbAccMap = liftIO $ LMDBAccountMap.openDatabase lmdbAccountMapDir closeLmdbAccMap handlers = liftIO $ do LMDBAccountMap.closeDatabase handlers - removeDirectory lmdbAccountMapDir `catch` (\(_ :: IOException) -> return ()) + removeDirectoryRecursive lmdbAccountMapDir `catch` (\(e :: IOException) -> liftIO $ void $ print e) runAction lmdbAccMap = do ac <- liftIO $ newAccountCache size mc <- liftIO $ Modules.newModuleCache 100 @@ -3549,7 +3548,7 @@ instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateStorage thawBlockState HashedPersistentBlockState{..} = liftIO $ newIORef =<< readIORef hpbsPointers - freezeBlockState pbs = hashBlockState pbs + freezeBlockState = hashBlockState dropUpdatableBlockState pbs = liftIO $ writeIORef pbs (error "Block state dropped") diff --git a/concordium-consensus/tests/consensus/Spec.hs b/concordium-consensus/tests/consensus/Spec.hs index 03297f22ae..247eead6c1 100644 --- a/concordium-consensus/tests/consensus/Spec.hs +++ b/concordium-consensus/tests/consensus/Spec.hs @@ -41,25 +41,25 @@ atLevel a = do main :: IO () main = atLevel $ \lvl -> hspec $ do ConcordiumTests.Update.test - ConcordiumTests.Afgjort.Types.tests lvl - ConcordiumTests.Afgjort.CSS.tests lvl - ConcordiumTests.Afgjort.CSS.NominationSet.tests lvl - ConcordiumTests.Afgjort.ABBA.tests lvl - ConcordiumTests.Afgjort.Freeze.tests lvl - ConcordiumTests.Afgjort.WMVBA.tests lvl - ConcordiumTests.Afgjort.Lottery.tests lvl - ConcordiumTests.FinalizationRecover.test - ConcordiumTests.PassiveFinalization.test - ConcordiumTests.ReceiveTransactionsTest.test - ConcordiumTests.LeaderElectionTest.tests - ConcordiumTests.KonsensusV1.Types.tests - ConcordiumTests.KonsensusV1.TreeStateTest.tests - ConcordiumTests.KonsensusV1.LMDB.tests - ConcordiumTests.KonsensusV1.TransactionProcessingTest.tests - ConcordiumTests.KonsensusV1.LeaderElectionTest.tests - ConcordiumTests.KonsensusV1.FinalizationCommittee.tests - ConcordiumTests.KonsensusV1.Consensus.tests - ConcordiumTests.KonsensusV1.Quorum.tests - ConcordiumTests.KonsensusV1.Timeout.tests - ConcordiumTests.KonsensusV1.Consensus.Blocks.tests - ConcordiumTests.KonsensusV1.CatchUp.tests + -- ConcordiumTests.Afgjort.Types.tests lvl + -- ConcordiumTests.Afgjort.CSS.tests lvl + -- ConcordiumTests.Afgjort.CSS.NominationSet.tests lvl + -- ConcordiumTests.Afgjort.ABBA.tests lvl + -- ConcordiumTests.Afgjort.Freeze.tests lvl + -- ConcordiumTests.Afgjort.WMVBA.tests lvl + -- ConcordiumTests.Afgjort.Lottery.tests lvl + -- ConcordiumTests.FinalizationRecover.test + -- ConcordiumTests.PassiveFinalization.test + -- ConcordiumTests.ReceiveTransactionsTest.test + -- ConcordiumTests.LeaderElectionTest.tests + -- ConcordiumTests.KonsensusV1.Types.tests + -- ConcordiumTests.KonsensusV1.TreeStateTest.tests + -- ConcordiumTests.KonsensusV1.LMDB.tests + -- ConcordiumTests.KonsensusV1.TransactionProcessingTest.tests + -- ConcordiumTests.KonsensusV1.LeaderElectionTest.tests + -- ConcordiumTests.KonsensusV1.FinalizationCommittee.tests + -- ConcordiumTests.KonsensusV1.Consensus.tests + -- ConcordiumTests.KonsensusV1.Quorum.tests + -- ConcordiumTests.KonsensusV1.Timeout.tests + -- ConcordiumTests.KonsensusV1.Consensus.Blocks.tests + -- ConcordiumTests.KonsensusV1.CatchUp.tests diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/AccountReleaseScheduleTest.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/AccountReleaseScheduleTest.hs index ab401d35d8..32c9883192 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/AccountReleaseScheduleTest.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/AccountReleaseScheduleTest.hs @@ -77,8 +77,7 @@ createGS = do acc0 <- makeTestAccountFromSeed 1_000_000 0 acc1 <- makeTestAccountFromSeed 1_000_000 1 initState <- - PBS.hpbsPointers - <$> PBS.initialPersistentState + PBS.initialPersistentState (initialSeedStateV0 (Hash.hash "") 1_000) dummyCryptographicParameters [acc0, acc1] @@ -86,9 +85,11 @@ createGS = do dummyArs dummyKeyCollection dummyChainParameters + -- save the block state so accounts are written to the lmdb database. + void $ saveBlockState initState addr0 <- BS.accountCanonicalAddress acc0 addr1 <- BS.accountCanonicalAddress acc1 - return (addr0, 0, addr1, 1, initState) + return (addr0, 0, addr1, 1, PBS.hpbsPointers initState) ------------------------------------- Test ------------------------------------- @@ -129,7 +130,7 @@ tests = do describe "GlobalState.AccountReleaseScheduleTest" $ specify "correct releases" $ runBlobStoreTemp "." $ - PBS.withNewAccountCacheAndLMDBAccountMap 1_000 "accmap" $ + PBS.withNewAccountCacheAndLMDBAccountMap 1_000 "accountmap" $ runNoLoggerT $ PBS.runPersistentBlockStateMonad testing diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs index 4232e68c04..76b204672f 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs @@ -19,7 +19,6 @@ import qualified Concordium.GlobalState.Persistent.Accounts as P import Concordium.GlobalState.Persistent.BlobStore import Concordium.GlobalState.Persistent.BlockState (PersistentBlockStateContext (..)) import qualified Concordium.GlobalState.Persistent.BlockState.Modules as M -import Concordium.GlobalState.Persistent.Cache (MonadCache) import qualified Concordium.GlobalState.Persistent.LFMBTree as L import Concordium.ID.DummyData import qualified Concordium.ID.Types as ID @@ -40,10 +39,8 @@ import Test.HUnit import Test.Hspec import Test.QuickCheck import Prelude hiding (fail) - import qualified Basic.AccountTable as BAT import qualified Basic.Accounts as B -import qualified Concordium.GlobalState.AccountMap.DifferenceMap as DiffMap import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap type PV = 'P5 diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs b/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs index e8c3dc1618..11fad39225 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs @@ -140,8 +140,8 @@ createTestBlockStateWithAccounts :: (Types.IsProtocolVersion pv) => [BS.PersistentAccount (Types.AccountVersionFor pv)] -> PersistentBSM pv (BS.HashedPersistentBlockState pv) -createTestBlockStateWithAccounts accounts = - BS.initialPersistentState +createTestBlockStateWithAccounts accounts = do + bs <- BS.initialPersistentState seedState DummyData.dummyCryptographicParameters accounts @@ -149,6 +149,9 @@ createTestBlockStateWithAccounts accounts = DummyData.dummyArs keys DummyData.dummyChainParameters + -- save the block state so accounts are written to the lmdb account map. + void $ BS.saveBlockState bs + return bs where keys = Types.withIsAuthorizationsVersionForPV (Types.protocolVersion @pv) $ DummyData.dummyKeyCollection seedState = case Types.consensusVersionFor (Types.protocolVersion @pv) of From c93fef7f534a114458dd99aca57638619f49199b Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Mon, 23 Oct 2023 11:00:53 +0200 Subject: [PATCH 25/92] Fix `getAccountWithIndex` so it also looks in the difference map. --- .../GlobalState/Persistent/Accounts.hs | 28 ++++++------------- 1 file changed, 9 insertions(+), 19 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index a03b8ae0ff..8b7b07fa5b 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -174,15 +174,7 @@ exists addr accts = isJust <$> getAccountIndex addr accts -- | Retrieve an account with the given address. -- Returns @Nothing@ if no such account exists. getAccount :: (SupportsPersistentAccount pv m) => AccountAddress -> AccountsAndDiffMap pv -> m (Maybe (PersistentAccount (AccountVersionFor pv))) -getAccount addr AccountsAndDiffMap{..} = - case DiffMap.lookup addr aadDiffMap of - Just ai -> fetchFromTable ai - Nothing -> - LMDBAccountMap.lookup addr >>= \case - Nothing -> return Nothing - Just ai -> fetchFromTable ai - where - fetchFromTable accIndex = L.lookup accIndex $ accountTable aadAccounts +getAccount addr accts = fmap snd <$> getAccountWithIndex addr accts -- | Retrieve an account associated with the given credential registration ID. -- Returns @Nothing@ if no such account exists. @@ -205,10 +197,11 @@ getAccountIndex addr AccountsAndDiffMap{..} = -- | Retrieve an account and its index from a given address. -- Returns @Nothing@ if no such account exists. getAccountWithIndex :: (SupportsPersistentAccount pv m) => AccountAddress -> AccountsAndDiffMap pv -> m (Maybe (AccountIndex, PersistentAccount (AccountVersionFor pv))) -getAccountWithIndex addr AccountsAndDiffMap{..} = - LMDBAccountMap.lookup addr >>= \case - Nothing -> return Nothing - Just ai -> fmap (ai,) <$> L.lookup ai (accountTable aadAccounts) +getAccountWithIndex addr AccountsAndDiffMap{..} = getAccountIndex >>= fetchFromTable + where + fetchFromTable accIndex = do + mAcc <- L.lookup accIndex $ accountTable aadAccounts + return $ (accIndex,) <$> mAcc -- | Retrieve the account at a given index. indexedAccount :: (SupportsPersistentAccount pv m) => AccountIndex -> AccountsAndDiffMap pv -> m (Maybe (PersistentAccount (AccountVersionFor pv))) @@ -257,12 +250,9 @@ updateAccounts :: AccountAddress -> AccountsAndDiffMap pv -> m (Maybe (AccountIndex, a), AccountsAndDiffMap pv) -updateAccounts fupd addr a0@AccountsAndDiffMap{aadAccounts = accs0@Accounts{..}, ..} = - case DiffMap.lookup addr aadDiffMap of - Nothing -> - LMDBAccountMap.lookup addr >>= \case - Nothing -> return (Nothing, a0) - Just ai -> update ai +updateAccounts fupd addr a0@AccountsAndDiffMap{aadAccounts = accs0@Accounts{..}, ..} = do + getAccountIndex >>= \case + Nothing -> return (Nothing, a0) Just ai -> update ai where update ai = From 03931b7a06c05a5da219a482f6d0ef8aa3c90885 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Mon, 23 Oct 2023 11:21:59 +0200 Subject: [PATCH 26/92] bugfixes. --- .../Concordium/GlobalState/AccountMap/LMDB.hs | 1 + .../src/Concordium/KonsensusV1/TestMonad.hs | 2 +- concordium-consensus/tests/consensus/Spec.hs | 44 +++++++++---------- 3 files changed, 24 insertions(+), 23 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index e046216fbd..4cc6838334 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -212,6 +212,7 @@ makeDatabaseHandlers accountMapDir readOnly initSize = do -- | Initialize database handlers in ReadWrite mode. -- This simply loads the references and does not initialize the databases. -- The initial size is set to 64MB. +-- Note that this function creates the directory for the database if not already present. openDatabase :: FilePath -> IO DatabaseHandlers openDatabase accountMapDir = do createDirectoryIfMissing False accountMapDir diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs index c2cd38ef09..1cb2bebc74 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs @@ -150,7 +150,7 @@ genesisCore = case protocolVersion @pv of -- This sets up a temporary blob store for the block state that is deleted after use. runTestMonad :: (IsConsensusV1 pv, IsProtocolVersion pv) => BakerContext -> UTCTime -> GenesisData pv -> TestMonad pv a -> IO a runTestMonad _tcBakerContext _tcCurrentTime genData (TestMonad a) = - runLog $ runBlobStoreTemp "." $ withNewAccountCacheAndLMDBAccountMap 1000 "." $ do + runLog $ runBlobStoreTemp "." $ withNewAccountCacheAndLMDBAccountMap 1000 "accountmap" $ do (genState, genStateRef, initTT, genTimeoutBase, genEpochBakers) <- runPersistentBlockStateMonad $ do genesisState genData >>= \case Left e -> error e diff --git a/concordium-consensus/tests/consensus/Spec.hs b/concordium-consensus/tests/consensus/Spec.hs index 247eead6c1..03297f22ae 100644 --- a/concordium-consensus/tests/consensus/Spec.hs +++ b/concordium-consensus/tests/consensus/Spec.hs @@ -41,25 +41,25 @@ atLevel a = do main :: IO () main = atLevel $ \lvl -> hspec $ do ConcordiumTests.Update.test - -- ConcordiumTests.Afgjort.Types.tests lvl - -- ConcordiumTests.Afgjort.CSS.tests lvl - -- ConcordiumTests.Afgjort.CSS.NominationSet.tests lvl - -- ConcordiumTests.Afgjort.ABBA.tests lvl - -- ConcordiumTests.Afgjort.Freeze.tests lvl - -- ConcordiumTests.Afgjort.WMVBA.tests lvl - -- ConcordiumTests.Afgjort.Lottery.tests lvl - -- ConcordiumTests.FinalizationRecover.test - -- ConcordiumTests.PassiveFinalization.test - -- ConcordiumTests.ReceiveTransactionsTest.test - -- ConcordiumTests.LeaderElectionTest.tests - -- ConcordiumTests.KonsensusV1.Types.tests - -- ConcordiumTests.KonsensusV1.TreeStateTest.tests - -- ConcordiumTests.KonsensusV1.LMDB.tests - -- ConcordiumTests.KonsensusV1.TransactionProcessingTest.tests - -- ConcordiumTests.KonsensusV1.LeaderElectionTest.tests - -- ConcordiumTests.KonsensusV1.FinalizationCommittee.tests - -- ConcordiumTests.KonsensusV1.Consensus.tests - -- ConcordiumTests.KonsensusV1.Quorum.tests - -- ConcordiumTests.KonsensusV1.Timeout.tests - -- ConcordiumTests.KonsensusV1.Consensus.Blocks.tests - -- ConcordiumTests.KonsensusV1.CatchUp.tests + ConcordiumTests.Afgjort.Types.tests lvl + ConcordiumTests.Afgjort.CSS.tests lvl + ConcordiumTests.Afgjort.CSS.NominationSet.tests lvl + ConcordiumTests.Afgjort.ABBA.tests lvl + ConcordiumTests.Afgjort.Freeze.tests lvl + ConcordiumTests.Afgjort.WMVBA.tests lvl + ConcordiumTests.Afgjort.Lottery.tests lvl + ConcordiumTests.FinalizationRecover.test + ConcordiumTests.PassiveFinalization.test + ConcordiumTests.ReceiveTransactionsTest.test + ConcordiumTests.LeaderElectionTest.tests + ConcordiumTests.KonsensusV1.Types.tests + ConcordiumTests.KonsensusV1.TreeStateTest.tests + ConcordiumTests.KonsensusV1.LMDB.tests + ConcordiumTests.KonsensusV1.TransactionProcessingTest.tests + ConcordiumTests.KonsensusV1.LeaderElectionTest.tests + ConcordiumTests.KonsensusV1.FinalizationCommittee.tests + ConcordiumTests.KonsensusV1.Consensus.tests + ConcordiumTests.KonsensusV1.Quorum.tests + ConcordiumTests.KonsensusV1.Timeout.tests + ConcordiumTests.KonsensusV1.Consensus.Blocks.tests + ConcordiumTests.KonsensusV1.CatchUp.tests From 916bc334867c6f0a1db835f78652a16c1ef49018 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Mon, 23 Oct 2023 12:20:46 +0200 Subject: [PATCH 27/92] Fix bug. --- .../GlobalState/Persistent/Accounts.hs | 29 ++++++++++--------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 8b7b07fa5b..5feedc30f9 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -171,11 +171,6 @@ fromList = foldlM insert $ emptyAccountsAndDiffMap Nothing exists :: (SupportsPersistentAccount pv m) => AccountAddress -> AccountsAndDiffMap pv -> m Bool exists addr accts = isJust <$> getAccountIndex addr accts --- | Retrieve an account with the given address. --- Returns @Nothing@ if no such account exists. -getAccount :: (SupportsPersistentAccount pv m) => AccountAddress -> AccountsAndDiffMap pv -> m (Maybe (PersistentAccount (AccountVersionFor pv))) -getAccount addr accts = fmap snd <$> getAccountWithIndex addr accts - -- | Retrieve an account associated with the given credential registration ID. -- Returns @Nothing@ if no such account exists. getAccountByCredId :: (SupportsPersistentAccount pv m) => ID.RawCredentialRegistrationID -> AccountsAndDiffMap pv -> m (Maybe (AccountIndex, PersistentAccount (AccountVersionFor pv))) @@ -185,7 +180,7 @@ getAccountByCredId cid accs@AccountsAndDiffMap{..} = Just ai -> fmap (ai,) <$> indexedAccount ai accs -- | Get the account at a given index (if any). -getAccountIndex :: (IsProtocolVersion pv, LMDBAccountMap.MonadAccountMapStore m) => AccountAddress -> AccountsAndDiffMap pv -> m (Maybe AccountIndex) +getAccountIndex :: (SupportsPersistentAccount pv m) => AccountAddress -> AccountsAndDiffMap pv -> m (Maybe AccountIndex) getAccountIndex addr AccountsAndDiffMap{..} = case DiffMap.lookup addr aadDiffMap of Just accIdx -> return $ Just accIdx @@ -194,14 +189,20 @@ getAccountIndex addr AccountsAndDiffMap{..} = Nothing -> return Nothing Just accIdx -> return $ Just accIdx +-- | Retrieve an account with the given address. +-- Returns @Nothing@ if no such account exists. +getAccount :: (SupportsPersistentAccount pv m) => AccountAddress -> AccountsAndDiffMap pv -> m (Maybe (PersistentAccount (AccountVersionFor pv))) +getAccount addr accts = fmap snd <$> getAccountWithIndex addr accts + -- | Retrieve an account and its index from a given address. -- Returns @Nothing@ if no such account exists. -getAccountWithIndex :: (SupportsPersistentAccount pv m) => AccountAddress -> AccountsAndDiffMap pv -> m (Maybe (AccountIndex, PersistentAccount (AccountVersionFor pv))) -getAccountWithIndex addr AccountsAndDiffMap{..} = getAccountIndex >>= fetchFromTable - where - fetchFromTable accIndex = do - mAcc <- L.lookup accIndex $ accountTable aadAccounts - return $ (accIndex,) <$> mAcc +getAccountWithIndex :: forall pv m. (SupportsPersistentAccount pv m) => AccountAddress -> AccountsAndDiffMap pv -> m (Maybe (AccountIndex, PersistentAccount (AccountVersionFor pv))) +getAccountWithIndex addr accts = + getAccountIndex addr accts >>= \case + Nothing -> return Nothing + Just ai -> do + mAcc <- L.lookup ai $ accountTable (aadAccounts accts) + return $ (ai,) <$> mAcc -- | Retrieve the account at a given index. indexedAccount :: (SupportsPersistentAccount pv m) => AccountIndex -> AccountsAndDiffMap pv -> m (Maybe (PersistentAccount (AccountVersionFor pv))) @@ -250,8 +251,8 @@ updateAccounts :: AccountAddress -> AccountsAndDiffMap pv -> m (Maybe (AccountIndex, a), AccountsAndDiffMap pv) -updateAccounts fupd addr a0@AccountsAndDiffMap{aadAccounts = accs0@Accounts{..}, ..} = do - getAccountIndex >>= \case +updateAccounts fupd addr a0@AccountsAndDiffMap{aadAccounts = accs0@Accounts{..}} = do + getAccountIndex addr a0 >>= \case Nothing -> return (Nothing, a0) Just ai -> update ai where From ce4845920002b99a7184b90ffc557c69df3b0649 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Mon, 23 Oct 2023 14:09:49 +0200 Subject: [PATCH 28/92] Fix bug --- .../GlobalState/Persistent/Accounts.hs | 6 +- .../GlobalState/Persistent/BlockState.hs | 1 + concordium-consensus/tests/scheduler/Spec.hs | 99 ++++++++++--------- 3 files changed, 54 insertions(+), 52 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 5feedc30f9..da43902fc0 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -283,9 +283,9 @@ updateAccountsAtIndex' fupd ai = fmap snd . updateAccountsAtIndex fupd' ai -- | Get a list of all account addresses and their assoicated account indices. allAccountAddressesAndIndices :: (SupportsPersistentAccount pv m) => AccountsAndDiffMap pv -> m [(AccountAddress, AccountIndex)] allAccountAddressesAndIndices accounts = do - allPersistedAccounts <- LMDBAccountMap.all - let inMemAccounts = Map.toList $ DiffMap.flatten $ aadDiffMap accounts - return $ allPersistedAccounts ++ inMemAccounts + persistedAccs <- Map.fromList <$> LMDBAccountMap.all + let allAccounts = persistedAccs `Map.union` DiffMap.flatten (aadDiffMap accounts) + return $ Map.toList allAccounts -- | Get a list of all account addresses. accountAddresses :: (SupportsPersistentAccount pv m) => AccountsAndDiffMap pv -> m [AccountAddress] diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 78a919f507..95cd81572b 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -3317,6 +3317,7 @@ instance (IsProtocolVersion pv) => MonadProtocolVersion (BlobStoreT (PersistentB -- | Create a new account cache of the specified size and a temporary 'LMDBAccountMap' for running the given monadic operation by -- extending the 'BlobStore' context to a 'PersistentBlockStateContext'. +-- Note. this function should only be used for tests. withNewAccountCacheAndLMDBAccountMap :: (MonadIO m, MonadCatch.MonadMask m) => Int -> FilePath -> BlobStoreT (PersistentBlockStateContext pv) m a -> BlobStoreT BlobStore m a withNewAccountCacheAndLMDBAccountMap size lmdbAccountMapDir bsm = MonadCatch.bracket openLmdbAccMap closeLmdbAccMap runAction where diff --git a/concordium-consensus/tests/scheduler/Spec.hs b/concordium-consensus/tests/scheduler/Spec.hs index 268f5c788b..21480dc2d7 100644 --- a/concordium-consensus/tests/scheduler/Spec.hs +++ b/concordium-consensus/tests/scheduler/Spec.hs @@ -54,52 +54,53 @@ import qualified SchedulerTests.SmartContracts.V1.ValidInvalidModules (tests) import Test.Hspec main :: IO () -main = hspec $ do - SchedulerTests.InitPoliciesTest.tests - SchedulerTests.SimpleTransfersTest.tests - SchedulerTests.ChainMetatest.tests - SchedulerTests.InitContextTest.tests - SchedulerTests.ReceiveContextTest.tests - SchedulerTests.TrySendTest.tests - SchedulerTests.FibonacciSelfMessageTest.tests - SchedulerTests.AccountTransactionSpecs.tests - SchedulerTests.InitialAccountCreationSpec.tests - SchedulerTests.BakerTransactions.tests - SchedulerTests.RandomBakerTransactions.tests - SchedulerTests.TransactionExpirySpec.tests - SchedulerTests.BlockEnergyLimitSpec.tests - SchedulerTests.TransactionGroupingSpec2.tests - SchedulerTests.SimpleTransferSpec.tests - SchedulerTests.UpdateAccountKeys.tests - SchedulerTests.UpdateCredentials.tests - SchedulerTests.TransfersWithScheduleTest.tests - SchedulerTests.EncryptedTransfersTest.tests - SchedulerTests.MaxIncomingAmountsTest.tests - SchedulerTests.StakedAmountLocked.tests - SchedulerTests.RejectReasons.tests - SchedulerTests.RejectReasonsRustContract.tests - SchedulerTests.SmartContracts.V0.SmartContractTests.tests - SchedulerTests.SmartContracts.V0.RelaxedRestrictions.tests - SchedulerTests.SmartContracts.V1.Counter.tests - SchedulerTests.SmartContracts.V1.Transfer.tests - SchedulerTests.SmartContracts.V1.CrossMessaging.tests - SchedulerTests.SmartContracts.Invoke.tests - SchedulerTests.SmartContracts.V1.ErrorCodes.tests - SchedulerTests.SmartContracts.V1.ValidInvalidModules.tests - SchedulerTests.SmartContracts.V1.SelfBalance.tests - SchedulerTests.SmartContracts.V1.Recorder.tests - SchedulerTests.SmartContracts.V1.Iterator.tests - SchedulerTests.SmartContracts.V1.Fallback.tests - SchedulerTests.SmartContracts.V1.Checkpointing.tests - SchedulerTests.SmartContracts.V1.AllNewHostFunctions.tests - SchedulerTests.SmartContracts.V1.Upgrading.tests - SchedulerTests.SmartContracts.V1.Queries.tests - SchedulerTests.SmartContracts.V1.RelaxedRestrictions.tests - SchedulerTests.SmartContracts.V1.UpgradingPersistent.tests - SchedulerTests.SmartContracts.V1.TransfersPersistent.tests - SchedulerTests.SmartContracts.V1.QueriesPersistent.tests - SchedulerTests.Payday.tests - SchedulerTests.Delegation.tests - SchedulerTests.SmartContracts.V1.P6WasmFeatures.tests - SchedulerTests.SmartContracts.V1.CustomSectionSize.tests - SchedulerTests.SmartContracts.V1.AccountSignatureChecks.tests +main = return () +-- main = hspec $ do + -- SchedulerTests.InitPoliciesTest.tests + -- SchedulerTests.SimpleTransfersTest.tests + -- SchedulerTests.ChainMetatest.tests + -- SchedulerTests.InitContextTest.tests + -- SchedulerTests.ReceiveContextTest.tests + -- SchedulerTests.TrySendTest.tests + -- SchedulerTests.FibonacciSelfMessageTest.tests + -- SchedulerTests.AccountTransactionSpecs.tests + -- SchedulerTests.InitialAccountCreationSpec.tests + -- SchedulerTests.BakerTransactions.tests + -- SchedulerTests.RandomBakerTransactions.tests + -- SchedulerTests.TransactionExpirySpec.tests + -- SchedulerTests.BlockEnergyLimitSpec.tests + -- SchedulerTests.TransactionGroupingSpec2.tests + -- SchedulerTests.SimpleTransferSpec.tests + -- SchedulerTests.UpdateAccountKeys.tests + -- SchedulerTests.UpdateCredentials.tests + -- SchedulerTests.TransfersWithScheduleTest.tests + -- SchedulerTests.EncryptedTransfersTest.tests + -- SchedulerTests.MaxIncomingAmountsTest.tests + -- SchedulerTests.StakedAmountLocked.tests + -- SchedulerTests.RejectReasons.tests + -- SchedulerTests.RejectReasonsRustContract.tests + -- SchedulerTests.SmartContracts.V0.SmartContractTests.tests + -- SchedulerTests.SmartContracts.V0.RelaxedRestrictions.tests + -- SchedulerTests.SmartContracts.V1.Counter.tests + -- SchedulerTests.SmartContracts.V1.Transfer.tests + -- SchedulerTests.SmartContracts.V1.CrossMessaging.tests + -- SchedulerTests.SmartContracts.Invoke.tests + -- SchedulerTests.SmartContracts.V1.ErrorCodes.tests + -- SchedulerTests.SmartContracts.V1.ValidInvalidModules.tests + -- SchedulerTests.SmartContracts.V1.SelfBalance.tests + -- SchedulerTests.SmartContracts.V1.Recorder.tests + -- SchedulerTests.SmartContracts.V1.Iterator.tests + -- SchedulerTests.SmartContracts.V1.Fallback.tests + -- SchedulerTests.SmartContracts.V1.Checkpointing.tests + -- SchedulerTests.SmartContracts.V1.AllNewHostFunctions.tests + -- SchedulerTests.SmartContracts.V1.Upgrading.tests + -- SchedulerTests.SmartContracts.V1.Queries.tests + -- SchedulerTests.SmartContracts.V1.RelaxedRestrictions.tests + -- SchedulerTests.SmartContracts.V1.UpgradingPersistent.tests + -- SchedulerTests.SmartContracts.V1.TransfersPersistent.tests + -- SchedulerTests.SmartContracts.V1.QueriesPersistent.tests + -- SchedulerTests.Payday.tests + -- SchedulerTests.Delegation.tests + -- SchedulerTests.SmartContracts.V1.P6WasmFeatures.tests + -- SchedulerTests.SmartContracts.V1.CustomSectionSize.tests + -- SchedulerTests.SmartContracts.V1.AccountSignatureChecks.tests From 474f40712305350e26d84470c7a1a9dbd3df1786 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Mon, 23 Oct 2023 14:10:33 +0200 Subject: [PATCH 29/92] Reintroduce scheduler tests. --- concordium-consensus/tests/scheduler/Spec.hs | 99 ++++++++++---------- 1 file changed, 49 insertions(+), 50 deletions(-) diff --git a/concordium-consensus/tests/scheduler/Spec.hs b/concordium-consensus/tests/scheduler/Spec.hs index 21480dc2d7..268f5c788b 100644 --- a/concordium-consensus/tests/scheduler/Spec.hs +++ b/concordium-consensus/tests/scheduler/Spec.hs @@ -54,53 +54,52 @@ import qualified SchedulerTests.SmartContracts.V1.ValidInvalidModules (tests) import Test.Hspec main :: IO () -main = return () --- main = hspec $ do - -- SchedulerTests.InitPoliciesTest.tests - -- SchedulerTests.SimpleTransfersTest.tests - -- SchedulerTests.ChainMetatest.tests - -- SchedulerTests.InitContextTest.tests - -- SchedulerTests.ReceiveContextTest.tests - -- SchedulerTests.TrySendTest.tests - -- SchedulerTests.FibonacciSelfMessageTest.tests - -- SchedulerTests.AccountTransactionSpecs.tests - -- SchedulerTests.InitialAccountCreationSpec.tests - -- SchedulerTests.BakerTransactions.tests - -- SchedulerTests.RandomBakerTransactions.tests - -- SchedulerTests.TransactionExpirySpec.tests - -- SchedulerTests.BlockEnergyLimitSpec.tests - -- SchedulerTests.TransactionGroupingSpec2.tests - -- SchedulerTests.SimpleTransferSpec.tests - -- SchedulerTests.UpdateAccountKeys.tests - -- SchedulerTests.UpdateCredentials.tests - -- SchedulerTests.TransfersWithScheduleTest.tests - -- SchedulerTests.EncryptedTransfersTest.tests - -- SchedulerTests.MaxIncomingAmountsTest.tests - -- SchedulerTests.StakedAmountLocked.tests - -- SchedulerTests.RejectReasons.tests - -- SchedulerTests.RejectReasonsRustContract.tests - -- SchedulerTests.SmartContracts.V0.SmartContractTests.tests - -- SchedulerTests.SmartContracts.V0.RelaxedRestrictions.tests - -- SchedulerTests.SmartContracts.V1.Counter.tests - -- SchedulerTests.SmartContracts.V1.Transfer.tests - -- SchedulerTests.SmartContracts.V1.CrossMessaging.tests - -- SchedulerTests.SmartContracts.Invoke.tests - -- SchedulerTests.SmartContracts.V1.ErrorCodes.tests - -- SchedulerTests.SmartContracts.V1.ValidInvalidModules.tests - -- SchedulerTests.SmartContracts.V1.SelfBalance.tests - -- SchedulerTests.SmartContracts.V1.Recorder.tests - -- SchedulerTests.SmartContracts.V1.Iterator.tests - -- SchedulerTests.SmartContracts.V1.Fallback.tests - -- SchedulerTests.SmartContracts.V1.Checkpointing.tests - -- SchedulerTests.SmartContracts.V1.AllNewHostFunctions.tests - -- SchedulerTests.SmartContracts.V1.Upgrading.tests - -- SchedulerTests.SmartContracts.V1.Queries.tests - -- SchedulerTests.SmartContracts.V1.RelaxedRestrictions.tests - -- SchedulerTests.SmartContracts.V1.UpgradingPersistent.tests - -- SchedulerTests.SmartContracts.V1.TransfersPersistent.tests - -- SchedulerTests.SmartContracts.V1.QueriesPersistent.tests - -- SchedulerTests.Payday.tests - -- SchedulerTests.Delegation.tests - -- SchedulerTests.SmartContracts.V1.P6WasmFeatures.tests - -- SchedulerTests.SmartContracts.V1.CustomSectionSize.tests - -- SchedulerTests.SmartContracts.V1.AccountSignatureChecks.tests +main = hspec $ do + SchedulerTests.InitPoliciesTest.tests + SchedulerTests.SimpleTransfersTest.tests + SchedulerTests.ChainMetatest.tests + SchedulerTests.InitContextTest.tests + SchedulerTests.ReceiveContextTest.tests + SchedulerTests.TrySendTest.tests + SchedulerTests.FibonacciSelfMessageTest.tests + SchedulerTests.AccountTransactionSpecs.tests + SchedulerTests.InitialAccountCreationSpec.tests + SchedulerTests.BakerTransactions.tests + SchedulerTests.RandomBakerTransactions.tests + SchedulerTests.TransactionExpirySpec.tests + SchedulerTests.BlockEnergyLimitSpec.tests + SchedulerTests.TransactionGroupingSpec2.tests + SchedulerTests.SimpleTransferSpec.tests + SchedulerTests.UpdateAccountKeys.tests + SchedulerTests.UpdateCredentials.tests + SchedulerTests.TransfersWithScheduleTest.tests + SchedulerTests.EncryptedTransfersTest.tests + SchedulerTests.MaxIncomingAmountsTest.tests + SchedulerTests.StakedAmountLocked.tests + SchedulerTests.RejectReasons.tests + SchedulerTests.RejectReasonsRustContract.tests + SchedulerTests.SmartContracts.V0.SmartContractTests.tests + SchedulerTests.SmartContracts.V0.RelaxedRestrictions.tests + SchedulerTests.SmartContracts.V1.Counter.tests + SchedulerTests.SmartContracts.V1.Transfer.tests + SchedulerTests.SmartContracts.V1.CrossMessaging.tests + SchedulerTests.SmartContracts.Invoke.tests + SchedulerTests.SmartContracts.V1.ErrorCodes.tests + SchedulerTests.SmartContracts.V1.ValidInvalidModules.tests + SchedulerTests.SmartContracts.V1.SelfBalance.tests + SchedulerTests.SmartContracts.V1.Recorder.tests + SchedulerTests.SmartContracts.V1.Iterator.tests + SchedulerTests.SmartContracts.V1.Fallback.tests + SchedulerTests.SmartContracts.V1.Checkpointing.tests + SchedulerTests.SmartContracts.V1.AllNewHostFunctions.tests + SchedulerTests.SmartContracts.V1.Upgrading.tests + SchedulerTests.SmartContracts.V1.Queries.tests + SchedulerTests.SmartContracts.V1.RelaxedRestrictions.tests + SchedulerTests.SmartContracts.V1.UpgradingPersistent.tests + SchedulerTests.SmartContracts.V1.TransfersPersistent.tests + SchedulerTests.SmartContracts.V1.QueriesPersistent.tests + SchedulerTests.Payday.tests + SchedulerTests.Delegation.tests + SchedulerTests.SmartContracts.V1.P6WasmFeatures.tests + SchedulerTests.SmartContracts.V1.CustomSectionSize.tests + SchedulerTests.SmartContracts.V1.AccountSignatureChecks.tests From b5828fa45102a96ca07499655e4d4fe95104bfa6 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Mon, 23 Oct 2023 14:22:58 +0200 Subject: [PATCH 30/92] Formatting. --- .../GlobalState/AccountMap/DifferenceMap.hs | 3 ++- .../Concordium/GlobalState/AccountMap/LMDB.hs | 9 ++++----- .../src/Concordium/GlobalState/LMDB/Helpers.hs | 2 +- .../GlobalState/Persistent/Accounts.hs | 6 +++--- .../AccountReleaseScheduleTest.hs | 14 +++++++------- .../globalstate/GlobalStateTests/Accounts.hs | 15 ++++++++------- .../GlobalStateTests/DifferenceMap.hs | 9 +++++---- .../GlobalStateTests/LMDBAccountMap.hs | 13 +++++++------ .../tests/scheduler/SchedulerTests/Helpers.hs | 17 +++++++++-------- 9 files changed, 46 insertions(+), 42 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index 93cd32efd2..0fbf0268d9 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -1,11 +1,12 @@ {-# LANGUAGE BangPatterns #-} + -- | The 'DifferenceMap' stores accounts have been created in a non-finalized block. -- When a block is being finalized then the assoicated 'DifferenceMap' must be written -- to disk via 'Concordium.GlobalState.AccountMap.LMDB.insert'. module Concordium.GlobalState.AccountMap.DifferenceMap where -import Prelude hiding (lookup) import qualified Data.Map.Strict as Map +import Prelude hiding (lookup) import Concordium.Types diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index 4cc6838334..51f2e241e9 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -37,13 +37,13 @@ import Control.Monad.State.Strict import Control.Monad.Trans.Except import Control.Monad.Trans.Writer.Strict import qualified Data.ByteString as BS -import qualified Data.FixedByteString as FBS import Data.Data (Typeable) +import qualified Data.FixedByteString as FBS import Data.Kind (Type) import Database.LMDB.Raw import Lens.Micro.Platform import System.Directory -import Prelude hiding (lookup, all) +import Prelude hiding (all, lookup) import Concordium.GlobalState.Classes import Concordium.GlobalState.LMDB.Helpers @@ -115,7 +115,6 @@ instance MDBDatabase AccountMapStore where type DBKey AccountMapStore = AccountAddress type DBValue AccountMapStore = AccountIndex - data DatabaseHandlers = DatabaseHandlers { _storeEnv :: !StoreEnv, _accountMapStore :: !AccountMapStore @@ -269,7 +268,7 @@ isInitialized dbh = liftIO $ transaction (dbh ^. storeEnv) True $ \txn -> (/= 0) -- This function deletes the provided accounts from the store and sets the last finalized block -- to the provided hash and height. -- --- It is to be considered unsafe as it does not +-- It is to be considered unsafe as it does not unsafeRollback :: (MonadIO m, MonadLogger m, MonadReader r m, HasDatabaseHandlers r) => [AccountAddress] -> m () unsafeRollback accounts = do handlers <- ask @@ -313,5 +312,5 @@ instance -- the last 3 bytes are reserved for aliases. accLookupKey = BS.take prefixAccountAddressSize $ FBS.toByteString accAddr checkEquivalence x y = accountAddressEmbed x == accountAddressEmbed y - + all = asReadTransaction $ \dbh txn -> loadAll txn (dbh ^. accountMapStore) diff --git a/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs b/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs index 22597d2f0e..5d6d5effcd 100644 --- a/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs +++ b/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs @@ -43,7 +43,7 @@ module Concordium.GlobalState.LMDB.Helpers ( -- * Low level operations. byteStringFromMDB_val, unsafeByteStringFromMDB_val, - withMDB_val + withMDB_val, ) where diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index da43902fc0..9d4ea47223 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -80,8 +80,8 @@ data Accounts (pv :: ProtocolVersion) = Accounts -- | An 'Accounts' with an assoicated ' DiffMap.DifferenceMap'. -- The 'DiffMap.DifferenceMap' includes a mapping @AccountAddress -> AccountIndex@ for accounts -- which have been added to a block which have not been persisted yet (certified or finalized). --- --- For blocks which have been persisted the 'DiffMap.DifferenceMap' is @Nothing@ as potential new +-- +-- For blocks which have been persisted the 'DiffMap.DifferenceMap' is @Nothing@ as potential new -- accounts have been written to the lmdb account map. data AccountsAndDiffMap (pv :: ProtocolVersion) = AccountsAndDiffMap { -- | The persistent accounts and what is stored on disk. @@ -112,7 +112,7 @@ instance (SupportsPersistentAccount pv m) => MHashableTo m H.Hash (AccountsAndDi getHashM AccountsAndDiffMap{..} = getHashM $ accountTable aadAccounts instance (SupportsPersistentAccount pv m) => BlobStorable m (AccountsAndDiffMap pv) where - storeUpdate AccountsAndDiffMap{aadAccounts = Accounts{..},..} = do + storeUpdate AccountsAndDiffMap{aadAccounts = Accounts{..}, ..} = do (pTable, accountTable') <- storeUpdate accountTable (pRegIdHistory, regIdHistory') <- storeUpdate accountRegIdHistory LMDBAccountMap.insert (Map.toList $ DiffMap.flatten aadDiffMap) diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/AccountReleaseScheduleTest.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/AccountReleaseScheduleTest.hs index 32c9883192..cad3eb7160 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/AccountReleaseScheduleTest.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/AccountReleaseScheduleTest.hs @@ -78,13 +78,13 @@ createGS = do acc1 <- makeTestAccountFromSeed 1_000_000 1 initState <- PBS.initialPersistentState - (initialSeedStateV0 (Hash.hash "") 1_000) - dummyCryptographicParameters - [acc0, acc1] - dummyIdentityProviders - dummyArs - dummyKeyCollection - dummyChainParameters + (initialSeedStateV0 (Hash.hash "") 1_000) + dummyCryptographicParameters + [acc0, acc1] + dummyIdentityProviders + dummyArs + dummyKeyCollection + dummyChainParameters -- save the block state so accounts are written to the lmdb database. void $ saveBlockState initState addr0 <- BS.accountCanonicalAddress acc0 diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs index 76b204672f..44788e36f3 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs @@ -1,17 +1,20 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-deprecations #-} module GlobalStateTests.Accounts where +import qualified Basic.AccountTable as BAT +import qualified Basic.Accounts as B import Concordium.Crypto.DummyData import Concordium.Crypto.FFIDataTypes import qualified Concordium.Crypto.SHA256 as H import qualified Concordium.Crypto.SignatureScheme as Sig import qualified Concordium.GlobalState.AccountMap as AccountMap +import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import Concordium.GlobalState.Basic.BlockState.Account as BA import Concordium.GlobalState.DummyData import qualified Concordium.GlobalState.Persistent.Account as PA @@ -39,9 +42,6 @@ import Test.HUnit import Test.Hspec import Test.QuickCheck import Prelude hiding (fail) -import qualified Basic.AccountTable as BAT -import qualified Basic.Accounts as B -import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap type PV = 'P5 @@ -225,8 +225,9 @@ runAccountAction (RecordRegId rid ai) (ba, pa) = do emptyTest :: SpecWith (PersistentBlockStateContext PV) emptyTest = it "empty" $ \bs -> - runNoLoggerT $ flip runBlobStoreT bs $ - (checkEquivalent B.emptyAccounts (P.emptyAccountsAndDiffMap Nothing) :: BlobStoreT (PersistentBlockStateContext PV) (NoLoggerT IO) ()) + runNoLoggerT $ + flip runBlobStoreT bs $ + (checkEquivalent B.emptyAccounts (P.emptyAccountsAndDiffMap Nothing) :: BlobStoreT (PersistentBlockStateContext PV) (NoLoggerT IO) ()) actionTest :: Word -> SpecWith (PersistentBlockStateContext PV) actionTest lvl = it "account actions" $ \bs -> withMaxSuccess (100 * fromIntegral lvl) $ property $ do diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs index 8be818b70b..0132a222fc 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs @@ -7,9 +7,8 @@ module GlobalStateTests.DifferenceMap where import Concordium.ID.Types (randomAccountAddress) import Concordium.Types -import System.Random -import Control.Monad (when) import qualified Data.Map.Strict as Map +import System.Random import qualified Concordium.GlobalState.AccountMap.DifferenceMap as DiffMap @@ -30,6 +29,7 @@ testInsertLookupAccount = do where acc = dummyPair 1 +-- | Testing lookups in flat and nested difference maps. testLookups :: Assertion testLookups = do let diffMap1 = uncurry DiffMap.insert (dummyPair 1) $ DiffMap.empty Nothing @@ -42,17 +42,18 @@ testLookups = do checkExists (dummyPair 2) diffMap3 checkExists (dummyPair 3) diffMap3 where - checkExists pair diffMap = + checkExists pair diffMap = case DiffMap.lookup (fst pair) diffMap of Nothing -> assertFailure "account should be present" Just accIdx -> assertEqual "wrong account index" (snd pair) accIdx +-- | Test flattening a difference map i.e. return all accounts as one flat map. testFlatten :: Assertion testFlatten = do let diffMap1 = uncurry DiffMap.insert (dummyPair 1) $ DiffMap.empty Nothing diffMap2 = uncurry DiffMap.insert (dummyPair 2) (DiffMap.empty $ Just diffMap1) diffMap3 = uncurry DiffMap.insert (dummyPair 3) (DiffMap.empty $ Just diffMap2) - assertEqual "accounts should be the same" (Map.fromList (map dummyPair [1..3])) $ DiffMap.flatten diffMap3 + assertEqual "accounts should be the same" (Map.fromList (map dummyPair [1 .. 3])) $ DiffMap.flatten diffMap3 tests :: Spec tests = describe "AccountMap.DifferenceMap" $ do diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs index 3dade37c00..85246864c9 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs @@ -11,9 +11,9 @@ module GlobalStateTests.LMDBAccountMap where import Control.Exception (bracket) import Control.Monad.Reader +import Data.Maybe (isJust) import System.IO.Temp import System.Random -import Data.Maybe (isJust) import Concordium.ID.Types (randomAccountAddress) import Concordium.Logger @@ -74,18 +74,19 @@ testLookupAccountViaAlias = runTest "lookupviaalias" $ do Just accIndex -> liftIO $ assertEqual "account indices should match" (snd acc) accIndex where acc = dummyPair 1 - -- | Test for retrieving all accounts present in the LMDB store. testGetAllAccounts :: Assertion testGetAllAccounts = runTest "allaccounts" $ do -- initialize the database - void $ LMDBAccountMap.insert $ dummyPair <$> [0..42] - void $ LMDBAccountMap.insert $ dummyPair <$> [42..84] + void $ LMDBAccountMap.insert $ dummyPair <$> [0 .. 42] + void $ LMDBAccountMap.insert $ dummyPair <$> [42 .. 84] allAccounts <- LMDBAccountMap.all when (length allAccounts /= 85) $ - liftIO $ assertFailure $ "unexpected number of accounts: " <> (show . length) allAccounts <> " should be " <> show (85 :: Int) - forM_ (dummyPair <$> [0..84]) $ \(accAddr, _) -> do + liftIO $ + assertFailure $ + "unexpected number of accounts: " <> (show . length) allAccounts <> " should be " <> show (85 :: Int) + forM_ (dummyPair <$> [0 .. 84]) $ \(accAddr, _) -> do isPresent <- isJust <$> LMDBAccountMap.lookup accAddr liftIO $ assertBool "account should be present" isPresent diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs b/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs index 11fad39225..3970716bb8 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs @@ -141,14 +141,15 @@ createTestBlockStateWithAccounts :: [BS.PersistentAccount (Types.AccountVersionFor pv)] -> PersistentBSM pv (BS.HashedPersistentBlockState pv) createTestBlockStateWithAccounts accounts = do - bs <- BS.initialPersistentState - seedState - DummyData.dummyCryptographicParameters - accounts - DummyData.dummyIdentityProviders - DummyData.dummyArs - keys - DummyData.dummyChainParameters + bs <- + BS.initialPersistentState + seedState + DummyData.dummyCryptographicParameters + accounts + DummyData.dummyIdentityProviders + DummyData.dummyArs + keys + DummyData.dummyChainParameters -- save the block state so accounts are written to the lmdb account map. void $ BS.saveBlockState bs return bs From 1a915abccb513d19961b3ebfdf67dd6ff90d6a73 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Mon, 23 Oct 2023 16:37:48 +0200 Subject: [PATCH 31/92] Work on initial populating of lmdb account map. --- .../GlobalState/Persistent/Accounts.hs | 30 +++++++++++++++---- .../globalstate/GlobalStateTests/Accounts.hs | 4 ++- 2 files changed, 27 insertions(+), 7 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 9d4ea47223..f59f80b56f 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -281,15 +281,14 @@ updateAccountsAtIndex' fupd ai = fmap snd . updateAccountsAtIndex fupd' ai fupd' = fmap ((),) . fupd -- | Get a list of all account addresses and their assoicated account indices. -allAccountAddressesAndIndices :: (SupportsPersistentAccount pv m) => AccountsAndDiffMap pv -> m [(AccountAddress, AccountIndex)] -allAccountAddressesAndIndices accounts = do +allAccounts :: (SupportsPersistentAccount pv m) => AccountsAndDiffMap pv -> m [(AccountAddress, AccountIndex)] +allAccounts accounts = do persistedAccs <- Map.fromList <$> LMDBAccountMap.all - let allAccounts = persistedAccs `Map.union` DiffMap.flatten (aadDiffMap accounts) - return $ Map.toList allAccounts + return $ Map.toList $ persistedAccs `Map.union` DiffMap.flatten (aadDiffMap accounts) -- | Get a list of all account addresses. accountAddresses :: (SupportsPersistentAccount pv m) => AccountsAndDiffMap pv -> m [AccountAddress] -accountAddresses accounts = map fst <$> allAccountAddressesAndIndices accounts +accountAddresses accounts = map fst <$> allAccounts accounts -- | Serialize accounts in V0 format. serializeAccounts :: (SupportsPersistentAccount pv m, MonadPut m) => GlobalContext -> AccountsAndDiffMap pv -> m () @@ -301,10 +300,29 @@ serializeAccounts cryptoParams AccountsAndDiffMap{..} = do foldAccounts :: (SupportsPersistentAccount pv m) => (a -> PersistentAccount (AccountVersionFor pv) -> m a) -> a -> Accounts pv -> m a foldAccounts f a accts = L.mfold f a (accountTable accts) --- | Fold over the account table in ascending order of account index. +-- | Fold over the account table in descending order of account index. foldAccountsDesc :: (SupportsPersistentAccount pv m) => (a -> PersistentAccount (AccountVersionFor pv) -> m a) -> a -> Accounts pv -> m a foldAccountsDesc f a accts = L.mfoldDesc f a (accountTable accts) +-- | Get all account addresses and their assoicated 'AccountIndex' via the account table in ascending order +-- of account index. +-- Note. This should only be used as part of migrating accounts to the lmdb backed account map. +-- All other queries should use 'allAccounts'. +allAccountsViaTable :: (SupportsPersistentAccount pv m) => AccountsAndDiffMap pv -> m [(AccountAddress, AccountIndex)] +allAccountsViaTable accts = do + addresses <- foldAccountsDesc (\accum pacc -> do + addr <- accountCanonicalAddress pacc + return $ addr : accum) + [] + (aadAccounts accts) + return $! zip addresses [0..] + +-- | Establish the LMDB account map from the accounts table of the provided 'AccountsAndDiffMap' +-- Returns 'True' if the lmdb backed map was established. +-- Returns 'False' if the LMDB store was already established. +establishLMDBStore :: (SupportsPersistentAccount pv m) => AccountsAndDiffMap pv -> m Bool +establishLMDBStore accts = undefined + -- | See documentation of @migratePersistentBlockState@. migrateAccounts :: forall oldpv pv t m. diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs index 44788e36f3..8704543a7e 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs @@ -68,7 +68,9 @@ checkBinaryM bop x y sbop sx sy = do -- use registration ids. checkEquivalent :: (P.SupportsPersistentAccount PV m, av ~ AccountVersionFor PV) => B.Accounts PV -> P.AccountsAndDiffMap PV -> m () checkEquivalent ba pa@P.AccountsAndDiffMap{..} = do - addrsAndIndices <- P.allAccountAddressesAndIndices pa + addrsAndIndices <- P.allAccounts pa + viaTable <- P.allAccountsViaTable pa + checkBinary (==) (Map.fromList viaTable) (Map.fromList addrsAndIndices) "==" "Account table" "Persistent account map" checkBinary (==) (AccountMap.toMapPure (B.accountMap ba)) (Map.fromList addrsAndIndices) "==" "Basic account map" "Persistent account map" let bat = BAT.toList (B.accountTable ba) pat <- L.toAscPairList (P.accountTable aadAccounts) From 90f7b135f4584de5e8d2c176501c048ddd284e18 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Mon, 23 Oct 2023 16:38:31 +0200 Subject: [PATCH 32/92] Rename. --- .../src/Concordium/GlobalState/Persistent/Accounts.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index f59f80b56f..066514b126 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -317,11 +317,11 @@ allAccountsViaTable accts = do (aadAccounts accts) return $! zip addresses [0..] --- | Establish the LMDB account map from the accounts table of the provided 'AccountsAndDiffMap' +-- | Populate the LMDB account map from the accounts table of the provided 'AccountsAndDiffMap' -- Returns 'True' if the lmdb backed map was established. -- Returns 'False' if the LMDB store was already established. -establishLMDBStore :: (SupportsPersistentAccount pv m) => AccountsAndDiffMap pv -> m Bool -establishLMDBStore accts = undefined +populateLMDBStore :: (SupportsPersistentAccount pv m) => AccountsAndDiffMap pv -> m Bool +populateLMDBStore accts = undefined -- | See documentation of @migratePersistentBlockState@. migrateAccounts :: From 6ab3281054e678cb99d28d4b8e2e82d2ae362ea7 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Tue, 24 Oct 2023 14:29:04 +0200 Subject: [PATCH 33/92] Initializing of lmdb backed account map from existing state. --- .../src/Concordium/GlobalState.hs | 7 +++++ .../Concordium/GlobalState/AccountMap/LMDB.hs | 28 +++++++++-------- .../src/Concordium/GlobalState/BlockState.hs | 10 +++++++ .../GlobalState/Persistent/Accounts.hs | 30 +++++++++++-------- .../GlobalState/Persistent/BlockState.hs | 7 +++++ .../GlobalState/Persistent/TreeState.hs | 6 ++++ .../src/Concordium/KonsensusV1/SkovMonad.hs | 6 ++++ .../GlobalStateTests/LMDBAccountMap.hs | 6 ++-- 8 files changed, 70 insertions(+), 30 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState.hs b/concordium-consensus/src/Concordium/GlobalState.hs index c0516e3cb2..fde79c850a 100644 --- a/concordium-consensus/src/Concordium/GlobalState.hs +++ b/concordium-consensus/src/Concordium/GlobalState.hs @@ -9,6 +9,7 @@ -- and shutdown. module Concordium.GlobalState where +import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Reader.Class @@ -16,6 +17,7 @@ import Control.Monad.Trans.Reader hiding (ask) import Data.Proxy import Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap +import Concordium.GlobalState.BlockPointer (_bpState) import Concordium.GlobalState.BlockState import Concordium.GlobalState.Parameters import Concordium.GlobalState.Persistent.Account (newAccountCache) @@ -80,6 +82,11 @@ initialiseExistingGlobalState _ GlobalStateConfig{..} = do skovData <- runLoggerT (loadSkovPersistentData dtdbRuntimeParameters dtdbTreeStateDirectory pbsc) logm `onException` closeBlobStore pbscBlobStore + -- initialize the account map if it has not already been so. + logm Skov LLDebug "Try initialize LMDB account map" + let lfbState = _bpState $ _lastFinalized skovData + void $ flip runLoggerT logm $ flip runReaderT pbsc $ runPersistentBlockStateMonad (tryPopulateAccountMap lfbState) + logm Skov LLDebug "Finished initializing LMDB account map" return (Just (pbsc, skovData)) else return Nothing diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index 51f2e241e9..2c01f78cf5 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -70,10 +70,9 @@ instance Exception DatabaseInvariantViolation where -- An implementation should ensure atomicity of operations. -- -- Invariants: --- * All accounts in the store are either finalized or "certified". --- * The +-- * All accounts in the store are in persisted blocks (finalized or certified). class (Monad m) => MonadAccountMapStore m where - -- | Adds the accounts to the underlying store. + -- | Inserts the accounts to the underlying store. insert :: [(AccountAddress, AccountIndex)] -> m () -- | Looks up the ‘AccountIndex’ for the provided ‘AccountAddress’ by using the @@ -86,13 +85,18 @@ class (Monad m) => MonadAccountMapStore m where -- in the store. all :: m [(AccountAddress, AccountIndex)] + -- | Checks whether the lmdb store is initialized or not. + isInitialized :: m Bool + instance (Monad (t m), MonadTrans t, MonadAccountMapStore m) => MonadAccountMapStore (MGSTrans t m) where insert = lift . insert lookup = lift . lookup all = lift all + isInitialized = lift isInitialized {-# INLINE insert #-} {-# INLINE lookup #-} {-# INLINE all #-} + {-# INLINE isInitialized #-} deriving via (MGSTrans (StateT s) m) instance (MonadAccountMapStore m) => MonadAccountMapStore (StateT s m) deriving via (MGSTrans (ExceptT e) m) instance (MonadAccountMapStore m) => MonadAccountMapStore (ExceptT e m) @@ -102,6 +106,7 @@ instance (MonadAccountMapStore m) => MonadAccountMapStore (PutT m) where insert = lift . insert lookup = lift . lookup all = lift all + isInitialized = lift isInitialized -- * Database stores @@ -258,17 +263,10 @@ asWriteTransaction t = do (LMDB_Error _ _ (Right MDB_MAP_FULL)) -> Just () _ -> Nothing --- | Check if the database is initialized (i.e. whether any accounts are present in the map). --- If the database is initialized then the function will return --- @True@ and otherwise @False@. -isInitialized :: (MonadIO m) => DatabaseHandlers -> m Bool -isInitialized dbh = liftIO $ transaction (dbh ^. storeEnv) True $ \txn -> (/= 0) <$> databaseSize txn (dbh ^. accountMapStore) - --- | Perform an unsafe roll back of the LMDB store. --- This function deletes the provided accounts from the store and sets the last finalized block --- to the provided hash and height. +-- | Delete the provided accounts from the LMDB store. -- --- It is to be considered unsafe as it does not +-- This function should only be used when rolling back certified blocks. When rolling back finalized blocks, +-- no accounts should be deleted as they are already confirmed to be finalized. unsafeRollback :: (MonadIO m, MonadLogger m, MonadReader r m, HasDatabaseHandlers r) => [AccountAddress] -> m () unsafeRollback accounts = do handlers <- ask @@ -314,3 +312,7 @@ instance checkEquivalence x y = accountAddressEmbed x == accountAddressEmbed y all = asReadTransaction $ \dbh txn -> loadAll txn (dbh ^. accountMapStore) + + isInitialized = do + size <- asReadTransaction $ \dbh txn -> databaseSize txn (dbh ^. accountMapStore) + return $ size /= 0 diff --git a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs index a6b639438c..0fddc53150 100644 --- a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs @@ -1401,6 +1401,14 @@ class (BlockStateOperations m, FixedSizeSerialization (BlockStateRef m)) => Bloc -- and update sequence numbers populated. cacheBlockStateAndGetTransactionTable :: BlockState m -> m TransactionTable + -- | Populate the LMDB account map if it has not already been initialized. + -- If the lmdb store has already been intialized, then this function does nothing. + -- This function must only be invoked when starting up when then account table already + -- contains accounts but these are not reflected in the lmdb backed account map. + -- + -- In particular this is the case when starting up from an existing state. + tryPopulateAccountMap :: BlockState m -> m () + instance (Monad (t m), MonadTrans t, ModuleQuery m) => ModuleQuery (MGSTrans t m) where getModuleArtifact = lift . getModuleArtifact {-# INLINE getModuleArtifact #-} @@ -1666,6 +1674,7 @@ instance (Monad (t m), MonadTrans t, BlockStateStorage m) => BlockStateStorage ( collapseCaches = lift collapseCaches cacheBlockState = lift . cacheBlockState cacheBlockStateAndGetTransactionTable = lift . cacheBlockStateAndGetTransactionTable + tryPopulateAccountMap = lift . tryPopulateAccountMap {-# INLINE thawBlockState #-} {-# INLINE freezeBlockState #-} {-# INLINE dropUpdatableBlockState #-} @@ -1678,6 +1687,7 @@ instance (Monad (t m), MonadTrans t, BlockStateStorage m) => BlockStateStorage ( {-# INLINE collapseCaches #-} {-# INLINE cacheBlockState #-} {-# INLINE cacheBlockStateAndGetTransactionTable #-} + {-# INLINE tryPopulateAccountMap #-} deriving via (MGSTrans MaybeT m) instance (BlockStateQuery m) => BlockStateQuery (MaybeT m) deriving via (MGSTrans MaybeT m) instance (AccountOperations m) => AccountOperations (MaybeT m) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 066514b126..09292c5637 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -14,7 +14,7 @@ module Concordium.GlobalState.Persistent.Accounts where -import Control.Monad.State +import Control.Monad.Reader import Data.Foldable (foldlM) import qualified Data.Map.Strict as Map import Data.Maybe @@ -310,18 +310,22 @@ foldAccountsDesc f a accts = L.mfoldDesc f a (accountTable accts) -- All other queries should use 'allAccounts'. allAccountsViaTable :: (SupportsPersistentAccount pv m) => AccountsAndDiffMap pv -> m [(AccountAddress, AccountIndex)] allAccountsViaTable accts = do - addresses <- foldAccountsDesc (\accum pacc -> do - addr <- accountCanonicalAddress pacc - return $ addr : accum) - [] - (aadAccounts accts) - return $! zip addresses [0..] - --- | Populate the LMDB account map from the accounts table of the provided 'AccountsAndDiffMap' --- Returns 'True' if the lmdb backed map was established. --- Returns 'False' if the LMDB store was already established. -populateLMDBStore :: (SupportsPersistentAccount pv m) => AccountsAndDiffMap pv -> m Bool -populateLMDBStore accts = undefined + addresses <- + foldAccountsDesc + ( \accum pacc -> do + addr <- accountCanonicalAddress pacc + return $ addr : accum + ) + [] + (aadAccounts accts) + return $! zip addresses [0 ..] + +-- | If the LMDB account map is not already initialized, then this function populates the LMDB account map via the provided provided 'AccountsAndDiffMap'. +-- Otherwise, this function does nothing. +tryPopulateLMDBStore :: (SupportsPersistentAccount pv m) => AccountsAndDiffMap pv -> m () +tryPopulateLMDBStore accts = do + isInitialized <- LMDBAccountMap.isInitialized + unless isInitialized (void $ LMDBAccountMap.insert =<< allAccountsViaTable accts) -- | See documentation of @migratePersistentBlockState@. migrateAccounts :: diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 95cd81572b..d57d291f65 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -50,6 +50,7 @@ import Concordium.GlobalState.Parameters import Concordium.GlobalState.Persistent.Account import Concordium.GlobalState.Persistent.Accounts (SupportsPersistentAccount) import qualified Concordium.GlobalState.Persistent.Accounts as Accounts +import qualified Concordium.GlobalState.Persistent.Accounts as LMDBAccountMap import Concordium.GlobalState.Persistent.Bakers import Concordium.GlobalState.Persistent.BlobStore import qualified Concordium.GlobalState.Persistent.BlockState.Modules as Modules @@ -3588,6 +3589,7 @@ instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateStorage cacheBlockState = cacheState cacheBlockStateAndGetTransactionTable = cacheStateAndGetTransactionTable + tryPopulateAccountMap = doTryPopulateAccountMap -- | Migrate the block state from the representation used by protocol version -- @oldpv@ to the one used by protocol version @pv@. The migration is done gradually, @@ -3729,6 +3731,11 @@ cacheState hpbs = do } return () +doTryPopulateAccountMap :: (SupportsPersistentState pv m) => HashedPersistentBlockState pv -> m () +doTryPopulateAccountMap hpbs = do + BlockStatePointers{..} <- loadPBS (hpbsPointers hpbs) + LMDBAccountMap.tryPopulateLMDBStore bspAccounts + -- | Cache the block state and get the initial (empty) transaction table with the next account nonces -- and update sequence numbers populated. cacheStateAndGetTransactionTable :: diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs index 6f69eb6383..13f7cbb6b4 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs @@ -368,6 +368,12 @@ checkExistingDatabase treeStateDir blockStateFile accountMapDir = do checkRWFile accountMapFile AccountMapPermissionError mapM_ (logEvent TreeState LLTrace) ["Existing database found.", "TreeState filepath: " ++ show blockStateFile, "BlockState filepath: " ++ show treeStateFile ++ "AccountMap filepath: " ++ accountMapFile] return True + | bsPathEx && tsPathEx -> do + -- check whether it is a normal file and whether we have the right permissions + checkRWFile blockStateFile BlockStatePermissionError + checkRWFile treeStateFile TreeStatePermissionError + mapM_ (logEvent TreeState LLTrace) ["Existing database found.", "TreeState filepath: " ++ show blockStateFile, "BlockState filepath: " ++ show treeStateFile ++ "AccountMap not found"] + return True | bsPathEx -> do logEvent GlobalState LLWarning "Block state file exists, but tree state database does not. Deleting the block state file." liftIO $ removeFile blockStateFile diff --git a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs index eaba9dbf3d..0bf2babdfb 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs @@ -32,6 +32,7 @@ import Concordium.GlobalState.BlockMonads import Concordium.GlobalState.BlockState import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap +import qualified Concordium.GlobalState.BlockState as PBS import Concordium.GlobalState.Parameters hiding (getChainParameters) import Concordium.GlobalState.Persistent.Account import Concordium.GlobalState.Persistent.BlobStore @@ -523,6 +524,11 @@ initialiseExistingSkovV1 bakerCtx handlerCtx unliftSkov GlobalStateConfig{..} = runInitMonad (loadSkovData gscRuntimeParameters (rollCount > 0)) initContext + -- initialize the account map if it has not already been so. + let lfbState = initialSkovData ^. lastFinalized . to bpState + logEvent Skov LLDebug "Try initialize LMDB account map" + void $ flip runReaderT pbsc $ PBS.runPersistentBlockStateMonad (PBS.tryPopulateAccountMap lfbState) + logEvent Skov LLDebug "Finsihed initializing LMDB account map" let !es = ExistingSkov { esContext = diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs index 85246864c9..aecde2a625 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs @@ -42,16 +42,14 @@ runTest dirName action = withTempDirectory "" dirName $ \path -> -- | Test that a database is not initialized. testCheckNotInitialized :: Assertion testCheckNotInitialized = runTest "notinitialized" $ do - dbh <- ask - liftIO (assertBool "database should not have been initialized" =<< not <$> LMDBAccountMap.isInitialized dbh) + liftIO (assertBool "database should not have been initialized" =<< not <$> LMDBAccountMap.isInitialized) -- | Test that a database is initialized. testCheckDbInitialized :: Assertion testCheckDbInitialized = runTest "initialized" $ do -- initialize the database void $ LMDBAccountMap.insert [dummyPair 1] - dbh <- ask - liftIO (assertBool "database should have been initialized" =<< LMDBAccountMap.isInitialized dbh) + liftIO (assertBool "database should have been initialized" =<< LMDBAccountMap.isInitialized) -- | Test that inserts a set of accounts and afterwards asserts that they are present. testInsertAndLookupAccounts :: Assertion From 60f6afc570c2e43d3efe5858c24854b66d50d4d2 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Tue, 24 Oct 2023 15:22:00 +0200 Subject: [PATCH 34/92] Fix test. --- .../tests/globalstate/GlobalStateTests/LMDBAccountMap.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs index aecde2a625..6e71fd683b 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs @@ -42,14 +42,16 @@ runTest dirName action = withTempDirectory "" dirName $ \path -> -- | Test that a database is not initialized. testCheckNotInitialized :: Assertion testCheckNotInitialized = runTest "notinitialized" $ do - liftIO (assertBool "database should not have been initialized" =<< not <$> LMDBAccountMap.isInitialized) + isInitialized <- LMDBAccountMap.isInitialized + liftIO $ assertBool "database should not have been initialized" $ not isInitialized -- | Test that a database is initialized. testCheckDbInitialized :: Assertion testCheckDbInitialized = runTest "initialized" $ do -- initialize the database void $ LMDBAccountMap.insert [dummyPair 1] - liftIO (assertBool "database should have been initialized" =<< LMDBAccountMap.isInitialized) + isInitialized <- LMDBAccountMap.isInitialized + liftIO $ assertBool "database should have been initialized" isInitialized -- | Test that inserts a set of accounts and afterwards asserts that they are present. testInsertAndLookupAccounts :: Assertion From 38afaeb1e377ada96b9d4a6d16e9077750972860 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Wed, 25 Oct 2023 12:36:08 +0200 Subject: [PATCH 35/92] Documentation. --- .../GlobalState/Persistent/Accounts.hs | 40 +++++++++++++++++++ 1 file changed, 40 insertions(+) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 09292c5637..2cca590e10 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -12,6 +12,46 @@ -- for pattern matching. (See: https://gitlab.haskell.org/ghc/ghc/-/issues/20896) {-# OPTIONS_GHC -Wno-redundant-constraints #-} +-- | +-- * Adding accounts +-- When an account is added (via ‘putNewAccount’) then it is first added to the ‘DifferenceMap’, it is kept in memory for the block until it either gets finalized or pruned. +-- If a block is pruned then the retaining pointers are dropped and thus the block and associated ‘DifferenceMap’ is evicted from memory. +-- +-- A thawed block is behind a ‘BufferedRef’, this ‘BufferedRef’ is written to disk upon finalization (or certification for consensus version 1). +-- This in return invokes ‘storeUpdate’ for all intermediate references for the block state for the particular block. +-- When the accounts structure is being written to disk so is the ‘DifferenceMap’ i.e. the contents of the ‘DifferenceMap’ is being written to the lmdb backed account map. +-- +-- * Startup flow +-- When a consensus runner starts up it can either be via an existing state or from a fresh state (i.e. via a provided genesis configuration) +-- +-- In the latter case then when starting up it is checked whether the lmdb backed account map is populated or not. +-- If the map is not populated then it is being populated by traversing the account table and writing all @AccountAddress -> AccountIndex@ mappings into +-- the lmdb store in one transaction and then it proceeds as normal. +-- On the other hand, if the lmdb backed account map is already populated then the startup procedure will skip the populating step. +-- +-- When starting up from a fresh genesis configuration then as part of creating the genesis state the difference map is being built containing all accounts present in the genesis configuration. +-- When the genesis block is being written to disk, then so is the ‘DifferenceMap’ via the ‘storeUpdate’ implementation of the accounts structure. +-- +-- * Rollbacks +-- For consensus version 0 no actions are required when rolling back blocks. That is because we only ever store finalized blocks in this consensus version, +-- then there is no need to actually roll back any of the account present in the lmdb backed account map - as the accounts are finalized. +-- +-- For consensus version 1 we also store certified blocks in addition to the finalized blocks. +-- Thus we have to roll back accounts that have been added to a certified block that is being rolled back. +-- We do not need to roll back accounts that have been added as part of finalized blocks in this consensus version as explained above for consensus version 0. +-- +-- General flow +-- The account map resides in its own lmdb database and functions across protocol versions. +-- There is a ‘DifferenceMap’ associated with each block. +-- For frozen blocks this is simply empty, while for thawed blocks it may or may not contain @ AccountAddress -> AccountIndex@ mappings depending on whether an account has been added for that particular block. +-- +-- The lmdb backed account map consists of a single lmdb store indexed by AccountAddresses and values are the associated ‘AccountIndex’ for each account. +-- +-- (The ‘DifferenceMap’ consists of a @Map AccountAddress AccountIndes@ which retains the accounts that have been added to the chain for the associated block. +-- Moreover the ‘DifferenceMap’ potentially retains a pointer to a so-called parent ‘DifferenceMap’. +-- I.e. @Maybe DifferenceMap@. If this is @Nothing@ then it means that the parent block is certified or finalized. +-- If the parent map yields a ‘DifferenceMap’ then the parent block is not persisted yet, and so the ‘DifferenceMap’ uses this parent map +-- for keeping track of non persisted accounts for supporting e.g. queries via the ‘AccountAddress’. module Concordium.GlobalState.Persistent.Accounts where import Control.Monad.Reader From a34d662f1eb1091fe203dbbcfaf0625c85ebec6a Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Wed, 25 Oct 2023 15:13:03 +0200 Subject: [PATCH 36/92] Formatting. --- .../src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs index 2661ec0633..4fcf16a3dd 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs @@ -806,8 +806,7 @@ rollBackBlocksUntil checkState = do count (qcRound qc - 1) else do - -- delete any accounts created in this block in the LMDB account map. - + -- delete any accounts created in this certified block in the LMDB account map. let accountsToDelete = mapMaybe getAccountAddressFromDeployment (blockTransactions block) void $ LMDBAccountMap.unsafeRollback accountsToDelete -- Delete the block and the QC @@ -870,7 +869,7 @@ rollBackBlocksUntil checkState = do return count -- Roll back finalized blocks until the last explicitly finalized block where the state -- check passes. - -- Note, that we do not need to delete accounts in the LMDB account map as + -- Note, that we do not need to delete accounts in the LMDB account map as finalized accounts should never be rolled back. rollFinalized count lastFin = do when (blockRound lastFin == 0) $ throwM . DatabaseRecoveryFailure $ From e85efdbec206d80fac1c0f3194342769fcb772e5 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Wed, 25 Oct 2023 21:59:45 +0200 Subject: [PATCH 37/92] Fix historical queries for allAccounts, fix bug in roll back which did not delete accounts created in certified blocks when lfb was invalid, fix backwards compatibility issue when de/serializing accounts structure. --- .../src/Concordium/GlobalState/BlockState.hs | 7 +- .../GlobalState/Persistent/Accounts.hs | 48 ++++++++++---- .../GlobalState/Persistent/BlockState.hs | 6 ++ .../src/Concordium/KonsensusV1/SkovMonad.hs | 6 +- .../KonsensusV1/TreeState/LowLevel/LMDB.hs | 65 +++++++++--------- .../src/Concordium/Queries.hs | 66 ++++++++++++------- 6 files changed, 128 insertions(+), 70 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs index 0fddc53150..533ecb3a3c 100644 --- a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs @@ -509,10 +509,14 @@ class (ContractStateOperations m, AccountOperations m, ModuleQuery m) => BlockSt -- | Get the list of addresses of modules existing in the given block state. getModuleList :: BlockState m -> m [ModuleRef] - -- | Get the list of account addresses existing in the given block state. + -- | Get the list of account addresses existing in the best block state. -- This returns the canonical addresses. getAccountList :: BlockState m -> m [AccountAddress] + -- | Get the list of account addresses existing in the given historical block state. + -- This returns the canonical addresses. + getAccountListHistorical :: BlockState m -> m [AccountAddress] + -- | Get the list of contract instances existing in the given block state. -- The list should be returned in ascending order of addresses. getContractInstanceList :: BlockState m -> m [ContractAddress] @@ -1428,6 +1432,7 @@ instance (Monad (t m), MonadTrans t, BlockStateQuery m) => BlockStateQuery (MGST getContractInstance s = lift . getContractInstance s getModuleList = lift . getModuleList getAccountList = lift . getAccountList + getAccountListHistorical = lift . getAccountListHistorical getContractInstanceList = lift . getContractInstanceList getSeedState = lift . getSeedState getCurrentEpochBakers = lift . getCurrentEpochBakers diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 2cca590e10..7fb1a37bb5 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -14,27 +14,35 @@ -- | -- * Adding accounts --- When an account is added (via ‘putNewAccount’) then it is first added to the ‘DifferenceMap’, it is kept in memory for the block until it either gets finalized or pruned. +-- When an account is added (via ‘putNewAccount’) then it is first added to the ‘DifferenceMap’, +-- it is kept in memory for the block until it either gets finalized or pruned. -- If a block is pruned then the retaining pointers are dropped and thus the block and associated ‘DifferenceMap’ is evicted from memory. -- --- A thawed block is behind a ‘BufferedRef’, this ‘BufferedRef’ is written to disk upon finalization (or certification for consensus version 1). +-- A thawed block is behind a ‘BufferedRef’, this ‘BufferedRef’ is written to disk upon finalization +-- (or certification for consensus version 1). -- This in return invokes ‘storeUpdate’ for all intermediate references for the block state for the particular block. --- When the accounts structure is being written to disk so is the ‘DifferenceMap’ i.e. the contents of the ‘DifferenceMap’ is being written to the lmdb backed account map. +-- When the accounts structure is being written to disk so is the ‘DifferenceMap’, +-- i.e. the contents of the ‘DifferenceMap’ is being written to the lmdb backed account map. -- -- * Startup flow --- When a consensus runner starts up it can either be via an existing state or from a fresh state (i.e. via a provided genesis configuration) +-- When a consensus runner starts up it can either be via an existing state or +-- from a fresh state (i.e. via a provided genesis configuration) -- -- In the latter case then when starting up it is checked whether the lmdb backed account map is populated or not. --- If the map is not populated then it is being populated by traversing the account table and writing all @AccountAddress -> AccountIndex@ mappings into +-- If the map is not populated then it is being populated by traversing the account table +-- and writing all @AccountAddress -> AccountIndex@ mappings into -- the lmdb store in one transaction and then it proceeds as normal. -- On the other hand, if the lmdb backed account map is already populated then the startup procedure will skip the populating step. -- --- When starting up from a fresh genesis configuration then as part of creating the genesis state the difference map is being built containing all accounts present in the genesis configuration. --- When the genesis block is being written to disk, then so is the ‘DifferenceMap’ via the ‘storeUpdate’ implementation of the accounts structure. +-- When starting up from a fresh genesis configuration then as part of creating the genesis state, +-- then the difference map is being built containing all accounts present in the genesis configuration. +-- When the genesis block is being written to disk, then so is the ‘DifferenceMap’ +-- via the ‘storeUpdate’ implementation of the accounts structure. -- -- * Rollbacks --- For consensus version 0 no actions are required when rolling back blocks. That is because we only ever store finalized blocks in this consensus version, --- then there is no need to actually roll back any of the account present in the lmdb backed account map - as the accounts are finalized. +-- For consensus version 0 no actions are required when rolling back blocks. +-- That is because we only ever store finalized blocks in this consensus version, +-- then there is no need to actually roll back any of the account present in the lmdb backed account map (as the accounts are finalized). -- -- For consensus version 1 we also store certified blocks in addition to the finalized blocks. -- Thus we have to roll back accounts that have been added to a certified block that is being rolled back. @@ -43,7 +51,8 @@ -- General flow -- The account map resides in its own lmdb database and functions across protocol versions. -- There is a ‘DifferenceMap’ associated with each block. --- For frozen blocks this is simply empty, while for thawed blocks it may or may not contain @ AccountAddress -> AccountIndex@ mappings depending on whether an account has been added for that particular block. +-- For frozen blocks this is simply empty, while for thawed blocks it may or may not +-- contain @ AccountAddress -> AccountIndex@ mappings depending on whether an account has been added for that particular block. -- -- The lmdb backed account map consists of a single lmdb store indexed by AccountAddresses and values are the associated ‘AccountIndex’ for each account. -- @@ -70,6 +79,7 @@ import Concordium.Types import Concordium.Utils.Serialization.Put import qualified Concordium.Crypto.SHA256 as H +import qualified Concordium.GlobalState.AccountMap as OldMap import qualified Concordium.GlobalState.AccountMap.DifferenceMap as DiffMap import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import Concordium.GlobalState.Parameters @@ -165,8 +175,18 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (AccountsAndDiffMap }, aadDiffMap = DiffMap.empty $ Just aadDiffMap } - return (pTable >> pRegIdHistory, newAccounts) + -- put an empty 'OldMap.PersistentAccountMap'. + -- In earlier versions of the node the above mentioned account map was used, + -- but this is now superseded by the 'LMDBAccountMap.MonadAccountMapStore'. + -- We put this (0 :: Int) here to remain backwards compatible as this simply indicates an empty map. + -- This should be revised as part of a future protocol update when the database layout can be changed. + return (put (0 :: Int) >> pTable >> pRegIdHistory, newAccounts) load = do + -- load the persistent account map and throw it away. We always put an empty one in, + -- but that has not always been the case. But the 'OldMap.PersistentAccountMap' is now superseded by + -- the LMDBAccountMap.MonadAccountMapStore. + -- This should be revised as part of a future protocol update when the database layout can be changed. + void (load :: Get (m (OldMap.PersistentAccountMap pv))) maccountTable <- load mrRIH <- load return $ do @@ -346,14 +366,14 @@ foldAccountsDesc f a accts = L.mfoldDesc f a (accountTable accts) -- | Get all account addresses and their assoicated 'AccountIndex' via the account table in ascending order -- of account index. --- Note. This should only be used as part of migrating accounts to the lmdb backed account map. --- All other queries should use 'allAccounts'. +-- Note. This function should only be used when querying a historical block. When querying with respect to the "best block" then +-- use 'allAccounts'. allAccountsViaTable :: (SupportsPersistentAccount pv m) => AccountsAndDiffMap pv -> m [(AccountAddress, AccountIndex)] allAccountsViaTable accts = do addresses <- foldAccountsDesc ( \accum pacc -> do - addr <- accountCanonicalAddress pacc + !addr <- accountCanonicalAddress pacc return $ addr : accum ) [] diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index d57d291f65..8d76b251d3 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -2236,6 +2236,11 @@ doAccountList pbs = do bsp <- loadPBS pbs Accounts.accountAddresses (bspAccounts bsp) +doGetAccountListHistorical :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m [AccountAddress] +doGetAccountListHistorical pbs = do + bsp <- loadPBS pbs + map fst <$> Accounts.allAccountsViaTable (bspAccounts bsp) + doRegIdExists :: (SupportsPersistentState pv m) => PersistentBlockState pv -> ID.CredentialRegistrationID -> m Bool doRegIdExists pbs regid = do bsp <- loadPBS pbs @@ -3388,6 +3393,7 @@ instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateQuery (P getContractInstance = doGetInstance . hpbsPointers getModuleList = doGetModuleList . hpbsPointers getAccountList = doAccountList . hpbsPointers + getAccountListHistorical = doGetAccountListHistorical . hpbsPointers getContractInstanceList = doContractInstanceList . hpbsPointers getSeedState = doGetSeedState . hpbsPointers getCurrentEpochFinalizationCommitteeParameters = doGetCurrentEpochFinalizationCommitteeParameters . hpbsPointers diff --git a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs index 0bf2babdfb..79906bded3 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs @@ -510,15 +510,17 @@ initialiseExistingSkovV1 bakerCtx handlerCtx unliftSkov GlobalStateConfig{..} = let initWithLLDB skovLldb = do checkDatabaseVersion skovLldb let checkBlockState bs = runReaderT (PBS.runPersistentBlockStateMonad (isValidBlobRef bs)) pbsc - (rollCount, bestState) <- + (rollCount, bestState, accountsToDelete) <- flip runReaderT (LMDBDatabases skovLldb $ pbscAccountMap pbsc) $ - (LMDBAccountMap.runAccountMapStoreMonad . runDiskLLDBM) (rollBackBlocksUntil checkBlockState) + runDiskLLDBM (rollBackBlocksUntil checkBlockState) when (rollCount > 0) $ do logEvent Skov LLWarning $ "Could not load state for " ++ show rollCount ++ " blocks. Truncating block state database." liftIO $ truncateBlobStore (bscBlobStore . PBS.pbscBlobStore $ pbsc) bestState + logEvent Skov LLWarning $ "Deleting " <> show (length accountsToDelete) <> " from account map." + runReaderT (LMDBAccountMap.unsafeRollback accountsToDelete) pbsc let initContext = InitContext pbsc skovLldb (initialSkovData, effectiveProtocolUpdate) <- runInitMonad diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs index 4fcf16a3dd..6e85b2af1e 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs @@ -40,7 +40,6 @@ import Concordium.Types import Concordium.Types.HashableTo import Concordium.Types.Transactions -import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import Concordium.GlobalState.LMDB.Helpers import Concordium.KonsensusV1.TreeState.LowLevel import Concordium.KonsensusV1.TreeState.Types @@ -484,12 +483,6 @@ newtype DiskLLDBM (pv :: ProtocolVersion) m a = DiskLLDBM {runDiskLLDBM :: m a} deriving instance (MonadReader r m) => MonadReader r (DiskLLDBM pv m) -deriving via - (LMDBAccountMap.AccountMapStoreMonad m) - instance - (MonadLogger m, MonadIO m, MonadReader r m, LMDBAccountMap.HasDatabaseHandlers r) => - LMDBAccountMap.MonadAccountMapStore (DiskLLDBM pv m) - instance (IsProtocolVersion pv) => MonadProtocolVersion (DiskLLDBM pv m) where type MPV (DiskLLDBM pv m) = pv @@ -726,14 +719,15 @@ rollBackBlocksUntil :: ( IsProtocolVersion pv, MonadReader r m, HasDatabaseHandlers r pv, - LMDBAccountMap.HasDatabaseHandlers r, MonadIO m, MonadCatch m, MonadLogger m ) => -- | Callback for checking if the state at a given reference is valid. (BlockStateRef pv -> DiskLLDBM pv m Bool) -> - DiskLLDBM pv m (Int, BlockStateRef pv) + -- | Returns the number of blocks rolled back, the best state after the roll back and a list of + -- accounts created in certified blocks that was rolled back. + DiskLLDBM pv m (Int, BlockStateRef pv, [AccountAddress]) rollBackBlocksUntil checkState = do lookupLastFinalizedBlock >>= \case Nothing -> throwM . DatabaseRecoveryFailure $ "No last finalized block." @@ -746,8 +740,9 @@ rollBackBlocksUntil checkState = do else do -- The last finalized block is not intact, so roll back all of the -- certified blocks, then roll back finalized blocks. - count <- purgeCertified - rollFinalized count lastFin + (count, accsCreated) <- purgeCertified + (count', bstState) <- rollFinalized count lastFin + return (count', bstState, accsCreated) where -- Check the non-finalized certified blocks, from the highest round backwards. checkCertified :: @@ -756,7 +751,7 @@ rollBackBlocksUntil checkState = do -- highest surviving block state so far (from last finalized block) BlockStateRef pv -> -- returns the number of blocks rolled back and the highest surviving block state - DiskLLDBM pv m (Int, BlockStateRef pv) + DiskLLDBM pv m (Int, BlockStateRef pv, [AccountAddress]) checkCertified lastFinRound bestState = do mHighestQC <- asReadTransaction $ \dbh txn -> withCursor @@ -764,9 +759,9 @@ rollBackBlocksUntil checkState = do (dbh ^. nonFinalizedQuorumCertificateStore) (getCursor CursorLast) case mHighestQC of - Nothing -> return (0, bestState) + Nothing -> return (0, bestState, []) Just (Left e) -> throwM . DatabaseRecoveryFailure $ e - Just (Right (_, qc)) -> checkCertifiedWithQC lastFinRound bestState 0 qc + Just (Right (_, qc)) -> checkCertifiedWithQC lastFinRound bestState 0 [] qc -- Get the account address of a creadential deployment. getAccountAddressFromDeployment bi = case bi of WithMetadata{wmdData = CredentialDeployment{biCred = AccountCreation{..}}} -> @@ -785,11 +780,13 @@ rollBackBlocksUntil checkState = do BlockStateRef pv -> -- number of blocks rolled back so far Int -> + -- accounts created in the certified blocks + [AccountAddress] -> -- QC for certified block to check QuorumCertificate -> -- returns the number of blocks rolled back and the highest surviving block state - DiskLLDBM pv m (Int, BlockStateRef pv) - checkCertifiedWithQC lastFinRound bestState !count qc = do + DiskLLDBM pv m (Int, BlockStateRef pv, [AccountAddress]) + checkCertifiedWithQC lastFinRound bestState !count accsCreated qc = do mBlock <- asReadTransaction $ \dbh txn -> loadRecord txn (dbh ^. blockStore) (qcBlock qc) case mBlock of @@ -804,11 +801,11 @@ rollBackBlocksUntil checkState = do lastFinRound (max bestState (stbStatePointer block)) count + accsCreated (qcRound qc - 1) else do - -- delete any accounts created in this certified block in the LMDB account map. + -- Record the accounts created in the rolled back certified block. let accountsToDelete = mapMaybe getAccountAddressFromDeployment (blockTransactions block) - void $ LMDBAccountMap.unsafeRollback accountsToDelete -- Delete the block and the QC asWriteTransaction $ \dbh txn -> do void $ @@ -826,6 +823,7 @@ rollBackBlocksUntil checkState = do lastFinRound bestState (count + 1) + (accsCreated ++ accountsToDelete) (qcRound qc - 1) -- Step the non-finalized certified block check to the previous round. checkCertifiedPreviousRound :: @@ -835,41 +833,46 @@ rollBackBlocksUntil checkState = do BlockStateRef pv -> -- number of blocks rolled back so far Int -> + -- Accounts created in the certified blocks + [AccountAddress] -> -- round to check for Round -> -- returns the number of blocks rolled back and the highest surviving block state - DiskLLDBM pv m (Int, BlockStateRef pv) - checkCertifiedPreviousRound lastFinRound bestState count currentRound - | currentRound <= lastFinRound = return (count, bestState) + DiskLLDBM pv m (Int, BlockStateRef pv, [AccountAddress]) + checkCertifiedPreviousRound lastFinRound bestState count accsCreated currentRound + | currentRound <= lastFinRound = return (count, bestState, accsCreated) | otherwise = do mNextQC <- asReadTransaction $ \dbh txn -> loadRecord txn (dbh ^. nonFinalizedQuorumCertificateStore) currentRound case mNextQC of Nothing -> - checkCertifiedPreviousRound lastFinRound bestState count (currentRound - 1) + checkCertifiedPreviousRound lastFinRound bestState count accsCreated (currentRound - 1) Just qc -> - checkCertifiedWithQC lastFinRound bestState count qc + checkCertifiedWithQC lastFinRound bestState count accsCreated qc -- Purge all of the certified blocks. Returns the number of blocks rolled back. purgeCertified = do - (count, hashes) <- asWriteTransaction $ \dbh txn -> do + (count, hashes, accsToDelete) <- asWriteTransaction $ \dbh txn -> do withCursor txn (dbh ^. nonFinalizedQuorumCertificateStore) $ \cursor -> do - let loop !count hashes Nothing = return (count, hashes) - loop _ _ (Just (Left e)) = throwM . DatabaseRecoveryFailure $ e - loop !count hashes (Just (Right (_, qc))) = do + let loop !count accsToDelete hashes Nothing = return (count, hashes, accsToDelete) + loop _ _ _ (Just (Left e)) = throwM . DatabaseRecoveryFailure $ e + loop !count accsToDelete hashes (Just (Right (_, qc))) = do + accsToDelete' <- + loadRecord txn (dbh ^. blockStore) (qcBlock qc) >>= \case + Nothing -> return [] + Just block -> return $ mapMaybe getAccountAddressFromDeployment (blockTransactions block) _ <- deleteRecord txn (dbh ^. blockStore) (qcBlock qc) -- Delete the QC entry. deleteAtCursor cursor - loop (count + 1) (qcBlock qc : hashes) =<< getCursor CursorNext cursor - loop 0 [] =<< getCursor CursorFirst cursor + loop (count + 1) (accsToDelete <> accsToDelete') (qcBlock qc : hashes) =<< getCursor CursorNext cursor + loop 0 [] [] =<< getCursor CursorFirst cursor logEvent LMDB LLDebug $ "The block state for the last finalized block was corrupted. \ \The following certified blocks were deleted: " <> intercalate ", " (show <$> hashes) <> "." - return count + return (count, accsToDelete) -- Roll back finalized blocks until the last explicitly finalized block where the state -- check passes. - -- Note, that we do not need to delete accounts in the LMDB account map as finalized accounts should never be rolled back. rollFinalized count lastFin = do when (blockRound lastFin == 0) $ throwM . DatabaseRecoveryFailure $ diff --git a/concordium-consensus/src/Concordium/Queries.hs b/concordium-consensus/src/Concordium/Queries.hs index 41a078eac4..2dec7bd473 100644 --- a/concordium-consensus/src/Concordium/Queries.hs +++ b/concordium-consensus/src/Concordium/Queries.hs @@ -243,7 +243,7 @@ liftSkovQueryBHI :: ) -> BlockHashInput -> MVR finconf (BHIQueryResponse a) -liftSkovQueryBHI av1 av2 = liftSkovQueryBHIAndVersion (const av1) (\_ bp _ -> av2 bp) +liftSkovQueryBHI av1 av2 = liftSkovQueryBHIAndVersion (\_ bp _ -> av1 bp) (\_ bp _ _ -> av2 bp) -- | Try a 'BlockHashInput' based state query on the latest skov version. If a specific -- block hash is given we work backwards through consensus versions until we @@ -267,6 +267,10 @@ liftSkovQueryStateBHI stateQuery = bestBlockConsensusV1 :: (MonadState (SkovV1.SkovData pv) m) => m (SkovV1.BlockPointer pv) bestBlockConsensusV1 = SkovV1.cbQuorumBlock <$> use (SkovV1.roundStatus . SkovV1.rsHighestCertifiedBlock) +-- | Whether the queried block is historical or the most recent one. +data BlockContext = BCBest | BCHistorical + deriving (Show, Eq) + -- | Try a 'BlockHashInput' based query on the latest skov version, provided with the configuration. -- If a specific block hash is given we work backwards through consensus versions until we -- find the specified block or run out of versions. @@ -281,6 +285,7 @@ liftSkovQueryBHIAndVersion :: ) => EVersionedConfiguration finconf -> BlockPointerType (VersionedSkovV0M finconf pv) -> + BlockContext -> VersionedSkovV0M finconf pv a ) -> -- | Query to run at consensus version 1. @@ -291,6 +296,7 @@ liftSkovQueryBHIAndVersion :: EVersionedConfiguration finconf -> SkovV1.BlockPointer pv -> Bool -> + BlockContext -> VersionedSkovV1M finconf pv a ) -> BlockHashInput -> @@ -306,13 +312,17 @@ liftSkovQueryBHIAndVersion av0 av1 bhi = do mvr vc -- consensus version 0 - (mapM (av0 vc) =<< resolveBlock bh) + ( do + resolveBlock bh >>= \case + Nothing -> return Nothing + Just bp -> Just <$> av0 vc bp BCHistorical + ) -- consensus version 1 ( do status <- SkovV1.getBlockStatus bh =<< get case status of - SkovV1.BlockAlive bp -> Just <$> av1 vc bp False - SkovV1.BlockFinalized bp -> Just <$> av1 vc bp True + SkovV1.BlockAlive bp -> Just <$> av1 vc bp False BCHistorical + SkovV1.BlockFinalized bp -> Just <$> av1 vc bp True BCHistorical _ -> return Nothing ) ) @@ -332,13 +342,17 @@ liftSkovQueryBHIAndVersion av0 av1 bhi = do mvr evc -- consensus version 0 - (mapM (av0 evc) =<< resolveBlock bh) + ( do + resolveBlock bh >>= \case + Nothing -> return Nothing + Just bp -> Just <$> av0 evc bp BCHistorical + ) -- consensus version 1 ( do status <- SkovV1.getBlockStatus bh =<< get case status of - SkovV1.BlockAlive bp -> Just <$> av1 evc bp False - SkovV1.BlockFinalized bp -> Just <$> av1 evc bp True + SkovV1.BlockAlive bp -> Just <$> av1 evc bp False BCHistorical + SkovV1.BlockFinalized bp -> Just <$> av1 evc bp True BCHistorical _ -> return Nothing ) return $ case maybeValue of @@ -352,17 +366,17 @@ liftSkovQueryBHIAndVersion av0 av1 bhi = do liftSkovQueryLatest ( do -- consensus version 0 - bp <- case other of - Best -> bestBlock - LastFinal -> lastFinalizedBlock - (bpHash bp,) . Just <$> av0 evc bp + (bp, blockContext) <- case other of + Best -> (,BCBest) <$> bestBlock + LastFinal -> (,BCHistorical) <$> lastFinalizedBlock + (bpHash bp,) . Just <$> av0 evc bp blockContext ) ( do -- consensus version 1 - (bp, finalized) <- case other of - Best -> (,False) <$> bestBlockConsensusV1 - LastFinal -> (,True) <$> use SkovV1.lastFinalized - (getHash bp,) . Just <$> av1 evc bp finalized + (bp, finalized, blockContext) <- case other of + Best -> (,False,BCBest) <$> bestBlockConsensusV1 + LastFinal -> (,True,BCHistorical) <$> use SkovV1.lastFinalized + (getHash bp,) . Just <$> av1 evc bp finalized blockContext ) return $ case maybeValue of Just v -> BQRBlock bh v @@ -647,7 +661,7 @@ getNextAccountNonce accountAddress = getBlockInfo :: BlockHashInput -> MVR finconf (BHIQueryResponse BlockInfo) getBlockInfo = liftSkovQueryBHIAndVersion - ( \evc bp -> do + ( \evc bp _ -> do let biBlockHash = getHash bp let biGenesisIndex = evcIndex evc biBlockParent <- @@ -682,7 +696,7 @@ getBlockInfo = let biEpoch = Nothing return BlockInfo{..} ) - ( \evc bp biFinalized -> do + ( \evc bp biFinalized _ -> do let biBlockHash = getHash bp let biGenesisIndex = evcIndex evc biBlockParent <- @@ -1013,7 +1027,15 @@ getAncestors bhi count = -- | Get a list of all accounts in the block state. getAccountList :: BlockHashInput -> MVR finconf (BHIQueryResponse [AccountAddress]) -getAccountList = liftSkovQueryStateBHI BS.getAccountList +getAccountList = + liftSkovQueryBHIAndVersion + (\_ bpt context -> getAccounts context =<< blockState bpt) + (\_ bpt _ context -> getAccounts context =<< blockState bpt) + where + getAccounts context bState = + case context of + BCBest -> BS.getAccountList bState + BCHistorical -> BS.getAccountListHistorical bState -- | Get a list of all smart contract instances in the block state. getInstanceList :: BlockHashInput -> MVR finconf (BHIQueryResponse [ContractAddress]) @@ -1266,14 +1288,14 @@ getFirstBlockEpoch (EpochOfBlock blockInput) = do where unBHIResponse BQRNoBlock = Left EQEBlockNotFound unBHIResponse (BQRBlock _ res) = res - epochOfBlockV0 curVersionIndex evc b = + epochOfBlockV0 curVersionIndex evc b _ = getFirstFinalizedOfEpoch (Right b) <&> \case Left FutureEpoch | evcIndex evc == curVersionIndex -> Left EQEFutureEpoch | otherwise -> Left EQEInvalidEpoch Left EmptyEpoch -> Left EQEBlockNotFound Right epochBlock -> Right (getHash epochBlock) - epochOfBlockV1 curVersionIndex evc b _ = + epochOfBlockV1 curVersionIndex evc b _ _ = (SkovV1.getFirstFinalizedBlockOfEpoch (Right b) =<< get) <&> \case Nothing | evcIndex evc == curVersionIndex -> Left EQEFutureEpoch @@ -1323,8 +1345,8 @@ getWinningBakersEpoch (EpochOfBlock blockInput) = do let curVersionIndex = fromIntegral (Vec.length versions - 1) res <- liftSkovQueryBHIAndVersion - (\_ _ -> return (Left EQEInvalidGenesisIndex)) - ( \evc b _ -> do + (\_ _ _ -> return (Left EQEInvalidGenesisIndex)) + ( \evc b _ _ -> do mwbs <- ConsensusV1.getWinningBakersForEpoch (SkovV1.blockEpoch b) =<< get return $! case mwbs of Nothing From 114933b5c1a4cd34b8710d62cc140760dc447d41 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Wed, 25 Oct 2023 22:31:05 +0200 Subject: [PATCH 38/92] Refactor to remove AccountsAndDiffMap and simply have the Accounts structure. --- .../GlobalState/Persistent/Accounts.hs | 170 ++++++++---------- .../GlobalState/Persistent/Bakers.hs | 2 +- .../GlobalState/Persistent/BlockState.hs | 38 ++-- .../GlobalState/Persistent/Genesis.hs | 4 +- 4 files changed, 94 insertions(+), 120 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 7fb1a37bb5..be31219833 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -124,26 +124,15 @@ data Accounts (pv :: ProtocolVersion) = Accounts { -- | Hashed Merkle-tree of the accounts accountTable :: !(LFMBTree' AccountIndex HashedBufferedRef (AccountRef (AccountVersionFor pv))), -- | Persisted representation of the map from registration ids to account indices. - accountRegIdHistory :: !(Trie.TrieN UnbufferedFix ID.RawCredentialRegistrationID AccountIndex) - } - --- | An 'Accounts' with an assoicated ' DiffMap.DifferenceMap'. --- The 'DiffMap.DifferenceMap' includes a mapping @AccountAddress -> AccountIndex@ for accounts --- which have been added to a block which have not been persisted yet (certified or finalized). --- --- For blocks which have been persisted the 'DiffMap.DifferenceMap' is @Nothing@ as potential new --- accounts have been written to the lmdb account map. -data AccountsAndDiffMap (pv :: ProtocolVersion) = AccountsAndDiffMap - { -- | The persistent accounts and what is stored on disk. - aadAccounts :: !(Accounts pv), + accountRegIdHistory :: !(Trie.TrieN UnbufferedFix ID.RawCredentialRegistrationID AccountIndex), -- | An in-memory difference map used keeping track of accounts -- added in live blocks. -- This is empty for a frozen block state. - aadDiffMap :: !DiffMap.DifferenceMap + accountDiffMap :: !DiffMap.DifferenceMap } -instance (IsProtocolVersion pv) => Show (AccountsAndDiffMap pv) where - show aad = "Accounts: " <> show (aadAccounts aad) <> "DiffMap: " <> show (aadDiffMap aad) +instance (IsProtocolVersion pv) => Show (Accounts pv) where + show accts = "Accounts: " <> show (accountTable accts) <> "DiffMap: " <> show (accountDiffMap accts) -- | A constraint that ensures a monad @m@ supports the persistent account operations. -- This essentially requires that the monad support 'MonadBlobStore', and 'MonadCache' for @@ -155,26 +144,21 @@ type SupportsPersistentAccount pv m = LMDBAccountMap.MonadAccountMapStore m ) -instance (IsProtocolVersion pv) => Show (Accounts pv) where - show a = show (accountTable a) - -instance (SupportsPersistentAccount pv m) => MHashableTo m H.Hash (AccountsAndDiffMap pv) where - getHashM AccountsAndDiffMap{..} = getHashM $ accountTable aadAccounts +instance (SupportsPersistentAccount pv m) => MHashableTo m H.Hash (Accounts pv) where + getHashM Accounts{..} = getHashM accountTable -instance (SupportsPersistentAccount pv m) => BlobStorable m (AccountsAndDiffMap pv) where - storeUpdate AccountsAndDiffMap{aadAccounts = Accounts{..}, ..} = do +instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where + storeUpdate Accounts{..} = do (pTable, accountTable') <- storeUpdate accountTable (pRegIdHistory, regIdHistory') <- storeUpdate accountRegIdHistory - LMDBAccountMap.insert (Map.toList $ DiffMap.flatten aadDiffMap) + LMDBAccountMap.insert (Map.toList $ DiffMap.flatten accountDiffMap) let newAccounts = - AccountsAndDiffMap - { aadAccounts = - Accounts - { accountTable = accountTable', - accountRegIdHistory = regIdHistory' - }, - aadDiffMap = DiffMap.empty $ Just aadDiffMap + Accounts + { accountTable = accountTable', + accountRegIdHistory = regIdHistory', + accountDiffMap = DiffMap.empty $ Just accountDiffMap } + -- put an empty 'OldMap.PersistentAccountMap'. -- In earlier versions of the node the above mentioned account map was used, -- but this is now superseded by the 'LMDBAccountMap.MonadAccountMapStore'. @@ -192,57 +176,53 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (AccountsAndDiffMap return $ do accountTable <- maccountTable accountRegIdHistory <- mrRIH - return $ AccountsAndDiffMap{aadAccounts = Accounts{..}, aadDiffMap = DiffMap.empty Nothing} + let accountDiffMap = DiffMap.empty Nothing + return $ Accounts{..} -instance (SupportsPersistentAccount pv m, av ~ AccountVersionFor pv) => Cacheable1 m (AccountsAndDiffMap pv) (PersistentAccount av) where - liftCache cch aad@AccountsAndDiffMap{aadAccounts = accts@Accounts{..}} = do +instance (SupportsPersistentAccount pv m, av ~ AccountVersionFor pv) => Cacheable1 m (Accounts pv) (PersistentAccount av) where + liftCache cch accts@Accounts{..} = do acctTable <- liftCache (liftCache @_ @(HashedCachedRef (AccountCache av) (PersistentAccount av)) cch) accountTable return - aad{aadAccounts = accts{accountTable = acctTable}} - -emptyAccounts :: Accounts pv -emptyAccounts = Accounts L.empty Trie.empty + accts{accountTable = acctTable} --- | Creates an empty 'AccountsAndDifferenceMap'. --- The difference map will inherit the difference map of the provided provided 'AccountsAndDiffMap' if supplied. -emptyAccountsAndDiffMap :: Maybe (AccountsAndDiffMap pv) -> AccountsAndDiffMap pv -emptyAccountsAndDiffMap Nothing = AccountsAndDiffMap emptyAccounts $ DiffMap.empty Nothing -emptyAccountsAndDiffMap (Just successor) = AccountsAndDiffMap emptyAccounts $ DiffMap.empty (Just $ aadDiffMap successor) +emptyAccounts :: Maybe DiffMap.DifferenceMap -> Accounts pv +emptyAccounts Nothing = Accounts L.empty Trie.empty $ DiffMap.empty Nothing +emptyAccounts successorDiffMap = Accounts L.empty Trie.empty $ DiffMap.empty successorDiffMap -- | Add a new account. Returns @Just idx@ if the new account is fresh, i.e., the address does not exist, -- or @Nothing@ in case the account already exists. In the latter case there is no change to the accounts structure. -putNewAccount :: (SupportsPersistentAccount pv m) => PersistentAccount (AccountVersionFor pv) -> AccountsAndDiffMap pv -> m (Maybe AccountIndex, AccountsAndDiffMap pv) -putNewAccount !acct a0@AccountsAndDiffMap{aadAccounts = accts0@Accounts{..}, ..} = do +putNewAccount :: (SupportsPersistentAccount pv m) => PersistentAccount (AccountVersionFor pv) -> Accounts pv -> m (Maybe AccountIndex, Accounts pv) +putNewAccount !acct a0@Accounts{..} = do addr <- accountCanonicalAddress acct exists addr a0 >>= \case True -> return (Nothing, a0) False -> do (accIdx, newAccountTable) <- L.append acct accountTable - let newDiffMap = DiffMap.insert addr accIdx aadDiffMap - return (Just accIdx, a0{aadAccounts = accts0{accountTable = newAccountTable}, aadDiffMap = newDiffMap}) + let newDiffMap = DiffMap.insert addr accIdx accountDiffMap + return (Just accIdx, a0{accountTable = newAccountTable, accountDiffMap = newDiffMap}) -- | Construct an 'Accounts' from a list of accounts. Inserted in the order of the list. -fromList :: (SupportsPersistentAccount pv m) => [PersistentAccount (AccountVersionFor pv)] -> m (AccountsAndDiffMap pv) -fromList = foldlM insert $ emptyAccountsAndDiffMap Nothing +fromList :: (SupportsPersistentAccount pv m) => [PersistentAccount (AccountVersionFor pv)] -> m (Accounts pv) +fromList = foldlM insert $ emptyAccounts Nothing where insert accounts account = snd <$> putNewAccount account accounts -- | Determine if an account with the given address exists. -exists :: (SupportsPersistentAccount pv m) => AccountAddress -> AccountsAndDiffMap pv -> m Bool +exists :: (SupportsPersistentAccount pv m) => AccountAddress -> Accounts pv -> m Bool exists addr accts = isJust <$> getAccountIndex addr accts -- | Retrieve an account associated with the given credential registration ID. -- Returns @Nothing@ if no such account exists. -getAccountByCredId :: (SupportsPersistentAccount pv m) => ID.RawCredentialRegistrationID -> AccountsAndDiffMap pv -> m (Maybe (AccountIndex, PersistentAccount (AccountVersionFor pv))) -getAccountByCredId cid accs@AccountsAndDiffMap{..} = - Trie.lookup cid (accountRegIdHistory aadAccounts) >>= \case +getAccountByCredId :: (SupportsPersistentAccount pv m) => ID.RawCredentialRegistrationID -> Accounts pv -> m (Maybe (AccountIndex, PersistentAccount (AccountVersionFor pv))) +getAccountByCredId cid accs@Accounts{..} = + Trie.lookup cid (accountRegIdHistory) >>= \case Nothing -> return Nothing Just ai -> fmap (ai,) <$> indexedAccount ai accs -- | Get the account at a given index (if any). -getAccountIndex :: (SupportsPersistentAccount pv m) => AccountAddress -> AccountsAndDiffMap pv -> m (Maybe AccountIndex) -getAccountIndex addr AccountsAndDiffMap{..} = - case DiffMap.lookup addr aadDiffMap of +getAccountIndex :: (SupportsPersistentAccount pv m) => AccountAddress -> Accounts pv -> m (Maybe AccountIndex) +getAccountIndex addr Accounts{..} = + case DiffMap.lookup addr accountDiffMap of Just accIdx -> return $ Just accIdx Nothing -> LMDBAccountMap.lookup addr >>= \case @@ -251,43 +231,40 @@ getAccountIndex addr AccountsAndDiffMap{..} = -- | Retrieve an account with the given address. -- Returns @Nothing@ if no such account exists. -getAccount :: (SupportsPersistentAccount pv m) => AccountAddress -> AccountsAndDiffMap pv -> m (Maybe (PersistentAccount (AccountVersionFor pv))) +getAccount :: (SupportsPersistentAccount pv m) => AccountAddress -> Accounts pv -> m (Maybe (PersistentAccount (AccountVersionFor pv))) getAccount addr accts = fmap snd <$> getAccountWithIndex addr accts -- | Retrieve an account and its index from a given address. -- Returns @Nothing@ if no such account exists. -getAccountWithIndex :: forall pv m. (SupportsPersistentAccount pv m) => AccountAddress -> AccountsAndDiffMap pv -> m (Maybe (AccountIndex, PersistentAccount (AccountVersionFor pv))) +getAccountWithIndex :: forall pv m. (SupportsPersistentAccount pv m) => AccountAddress -> Accounts pv -> m (Maybe (AccountIndex, PersistentAccount (AccountVersionFor pv))) getAccountWithIndex addr accts = getAccountIndex addr accts >>= \case Nothing -> return Nothing Just ai -> do - mAcc <- L.lookup ai $ accountTable (aadAccounts accts) + mAcc <- L.lookup ai $ accountTable accts return $ (ai,) <$> mAcc -- | Retrieve the account at a given index. -indexedAccount :: (SupportsPersistentAccount pv m) => AccountIndex -> AccountsAndDiffMap pv -> m (Maybe (PersistentAccount (AccountVersionFor pv))) -indexedAccount ai AccountsAndDiffMap{..} = L.lookup ai (accountTable aadAccounts) +indexedAccount :: (SupportsPersistentAccount pv m) => AccountIndex -> Accounts pv -> m (Maybe (PersistentAccount (AccountVersionFor pv))) +indexedAccount ai Accounts{..} = L.lookup ai accountTable -- | Check that an account registration ID is not already on the chain. -- See the foundation (Section 4.2) for why this is necessary. -- Return @Just ai@ if the registration ID already exists, and @ai@ is the index of the account it is or was associated with. -regIdExists :: (MonadBlobStore m) => ID.CredentialRegistrationID -> AccountsAndDiffMap pv -> m (Maybe AccountIndex) -regIdExists rid accts = Trie.lookup (ID.toRawCredRegId rid) (accountRegIdHistory $ aadAccounts accts) +regIdExists :: (MonadBlobStore m) => ID.CredentialRegistrationID -> Accounts pv -> m (Maybe AccountIndex) +regIdExists rid accts = Trie.lookup (ID.toRawCredRegId rid) (accountRegIdHistory $ accts) -- | Record an account registration ID as used. -recordRegId :: (MonadBlobStore m) => ID.CredentialRegistrationID -> AccountIndex -> AccountsAndDiffMap pv -> m (AccountsAndDiffMap pv) +recordRegId :: (MonadBlobStore m) => ID.CredentialRegistrationID -> AccountIndex -> Accounts pv -> m (Accounts pv) recordRegId rid idx accts0 = do - accountRegIdHistory' <- Trie.insert (ID.toRawCredRegId rid) idx (accountRegIdHistory (aadAccounts accts0)) + accountRegIdHistory' <- Trie.insert (ID.toRawCredRegId rid) idx (accountRegIdHistory accts0) return $! accts0 - { aadAccounts = - Accounts - { accountTable = accountTable $ aadAccounts accts0, - accountRegIdHistory = accountRegIdHistory' - } + { accountTable = accountTable accts0, + accountRegIdHistory = accountRegIdHistory' } -recordRegIds :: (MonadBlobStore m) => [(ID.CredentialRegistrationID, AccountIndex)] -> AccountsAndDiffMap pv -> m (AccountsAndDiffMap pv) +recordRegIds :: (MonadBlobStore m) => [(ID.CredentialRegistrationID, AccountIndex)] -> Accounts pv -> m (Accounts pv) recordRegIds rids accts0 = foldM (\accts (cid, idx) -> recordRegId cid idx accts) accts0 rids -- | Get the account registration ids map. This loads the entire map from the blob store, and so @@ -309,9 +286,9 @@ updateAccounts :: m (a, PersistentAccount (AccountVersionFor pv)) ) -> AccountAddress -> - AccountsAndDiffMap pv -> - m (Maybe (AccountIndex, a), AccountsAndDiffMap pv) -updateAccounts fupd addr a0@AccountsAndDiffMap{aadAccounts = accs0@Accounts{..}} = do + Accounts pv -> + m (Maybe (AccountIndex, a), Accounts pv) +updateAccounts fupd addr a0@Accounts{..} = do getAccountIndex addr a0 >>= \case Nothing -> return (Nothing, a0) Just ai -> update ai @@ -319,42 +296,42 @@ updateAccounts fupd addr a0@AccountsAndDiffMap{aadAccounts = accs0@Accounts{..}} update ai = L.update fupd ai accountTable >>= \case Nothing -> return (Nothing, a0) - Just (res, act') -> return (Just (ai, res), a0{aadAccounts = accs0{accountTable = act'}}) + Just (res, act') -> return (Just (ai, res), a0{accountTable = act'}) -- | Perform an update to an account with the given index. -- Does nothing (returning @Nothing@) if the account does not exist. -- This should not be used to alter the address of an account (which is -- disallowed). -updateAccountsAtIndex :: (SupportsPersistentAccount pv m) => (PersistentAccount (AccountVersionFor pv) -> m (a, PersistentAccount (AccountVersionFor pv))) -> AccountIndex -> AccountsAndDiffMap pv -> m (Maybe a, AccountsAndDiffMap pv) -updateAccountsAtIndex fupd ai a0@AccountsAndDiffMap{aadAccounts = accs0@Accounts{..}} = +updateAccountsAtIndex :: (SupportsPersistentAccount pv m) => (PersistentAccount (AccountVersionFor pv) -> m (a, PersistentAccount (AccountVersionFor pv))) -> AccountIndex -> Accounts pv -> m (Maybe a, Accounts pv) +updateAccountsAtIndex fupd ai a0@Accounts{..} = L.update fupd ai accountTable >>= \case Nothing -> return (Nothing, a0) - Just (res, act') -> return (Just res, a0{aadAccounts = accs0{accountTable = act'}}) + Just (res, act') -> return (Just res, a0{accountTable = act'}) -- | Perform an update to an account with the given index. -- Does nothing if the account does not exist. -- This should not be used to alter the address of an account (which is -- disallowed). -updateAccountsAtIndex' :: (SupportsPersistentAccount pv m) => (PersistentAccount (AccountVersionFor pv) -> m (PersistentAccount (AccountVersionFor pv))) -> AccountIndex -> AccountsAndDiffMap pv -> m (AccountsAndDiffMap pv) +updateAccountsAtIndex' :: (SupportsPersistentAccount pv m) => (PersistentAccount (AccountVersionFor pv) -> m (PersistentAccount (AccountVersionFor pv))) -> AccountIndex -> Accounts pv -> m (Accounts pv) updateAccountsAtIndex' fupd ai = fmap snd . updateAccountsAtIndex fupd' ai where fupd' = fmap ((),) . fupd -- | Get a list of all account addresses and their assoicated account indices. -allAccounts :: (SupportsPersistentAccount pv m) => AccountsAndDiffMap pv -> m [(AccountAddress, AccountIndex)] +allAccounts :: (SupportsPersistentAccount pv m) => Accounts pv -> m [(AccountAddress, AccountIndex)] allAccounts accounts = do persistedAccs <- Map.fromList <$> LMDBAccountMap.all - return $ Map.toList $ persistedAccs `Map.union` DiffMap.flatten (aadDiffMap accounts) + return $ Map.toList $ persistedAccs `Map.union` DiffMap.flatten (accountDiffMap accounts) -- | Get a list of all account addresses. -accountAddresses :: (SupportsPersistentAccount pv m) => AccountsAndDiffMap pv -> m [AccountAddress] +accountAddresses :: (SupportsPersistentAccount pv m) => Accounts pv -> m [AccountAddress] accountAddresses accounts = map fst <$> allAccounts accounts -- | Serialize accounts in V0 format. -serializeAccounts :: (SupportsPersistentAccount pv m, MonadPut m) => GlobalContext -> AccountsAndDiffMap pv -> m () -serializeAccounts cryptoParams AccountsAndDiffMap{..} = do - liftPut $ putWord64be $ L.size (accountTable aadAccounts) - L.mmap_ (serializeAccount cryptoParams) (accountTable aadAccounts) +serializeAccounts :: (SupportsPersistentAccount pv m, MonadPut m) => GlobalContext -> Accounts pv -> m () +serializeAccounts cryptoParams Accounts{..} = do + liftPut $ putWord64be $ L.size accountTable + L.mmap_ (serializeAccount cryptoParams) accountTable -- | Fold over the account table in ascending order of account index. foldAccounts :: (SupportsPersistentAccount pv m) => (a -> PersistentAccount (AccountVersionFor pv) -> m a) -> a -> Accounts pv -> m a @@ -368,7 +345,7 @@ foldAccountsDesc f a accts = L.mfoldDesc f a (accountTable accts) -- of account index. -- Note. This function should only be used when querying a historical block. When querying with respect to the "best block" then -- use 'allAccounts'. -allAccountsViaTable :: (SupportsPersistentAccount pv m) => AccountsAndDiffMap pv -> m [(AccountAddress, AccountIndex)] +allAccountsViaTable :: (SupportsPersistentAccount pv m) => Accounts pv -> m [(AccountAddress, AccountIndex)] allAccountsViaTable accts = do addresses <- foldAccountsDesc @@ -377,12 +354,12 @@ allAccountsViaTable accts = do return $ addr : accum ) [] - (aadAccounts accts) + accts return $! zip addresses [0 ..] -- | If the LMDB account map is not already initialized, then this function populates the LMDB account map via the provided provided 'AccountsAndDiffMap'. -- Otherwise, this function does nothing. -tryPopulateLMDBStore :: (SupportsPersistentAccount pv m) => AccountsAndDiffMap pv -> m () +tryPopulateLMDBStore :: (SupportsPersistentAccount pv m) => Accounts pv -> m () tryPopulateLMDBStore accts = do isInitialized <- LMDBAccountMap.isInitialized unless isInitialized (void $ LMDBAccountMap.insert =<< allAccountsViaTable accts) @@ -397,19 +374,16 @@ migrateAccounts :: SupportsPersistentAccount pv (t m) ) => StateMigrationParameters oldpv pv -> - AccountsAndDiffMap oldpv -> - t m (AccountsAndDiffMap pv) -migrateAccounts migration AccountsAndDiffMap{aadAccounts = Accounts{..}} = do + Accounts oldpv -> + t m (Accounts pv) +migrateAccounts migration Accounts{..} = do newAccountTable <- L.migrateLFMBTree (migrateHashedCachedRef' (migratePersistentAccount migration)) accountTable -- The account registration IDs are not cached. There is a separate cache -- that is purely in-memory and just copied over. newAccountRegIds <- Trie.migrateUnbufferedTrieN return accountRegIdHistory return $! - AccountsAndDiffMap - { aadAccounts = - Accounts - { accountTable = newAccountTable, - accountRegIdHistory = newAccountRegIds - }, - aadDiffMap = DiffMap.empty Nothing + Accounts + { accountTable = newAccountTable, + accountRegIdHistory = newAccountRegIds, + accountDiffMap = DiffMap.empty Nothing } diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Bakers.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Bakers.hs index 67ee79dc0c..3bcfc848c5 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Bakers.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Bakers.hs @@ -391,7 +391,7 @@ migratePersistentActiveBakers :: ) => StateMigrationParameters oldpv pv -> -- | Already migrated accounts. - Accounts.AccountsAndDiffMap pv -> + Accounts.Accounts pv -> PersistentActiveBakers (AccountVersionFor oldpv) -> t m (PersistentActiveBakers (AccountVersionFor pv)) migratePersistentActiveBakers migration accounts PersistentActiveBakers{..} = do diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 8d76b251d3..3a131d1ee7 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -188,7 +188,7 @@ migratePersistentBirkParameters :: SupportsPersistentAccount pv (t m) ) => StateMigrationParameters oldpv pv -> - Accounts.AccountsAndDiffMap pv -> + Accounts.Accounts pv -> PersistentBirkParameters oldpv -> t m (PersistentBirkParameters pv) migratePersistentBirkParameters migration accounts PersistentBirkParameters{..} = do @@ -739,7 +739,7 @@ emptyTransactionOutcomes Proxy = case transactionOutcomesVersion @(TransactionOu -- those components themselves should be parametrised by the protocol -- version. data BlockStatePointers (pv :: ProtocolVersion) = BlockStatePointers - { bspAccounts :: !(Accounts.AccountsAndDiffMap pv), + { bspAccounts :: !(Accounts.Accounts pv), bspInstances :: !(Instances.Instances pv), bspModules :: !(HashedBufferedRef Modules.Modules), bspBank :: !(Hashed Rewards.BankStatus), @@ -935,7 +935,7 @@ emptyBlockState bspBirkParameters cryptParams keysCollection chainParams = do bsp <- makeBufferedRef $ BlockStatePointers - { bspAccounts = Accounts.emptyAccountsAndDiffMap Nothing, + { bspAccounts = Accounts.emptyAccounts Nothing, bspInstances = Instances.emptyInstances, bspModules = modules, bspBank = makeHashed Rewards.emptyBankStatus, @@ -1443,9 +1443,9 @@ doAddBaker pbs ai ba@BakerAdd{..} = do redelegatePassive :: forall pv m. (SupportsPersistentAccount pv m, PVSupportsDelegation pv) => - Accounts.AccountsAndDiffMap pv -> + Accounts.Accounts pv -> DelegatorId -> - m (Accounts.AccountsAndDiffMap pv) + m (Accounts.Accounts pv) redelegatePassive accounts (DelegatorId accId) = Accounts.updateAccountsAtIndex' (setAccountDelegationTarget Transactions.DelegatePassive) @@ -2794,9 +2794,9 @@ doProcessReleaseSchedule pbs ts = do else do let processAccountP1 :: (RSAccountRef pv ~ AccountAddress) => - (Accounts.AccountsAndDiffMap pv, ReleaseSchedule pv) -> + (Accounts.Accounts pv, ReleaseSchedule pv) -> RSAccountRef pv -> - m (Accounts.AccountsAndDiffMap pv, ReleaseSchedule pv) + m (Accounts.Accounts pv, ReleaseSchedule pv) processAccountP1 (accs, rs) addr = do (reAdd, accs') <- Accounts.updateAccounts (unlockAccountReleases ts) addr accs rs' <- case reAdd of @@ -2806,9 +2806,9 @@ doProcessReleaseSchedule pbs ts = do return (accs', rs') processAccountP5 :: (RSAccountRef pv ~ AccountIndex) => - (Accounts.AccountsAndDiffMap pv, ReleaseSchedule pv) -> + (Accounts.Accounts pv, ReleaseSchedule pv) -> RSAccountRef pv -> - m (Accounts.AccountsAndDiffMap pv, ReleaseSchedule pv) + m (Accounts.Accounts pv, ReleaseSchedule pv) processAccountP5 (accs, rs) ai = do (reAdd, accs') <- Accounts.updateAccountsAtIndex (unlockAccountReleases ts) ai accs rs' <- case reAdd of @@ -2816,7 +2816,7 @@ doProcessReleaseSchedule pbs ts = do Just Nothing -> return rs Nothing -> error "processReleaseSchedule: scheduled release for invalid account index" return (accs', rs') - processAccount :: (Accounts.AccountsAndDiffMap pv, ReleaseSchedule pv) -> RSAccountRef pv -> m (Accounts.AccountsAndDiffMap pv, ReleaseSchedule pv) + processAccount :: (Accounts.Accounts pv, ReleaseSchedule pv) -> RSAccountRef pv -> m (Accounts.Accounts pv, ReleaseSchedule pv) processAccount = case protocolVersion @pv of SP1 -> processAccountP1 SP2 -> processAccountP1 @@ -3123,7 +3123,7 @@ doProcessPendingChanges persistentBS isEffective = do -- an entry for a particular pool. processDelegators :: PersistentActiveDelegators (AccountVersionFor pv) -> - MTL.StateT (Accounts.AccountsAndDiffMap pv) m (PersistentActiveDelegators (AccountVersionFor pv)) + MTL.StateT (Accounts.Accounts pv) m (PersistentActiveDelegators (AccountVersionFor pv)) processDelegators (PersistentActiveDelegatorsV1 dset _) = do (newDlgs, newAmt) <- MTL.runWriterT $ Trie.filterKeysM processDelegator dset return (PersistentActiveDelegatorsV1 newDlgs newAmt) @@ -3131,7 +3131,7 @@ doProcessPendingChanges persistentBS isEffective = do -- Update the delegator on an account if its cooldown has expired. -- This only updates the account table, and not the active bakers index. -- This also 'MTL.tell's the (updated) staked amount of the account. - processDelegator :: DelegatorId -> MTL.WriterT Amount (MTL.StateT (Accounts.AccountsAndDiffMap pv) m) Bool + processDelegator :: DelegatorId -> MTL.WriterT Amount (MTL.StateT (Accounts.Accounts pv) m) Bool processDelegator (DelegatorId accId) = do accounts <- MTL.get Accounts.indexedAccount accId accounts >>= \case @@ -3145,7 +3145,7 @@ doProcessPendingChanges persistentBS isEffective = do updateAccountDelegator :: AccountIndex -> PersistentAccount (AccountVersionFor pv) -> - MTL.WriterT Amount (MTL.StateT (Accounts.AccountsAndDiffMap pv) m) Bool + MTL.WriterT Amount (MTL.StateT (Accounts.Accounts pv) m) Bool updateAccountDelegator accId acct = accountDelegator acct >>= \case Just BaseAccounts.AccountDelegationV1{..} -> do @@ -3166,7 +3166,7 @@ doProcessPendingChanges persistentBS isEffective = do -- Remove a delegator from an account. -- This only affects the account, and does not affect the active bakers index. - removeDelegatorStake :: AccountIndex -> MTL.StateT (Accounts.AccountsAndDiffMap pv) m () + removeDelegatorStake :: AccountIndex -> MTL.StateT (Accounts.Accounts pv) m () removeDelegatorStake accId = do accounts <- MTL.get newAccounts <- Accounts.updateAccountsAtIndex' removeAccountStaking accId accounts @@ -3178,7 +3178,7 @@ doProcessPendingChanges persistentBS isEffective = do reduceDelegatorStake :: AccountIndex -> Amount -> - MTL.StateT (Accounts.AccountsAndDiffMap pv) m () + MTL.StateT (Accounts.Accounts pv) m () reduceDelegatorStake accId newAmt = do accounts <- MTL.get let updAcc = setAccountStake newAmt >=> setAccountStakePendingChange BaseAccounts.NoChange @@ -3193,7 +3193,7 @@ doProcessPendingChanges persistentBS isEffective = do processBakers :: BakerIdTrieMap (AccountVersionFor pv) -> MTL.StateT - (Accounts.AccountsAndDiffMap pv, AggregationKeySet, PersistentActiveDelegators (AccountVersionFor pv)) + (Accounts.Accounts pv, AggregationKeySet, PersistentActiveDelegators (AccountVersionFor pv)) m (BakerIdTrieMap (AccountVersionFor pv), Amount) processBakers = MTL.runWriterT . Trie.alterMapM processBaker @@ -3208,7 +3208,7 @@ doProcessPendingChanges persistentBS isEffective = do PersistentActiveDelegators (AccountVersionFor pv) -> MTL.WriterT Amount - (MTL.StateT (Accounts.AccountsAndDiffMap pv, AggregationKeySet, PersistentActiveDelegators (AccountVersionFor pv)) m) + (MTL.StateT (Accounts.Accounts pv, AggregationKeySet, PersistentActiveDelegators (AccountVersionFor pv)) m) (Trie.Alteration (PersistentActiveDelegators (AccountVersionFor pv))) processBaker bid@(BakerId accId) oldDelegators = do accts0 <- use _1 @@ -3255,7 +3255,7 @@ doProcessPendingChanges persistentBS isEffective = do BakerId -> AccountBaker av -> PersistentActiveDelegators (AccountVersionFor pv) -> - MTL.StateT (Accounts.AccountsAndDiffMap pv, AggregationKeySet, PersistentActiveDelegators (AccountVersionFor pv)) m () + MTL.StateT (Accounts.Accounts pv, AggregationKeySet, PersistentActiveDelegators (AccountVersionFor pv)) m () removeBaker (BakerId accId) acctBkr (PersistentActiveDelegatorsV1 dset dcapital) = do accounts0 <- use _1 -- Update the baker's account to have no delegation @@ -3277,7 +3277,7 @@ doProcessPendingChanges persistentBS isEffective = do reduceBakerStake :: BakerId -> Amount -> - MTL.StateT (Accounts.AccountsAndDiffMap pv, a, b) m () + MTL.StateT (Accounts.Accounts pv, a, b) m () reduceBakerStake (BakerId accId) newAmt = do let updAcc = setAccountStake newAmt >=> setAccountStakePendingChange BaseAccounts.NoChange accounts <- use _1 diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Genesis.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Genesis.hs index 7ef9ebd46c..9905f498ed 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Genesis.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Genesis.hs @@ -86,7 +86,7 @@ data VersionedCoreGenesisParameters (pv :: Types.ProtocolVersion) where -- It is then used to construct the initial block state from genesis. data AccumGenesisState pv = AccumGenesisState { -- | Tracking all the accounts. - agsAllAccounts :: !(Accounts.AccountsAndDiffMap pv), + agsAllAccounts :: !(Accounts.Accounts pv), -- | Collection of the IDs of the active bakers. agsBakerIds :: !(Bakers.BakerIdTrieMap (Types.AccountVersionFor pv)), -- | Collection of the aggregation keys of the active bakers. @@ -113,7 +113,7 @@ data AccumGenesisState pv = AccumGenesisState initialAccumGenesisState :: AccumGenesisState pv initialAccumGenesisState = AccumGenesisState - { agsAllAccounts = Accounts.emptyAccountsAndDiffMap Nothing, + { agsAllAccounts = Accounts.emptyAccounts Nothing, agsBakerIds = Trie.empty, agsBakerKeys = Trie.empty, agsTotal = 0, From cdb83061b6d6b842046de8fca6eef8ab451d4096 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Wed, 25 Oct 2023 22:32:10 +0200 Subject: [PATCH 39/92] doc. --- .../src/Concordium/GlobalState/Persistent/Accounts.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index be31219833..19461ed694 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -94,7 +94,7 @@ import Concordium.Types.HashableTo -- -- The operations on 'Accounts', when used correctly, maintain the following invariants: -- --- * Every @(address, index)@ pair in 'accountMap' has a corresponding account +-- * Every @(address, index)@ pair in the LMDB account map and difference map has a corresponding account -- in 'accountTable' with the given index and address. -- * Every @(index, account)@ pair in 'accountTable' has a corresponding entry -- in 'accountMap', which maps the account address to @index@. From e60fa895605a08e942d9d39c55872402af849c7d Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Wed, 25 Oct 2023 22:34:17 +0200 Subject: [PATCH 40/92] Fix last remnants of AccountsAndDiffMap. --- .../Concordium/GlobalState/Persistent/Accounts.hs | 2 +- .../tests/globalstate/GlobalStateTests/Accounts.hs | 12 ++++++------ 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 19461ed694..b0715fa042 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -357,7 +357,7 @@ allAccountsViaTable accts = do accts return $! zip addresses [0 ..] --- | If the LMDB account map is not already initialized, then this function populates the LMDB account map via the provided provided 'AccountsAndDiffMap'. +-- | If the LMDB account map is not already initialized, then this function populates the LMDB account map via the provided provided 'Accounts'. -- Otherwise, this function does nothing. tryPopulateLMDBStore :: (SupportsPersistentAccount pv m) => Accounts pv -> m () tryPopulateLMDBStore accts = do diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs index 8704543a7e..96ea0c6665 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs @@ -63,11 +63,11 @@ checkBinaryM bop x y sbop sx sy = do satisfied <- bop x y unless satisfied $ liftIO $ assertFailure $ "Not satisfied: " ++ sx ++ " (" ++ show x ++ ") " ++ sbop ++ " " ++ show y ++ " (" ++ sy ++ ")" --- | Check that a 'B.Accounts' and a 'P.AccountsAndDiffMap' are equivalent. +-- | Check that a 'B.Accounts' and a 'P.Accounts' are equivalent. -- That is, they have the same account map, account table, and set of -- use registration ids. -checkEquivalent :: (P.SupportsPersistentAccount PV m, av ~ AccountVersionFor PV) => B.Accounts PV -> P.AccountsAndDiffMap PV -> m () -checkEquivalent ba pa@P.AccountsAndDiffMap{..} = do +checkEquivalent :: (P.SupportsPersistentAccount PV m, av ~ AccountVersionFor PV) => B.Accounts PV -> P.Accounts PV -> m () +checkEquivalent ba pa@P.Accounts{..} = do addrsAndIndices <- P.allAccounts pa viaTable <- P.allAccountsViaTable pa checkBinary (==) (Map.fromList viaTable) (Map.fromList addrsAndIndices) "==" "Account table" "Persistent account map" @@ -181,7 +181,7 @@ randomActions = sized (ra Set.empty Map.empty) (rid, ai) <- elements (Map.toList rids) (RecordRegId rid ai :) <$> ra s rids (n - 1) -runAccountAction :: (P.SupportsPersistentAccount PV m, av ~ AccountVersionFor PV) => AccountAction -> (B.Accounts PV, P.AccountsAndDiffMap PV) -> m (B.Accounts PV, P.AccountsAndDiffMap PV) +runAccountAction :: (P.SupportsPersistentAccount PV m, av ~ AccountVersionFor PV) => AccountAction -> (B.Accounts PV, P.Accounts PV) -> m (B.Accounts PV, P.Accounts PV) runAccountAction (PutAccount acct) (ba, pa) = do let ba' = B.putNewAccount acct ba pAcct <- PA.makePersistentAccount acct @@ -229,13 +229,13 @@ emptyTest = it "empty" $ \bs -> runNoLoggerT $ flip runBlobStoreT bs $ - (checkEquivalent B.emptyAccounts (P.emptyAccountsAndDiffMap Nothing) :: BlobStoreT (PersistentBlockStateContext PV) (NoLoggerT IO) ()) + (checkEquivalent B.emptyAccounts (P.emptyAccounts Nothing) :: BlobStoreT (PersistentBlockStateContext PV) (NoLoggerT IO) ()) actionTest :: Word -> SpecWith (PersistentBlockStateContext PV) actionTest lvl = it "account actions" $ \bs -> withMaxSuccess (100 * fromIntegral lvl) $ property $ do acts <- randomActions return $ ioProperty $ runNoLoggerT $ flip runBlobStoreT bs $ do - (ba, pa) <- foldM (flip runAccountAction) (B.emptyAccounts, P.emptyAccountsAndDiffMap @PV Nothing) acts + (ba, pa) <- foldM (flip runAccountAction) (B.emptyAccounts, P.emptyAccounts @PV Nothing) acts checkEquivalent ba pa tests :: Word -> Spec From f06cff7ddc3a7bc828e4546cabb4bcccc0b6d4e6 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Wed, 25 Oct 2023 22:47:38 +0200 Subject: [PATCH 41/92] Fix the very last remnants of AccountsAndDiffMap. --- .../tests/globalstate/GlobalStateTests/Accounts.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs index 96ea0c6665..d1b5a00594 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs @@ -67,19 +67,19 @@ checkBinaryM bop x y sbop sx sy = do -- That is, they have the same account map, account table, and set of -- use registration ids. checkEquivalent :: (P.SupportsPersistentAccount PV m, av ~ AccountVersionFor PV) => B.Accounts PV -> P.Accounts PV -> m () -checkEquivalent ba pa@P.Accounts{..} = do +checkEquivalent ba pa = do addrsAndIndices <- P.allAccounts pa viaTable <- P.allAccountsViaTable pa checkBinary (==) (Map.fromList viaTable) (Map.fromList addrsAndIndices) "==" "Account table" "Persistent account map" checkBinary (==) (AccountMap.toMapPure (B.accountMap ba)) (Map.fromList addrsAndIndices) "==" "Basic account map" "Persistent account map" let bat = BAT.toList (B.accountTable ba) - pat <- L.toAscPairList (P.accountTable aadAccounts) + pat <- L.toAscPairList (P.accountTable pa) bpat <- mapM (_2 PA.toTransientAccount) pat checkBinary (==) bat bpat "==" "Basic account table (as list)" "Persistent account table (as list)" let bath = getHash (B.accountTable ba) :: H.Hash - path <- getHashM (P.accountTable aadAccounts) + path <- getHashM (P.accountTable pa) checkBinary (==) bath path "==" "Basic account table hash" "Persistent account table hash" - pregids <- P.loadRegIds aadAccounts + pregids <- P.loadRegIds pa checkBinary (==) (B.accountRegIds ba) pregids "==" "Basic registration ids" "Persistent registration ids" data AccountAction From 775cf453bd376d2d7ded060622f3a7914b5e515e Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Wed, 25 Oct 2023 22:53:12 +0200 Subject: [PATCH 42/92] Changelog. --- CHANGELOG.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 24c6de9eb7..ce17a25616 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,8 @@ # Changelog ## Unreleased changes +- The account map is now kept solely on disk in a separate lmdb database and it is no longer part of the internal block state database. + This change results in less memory usage per account and a decrease in the growth of the database. ## 6.1.4 From f55f78d142a83ecf1fc7125fe500cc229e3aaa49 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Wed, 25 Oct 2023 22:58:07 +0200 Subject: [PATCH 43/92] cargo lock. --- concordium-node/Cargo.lock | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/concordium-node/Cargo.lock b/concordium-node/Cargo.lock index 3d7db1b8ce..f37f58d940 100644 --- a/concordium-node/Cargo.lock +++ b/concordium-node/Cargo.lock @@ -599,7 +599,7 @@ version = "3.0.1" dependencies = [ "aes", "anyhow", - "base64 0.13.1", + "base64 0.21.1", "bs58", "byteorder", "cbc", From 140626bd09f4fb8d8d3c3a6be453216d80a5cb45 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Thu, 26 Oct 2023 11:38:14 +0200 Subject: [PATCH 44/92] Remove unused error. --- concordium-consensus/src/Concordium/External.hs | 1 - .../src/Concordium/GlobalState/Persistent/TreeState.hs | 3 --- 2 files changed, 4 deletions(-) diff --git a/concordium-consensus/src/Concordium/External.hs b/concordium-consensus/src/Concordium/External.hs index 4a625fbd82..0c0f6b8776 100644 --- a/concordium-consensus/src/Concordium/External.hs +++ b/concordium-consensus/src/Concordium/External.hs @@ -271,7 +271,6 @@ toStartResult = DatabaseInvariantViolation _ -> 10 IncorrectDatabaseVersion _ -> 11 AccountMapPermissionError -> 12 - AccountMapMismatch{} -> 13 -- | Catch exceptions which may occur at start up and return an appropriate exit code. handleStartExceptions :: LogMethod IO -> IO StartResult -> IO Int64 diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs index f89aa8c4e1..61c69a7a1b 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs @@ -79,8 +79,6 @@ data InitException IncorrectDatabaseVersion !String | -- | Cannot get read/write permissions for the account map file. AccountMapPermissionError - | -- | The account map does not match the last finalized block. - AccountMapMismatch {ieAccountMapLfb :: !BlockHash, ieTsLfb :: !BlockHash} deriving (Show, Typeable) instance Exception InitException where @@ -95,7 +93,6 @@ instance Exception InitException where "Database invariant violation: " ++ err displayException (IncorrectDatabaseVersion err) = "Incorrect database version: " ++ err displayException AccountMapPermissionError = "Cannot get read and write permissions for the account map file." - displayException AccountMapMismatch{..} = "The lfb of the account map " <> show ieAccountMapLfb <> " does not match tree state lfb: " <> show ieTsLfb logExceptionAndThrowTS :: (MonadLogger m, MonadIO m, Exception e) => e -> m a logExceptionAndThrowTS = logExceptionAndThrow TreeState From 1b8d637705989957182606532d203f1fb854a11d Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Thu, 26 Oct 2023 16:41:08 +0200 Subject: [PATCH 45/92] Fix a memory leak with difference maps. Updated documentation. --- .../GlobalState/Persistent/Accounts.hs | 17 +++++++++++---- .../GlobalState/Persistent/BlockState.hs | 21 +++++++++++++++++-- 2 files changed, 32 insertions(+), 6 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index b0715fa042..9d0616b097 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -20,9 +20,10 @@ -- -- A thawed block is behind a ‘BufferedRef’, this ‘BufferedRef’ is written to disk upon finalization -- (or certification for consensus version 1). --- This in return invokes ‘storeUpdate’ for all intermediate references for the block state for the particular block. --- When the accounts structure is being written to disk so is the ‘DifferenceMap’, --- i.e. the contents of the ‘DifferenceMap’ is being written to the lmdb backed account map. +-- This in return invokes ‘storeUpdate’ for all ynderlying references for the block state, for the particular block. +-- When the accounts structure is being written to disk so is the ‘DifferenceMap’ and it is then being emptied. +-- When thawing from a non-persisted block then the difference map is being inherited by the new thawed updatable block, +-- thus the differnce map potentially forms a chain of difference map "down" until the highest persisted block. -- -- * Startup flow -- When a consensus runner starts up it can either be via an existing state or @@ -147,6 +148,12 @@ type SupportsPersistentAccount pv m = instance (SupportsPersistentAccount pv m) => MHashableTo m H.Hash (Accounts pv) where getHashM Accounts{..} = getHashM accountTable +-- Note. We're writing to the LMDB accountmap as part of the 'storeUpdate' implementation below. +-- This in turn means that no associated metadata is being written to the LMDB database (i.e. the block hash) of the +-- persisted block. If we need this, then the write to the LMDB database could be done in 'saveBlockState' and the 'DifferenceMap' should be retained up +-- to that point. +-- It shouldn't be necessary with this additional metadata as when (potentially) certified blocks are being rolled back, so are the +-- accounts created in those, in turn this means that the LMDB account map will have entries for all accounts present in the last finalized block. instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where storeUpdate Accounts{..} = do (pTable, accountTable') <- storeUpdate accountTable @@ -156,7 +163,9 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where Accounts { accountTable = accountTable', accountRegIdHistory = regIdHistory', - accountDiffMap = DiffMap.empty $ Just accountDiffMap + -- The difference map is empty as any potential new accounts have been written to the + -- lmdb account map. + accountDiffMap = DiffMap.empty Nothing } -- put an empty 'OldMap.PersistentAccountMap'. diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 3a131d1ee7..4a86d9000a 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -41,6 +41,7 @@ module Concordium.GlobalState.Persistent.BlockState ( import qualified Concordium.Crypto.SHA256 as H import qualified Concordium.Genesis.Data.P6 as P6 import Concordium.GlobalState.Account hiding (addIncomingEncryptedAmount, addToSelfEncryptedAmount) +import qualified Concordium.GlobalState.AccountMap.DifferenceMap as DiffMap import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import Concordium.GlobalState.BakerInfo import Concordium.GlobalState.BlockState @@ -3553,8 +3554,7 @@ instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateOperatio bsoIsProtocolUpdateEffective = doIsProtocolUpdateEffective instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateStorage (PersistentBlockStateMonad pv r m) where - thawBlockState HashedPersistentBlockState{..} = - liftIO $ newIORef =<< readIORef hpbsPointers + thawBlockState = doThawBlockState freezeBlockState = hashBlockState @@ -3696,6 +3696,23 @@ migrateBlockPointers migration BlockStatePointers{..} = do bspRewardDetails = newRewardDetails } +-- | Thaw the block state, making it ready for modification. +-- This function wraps the underlying 'PersistentBlockState' of the provided 'HasedPersistentBlockState' in a new 'IORef' +-- such that changes to the thawed block state does not propagate into the parent state. +-- +-- Further the 'DiffMap.DifferenceMap' of the accounts structure in the provided block state is +-- "bumped" in the sense that a new one is created for the new thawed block with a pointer to the parent difference map. +-- The parent difference map is empty if the parent is persisted otherwise it may contain new accounts created in that block. +doThawBlockState :: + (SupportsPersistentState pv m) => + HashedPersistentBlockState pv -> + m (PersistentBlockState pv) +doThawBlockState HashedPersistentBlockState{..} = do + -- This load is cheap as the underlying block state is retained in memory as we're building from it, so it must be the "best" block. + bsp@BlockStatePointers{bspAccounts = a0@Accounts.Accounts{..}} <- loadPBS hpbsPointers + let bsp' = bsp{bspAccounts = a0{Accounts.accountDiffMap = DiffMap.empty $ Just accountDiffMap}} + liftIO $ newIORef =<< makeBufferedRef bsp' + -- | Cache the block state. cacheState :: forall pv m. From 372a0afb0d307da7c4319c42d011cbd8781d8d2e Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Mon, 30 Oct 2023 09:31:42 +0100 Subject: [PATCH 46/92] Fix mem leak. --- .../GlobalState/Persistent/Accounts.hs | 59 ++++++++++++------- .../GlobalState/Persistent/BlockState.hs | 5 +- 2 files changed, 41 insertions(+), 23 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 9d0616b097..5113c7d52b 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -51,9 +51,9 @@ -- -- General flow -- The account map resides in its own lmdb database and functions across protocol versions. --- There is a ‘DifferenceMap’ associated with each block. --- For frozen blocks this is simply empty, while for thawed blocks it may or may not --- contain @ AccountAddress -> AccountIndex@ mappings depending on whether an account has been added for that particular block. +-- For a thawed block, then the ‘DifferenceMap’ is either @Nothing@ or @Just DifferenceMap@ depending whether the parent block is written to disk. +-- If the parent block is written to disk, then a new 'DifferenceMap' is created for the block as part of 'putNewAccount'. +-- Frozen blocks always have a @Nothing@ 'DifferenceMap'. -- -- The lmdb backed account map consists of a single lmdb store indexed by AccountAddresses and values are the associated ‘AccountIndex’ for each account. -- @@ -128,8 +128,12 @@ data Accounts (pv :: ProtocolVersion) = Accounts accountRegIdHistory :: !(Trie.TrieN UnbufferedFix ID.RawCredentialRegistrationID AccountIndex), -- | An in-memory difference map used keeping track of accounts -- added in live blocks. - -- This is empty for a frozen block state. - accountDiffMap :: !DiffMap.DifferenceMap + -- This is @Nothing@ if either the block is persisted or no accounts have been + -- added in the block (and it is thawed). + -- Otherwise if the block is not persisted and accounts have been added, then + -- the 'DiffMap.DifferenceMap' yields the @AccountAddress -> AccountIndex@ mapping for + -- accounts created in the block. + accountDiffMap :: !(Maybe DiffMap.DifferenceMap) } instance (IsProtocolVersion pv) => Show (Accounts pv) where @@ -158,14 +162,16 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where storeUpdate Accounts{..} = do (pTable, accountTable') <- storeUpdate accountTable (pRegIdHistory, regIdHistory') <- storeUpdate accountRegIdHistory - LMDBAccountMap.insert (Map.toList $ DiffMap.flatten accountDiffMap) + case accountDiffMap of + Nothing -> return () + Just accDiffMap -> LMDBAccountMap.insert (Map.toList $ DiffMap.flatten accDiffMap) let newAccounts = Accounts { accountTable = accountTable', accountRegIdHistory = regIdHistory', - -- The difference map is empty as any potential new accounts have been written to the + -- The difference map is set to @Nothing@ as any potential new accounts have been written to the -- lmdb account map. - accountDiffMap = DiffMap.empty Nothing + accountDiffMap = Nothing } -- put an empty 'OldMap.PersistentAccountMap'. @@ -185,7 +191,7 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where return $ do accountTable <- maccountTable accountRegIdHistory <- mrRIH - let accountDiffMap = DiffMap.empty Nothing + let accountDiffMap = Nothing return $ Accounts{..} instance (SupportsPersistentAccount pv m, av ~ AccountVersionFor pv) => Cacheable1 m (Accounts pv) (PersistentAccount av) where @@ -195,8 +201,8 @@ instance (SupportsPersistentAccount pv m, av ~ AccountVersionFor pv) => Cacheabl accts{accountTable = acctTable} emptyAccounts :: Maybe DiffMap.DifferenceMap -> Accounts pv -emptyAccounts Nothing = Accounts L.empty Trie.empty $ DiffMap.empty Nothing -emptyAccounts successorDiffMap = Accounts L.empty Trie.empty $ DiffMap.empty successorDiffMap +emptyAccounts Nothing = Accounts L.empty Trie.empty Nothing +emptyAccounts successorDiffMap = Accounts L.empty Trie.empty $ Just $ DiffMap.empty successorDiffMap -- | Add a new account. Returns @Just idx@ if the new account is fresh, i.e., the address does not exist, -- or @Nothing@ in case the account already exists. In the latter case there is no change to the accounts structure. @@ -207,8 +213,10 @@ putNewAccount !acct a0@Accounts{..} = do True -> return (Nothing, a0) False -> do (accIdx, newAccountTable) <- L.append acct accountTable - let newDiffMap = DiffMap.insert addr accIdx accountDiffMap - return (Just accIdx, a0{accountTable = newAccountTable, accountDiffMap = newDiffMap}) + let newDiffMap = case accountDiffMap of + Nothing -> DiffMap.insert addr accIdx $ DiffMap.empty Nothing + Just accDiffMap -> DiffMap.insert addr accIdx accDiffMap + return (Just accIdx, a0{accountTable = newAccountTable, accountDiffMap = Just newDiffMap}) -- | Construct an 'Accounts' from a list of accounts. Inserted in the order of the list. fromList :: (SupportsPersistentAccount pv m) => [PersistentAccount (AccountVersionFor pv)] -> m (Accounts pv) @@ -224,19 +232,24 @@ exists addr accts = isJust <$> getAccountIndex addr accts -- Returns @Nothing@ if no such account exists. getAccountByCredId :: (SupportsPersistentAccount pv m) => ID.RawCredentialRegistrationID -> Accounts pv -> m (Maybe (AccountIndex, PersistentAccount (AccountVersionFor pv))) getAccountByCredId cid accs@Accounts{..} = - Trie.lookup cid (accountRegIdHistory) >>= \case + Trie.lookup cid accountRegIdHistory >>= \case Nothing -> return Nothing Just ai -> fmap (ai,) <$> indexedAccount ai accs -- | Get the account at a given index (if any). getAccountIndex :: (SupportsPersistentAccount pv m) => AccountAddress -> Accounts pv -> m (Maybe AccountIndex) getAccountIndex addr Accounts{..} = - case DiffMap.lookup addr accountDiffMap of - Just accIdx -> return $ Just accIdx - Nothing -> - LMDBAccountMap.lookup addr >>= \case - Nothing -> return Nothing - Just accIdx -> return $ Just accIdx + case accountDiffMap of + Nothing -> lookupDisk + Just accDiffMap -> case DiffMap.lookup addr accDiffMap of + Just accIdx -> return $ Just accIdx + Nothing -> lookupDisk + where + -- Lookup the 'AccountIndex' in the lmdb backed account map. + lookupDisk = + LMDBAccountMap.lookup addr >>= \case + Nothing -> return Nothing + Just accIdx -> return $ Just accIdx -- | Retrieve an account with the given address. -- Returns @Nothing@ if no such account exists. @@ -330,7 +343,9 @@ updateAccountsAtIndex' fupd ai = fmap snd . updateAccountsAtIndex fupd' ai allAccounts :: (SupportsPersistentAccount pv m) => Accounts pv -> m [(AccountAddress, AccountIndex)] allAccounts accounts = do persistedAccs <- Map.fromList <$> LMDBAccountMap.all - return $ Map.toList $ persistedAccs `Map.union` DiffMap.flatten (accountDiffMap accounts) + case accountDiffMap accounts of + Nothing -> return $ Map.toList persistedAccs + Just accDiffMap -> return $ Map.toList $ persistedAccs `Map.union` DiffMap.flatten accDiffMap -- | Get a list of all account addresses. accountAddresses :: (SupportsPersistentAccount pv m) => Accounts pv -> m [AccountAddress] @@ -394,5 +409,5 @@ migrateAccounts migration Accounts{..} = do Accounts { accountTable = newAccountTable, accountRegIdHistory = newAccountRegIds, - accountDiffMap = DiffMap.empty Nothing + accountDiffMap = Nothing } diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 4a86d9000a..488984dc24 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -3710,7 +3710,10 @@ doThawBlockState :: doThawBlockState HashedPersistentBlockState{..} = do -- This load is cheap as the underlying block state is retained in memory as we're building from it, so it must be the "best" block. bsp@BlockStatePointers{bspAccounts = a0@Accounts.Accounts{..}} <- loadPBS hpbsPointers - let bsp' = bsp{bspAccounts = a0{Accounts.accountDiffMap = DiffMap.empty $ Just accountDiffMap}} + let newDiffMap = case accountDiffMap of + Nothing -> Nothing + Just diffMap -> Just $ DiffMap.empty (Just diffMap) + let bsp' = bsp{bspAccounts = a0{Accounts.accountDiffMap = newDiffMap}} liftIO $ newIORef =<< makeBufferedRef bsp' -- | Cache the block state. From 0931e7a832e8fd0b4e4e713e0662679127c3f104 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Tue, 31 Oct 2023 00:13:44 +0100 Subject: [PATCH 47/92] Added some strictness. --- .../GlobalState/AccountMap/DifferenceMap.hs | 14 +++++++++----- .../src/Concordium/GlobalState/AccountMap/LMDB.hs | 1 - .../Concordium/GlobalState/Persistent/Accounts.hs | 8 ++++---- .../globalstate/GlobalStateTests/DifferenceMap.hs | 3 +-- 4 files changed, 14 insertions(+), 12 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index 0fbf0268d9..9da5250053 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -26,12 +26,16 @@ data DifferenceMap = DifferenceMap -- | Gather all accounts from the provided 'DifferenceMap' and its parent maps. -- Accounts are returned in ascending order of their 'AccountIndex'. -flatten :: DifferenceMap -> Map.Map AccountAddress AccountIndex -flatten dmap = go (Just dmap) Map.empty +flatten :: DifferenceMap -> [(AccountAddress, AccountIndex)] +flatten dmap = go dmap [] where - go :: Maybe DifferenceMap -> Map.Map AccountAddress AccountIndex -> Map.Map AccountAddress AccountIndex - go Nothing accum = accum - go (Just DifferenceMap{..}) !accum = go dmParentMap $ dmAccounts `Map.union` accum + go :: DifferenceMap -> [(AccountAddress, AccountIndex)] -> [(AccountAddress, AccountIndex)] + go DifferenceMap{dmParentMap = Nothing, ..} !accum = + let !listOfAccounts = Map.toList dmAccounts + in listOfAccounts <> accum + go DifferenceMap{dmParentMap = Just parentMap, ..} !accum = + let !listOfAccounts = Map.toList dmAccounts + in go parentMap $! listOfAccounts <> accum -- | Create a new empty 'DifferenceMap' based on the difference map of -- the parent. diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index 2c01f78cf5..9b547757d5 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -292,7 +292,6 @@ instance doInsert dbh txn accounts = do forM_ accounts $ \(accAddr, accIndex) -> do storeRecord txn (dbh ^. accountMapStore) accAddr accIndex - return $ Just accIndex lookup a@(AccountAddress accAddr) = asReadTransaction $ \dbh txn -> withCursor txn (dbh ^. accountMapStore) $ \cursor -> do diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 5113c7d52b..738f552916 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -164,7 +164,7 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where (pRegIdHistory, regIdHistory') <- storeUpdate accountRegIdHistory case accountDiffMap of Nothing -> return () - Just accDiffMap -> LMDBAccountMap.insert (Map.toList $ DiffMap.flatten accDiffMap) + Just accDiffMap -> LMDBAccountMap.insert $! DiffMap.flatten accDiffMap let newAccounts = Accounts { accountTable = accountTable', @@ -342,10 +342,10 @@ updateAccountsAtIndex' fupd ai = fmap snd . updateAccountsAtIndex fupd' ai -- | Get a list of all account addresses and their assoicated account indices. allAccounts :: (SupportsPersistentAccount pv m) => Accounts pv -> m [(AccountAddress, AccountIndex)] allAccounts accounts = do - persistedAccs <- Map.fromList <$> LMDBAccountMap.all + persistedAccs <- LMDBAccountMap.all case accountDiffMap accounts of - Nothing -> return $ Map.toList persistedAccs - Just accDiffMap -> return $ Map.toList $ persistedAccs `Map.union` DiffMap.flatten accDiffMap + Nothing -> return persistedAccs + Just accDiffMap -> return $! persistedAccs <> DiffMap.flatten accDiffMap -- | Get a list of all account addresses. accountAddresses :: (SupportsPersistentAccount pv m) => Accounts pv -> m [AccountAddress] diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs index 0132a222fc..4eb48a84ce 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs @@ -7,7 +7,6 @@ module GlobalStateTests.DifferenceMap where import Concordium.ID.Types (randomAccountAddress) import Concordium.Types -import qualified Data.Map.Strict as Map import System.Random import qualified Concordium.GlobalState.AccountMap.DifferenceMap as DiffMap @@ -53,7 +52,7 @@ testFlatten = do let diffMap1 = uncurry DiffMap.insert (dummyPair 1) $ DiffMap.empty Nothing diffMap2 = uncurry DiffMap.insert (dummyPair 2) (DiffMap.empty $ Just diffMap1) diffMap3 = uncurry DiffMap.insert (dummyPair 3) (DiffMap.empty $ Just diffMap2) - assertEqual "accounts should be the same" (Map.fromList (map dummyPair [1 .. 3])) $ DiffMap.flatten diffMap3 + assertEqual "accounts should be the same" (map dummyPair [1 .. 3]) $ DiffMap.flatten diffMap3 tests :: Spec tests = describe "AccountMap.DifferenceMap" $ do From d331c8ecc02dca885211f62fb1a17976252f0c8b Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Tue, 31 Oct 2023 15:12:38 +0100 Subject: [PATCH 48/92] cleanup --- .../Concordium/GlobalState/AccountMap/LMDB.hs | 33 +++---------------- 1 file changed, 4 insertions(+), 29 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index 9b547757d5..1aba8bd96c 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -128,16 +128,16 @@ makeClassy ''DatabaseHandlers -- | The number of stores in the LMDB environment for 'DatabaseHandlers'. databaseCount :: Int -databaseCount = 2 +databaseCount = 1 -- | Database growth size increment. -- This is currently set at 64MB, and must be a multiple of the page size. dbStepSize :: Int -dbStepSize = 2 ^ (25 :: Int) -- 32MB +dbStepSize = 2 ^ (26 :: Int) -- 64MB -- | Maximum step to increment the database size. dbMaxStepSize :: Int -dbMaxStepSize = 2 ^ (28 :: Int) -- 256mb +dbMaxStepSize = 2 ^ (30 :: Int) -- 1GB -- | Initial database size. -- This is currently set to be the same as 'dbStepSize'. @@ -146,31 +146,6 @@ dbInitSize = dbStepSize -- ** Helpers --- TODO: These helper functions below should probably be refactored and moved into LDMBHelpers so --- they can be used across all lmdb database implementations. - --- | Resize the LMDB map if the file size has changed. --- This is used to allow a secondary process that is reading the database --- to handle resizes to the database that are made by the writer. --- The supplied action will be executed. If it fails with an 'MDB_MAP_RESIZED' --- error, then the map will be resized and the action retried. -resizeOnResized :: (MonadIO m, MonadReader r m, HasDatabaseHandlers r, MonadCatch m) => m a -> m a -resizeOnResized a = do - dbh <- view databaseHandlers - resizeOnResizedInternal (dbh ^. storeEnv) a - --- | Perform a database action and resize the LMDB map if the file size has changed. The difference --- with `resizeOnResized` is that this function takes database handlers as an argument, instead of --- reading their value from `HasDatabaseHandlers`. -resizeOnResizedInternal :: (MonadIO m, MonadCatch m) => StoreEnv -> m a -> m a -resizeOnResizedInternal se a = inner - where - inner = handleJust checkResized onResized a - checkResized LMDB_Error{..} = guard (e_code == Right MDB_MAP_RESIZED) - onResized _ = do - liftIO (withWriteStoreEnv se $ flip mdb_env_set_mapsize 0) - inner - -- | Increase the database size by at least the supplied size. -- The size SHOULD be a multiple of 'dbStepSize', and MUST be a multiple of the page size. resizeDatabaseHandlers :: (MonadIO m, MonadLogger m) => DatabaseHandlers -> Int -> m () @@ -291,7 +266,7 @@ instance where doInsert dbh txn accounts = do forM_ accounts $ \(accAddr, accIndex) -> do - storeRecord txn (dbh ^. accountMapStore) accAddr accIndex + storeReplaceRecord txn (dbh ^. accountMapStore) accAddr accIndex lookup a@(AccountAddress accAddr) = asReadTransaction $ \dbh txn -> withCursor txn (dbh ^. accountMapStore) $ \cursor -> do From b68ef786a0060b722949306ec1dea77d934cea46 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Tue, 31 Oct 2023 20:07:43 +0100 Subject: [PATCH 49/92] Add todo --- .../src/Concordium/GlobalState/AccountMap/LMDB.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index 1aba8bd96c..afe2f2e6d5 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -210,6 +210,8 @@ newtype AccountMapStoreMonad (m :: Type -> Type) (a :: Type) = AccountMapStoreMo deriving instance (MonadProtocolVersion m) => MonadProtocolVersion (AccountMapStoreMonad m) +-- todo: move these into Helpers.hs so they can be reused across the different lmdb database connections. + -- | Run a read-only transaction. asReadTransaction :: (MonadIO m, MonadReader r m, HasDatabaseHandlers r) => (DatabaseHandlers -> MDB_txn -> IO a) -> AccountMapStoreMonad m a asReadTransaction t = do @@ -266,7 +268,7 @@ instance where doInsert dbh txn accounts = do forM_ accounts $ \(accAddr, accIndex) -> do - storeReplaceRecord txn (dbh ^. accountMapStore) accAddr accIndex + storeRecord txn (dbh ^. accountMapStore) accAddr accIndex lookup a@(AccountAddress accAddr) = asReadTransaction $ \dbh txn -> withCursor txn (dbh ^. accountMapStore) $ \cursor -> do From d8a0871119631fd91d99ab2143630178157cde59 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Wed, 1 Nov 2023 01:47:04 +0100 Subject: [PATCH 50/92] Fix memory leak caused by difference maps. --- .../GlobalState/AccountMap/DifferenceMap.hs | 40 ++++++----- .../GlobalState/Persistent/Accounts.hs | 67 ++++++++++++------- .../GlobalState/Persistent/BlockState.hs | 14 ++-- .../GlobalState/Persistent/Genesis.hs | 29 ++++---- 4 files changed, 92 insertions(+), 58 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index 9da5250053..b2b8976e5a 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -5,6 +5,8 @@ -- to disk via 'Concordium.GlobalState.AccountMap.LMDB.insert'. module Concordium.GlobalState.AccountMap.DifferenceMap where +import Control.Monad.IO.Class +import Data.IORef import qualified Data.Map.Strict as Map import Prelude hiding (lookup) @@ -20,26 +22,26 @@ data DifferenceMap = DifferenceMap -- In other words, if the parent block is finalized, -- then the parent map is @Notnhing@ as the LMDB account map -- should be consulted instead. - dmParentMap :: !(Maybe DifferenceMap) + dmParentMap :: !(IORef (Maybe DifferenceMap)) } - deriving (Eq, Show) + deriving (Eq) -- | Gather all accounts from the provided 'DifferenceMap' and its parent maps. -- Accounts are returned in ascending order of their 'AccountIndex'. -flatten :: DifferenceMap -> [(AccountAddress, AccountIndex)] +flatten :: (MonadIO m) => DifferenceMap -> m [(AccountAddress, AccountIndex)] flatten dmap = go dmap [] where - go :: DifferenceMap -> [(AccountAddress, AccountIndex)] -> [(AccountAddress, AccountIndex)] - go DifferenceMap{dmParentMap = Nothing, ..} !accum = - let !listOfAccounts = Map.toList dmAccounts - in listOfAccounts <> accum - go DifferenceMap{dmParentMap = Just parentMap, ..} !accum = - let !listOfAccounts = Map.toList dmAccounts - in go parentMap $! listOfAccounts <> accum + go diffMap !accum = do + mParentMap <- liftIO $ readIORef (dmParentMap diffMap) + case mParentMap of + Nothing -> return collectedAccounts + Just parentMap -> go parentMap collectedAccounts + where + collectedAccounts = Map.toList (dmAccounts diffMap) <> accum --- | Create a new empty 'DifferenceMap' based on the difference map of +-- | Create a new empty 'DifferenceMap' potentially based on the difference map of -- the parent. -empty :: Maybe DifferenceMap -> DifferenceMap +empty :: IORef (Maybe DifferenceMap) -> DifferenceMap empty mParentDifferenceMap = DifferenceMap { dmAccounts = Map.empty, @@ -50,15 +52,19 @@ empty mParentDifferenceMap = -- difference maps. -- Returns @Just AccountIndex@ if the account is present and -- otherwise @Nothing@. -lookup :: AccountAddress -> DifferenceMap -> Maybe AccountIndex +lookup :: (MonadIO m) => AccountAddress -> DifferenceMap -> m (Maybe AccountIndex) lookup addr = check where - check DifferenceMap{..} = case Map.lookupGE k dmAccounts of - Nothing -> check =<< dmParentMap + check diffMap = case Map.lookupGE k (dmAccounts diffMap) of + Nothing -> do + mParentMap <- liftIO $ readIORef (dmParentMap diffMap) + case mParentMap of + Nothing -> return Nothing + Just parentMap -> check parentMap Just (foundAccAddr, accIdx) -> if checkEquivalence foundAccAddr - then Just accIdx - else Nothing + then return $ Just accIdx + else return Nothing k = createAlias addr 0 checkEquivalence found = accountAddressEmbed k == accountAddressEmbed found diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 738f552916..24434f788e 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -66,6 +66,7 @@ module Concordium.GlobalState.Persistent.Accounts where import Control.Monad.Reader import Data.Foldable (foldlM) +import Data.IORef import qualified Data.Map.Strict as Map import Data.Maybe import Data.Serialize @@ -133,11 +134,11 @@ data Accounts (pv :: ProtocolVersion) = Accounts -- Otherwise if the block is not persisted and accounts have been added, then -- the 'DiffMap.DifferenceMap' yields the @AccountAddress -> AccountIndex@ mapping for -- accounts created in the block. - accountDiffMap :: !(Maybe DiffMap.DifferenceMap) + accountDiffMap :: !(IORef (Maybe DiffMap.DifferenceMap)) } instance (IsProtocolVersion pv) => Show (Accounts pv) where - show accts = "Accounts: " <> show (accountTable accts) <> "DiffMap: " <> show (accountDiffMap accts) + show accts = "Accounts: " <> show (accountTable accts) -- | A constraint that ensures a monad @m@ supports the persistent account operations. -- This essentially requires that the monad support 'MonadBlobStore', and 'MonadCache' for @@ -162,16 +163,20 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where storeUpdate Accounts{..} = do (pTable, accountTable') <- storeUpdate accountTable (pRegIdHistory, regIdHistory') <- storeUpdate accountRegIdHistory - case accountDiffMap of + mAccDiffMap <- liftIO $ readIORef accountDiffMap + case mAccDiffMap of Nothing -> return () - Just accDiffMap -> LMDBAccountMap.insert $! DiffMap.flatten accDiffMap + Just accDiffMap -> do + flattenedAccounts <- liftIO $ DiffMap.flatten accDiffMap + LMDBAccountMap.insert flattenedAccounts + -- The difference map is set to @Nothing@ as any potential new accounts have been written to the + -- lmdb account map. + liftIO $ modifyIORef' accountDiffMap (const Nothing) let newAccounts = Accounts { accountTable = accountTable', accountRegIdHistory = regIdHistory', - -- The difference map is set to @Nothing@ as any potential new accounts have been written to the - -- lmdb account map. - accountDiffMap = Nothing + .. } -- put an empty 'OldMap.PersistentAccountMap'. @@ -191,7 +196,7 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where return $ do accountTable <- maccountTable accountRegIdHistory <- mrRIH - let accountDiffMap = Nothing + accountDiffMap <- liftIO $ newIORef Nothing return $ Accounts{..} instance (SupportsPersistentAccount pv m, av ~ AccountVersionFor pv) => Cacheable1 m (Accounts pv) (PersistentAccount av) where @@ -200,9 +205,10 @@ instance (SupportsPersistentAccount pv m, av ~ AccountVersionFor pv) => Cacheabl return accts{accountTable = acctTable} -emptyAccounts :: Maybe DiffMap.DifferenceMap -> Accounts pv -emptyAccounts Nothing = Accounts L.empty Trie.empty Nothing -emptyAccounts successorDiffMap = Accounts L.empty Trie.empty $ Just $ DiffMap.empty successorDiffMap +emptyAccounts :: (MonadIO m) => m (Accounts pv) +emptyAccounts = do + accountDiffMap <- liftIO $ newIORef Nothing + return $ Accounts L.empty Trie.empty accountDiffMap -- | Add a new account. Returns @Just idx@ if the new account is fresh, i.e., the address does not exist, -- or @Nothing@ in case the account already exists. In the latter case there is no change to the accounts structure. @@ -213,14 +219,21 @@ putNewAccount !acct a0@Accounts{..} = do True -> return (Nothing, a0) False -> do (accIdx, newAccountTable) <- L.append acct accountTable - let newDiffMap = case accountDiffMap of - Nothing -> DiffMap.insert addr accIdx $ DiffMap.empty Nothing - Just accDiffMap -> DiffMap.insert addr accIdx accDiffMap - return (Just accIdx, a0{accountTable = newAccountTable, accountDiffMap = Just newDiffMap}) + mAccountDiffMap <- liftIO $ readIORef accountDiffMap + newDiffMap <- case mAccountDiffMap of + Nothing -> do + freshDifferenceMap <- liftIO $ newIORef (Nothing :: Maybe DiffMap.DifferenceMap) + return $ DiffMap.insert addr accIdx $ DiffMap.empty freshDifferenceMap + Just accDiffMap -> do + return $ DiffMap.insert addr accIdx accDiffMap + liftIO $ modifyIORef' accountDiffMap (const $ Just newDiffMap) + return (Just accIdx, a0{accountTable = newAccountTable}) -- | Construct an 'Accounts' from a list of accounts. Inserted in the order of the list. fromList :: (SupportsPersistentAccount pv m) => [PersistentAccount (AccountVersionFor pv)] -> m (Accounts pv) -fromList = foldlM insert $ emptyAccounts Nothing +fromList accs = do + accum <- emptyAccounts + foldlM insert accum accs where insert accounts account = snd <$> putNewAccount account accounts @@ -238,12 +251,14 @@ getAccountByCredId cid accs@Accounts{..} = -- | Get the account at a given index (if any). getAccountIndex :: (SupportsPersistentAccount pv m) => AccountAddress -> Accounts pv -> m (Maybe AccountIndex) -getAccountIndex addr Accounts{..} = - case accountDiffMap of +getAccountIndex addr Accounts{..} = do + mAccountDiffMap <- liftIO $ readIORef accountDiffMap + case mAccountDiffMap of Nothing -> lookupDisk - Just accDiffMap -> case DiffMap.lookup addr accDiffMap of - Just accIdx -> return $ Just accIdx - Nothing -> lookupDisk + Just accDiffMap -> + DiffMap.lookup addr accDiffMap >>= \case + Just accIdx -> return $ Just accIdx + Nothing -> lookupDisk where -- Lookup the 'AccountIndex' in the lmdb backed account map. lookupDisk = @@ -343,9 +358,12 @@ updateAccountsAtIndex' fupd ai = fmap snd . updateAccountsAtIndex fupd' ai allAccounts :: (SupportsPersistentAccount pv m) => Accounts pv -> m [(AccountAddress, AccountIndex)] allAccounts accounts = do persistedAccs <- LMDBAccountMap.all - case accountDiffMap accounts of + mDiffMap <- liftIO $ readIORef (accountDiffMap accounts) + case mDiffMap of Nothing -> return persistedAccs - Just accDiffMap -> return $! persistedAccs <> DiffMap.flatten accDiffMap + Just accDiffMap -> do + flattenedDiffMapAccounts <- DiffMap.flatten accDiffMap + return $! persistedAccs <> flattenedDiffMapAccounts -- | Get a list of all account addresses. accountAddresses :: (SupportsPersistentAccount pv m) => Accounts pv -> m [AccountAddress] @@ -405,9 +423,10 @@ migrateAccounts migration Accounts{..} = do -- The account registration IDs are not cached. There is a separate cache -- that is purely in-memory and just copied over. newAccountRegIds <- Trie.migrateUnbufferedTrieN return accountRegIdHistory + emptyAccountDiffMap <- liftIO $ newIORef (Nothing :: Maybe DiffMap.DifferenceMap) return $! Accounts { accountTable = newAccountTable, accountRegIdHistory = newAccountRegIds, - accountDiffMap = Nothing + accountDiffMap = emptyAccountDiffMap } diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 488984dc24..2ac81bab71 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -933,10 +933,11 @@ emptyBlockState bspBirkParameters cryptParams keysCollection chainParams = do bspUpdates <- refMake =<< initialUpdates keysCollection chainParams bspReleaseSchedule <- emptyReleaseSchedule bspRewardDetails <- emptyBlockRewardDetails + bspAccounts <- Accounts.emptyAccounts bsp <- makeBufferedRef $ BlockStatePointers - { bspAccounts = Accounts.emptyAccounts Nothing, + { bspAccounts = bspAccounts, bspInstances = Instances.emptyInstances, bspModules = modules, bspBank = makeHashed Rewards.emptyBankStatus, @@ -3710,9 +3711,14 @@ doThawBlockState :: doThawBlockState HashedPersistentBlockState{..} = do -- This load is cheap as the underlying block state is retained in memory as we're building from it, so it must be the "best" block. bsp@BlockStatePointers{bspAccounts = a0@Accounts.Accounts{..}} <- loadPBS hpbsPointers - let newDiffMap = case accountDiffMap of - Nothing -> Nothing - Just diffMap -> Just $ DiffMap.empty (Just diffMap) + mDiffMap <- liftIO $ readIORef accountDiffMap + newDiffMap <- case mDiffMap of + -- reuse the reference pointing to @Nothing@. + Nothing -> return accountDiffMap + Just _ -> do + -- create a new reference pointing to + -- a new difference map which inherits the parent difference map. + liftIO $ newIORef $ Just (DiffMap.empty accountDiffMap) let bsp' = bsp{bspAccounts = a0{Accounts.accountDiffMap = newDiffMap}} liftIO $ newIORef =<< makeBufferedRef bsp' diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Genesis.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Genesis.hs index 9905f498ed..053fcf5ca6 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Genesis.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Genesis.hs @@ -110,18 +110,20 @@ data AccumGenesisState pv = AccumGenesisState --------- Helper functions ---------- -- | The initial value for accumulating data from genesis data accounts. -initialAccumGenesisState :: AccumGenesisState pv -initialAccumGenesisState = - AccumGenesisState - { agsAllAccounts = Accounts.emptyAccounts Nothing, - agsBakerIds = Trie.empty, - agsBakerKeys = Trie.empty, - agsTotal = 0, - agsStakedTotal = 0, - agsBakerInfoRefs = Vec.empty, - agsBakerStakes = Vec.empty, - agsBakerCapitals = Vec.empty - } +initialAccumGenesisState :: (MTL.MonadIO m) => m (AccumGenesisState pv) +initialAccumGenesisState = do + emptyAccs <- Accounts.emptyAccounts + return $ + AccumGenesisState + { agsAllAccounts = emptyAccs, + agsBakerIds = Trie.empty, + agsBakerKeys = Trie.empty, + agsTotal = 0, + agsStakedTotal = 0, + agsBakerInfoRefs = Vec.empty, + agsBakerStakes = Vec.empty, + agsBakerCapitals = Vec.empty + } -- | Construct a hashed persistent block state from the data in genesis. -- The result is immediately flushed to disc and cached. @@ -132,8 +134,9 @@ buildGenesisBlockState :: GenesisData.GenesisState pv -> MTL.ExceptT String m (BS.HashedPersistentBlockState pv, TransactionTable.TransactionTable) buildGenesisBlockState vcgp GenesisData.GenesisState{..} = do + initState <- initialAccumGenesisState -- Iterate the accounts in genesis once and accumulate all relevant information. - AccumGenesisState{..} <- Vec.ifoldM' accumStateFromGenesisAccounts initialAccumGenesisState genesisAccounts + AccumGenesisState{..} <- Vec.ifoldM' accumStateFromGenesisAccounts initState genesisAccounts -- Birk parameters persistentBirkParameters :: BS.PersistentBirkParameters pv <- do From 9bfd9d691a39121431e1d681fb7393ef08d1d3ed Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Wed, 1 Nov 2023 16:07:24 +0100 Subject: [PATCH 51/92] Address review comments. --- .../GlobalState/AccountMap/DifferenceMap.hs | 40 +++++----- .../Concordium/GlobalState/AccountMap/LMDB.hs | 13 ++- .../src/Concordium/GlobalState/BlockState.hs | 4 +- .../GlobalState/Persistent/Accounts.hs | 79 ++++++++++--------- .../GlobalState/Persistent/BlockState.hs | 14 +++- .../GlobalState/Persistent/TreeState.hs | 10 ++- .../Concordium/GlobalState/Persistent/Trie.hs | 2 +- .../src/Concordium/KonsensusV1/SkovMonad.hs | 14 ++-- .../KonsensusV1/TreeState/LowLevel/LMDB.hs | 34 +++++--- .../globalstate/GlobalStateTests/Accounts.hs | 8 +- .../GlobalStateTests/DifferenceMap.hs | 32 +++++--- 11 files changed, 153 insertions(+), 97 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index b2b8976e5a..03a7eaf766 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -1,35 +1,37 @@ {-# LANGUAGE BangPatterns #-} --- | The 'DifferenceMap' stores accounts have been created in a non-finalized block. --- When a block is being finalized then the assoicated 'DifferenceMap' must be written +-- | The 'DifferenceMap' stores accounts that have been created in a non-finalized block. +-- When a block is being finalized (or certified for consensus version 1) +-- then the associated 'DifferenceMap' must be written -- to disk via 'Concordium.GlobalState.AccountMap.LMDB.insert'. module Concordium.GlobalState.AccountMap.DifferenceMap where import Control.Monad.IO.Class +import Data.Bifunctor +import qualified Data.HashMap.Strict as HM import Data.IORef -import qualified Data.Map.Strict as Map import Prelude hiding (lookup) import Concordium.Types -- | A difference map that indicates newly added accounts for -- a block identified by a 'BlockHash' and its associated 'BlockHeight'. --- The difference map only contains accounds that was added since the '_dmParentMap'. +-- The difference map only contains accounts that were added since the '_dmParentMap'. data DifferenceMap = DifferenceMap { -- | Accounts added in a block. - dmAccounts :: !(Map.Map AccountAddress AccountIndex), + dmAccounts :: !(HM.HashMap AccountAddressEq AccountIndex), -- | Parent map of non-finalized blocks. -- In other words, if the parent block is finalized, - -- then the parent map is @Notnhing@ as the LMDB account map + -- then the parent map is @Nothing@ as the LMDB account map -- should be consulted instead. dmParentMap :: !(IORef (Maybe DifferenceMap)) } deriving (Eq) -- | Gather all accounts from the provided 'DifferenceMap' and its parent maps. --- Accounts are returned in ascending order of their 'AccountIndex'. +-- Accounts are returned in ascending order of their 'AccountAddress'. flatten :: (MonadIO m) => DifferenceMap -> m [(AccountAddress, AccountIndex)] -flatten dmap = go dmap [] +flatten dmap = map (first aaeAddress) <$> go dmap [] where go diffMap !accum = do mParentMap <- liftIO $ readIORef (dmParentMap diffMap) @@ -37,38 +39,34 @@ flatten dmap = go dmap [] Nothing -> return collectedAccounts Just parentMap -> go parentMap collectedAccounts where - collectedAccounts = Map.toList (dmAccounts diffMap) <> accum + collectedAccounts = HM.toList (dmAccounts diffMap) <> accum -- | Create a new empty 'DifferenceMap' potentially based on the difference map of -- the parent. empty :: IORef (Maybe DifferenceMap) -> DifferenceMap empty mParentDifferenceMap = DifferenceMap - { dmAccounts = Map.empty, + { dmAccounts = HM.empty, dmParentMap = mParentDifferenceMap } -- | Lookup an account in the difference map or any of the parent --- difference maps. +-- difference maps using the account address equivalence class. -- Returns @Just AccountIndex@ if the account is present and -- otherwise @Nothing@. lookup :: (MonadIO m) => AccountAddress -> DifferenceMap -> m (Maybe AccountIndex) lookup addr = check where - check diffMap = case Map.lookupGE k (dmAccounts diffMap) of + k = accountAddressEmbed addr + check diffMap = case HM.lookup k (dmAccounts diffMap) of Nothing -> do mParentMap <- liftIO $ readIORef (dmParentMap diffMap) case mParentMap of Nothing -> return Nothing Just parentMap -> check parentMap - Just (foundAccAddr, accIdx) -> - if checkEquivalence foundAccAddr - then return $ Just accIdx - else return Nothing - k = createAlias addr 0 - checkEquivalence found = accountAddressEmbed k == accountAddressEmbed found + Just accIdx -> return $ Just accIdx -- | Insert an account into the difference map. --- Note that it is up to the caller to ensure only the canonical 'AccountAddress' is added. -insert :: AccountAddress -> AccountIndex -> DifferenceMap -> DifferenceMap -insert addr accIndex m = m{dmAccounts = Map.insert addr accIndex $ dmAccounts m} +-- Note that it is up to the caller to ensure only the canonical 'AccountAddress' is being inserted. +insert :: AccountAddressEq -> AccountIndex -> DifferenceMap -> DifferenceMap +insert addr accIndex m = m{dmAccounts = HM.insert addr accIndex $ dmAccounts m} diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index afe2f2e6d5..a49402b72e 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -188,13 +188,14 @@ makeDatabaseHandlers accountMapDir readOnly initSize = do [MDB_CREATE | not readOnly] return DatabaseHandlers{..} --- | Initialize database handlers in ReadWrite mode. +-- | Create the lmdb stores and return back database handlers for interacting with it. -- This simply loads the references and does not initialize the databases. --- The initial size is set to 64MB. --- Note that this function creates the directory for the database if not already present. +-- The initial environment size is set to 128MB. +-- Note that this function creates the directory for the database if not already present at the provided +-- path and any missing parent directories. openDatabase :: FilePath -> IO DatabaseHandlers openDatabase accountMapDir = do - createDirectoryIfMissing False accountMapDir + createDirectoryIfMissing True accountMapDir makeDatabaseHandlers accountMapDir False dbInitSize -- | Close the database. The database should not be used after it is closed. @@ -277,6 +278,10 @@ instance Nothing -> return Nothing Just (Left err) -> throwM $ DatabaseInvariantViolation err Just (Right (foundAccAddr, accIdx)) -> + -- we need to check equivalence here as we are performing + -- prefix lookup in the lmdb database, so if the account does not exist + -- then the lmdb query would return the "next" account address + -- by lexicographic order of account address. if checkEquivalence a foundAccAddr then return $ Just accIdx else return Nothing diff --git a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs index 533ecb3a3c..ee8fdc3452 100644 --- a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs @@ -509,7 +509,9 @@ class (ContractStateOperations m, AccountOperations m, ModuleQuery m) => BlockSt -- | Get the list of addresses of modules existing in the given block state. getModuleList :: BlockState m -> m [ModuleRef] - -- | Get the list of account addresses existing in the best block state. + -- | Get the list of account addresses existing in the given block state, + -- Note that this function also includes any created - but not persisted accounts + -- for the provided block and any non-persisted blocks. -- This returns the canonical addresses. getAccountList :: BlockState m -> m [AccountAddress] diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 24434f788e..577607574f 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -1,5 +1,3 @@ --- here because of the 'SupportsPersistentAccount' constraint is a bit too coarse right now. -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} @@ -20,10 +18,10 @@ -- -- A thawed block is behind a ‘BufferedRef’, this ‘BufferedRef’ is written to disk upon finalization -- (or certification for consensus version 1). --- This in return invokes ‘storeUpdate’ for all ynderlying references for the block state, for the particular block. +-- This in return invokes ‘storeUpdate’ for all underlying references for the block state, for the particular block. -- When the accounts structure is being written to disk so is the ‘DifferenceMap’ and it is then being emptied. -- When thawing from a non-persisted block then the difference map is being inherited by the new thawed updatable block, --- thus the differnce map potentially forms a chain of difference map "down" until the highest persisted block. +-- thus the difference map potentially forms a chain of difference map "down" until the highest persisted block. -- -- * Startup flow -- When a consensus runner starts up it can either be via an existing state or @@ -70,6 +68,7 @@ import Data.IORef import qualified Data.Map.Strict as Map import Data.Maybe import Data.Serialize +import Data.Word import Concordium.GlobalState.Persistent.Account import Concordium.GlobalState.Persistent.BlobStore @@ -130,10 +129,10 @@ data Accounts (pv :: ProtocolVersion) = Accounts -- | An in-memory difference map used keeping track of accounts -- added in live blocks. -- This is @Nothing@ if either the block is persisted or no accounts have been - -- added in the block (and it is thawed). + -- added in the block. -- Otherwise if the block is not persisted and accounts have been added, then -- the 'DiffMap.DifferenceMap' yields the @AccountAddress -> AccountIndex@ mapping for - -- accounts created in the block. + -- accounts created in the block, where the account addresses are in canonical form. accountDiffMap :: !(IORef (Maybe DiffMap.DifferenceMap)) } @@ -153,6 +152,18 @@ type SupportsPersistentAccount pv m = instance (SupportsPersistentAccount pv m) => MHashableTo m H.Hash (Accounts pv) where getHashM Accounts{..} = getHashM accountTable +-- | Get the accounts created for this block or any non-persisted parent block. +-- Note that this also empties the difference map for this block. +writeAccountsCreated :: (SupportsPersistentAccount pv m) => Accounts pv -> m () +writeAccountsCreated Accounts{..} = do + mAccountsCreated <- liftIO $ readIORef accountDiffMap + case mAccountsCreated of + Nothing -> return () + Just accountsCreated -> do + listOfAccountsCreated <- liftIO $ DiffMap.flatten accountsCreated + liftIO $ atomicWriteIORef accountDiffMap Nothing + LMDBAccountMap.insert listOfAccountsCreated + -- Note. We're writing to the LMDB accountmap as part of the 'storeUpdate' implementation below. -- This in turn means that no associated metadata is being written to the LMDB database (i.e. the block hash) of the -- persisted block. If we need this, then the write to the LMDB database could be done in 'saveBlockState' and the 'DifferenceMap' should be retained up @@ -163,15 +174,6 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where storeUpdate Accounts{..} = do (pTable, accountTable') <- storeUpdate accountTable (pRegIdHistory, regIdHistory') <- storeUpdate accountRegIdHistory - mAccDiffMap <- liftIO $ readIORef accountDiffMap - case mAccDiffMap of - Nothing -> return () - Just accDiffMap -> do - flattenedAccounts <- liftIO $ DiffMap.flatten accDiffMap - LMDBAccountMap.insert flattenedAccounts - -- The difference map is set to @Nothing@ as any potential new accounts have been written to the - -- lmdb account map. - liftIO $ modifyIORef' accountDiffMap (const Nothing) let newAccounts = Accounts { accountTable = accountTable', @@ -184,7 +186,7 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where -- but this is now superseded by the 'LMDBAccountMap.MonadAccountMapStore'. -- We put this (0 :: Int) here to remain backwards compatible as this simply indicates an empty map. -- This should be revised as part of a future protocol update when the database layout can be changed. - return (put (0 :: Int) >> pTable >> pRegIdHistory, newAccounts) + return (put (0 :: Word64) >> pTable >> pRegIdHistory, newAccounts) load = do -- load the persistent account map and throw it away. We always put an empty one in, -- but that has not always been the case. But the 'OldMap.PersistentAccountMap' is now superseded by @@ -205,6 +207,8 @@ instance (SupportsPersistentAccount pv m, av ~ AccountVersionFor pv) => Cacheabl return accts{accountTable = acctTable} +-- | Create a new empty 'Accounts' structure with a pointer +-- to an empty 'DiffMap.DifferenceMap'. emptyAccounts :: (MonadIO m) => m (Accounts pv) emptyAccounts = do accountDiffMap <- liftIO $ newIORef Nothing @@ -223,11 +227,13 @@ putNewAccount !acct a0@Accounts{..} = do newDiffMap <- case mAccountDiffMap of Nothing -> do freshDifferenceMap <- liftIO $ newIORef (Nothing :: Maybe DiffMap.DifferenceMap) - return $ DiffMap.insert addr accIdx $ DiffMap.empty freshDifferenceMap + return $ addToDiffMap accIdx $ DiffMap.empty freshDifferenceMap Just accDiffMap -> do - return $ DiffMap.insert addr accIdx accDiffMap - liftIO $ modifyIORef' accountDiffMap (const $ Just newDiffMap) + return $ addToDiffMap accIdx accDiffMap + liftIO $ atomicWriteIORef accountDiffMap (Just newDiffMap) return (Just accIdx, a0{accountTable = newAccountTable}) + where + addToDiffMap = DiffMap.insert (accountAddressEmbed addr) -- | Construct an 'Accounts' from a list of accounts. Inserted in the order of the list. fromList :: (SupportsPersistentAccount pv m) => [PersistentAccount (AccountVersionFor pv)] -> m (Accounts pv) @@ -238,6 +244,8 @@ fromList accs = do insert accounts account = snd <$> putNewAccount account accounts -- | Determine if an account with the given address exists. +-- Note that this is looking up via the account alias mechanism introduced in protocol version 3 for all protocol versions. +-- This is fine as there are no clashes and this approach simplifies the implementation. exists :: (SupportsPersistentAccount pv m) => AccountAddress -> Accounts pv -> m Bool exists addr accts = isJust <$> getAccountIndex addr accts @@ -250,6 +258,8 @@ getAccountByCredId cid accs@Accounts{..} = Just ai -> fmap (ai,) <$> indexedAccount ai accs -- | Get the account at a given index (if any). +-- Note that this is looking up via the account alias mechanism introduced in protocol version 3 for all protocol versions. +-- This is fine as there are no clashes and this approach simplifies the implementation. getAccountIndex :: (SupportsPersistentAccount pv m) => AccountAddress -> Accounts pv -> m (Maybe AccountIndex) getAccountIndex addr Accounts{..} = do mAccountDiffMap <- liftIO $ readIORef accountDiffMap @@ -289,17 +299,13 @@ indexedAccount ai Accounts{..} = L.lookup ai accountTable -- See the foundation (Section 4.2) for why this is necessary. -- Return @Just ai@ if the registration ID already exists, and @ai@ is the index of the account it is or was associated with. regIdExists :: (MonadBlobStore m) => ID.CredentialRegistrationID -> Accounts pv -> m (Maybe AccountIndex) -regIdExists rid accts = Trie.lookup (ID.toRawCredRegId rid) (accountRegIdHistory $ accts) +regIdExists rid accts = Trie.lookup (ID.toRawCredRegId rid) (accountRegIdHistory accts) -- | Record an account registration ID as used. recordRegId :: (MonadBlobStore m) => ID.CredentialRegistrationID -> AccountIndex -> Accounts pv -> m (Accounts pv) recordRegId rid idx accts0 = do accountRegIdHistory' <- Trie.insert (ID.toRawCredRegId rid) idx (accountRegIdHistory accts0) - return $! - accts0 - { accountTable = accountTable accts0, - accountRegIdHistory = accountRegIdHistory' - } + return $! accts0{accountRegIdHistory = accountRegIdHistory'} recordRegIds :: (MonadBlobStore m) => [(ID.CredentialRegistrationID, AccountIndex)] -> Accounts pv -> m (Accounts pv) recordRegIds rids accts0 = foldM (\accts (cid, idx) -> recordRegId cid idx accts) accts0 rids @@ -328,12 +334,10 @@ updateAccounts :: updateAccounts fupd addr a0@Accounts{..} = do getAccountIndex addr a0 >>= \case Nothing -> return (Nothing, a0) - Just ai -> update ai - where - update ai = - L.update fupd ai accountTable >>= \case - Nothing -> return (Nothing, a0) - Just (res, act') -> return (Just (ai, res), a0{accountTable = act'}) + Just ai -> + L.update fupd ai accountTable >>= \case + Nothing -> return (Nothing, a0) + Just (res, act') -> return (Just (ai, res), a0{accountTable = act'}) -- | Perform an update to an account with the given index. -- Does nothing (returning @Nothing@) if the account does not exist. @@ -354,7 +358,9 @@ updateAccountsAtIndex' fupd ai = fmap snd . updateAccountsAtIndex fupd' ai where fupd' = fmap ((),) . fupd --- | Get a list of all account addresses and their assoicated account indices. +-- | Get a list of all account addresses and their associated account indices. +-- There are no guarantees of the order of the list. This is because the resulting list is potentially +-- a concatenation of two lists of account addresses. allAccounts :: (SupportsPersistentAccount pv m) => Accounts pv -> m [(AccountAddress, AccountIndex)] allAccounts accounts = do persistedAccs <- LMDBAccountMap.all @@ -366,6 +372,8 @@ allAccounts accounts = do return $! persistedAccs <> flattenedDiffMapAccounts -- | Get a list of all account addresses. +-- There are no guarantees of the order of the list. This is because the resulting list is potentially +-- a concatenation of two lists of account addresses. accountAddresses :: (SupportsPersistentAccount pv m) => Accounts pv -> m [AccountAddress] accountAddresses accounts = map fst <$> allAccounts accounts @@ -383,7 +391,7 @@ foldAccounts f a accts = L.mfold f a (accountTable accts) foldAccountsDesc :: (SupportsPersistentAccount pv m) => (a -> PersistentAccount (AccountVersionFor pv) -> m a) -> a -> Accounts pv -> m a foldAccountsDesc f a accts = L.mfoldDesc f a (accountTable accts) --- | Get all account addresses and their assoicated 'AccountIndex' via the account table in ascending order +-- | Get all account addresses and their associated 'AccountIndex' via the account table in ascending order -- of account index. -- Note. This function should only be used when querying a historical block. When querying with respect to the "best block" then -- use 'allAccounts'. @@ -397,7 +405,7 @@ allAccountsViaTable accts = do ) [] accts - return $! zip addresses [0 ..] + return $ zip addresses [0 ..] -- | If the LMDB account map is not already initialized, then this function populates the LMDB account map via the provided provided 'Accounts'. -- Otherwise, this function does nothing. @@ -423,10 +431,9 @@ migrateAccounts migration Accounts{..} = do -- The account registration IDs are not cached. There is a separate cache -- that is purely in-memory and just copied over. newAccountRegIds <- Trie.migrateUnbufferedTrieN return accountRegIdHistory - emptyAccountDiffMap <- liftIO $ newIORef (Nothing :: Maybe DiffMap.DifferenceMap) return $! Accounts { accountTable = newAccountTable, accountRegIdHistory = newAccountRegIds, - accountDiffMap = emptyAccountDiffMap + accountDiffMap = accountDiffMap } diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 2ac81bab71..4131596606 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -2238,6 +2238,11 @@ doAccountList pbs = do bsp <- loadPBS pbs Accounts.accountAddresses (bspAccounts bsp) +-- | This function should be used when querying all accounts for a +-- block that is only on disk, hence the 'historical' part. +-- For blocks only retained in memory, then this function will not return accounts created +-- in this block or any parent blocks that have not yet been written to disk. +-- Use 'doGetAccountList' when querying the "best" block. doGetAccountListHistorical :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m [AccountAddress] doGetAccountListHistorical pbs = do bsp <- loadPBS pbs @@ -3571,6 +3576,13 @@ instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateStorage saveBlockState HashedPersistentBlockState{..} = do inner <- liftIO $ readIORef hpbsPointers + -- this load should be cheap as the blockstate is in memory. + accs <- bspAccounts <$> loadPBS hpbsPointers + -- write the accounts that was created in the block and + -- potentially non-persisted parent blocks. + -- Note that this also empties the difference map for the + -- block. + void $ Accounts.writeAccountsCreated accs (!inner', !ref) <- flushBufferedRef inner liftIO $ writeIORef hpbsPointers inner' flushStore @@ -3698,7 +3710,7 @@ migrateBlockPointers migration BlockStatePointers{..} = do } -- | Thaw the block state, making it ready for modification. --- This function wraps the underlying 'PersistentBlockState' of the provided 'HasedPersistentBlockState' in a new 'IORef' +-- This function wraps the underlying 'PersistentBlockState' of the provided 'HashedPersistentBlockState' in a new 'IORef' -- such that changes to the thawed block state does not propagate into the parent state. -- -- Further the 'DiffMap.DifferenceMap' of the accounts structure in the provided block state is diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs index 61c69a7a1b..f290140d34 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs @@ -363,13 +363,19 @@ checkExistingDatabase treeStateDir blockStateFile accountMapDir = do checkRWFile blockStateFile BlockStatePermissionError checkRWFile treeStateFile TreeStatePermissionError checkRWFile accountMapFile AccountMapPermissionError - mapM_ (logEvent TreeState LLTrace) ["Existing database found.", "TreeState filepath: " ++ show blockStateFile, "BlockState filepath: " ++ show treeStateFile ++ "AccountMap filepath: " ++ accountMapFile] + logEvent TreeState LLTrace "Existing database found." + logEvent TreeState LLTrace $ "TreeState filepath: " ++ show treeStateFile + logEvent TreeState LLTrace $ "BlockState filepath: " ++ show blockStateFile + logEvent TreeState LLTrace $ "AccountMap filepath: " ++ accountMapFile return True | bsPathEx && tsPathEx -> do -- check whether it is a normal file and whether we have the right permissions checkRWFile blockStateFile BlockStatePermissionError checkRWFile treeStateFile TreeStatePermissionError - mapM_ (logEvent TreeState LLTrace) ["Existing database found.", "TreeState filepath: " ++ show blockStateFile, "BlockState filepath: " ++ show treeStateFile ++ "AccountMap not found"] + logEvent TreeState LLTrace "Existing database found." + logEvent TreeState LLTrace $ "TreeState filepath: " ++ show treeStateFile + logEvent TreeState LLTrace $ "BlockState filepath: " ++ show blockStateFile + logEvent TreeState LLTrace $ "AccountMap not found" return True | bsPathEx -> do logEvent GlobalState LLWarning "Block state file exists, but tree state database does not. Deleting the block state file." diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Trie.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Trie.hs index f60d02ca6b..37091a0d34 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Trie.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Trie.hs @@ -566,7 +566,7 @@ instance (Show v, FixShowable fix) => Show (TrieN fix k v) where show (TrieN _ t) = showFix showTrieFString t instance (BlobStorable m (fix (TrieF k v)), BlobStorable m v, Base (fix (TrieF k v)) ~ TrieF k v) => BlobStorable m (TrieN fix k v) where - storeUpdate v@EmptyTrieN = return (put (0 :: Int), v) + storeUpdate v@EmptyTrieN = return (put (0 :: Word64), v) storeUpdate (TrieN size t) = do (pt, t') <- storeUpdate t let bs = put size >> pt diff --git a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs index 79906bded3..e9280f850a 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs @@ -510,21 +510,21 @@ initialiseExistingSkovV1 bakerCtx handlerCtx unliftSkov GlobalStateConfig{..} = let initWithLLDB skovLldb = do checkDatabaseVersion skovLldb let checkBlockState bs = runReaderT (PBS.runPersistentBlockStateMonad (isValidBlobRef bs)) pbsc - (rollCount, bestState, accountsToDelete) <- + RollbackResult{..} <- flip runReaderT (LMDBDatabases skovLldb $ pbscAccountMap pbsc) $ runDiskLLDBM (rollBackBlocksUntil checkBlockState) - when (rollCount > 0) $ do + when (rbrCount > 0) $ do logEvent Skov LLWarning $ "Could not load state for " - ++ show rollCount + ++ show rbrCount ++ " blocks. Truncating block state database." - liftIO $ truncateBlobStore (bscBlobStore . PBS.pbscBlobStore $ pbsc) bestState - logEvent Skov LLWarning $ "Deleting " <> show (length accountsToDelete) <> " from account map." - runReaderT (LMDBAccountMap.unsafeRollback accountsToDelete) pbsc + liftIO $ truncateBlobStore (bscBlobStore . PBS.pbscBlobStore $ pbsc) rbrBestState + logEvent Skov LLWarning $ "Deleting " <> show (length rbrAccountsForDeletion) <> " from account map." + runReaderT (LMDBAccountMap.unsafeRollback rbrAccountsForDeletion) pbsc let initContext = InitContext pbsc skovLldb (initialSkovData, effectiveProtocolUpdate) <- runInitMonad - (loadSkovData gscRuntimeParameters (rollCount > 0)) + (loadSkovData gscRuntimeParameters (rbrCount > 0)) initContext -- initialize the account map if it has not already been so. let lfbState = initialSkovData ^. lastFinalized . to bpState diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs index 6e85b2af1e..f8baecfcb6 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs @@ -699,6 +699,18 @@ initialiseLowLevelDB genesisBlock roundStatus = asWriteTransaction $ \dbh txn -> } storeReplaceRecord txn (dbh ^. metadataStore) versionMetadata $ S.encode metadata +-- | A result of a roll back. +data RollbackResult = forall (pv :: ProtocolVersion). + RollbackResult + { -- | Number of blocks rolled back. + rbrCount :: !Int, + -- | Reference to the best block after the rollback. + rbrBestState :: !(BlockStateRef pv), + -- | Accounts that were created in (certified) blocks that are rolled back. + -- These must be deleted. + rbrAccountsForDeletion :: ![AccountAddress] + } + -- | Remove certified and finalized blocks from the database whose states cannot be loaded. -- This can throw an exception if the database recovery was not possible. -- @@ -727,7 +739,7 @@ rollBackBlocksUntil :: (BlockStateRef pv -> DiskLLDBM pv m Bool) -> -- | Returns the number of blocks rolled back, the best state after the roll back and a list of -- accounts created in certified blocks that was rolled back. - DiskLLDBM pv m (Int, BlockStateRef pv, [AccountAddress]) + DiskLLDBM pv m RollbackResult rollBackBlocksUntil checkState = do lookupLastFinalizedBlock >>= \case Nothing -> throwM . DatabaseRecoveryFailure $ "No last finalized block." @@ -742,7 +754,7 @@ rollBackBlocksUntil checkState = do -- certified blocks, then roll back finalized blocks. (count, accsCreated) <- purgeCertified (count', bstState) <- rollFinalized count lastFin - return (count', bstState, accsCreated) + return $ RollbackResult count' bstState accsCreated where -- Check the non-finalized certified blocks, from the highest round backwards. checkCertified :: @@ -750,8 +762,8 @@ rollBackBlocksUntil checkState = do Round -> -- highest surviving block state so far (from last finalized block) BlockStateRef pv -> - -- returns the number of blocks rolled back and the highest surviving block state - DiskLLDBM pv m (Int, BlockStateRef pv, [AccountAddress]) + -- returns the @RollbackResult@. + DiskLLDBM pv m RollbackResult checkCertified lastFinRound bestState = do mHighestQC <- asReadTransaction $ \dbh txn -> withCursor @@ -759,10 +771,10 @@ rollBackBlocksUntil checkState = do (dbh ^. nonFinalizedQuorumCertificateStore) (getCursor CursorLast) case mHighestQC of - Nothing -> return (0, bestState, []) + Nothing -> return $ RollbackResult 0 bestState [] Just (Left e) -> throwM . DatabaseRecoveryFailure $ e Just (Right (_, qc)) -> checkCertifiedWithQC lastFinRound bestState 0 [] qc - -- Get the account address of a creadential deployment. + -- Get the account address of a credential deployment. getAccountAddressFromDeployment bi = case bi of WithMetadata{wmdData = CredentialDeployment{biCred = AccountCreation{..}}} -> case credential of @@ -784,8 +796,8 @@ rollBackBlocksUntil checkState = do [AccountAddress] -> -- QC for certified block to check QuorumCertificate -> - -- returns the number of blocks rolled back and the highest surviving block state - DiskLLDBM pv m (Int, BlockStateRef pv, [AccountAddress]) + -- returns the @RollbackResult@. + DiskLLDBM pv m RollbackResult checkCertifiedWithQC lastFinRound bestState !count accsCreated qc = do mBlock <- asReadTransaction $ \dbh txn -> loadRecord txn (dbh ^. blockStore) (qcBlock qc) @@ -837,10 +849,10 @@ rollBackBlocksUntil checkState = do [AccountAddress] -> -- round to check for Round -> - -- returns the number of blocks rolled back and the highest surviving block state - DiskLLDBM pv m (Int, BlockStateRef pv, [AccountAddress]) + -- returns the @RollbackResult@. + DiskLLDBM pv m RollbackResult checkCertifiedPreviousRound lastFinRound bestState count accsCreated currentRound - | currentRound <= lastFinRound = return (count, bestState, accsCreated) + | currentRound <= lastFinRound = return $ RollbackResult count bestState accsCreated | otherwise = do mNextQC <- asReadTransaction $ \dbh txn -> loadRecord txn (dbh ^. nonFinalizedQuorumCertificateStore) currentRound diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs index d1b5a00594..47a76d0fbf 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs @@ -228,14 +228,16 @@ emptyTest :: SpecWith (PersistentBlockStateContext PV) emptyTest = it "empty" $ \bs -> runNoLoggerT $ - flip runBlobStoreT bs $ - (checkEquivalent B.emptyAccounts (P.emptyAccounts Nothing) :: BlobStoreT (PersistentBlockStateContext PV) (NoLoggerT IO) ()) + flip runBlobStoreT bs $ do + emptyPersistentAccs <- P.emptyAccounts + (checkEquivalent B.emptyAccounts emptyPersistentAccs :: BlobStoreT (PersistentBlockStateContext PV) (NoLoggerT IO) ()) actionTest :: Word -> SpecWith (PersistentBlockStateContext PV) actionTest lvl = it "account actions" $ \bs -> withMaxSuccess (100 * fromIntegral lvl) $ property $ do acts <- randomActions return $ ioProperty $ runNoLoggerT $ flip runBlobStoreT bs $ do - (ba, pa) <- foldM (flip runAccountAction) (B.emptyAccounts, P.emptyAccounts @PV Nothing) acts + emptyPersistentAccs <- P.emptyAccounts + (ba, pa) <- foldM (flip runAccountAction) (B.emptyAccounts, emptyPersistentAccs) acts checkEquivalent ba pa tests :: Word -> Spec diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs index 4eb48a84ce..49cf7c8184 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs @@ -7,6 +7,7 @@ module GlobalStateTests.DifferenceMap where import Concordium.ID.Types (randomAccountAddress) import Concordium.Types +import Data.IORef import System.Random import qualified Concordium.GlobalState.AccountMap.DifferenceMap as DiffMap @@ -21,19 +22,27 @@ dummyPair seed = (fst $ randomAccountAddress (mkStdGen seed), AccountIndex $ fro -- | Test that an account can be inserted and looked up in the 'DiffMap.DifferenceMap'. testInsertLookupAccount :: Assertion testInsertLookupAccount = do - let diffMap = uncurry DiffMap.insert acc $ DiffMap.empty Nothing - case DiffMap.lookup (fst acc) diffMap of + emptyParentMap <- mkParentPointer Nothing + let diffMap = uncurry DiffMap.insert acc $ DiffMap.empty emptyParentMap + DiffMap.lookup (fst acc) diffMap >>= \case Nothing -> assertFailure "account should be present in diff map" Just accIdx -> assertEqual "account should be there" (snd acc) accIdx where acc = dummyPair 1 +-- | Create a parent pointer for the provided difference map. +mkParentPointer :: Maybe DiffMap.DifferenceMap -> IO (IORef (Maybe DiffMap.DifferenceMap)) +mkParentPointer diffMap = newIORef diffMap >>= return + -- | Testing lookups in flat and nested difference maps. testLookups :: Assertion testLookups = do - let diffMap1 = uncurry DiffMap.insert (dummyPair 1) $ DiffMap.empty Nothing - diffMap2 = uncurry DiffMap.insert (dummyPair 2) (DiffMap.empty $ Just diffMap1) - diffMap3 = uncurry DiffMap.insert (dummyPair 3) (DiffMap.empty $ Just diffMap2) + emptyParentMap <- mkParentPointer Nothing + let diffMap1 = uncurry DiffMap.insert (dummyPair 1) $ DiffMap.empty emptyParentMap + diffMap1Pointer <- mkParentPointer $ Just diffMap1 + let diffMap2 = uncurry DiffMap.insert (dummyPair 2) (DiffMap.empty diffMap1Pointer) + diffMap2Pointer <- mkParentPointer $ Just diffMap2 + let diffMap3 = uncurry DiffMap.insert (dummyPair 3) (DiffMap.empty diffMap2Pointer) checkExists (dummyPair 1) diffMap1 checkExists (dummyPair 1) diffMap2 checkExists (dummyPair 2) diffMap2 @@ -42,17 +51,20 @@ testLookups = do checkExists (dummyPair 3) diffMap3 where checkExists pair diffMap = - case DiffMap.lookup (fst pair) diffMap of + DiffMap.lookup (fst pair) diffMap >>= \case Nothing -> assertFailure "account should be present" Just accIdx -> assertEqual "wrong account index" (snd pair) accIdx -- | Test flattening a difference map i.e. return all accounts as one flat map. testFlatten :: Assertion testFlatten = do - let diffMap1 = uncurry DiffMap.insert (dummyPair 1) $ DiffMap.empty Nothing - diffMap2 = uncurry DiffMap.insert (dummyPair 2) (DiffMap.empty $ Just diffMap1) - diffMap3 = uncurry DiffMap.insert (dummyPair 3) (DiffMap.empty $ Just diffMap2) - assertEqual "accounts should be the same" (map dummyPair [1 .. 3]) $ DiffMap.flatten diffMap3 + emptyParentMap <- mkParentPointer Nothing + let diffMap1 = uncurry DiffMap.insert (dummyPair 1) $ DiffMap.empty emptyParentMap + diffMap1Pointer <- mkParentPointer $ Just diffMap1 + let diffMap2 = uncurry DiffMap.insert (dummyPair 2) (DiffMap.empty diffMap1Pointer) + diffMap2Pointer <- mkParentPointer $ Just diffMap2 + let diffMap3 = uncurry DiffMap.insert (dummyPair 3) (DiffMap.empty diffMap2Pointer) + assertEqual "accounts should be the same" (map dummyPair [1 .. 3]) =<< DiffMap.flatten diffMap3 tests :: Spec tests = describe "AccountMap.DifferenceMap" $ do From 70c885135f7a3495d981a67dffea35ff43994905 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Thu, 2 Nov 2023 10:58:18 +0100 Subject: [PATCH 52/92] Address review comments on diff map and accounts. --- .../GlobalState/AccountMap/DifferenceMap.hs | 25 +++--- .../GlobalState/Persistent/Accounts.hs | 86 ++++++++++--------- .../GlobalState/Persistent/BlockState.hs | 13 +-- 3 files changed, 68 insertions(+), 56 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index 03a7eaf766..8363f34416 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -12,11 +12,12 @@ import qualified Data.HashMap.Strict as HM import Data.IORef import Prelude hiding (lookup) +import Concordium.KonsensusV1.Types (Option (..)) import Concordium.Types -- | A difference map that indicates newly added accounts for -- a block identified by a 'BlockHash' and its associated 'BlockHeight'. --- The difference map only contains accounts that were added since the '_dmParentMap'. +-- The difference map only contains accounts that were added since the '_dmParentMapRef'. data DifferenceMap = DifferenceMap { -- | Accounts added in a block. dmAccounts :: !(HM.HashMap AccountAddressEq AccountIndex), @@ -24,7 +25,11 @@ data DifferenceMap = DifferenceMap -- In other words, if the parent block is finalized, -- then the parent map is @Nothing@ as the LMDB account map -- should be consulted instead. - dmParentMap :: !(IORef (Maybe DifferenceMap)) + -- This is an 'IORef' since the parent map may belong + -- to multiple blocks if they have not yet been persisted. + -- So the 'IORef' enables us to when persisting a block, + -- then we also clear the 'DifferenceMap' for the child block. + dmParentMapRef :: !(IORef (Option DifferenceMap)) } deriving (Eq) @@ -34,20 +39,20 @@ flatten :: (MonadIO m) => DifferenceMap -> m [(AccountAddress, AccountIndex)] flatten dmap = map (first aaeAddress) <$> go dmap [] where go diffMap !accum = do - mParentMap <- liftIO $ readIORef (dmParentMap diffMap) + mParentMap <- liftIO $ readIORef (dmParentMapRef diffMap) case mParentMap of - Nothing -> return collectedAccounts - Just parentMap -> go parentMap collectedAccounts + Absent -> return collectedAccounts + Present parentMap -> go parentMap collectedAccounts where collectedAccounts = HM.toList (dmAccounts diffMap) <> accum -- | Create a new empty 'DifferenceMap' potentially based on the difference map of -- the parent. -empty :: IORef (Maybe DifferenceMap) -> DifferenceMap +empty :: IORef (Option DifferenceMap) -> DifferenceMap empty mParentDifferenceMap = DifferenceMap { dmAccounts = HM.empty, - dmParentMap = mParentDifferenceMap + dmParentMapRef = mParentDifferenceMap } -- | Lookup an account in the difference map or any of the parent @@ -60,10 +65,10 @@ lookup addr = check k = accountAddressEmbed addr check diffMap = case HM.lookup k (dmAccounts diffMap) of Nothing -> do - mParentMap <- liftIO $ readIORef (dmParentMap diffMap) + mParentMap <- liftIO $ readIORef (dmParentMapRef diffMap) case mParentMap of - Nothing -> return Nothing - Just parentMap -> check parentMap + Absent -> return Nothing + Present parentMap -> check parentMap Just accIdx -> return $ Just accIdx -- | Insert an account into the difference map. diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 577607574f..911cdbec5c 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -49,9 +49,10 @@ -- -- General flow -- The account map resides in its own lmdb database and functions across protocol versions. --- For a thawed block, then the ‘DifferenceMap’ is either @Nothing@ or @Just DifferenceMap@ depending whether the parent block is written to disk. --- If the parent block is written to disk, then a new 'DifferenceMap' is created for the block as part of 'putNewAccount'. --- Frozen blocks always have a @Nothing@ 'DifferenceMap'. +-- For non-persisted blocks, then the ‘DifferenceMap’ is either @IORef Nothing@ or @IORef (Just DifferenceMap)@ depending on whether the block is written to disk. +-- The 'putNewAccount' function creates a new 'DifferenceMap' on demand, hence a new 'Accounts' is initialized with a @accountDiffMap@ set to @IORef Nothing@. +-- Subsequent accounts created are then being added to the difference map created by the first invocation of 'putNewAccount'. +-- Blocks that are persisted always have a @IORef Nothing@ 'accountDiffMapRef'. -- -- The lmdb backed account map consists of a single lmdb store indexed by AccountAddresses and values are the associated ‘AccountIndex’ for each account. -- @@ -62,32 +63,31 @@ -- for keeping track of non persisted accounts for supporting e.g. queries via the ‘AccountAddress’. module Concordium.GlobalState.Persistent.Accounts where -import Control.Monad.Reader -import Data.Foldable (foldlM) -import Data.IORef -import qualified Data.Map.Strict as Map -import Data.Maybe -import Data.Serialize -import Data.Word - -import Concordium.GlobalState.Persistent.Account -import Concordium.GlobalState.Persistent.BlobStore -import Concordium.GlobalState.Persistent.Cache -import Concordium.GlobalState.Persistent.CachedRef -import qualified Concordium.GlobalState.Persistent.Trie as Trie -import qualified Concordium.ID.Types as ID -import Concordium.Types -import Concordium.Utils.Serialization.Put - import qualified Concordium.Crypto.SHA256 as H import qualified Concordium.GlobalState.AccountMap as OldMap import qualified Concordium.GlobalState.AccountMap.DifferenceMap as DiffMap import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import Concordium.GlobalState.Parameters +import Concordium.GlobalState.Persistent.Account +import Concordium.GlobalState.Persistent.BlobStore +import Concordium.GlobalState.Persistent.Cache +import Concordium.GlobalState.Persistent.CachedRef import Concordium.GlobalState.Persistent.LFMBTree (LFMBTree') import qualified Concordium.GlobalState.Persistent.LFMBTree as L +import qualified Concordium.GlobalState.Persistent.Trie as Trie import Concordium.ID.Parameters +import qualified Concordium.ID.Types as ID +import Concordium.KonsensusV1.Types (Option (..)) +import Concordium.Types import Concordium.Types.HashableTo +import Concordium.Utils.Serialization.Put +import Control.Monad.Reader +import Data.Foldable (foldlM) +import Data.IORef +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.Serialize +import Data.Word -- | Representation of the set of accounts on the chain. -- Each account has an 'AccountIndex' which is the order @@ -133,7 +133,10 @@ data Accounts (pv :: ProtocolVersion) = Accounts -- Otherwise if the block is not persisted and accounts have been added, then -- the 'DiffMap.DifferenceMap' yields the @AccountAddress -> AccountIndex@ mapping for -- accounts created in the block, where the account addresses are in canonical form. - accountDiffMap :: !(IORef (Maybe DiffMap.DifferenceMap)) + -- The 'DiffMap.DifferenceMap' is wrapped in an 'IORef' because it is inherited + -- by child blocks, and so when this block state is persisted then we need to clear it + -- for any children block states. + accountDiffMapRef :: !(IORef (Option DiffMap.DifferenceMap)) } instance (IsProtocolVersion pv) => Show (Accounts pv) where @@ -156,12 +159,12 @@ instance (SupportsPersistentAccount pv m) => MHashableTo m H.Hash (Accounts pv) -- Note that this also empties the difference map for this block. writeAccountsCreated :: (SupportsPersistentAccount pv m) => Accounts pv -> m () writeAccountsCreated Accounts{..} = do - mAccountsCreated <- liftIO $ readIORef accountDiffMap + mAccountsCreated <- liftIO $ readIORef accountDiffMapRef case mAccountsCreated of - Nothing -> return () - Just accountsCreated -> do + Absent -> return () + Present accountsCreated -> do listOfAccountsCreated <- liftIO $ DiffMap.flatten accountsCreated - liftIO $ atomicWriteIORef accountDiffMap Nothing + liftIO $ atomicWriteIORef accountDiffMapRef Absent LMDBAccountMap.insert listOfAccountsCreated -- Note. We're writing to the LMDB accountmap as part of the 'storeUpdate' implementation below. @@ -198,7 +201,7 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where return $ do accountTable <- maccountTable accountRegIdHistory <- mrRIH - accountDiffMap <- liftIO $ newIORef Nothing + accountDiffMapRef <- liftIO $ newIORef Absent return $ Accounts{..} instance (SupportsPersistentAccount pv m, av ~ AccountVersionFor pv) => Cacheable1 m (Accounts pv) (PersistentAccount av) where @@ -211,8 +214,8 @@ instance (SupportsPersistentAccount pv m, av ~ AccountVersionFor pv) => Cacheabl -- to an empty 'DiffMap.DifferenceMap'. emptyAccounts :: (MonadIO m) => m (Accounts pv) emptyAccounts = do - accountDiffMap <- liftIO $ newIORef Nothing - return $ Accounts L.empty Trie.empty accountDiffMap + accountDiffMapRef <- liftIO $ newIORef Absent + return $ Accounts L.empty Trie.empty accountDiffMapRef -- | Add a new account. Returns @Just idx@ if the new account is fresh, i.e., the address does not exist, -- or @Nothing@ in case the account already exists. In the latter case there is no change to the accounts structure. @@ -223,14 +226,17 @@ putNewAccount !acct a0@Accounts{..} = do True -> return (Nothing, a0) False -> do (accIdx, newAccountTable) <- L.append acct accountTable - mAccountDiffMap <- liftIO $ readIORef accountDiffMap + mAccountDiffMap <- liftIO $ readIORef accountDiffMapRef newDiffMap <- case mAccountDiffMap of - Nothing -> do - freshDifferenceMap <- liftIO $ newIORef (Nothing :: Maybe DiffMap.DifferenceMap) + Absent -> do + -- create a difference map for this block state with a @Nothing@ as the parent. + freshDifferenceMap <- liftIO $ newIORef (Absent :: Option DiffMap.DifferenceMap) return $ addToDiffMap accIdx $ DiffMap.empty freshDifferenceMap - Just accDiffMap -> do + Present accDiffMap -> do + -- reuse the already existing difference map for this block state. return $ addToDiffMap accIdx accDiffMap - liftIO $ atomicWriteIORef accountDiffMap (Just newDiffMap) + -- we write to the difference map atomically here as there might be concurrent readers. + liftIO $ atomicWriteIORef accountDiffMapRef (Present newDiffMap) return (Just accIdx, a0{accountTable = newAccountTable}) where addToDiffMap = DiffMap.insert (accountAddressEmbed addr) @@ -262,10 +268,10 @@ getAccountByCredId cid accs@Accounts{..} = -- This is fine as there are no clashes and this approach simplifies the implementation. getAccountIndex :: (SupportsPersistentAccount pv m) => AccountAddress -> Accounts pv -> m (Maybe AccountIndex) getAccountIndex addr Accounts{..} = do - mAccountDiffMap <- liftIO $ readIORef accountDiffMap + mAccountDiffMap <- liftIO $ readIORef accountDiffMapRef case mAccountDiffMap of - Nothing -> lookupDisk - Just accDiffMap -> + Absent -> lookupDisk + Present accDiffMap -> DiffMap.lookup addr accDiffMap >>= \case Just accIdx -> return $ Just accIdx Nothing -> lookupDisk @@ -364,10 +370,10 @@ updateAccountsAtIndex' fupd ai = fmap snd . updateAccountsAtIndex fupd' ai allAccounts :: (SupportsPersistentAccount pv m) => Accounts pv -> m [(AccountAddress, AccountIndex)] allAccounts accounts = do persistedAccs <- LMDBAccountMap.all - mDiffMap <- liftIO $ readIORef (accountDiffMap accounts) + mDiffMap <- liftIO $ readIORef (accountDiffMapRef accounts) case mDiffMap of - Nothing -> return persistedAccs - Just accDiffMap -> do + Absent -> return persistedAccs + Present accDiffMap -> do flattenedDiffMapAccounts <- DiffMap.flatten accDiffMap return $! persistedAccs <> flattenedDiffMapAccounts @@ -435,5 +441,5 @@ migrateAccounts migration Accounts{..} = do Accounts { accountTable = newAccountTable, accountRegIdHistory = newAccountRegIds, - accountDiffMap = accountDiffMap + accountDiffMapRef = accountDiffMapRef } diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 4131596606..12a7458064 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -69,6 +69,7 @@ import Concordium.GlobalState.Types import qualified Concordium.GlobalState.Wasm as GSWasm import qualified Concordium.ID.Parameters as ID import qualified Concordium.ID.Types as ID +import Concordium.KonsensusV1.Types (Option (..)) import Concordium.Kontrol.Bakers import Concordium.Logger (MonadLogger) import Concordium.TimeMonad (TimeMonad) @@ -3723,15 +3724,15 @@ doThawBlockState :: doThawBlockState HashedPersistentBlockState{..} = do -- This load is cheap as the underlying block state is retained in memory as we're building from it, so it must be the "best" block. bsp@BlockStatePointers{bspAccounts = a0@Accounts.Accounts{..}} <- loadPBS hpbsPointers - mDiffMap <- liftIO $ readIORef accountDiffMap - newDiffMap <- case mDiffMap of + mDiffMap <- liftIO $ readIORef accountDiffMapRef + newDiffMapRef <- case mDiffMap of -- reuse the reference pointing to @Nothing@. - Nothing -> return accountDiffMap - Just _ -> do + Absent -> return accountDiffMapRef + Present _ -> do -- create a new reference pointing to -- a new difference map which inherits the parent difference map. - liftIO $ newIORef $ Just (DiffMap.empty accountDiffMap) - let bsp' = bsp{bspAccounts = a0{Accounts.accountDiffMap = newDiffMap}} + liftIO $ newIORef $ Present (DiffMap.empty accountDiffMapRef) + let bsp' = bsp{bspAccounts = a0{Accounts.accountDiffMapRef = newDiffMapRef}} liftIO $ newIORef =<< makeBufferedRef bsp' -- | Cache the block state. From 22a224dc5db7c4a6c5955bf033fc1426904bfd34 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Thu, 2 Nov 2023 14:36:00 +0100 Subject: [PATCH 53/92] Refactor lmdb helper functions into helpers and reuse across all lmdb databases. --- .../Concordium/GlobalState/AccountMap/LMDB.hs | 186 +++++++--------- .../Concordium/GlobalState/LMDB/Helpers.hs | 73 ++++++- .../GlobalState/Persistent/Accounts.hs | 8 +- .../Concordium/GlobalState/Persistent/LMDB.hs | 34 +-- .../KonsensusV1/TreeState/LowLevel/LMDB.hs | 200 ++++++++---------- .../globalstate/GlobalStateTests/Accounts.hs | 1 - 6 files changed, 253 insertions(+), 249 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index a49402b72e..0ddef103eb 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -43,7 +46,6 @@ import Data.Kind (Type) import Database.LMDB.Raw import Lens.Micro.Platform import System.Directory -import Prelude hiding (all, lookup) import Concordium.GlobalState.Classes import Concordium.GlobalState.LMDB.Helpers @@ -73,29 +75,29 @@ instance Exception DatabaseInvariantViolation where -- * All accounts in the store are in persisted blocks (finalized or certified). class (Monad m) => MonadAccountMapStore m where -- | Inserts the accounts to the underlying store. - insert :: [(AccountAddress, AccountIndex)] -> m () + insertAccount :: [(AccountAddress, AccountIndex)] -> m () -- | Looks up the ‘AccountIndex’ for the provided ‘AccountAddress’ by using the -- equivalence class 'AccountAddressEq'. -- Returns @Just AccountIndex@ if the account is present in the ‘AccountMap’ -- and returns @Nothing@ if the account was not present. - lookup :: AccountAddress -> m (Maybe AccountIndex) + lookupAccountIndex :: AccountAddress -> m (Maybe AccountIndex) - -- | Return all the canonical addresses of accounts present + -- | Return all the canonical addresses and their associated account indices of accounts present -- in the store. - all :: m [(AccountAddress, AccountIndex)] + getAllAccounts :: m [(AccountAddress, AccountIndex)] -- | Checks whether the lmdb store is initialized or not. isInitialized :: m Bool instance (Monad (t m), MonadTrans t, MonadAccountMapStore m) => MonadAccountMapStore (MGSTrans t m) where - insert = lift . insert - lookup = lift . lookup - all = lift all + insertAccount = lift . insertAccount + lookupAccountIndex = lift . lookupAccountIndex + getAllAccounts = lift getAllAccounts isInitialized = lift isInitialized - {-# INLINE insert #-} - {-# INLINE lookup #-} - {-# INLINE all #-} + {-# INLINE insertAccount #-} + {-# INLINE lookupAccountIndex #-} + {-# INLINE getAllAccounts #-} {-# INLINE isInitialized #-} deriving via (MGSTrans (StateT s) m) instance (MonadAccountMapStore m) => MonadAccountMapStore (StateT s m) @@ -103,10 +105,14 @@ deriving via (MGSTrans (ExceptT e) m) instance (MonadAccountMapStore m) => Monad deriving via (MGSTrans (WriterT w) m) instance (Monoid w, MonadAccountMapStore m) => MonadAccountMapStore (WriterT w m) instance (MonadAccountMapStore m) => MonadAccountMapStore (PutT m) where - insert = lift . insert - lookup = lift . lookup - all = lift all + insertAccount = lift . insertAccount + lookupAccountIndex = lift . lookupAccountIndex + getAllAccounts = lift getAllAccounts isInitialized = lift isInitialized + {-# INLINE insertAccount #-} + {-# INLINE lookupAccountIndex #-} + {-# INLINE getAllAccounts #-} + {-# INLINE isInitialized #-} -- * Database stores @@ -120,43 +126,22 @@ instance MDBDatabase AccountMapStore where type DBKey AccountMapStore = AccountAddress type DBValue AccountMapStore = AccountIndex +-- | Datbase handlers to interact with the account map lmdb +-- database. Create via 'makeDatabasehandlers'. data DatabaseHandlers = DatabaseHandlers - { _storeEnv :: !StoreEnv, - _accountMapStore :: !AccountMapStore + { -- | The underlying lmdb store environment. + _dbhStoreEnv :: !StoreEnv, + -- | The only store for this lmdb database. + -- The account map functions as a persistent @AccountAddress -> Maybe AccountIndex@ mapping. + _dbhAccountMapStore :: !AccountMapStore } + makeClassy ''DatabaseHandlers -- | The number of stores in the LMDB environment for 'DatabaseHandlers'. databaseCount :: Int databaseCount = 1 --- | Database growth size increment. --- This is currently set at 64MB, and must be a multiple of the page size. -dbStepSize :: Int -dbStepSize = 2 ^ (26 :: Int) -- 64MB - --- | Maximum step to increment the database size. -dbMaxStepSize :: Int -dbMaxStepSize = 2 ^ (30 :: Int) -- 1GB - --- | Initial database size. --- This is currently set to be the same as 'dbStepSize'. -dbInitSize :: Int -dbInitSize = dbStepSize - --- ** Helpers - --- | Increase the database size by at least the supplied size. --- The size SHOULD be a multiple of 'dbStepSize', and MUST be a multiple of the page size. -resizeDatabaseHandlers :: (MonadIO m, MonadLogger m) => DatabaseHandlers -> Int -> m () -resizeDatabaseHandlers dbh delta = do - envInfo <- liftIO $ mdb_env_info (dbh ^. storeEnv . seEnv) - let oldMapSize = fromIntegral $ me_mapsize envInfo - newMapSize = oldMapSize + delta - _storeEnv = dbh ^. storeEnv - logEvent LMDB LLDebug $ "Resizing database from " ++ show oldMapSize ++ " to " ++ show newMapSize - liftIO . withWriteStoreEnv (dbh ^. storeEnv) $ flip mdb_env_set_mapsize newMapSize - -- ** Initialization -- | Initialize database handlers. @@ -168,19 +153,17 @@ makeDatabaseHandlers :: FilePath -> -- | Open read only Bool -> - -- | Initial database size - Int -> IO DatabaseHandlers -makeDatabaseHandlers accountMapDir readOnly initSize = do - _storeEnv <- makeStoreEnv +makeDatabaseHandlers accountMapDir readOnly = do + _dbhStoreEnv <- makeStoreEnv -- here nobody else has access to the environment, so we need not lock - let env = _storeEnv ^. seEnv - mdb_env_set_mapsize env (initSize + dbStepSize - initSize `mod` dbStepSize) + let env = _dbhStoreEnv ^. seEnv + mdb_env_set_mapsize env defaultEnvSize mdb_env_set_maxdbs env databaseCount mdb_env_set_maxreaders env 126 mdb_env_open env accountMapDir [MDB_RDONLY | readOnly] - transaction _storeEnv readOnly $ \txn -> do - _accountMapStore <- + transaction _dbhStoreEnv readOnly $ \txn -> do + _dbhAccountMapStore <- AccountMapStore <$> mdb_dbi_open' txn @@ -196,11 +179,11 @@ makeDatabaseHandlers accountMapDir readOnly initSize = do openDatabase :: FilePath -> IO DatabaseHandlers openDatabase accountMapDir = do createDirectoryIfMissing True accountMapDir - makeDatabaseHandlers accountMapDir False dbInitSize + makeDatabaseHandlers accountMapDir False -- | Close the database. The database should not be used after it is closed. closeDatabase :: DatabaseHandlers -> IO () -closeDatabase dbHandlers = runInBoundThread $ mdb_env_close $ dbHandlers ^. storeEnv . seEnv +closeDatabase dbHandlers = runInBoundThread $ mdb_env_close $ dbHandlers ^. dbhStoreEnv . seEnv -- ** Monad implementation @@ -211,36 +194,6 @@ newtype AccountMapStoreMonad (m :: Type -> Type) (a :: Type) = AccountMapStoreMo deriving instance (MonadProtocolVersion m) => MonadProtocolVersion (AccountMapStoreMonad m) --- todo: move these into Helpers.hs so they can be reused across the different lmdb database connections. - --- | Run a read-only transaction. -asReadTransaction :: (MonadIO m, MonadReader r m, HasDatabaseHandlers r) => (DatabaseHandlers -> MDB_txn -> IO a) -> AccountMapStoreMonad m a -asReadTransaction t = do - dbh <- view databaseHandlers - liftIO $ transaction (dbh ^. storeEnv) True $ t dbh - --- | Run a write transaction. If the transaction fails due to the database being full, this resizes --- the database and retries the transaction. -asWriteTransaction :: (MonadIO m, MonadReader r m, HasDatabaseHandlers r, MonadLogger m) => (DatabaseHandlers -> MDB_txn -> IO a) -> AccountMapStoreMonad m a -asWriteTransaction t = do - dbh <- view databaseHandlers - let doTransaction = transaction (dbh ^. storeEnv) False $ t dbh - inner step = do - r <- liftIO $ tryJust selectDBFullError doTransaction - case r of - Left _ -> do - -- We resize by the step size initially, and by double for each successive - -- failure. - resizeDatabaseHandlers dbh step - inner (min (step * 2) dbMaxStepSize) - Right res -> return res - inner dbStepSize - where - -- only handle the db full error and propagate other exceptions. - selectDBFullError = \case - (LMDB_Error _ _ (Right MDB_MAP_FULL)) -> Just () - _ -> Nothing - -- | Delete the provided accounts from the LMDB store. -- -- This function should only be used when rolling back certified blocks. When rolling back finalized blocks, @@ -248,8 +201,9 @@ asWriteTransaction t = do unsafeRollback :: (MonadIO m, MonadLogger m, MonadReader r m, HasDatabaseHandlers r) => [AccountAddress] -> m () unsafeRollback accounts = do handlers <- ask - flip runReaderT handlers $ runAccountMapStoreMonad $ asWriteTransaction $ \dbh txn -> do - forM_ accounts $ \accAddr -> deleteRecord txn (dbh ^. accountMapStore) accAddr + let env = handlers ^. dbhStoreEnv + runAccountMapStoreMonad $ asWriteTransaction env $ \txn -> do + forM_ accounts $ \accAddr -> deleteRecord txn (handlers ^. dbhAccountMapStore) accAddr -- | When looking up accounts we perform a prefix search as we -- store the canonical account addresses in the lmdb store and we @@ -265,35 +219,51 @@ instance ) => MonadAccountMapStore (AccountMapStoreMonad m) where - insert differenceMap = asWriteTransaction $ \dbh txn -> doInsert dbh txn differenceMap + insertAccount differenceMap = do + dbh <- ask + asWriteTransaction (dbh ^. dbhStoreEnv) $ \txn -> doInsert dbh txn differenceMap where - doInsert dbh txn accounts = do + doInsert handlers txn accounts = do forM_ accounts $ \(accAddr, accIndex) -> do - storeRecord txn (dbh ^. accountMapStore) accAddr accIndex - - lookup a@(AccountAddress accAddr) = asReadTransaction $ \dbh txn -> - withCursor txn (dbh ^. accountMapStore) $ \cursor -> do - withMDB_val accLookupKey $ \k -> do - getCursor (CursorMoveTo k) cursor >>= \case - Nothing -> return Nothing - Just (Left err) -> throwM $ DatabaseInvariantViolation err - Just (Right (foundAccAddr, accIdx)) -> - -- we need to check equivalence here as we are performing - -- prefix lookup in the lmdb database, so if the account does not exist - -- then the lmdb query would return the "next" account address - -- by lexicographic order of account address. - if checkEquivalence a foundAccAddr - then return $ Just accIdx - else return Nothing + storeRecord txn (handlers ^. dbhAccountMapStore) accAddr accIndex + + lookupAccountIndex a@(AccountAddress accAddr) = do + dbh <- ask + asReadTransaction (dbh ^. dbhStoreEnv) $ \txn -> + withCursor txn (dbh ^. dbhAccountMapStore) $ \cursor -> do + withMDB_val accLookupKey $ \k -> do + getCursor (CursorMoveTo k) cursor >>= \case + Nothing -> return Nothing + Just (Left err) -> throwM $ DatabaseInvariantViolation err + Just (Right (foundAccAddr, accIdx)) -> + -- we need to check equivalence here as we are performing + -- prefix lookup in the lmdb database, so if the account does not exist + -- then the lmdb query would return the "next" account address + -- by lexicographic order of account address. + if eqCheck a foundAccAddr + then return $ Just accIdx + else return Nothing where - -- The key to use for looking up an account. - -- We do a prefix lookup on the first 29 bytes of the account address as - -- the last 3 bytes are reserved for aliases. + -- If account aliases are supported then we check if + -- the found addresses matches the one we looked for via + -- the equivalence class 'AddressAccountEq'. + -- If account aliases are not supported then we check if the + -- found account address matches via exactness. + eqCheck actual found = + -- if supportsAccountAliases (protocolVersion @(MPV m)) + checkEquivalence actual found -- then checkEquivalence actual found + -- else actual == found + -- The key to use for looking up an account. + -- We do a prefix lookup on the first 29 bytes of the account address as + -- the last 3 bytes are reserved for aliases. accLookupKey = BS.take prefixAccountAddressSize $ FBS.toByteString accAddr checkEquivalence x y = accountAddressEmbed x == accountAddressEmbed y - all = asReadTransaction $ \dbh txn -> loadAll txn (dbh ^. accountMapStore) + getAllAccounts = do + dbh <- ask + asReadTransaction (dbh ^. dbhStoreEnv) $ \txn -> loadAll txn (dbh ^. dbhAccountMapStore) isInitialized = do - size <- asReadTransaction $ \dbh txn -> databaseSize txn (dbh ^. accountMapStore) + dbh <- ask + size <- asReadTransaction (dbh ^. dbhStoreEnv) $ \txn -> databaseSize txn (dbh ^. dbhAccountMapStore) return $ size /= 0 diff --git a/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs b/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs index 5d6d5effcd..81525b8cc9 100644 --- a/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs +++ b/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs @@ -15,6 +15,9 @@ module Concordium.GlobalState.LMDB.Helpers ( makeStoreEnv, withWriteStoreEnv, seEnv, + defaultStepSize, + defaultEnvSize, + resizeDatabaseHandlers, -- * Database queries and updates. MDBDatabase (..), @@ -44,13 +47,19 @@ module Concordium.GlobalState.LMDB.Helpers ( byteStringFromMDB_val, unsafeByteStringFromMDB_val, withMDB_val, + + -- * Helpers + asReadTransaction, + asWriteTransaction, ) where +import Concordium.Logger import Control.Concurrent (runInBoundThread, yield) import Control.Concurrent.MVar import Control.Exception import Control.Monad +import Control.Monad.IO.Class import Control.Monad.Trans.Except import Data.ByteString import qualified Data.ByteString.Lazy as LBS @@ -272,18 +281,39 @@ data StoreEnv = StoreEnv _seEnv :: !MDB_env, -- | Lock to quard access to the environment. When resizing the environment -- we must ensure that there are no outstanding transactions. - _seEnvLock :: !RWLock + _seEnvLock :: !RWLock, + -- | Database growth size increment. + -- This is currently set at 64MB, and must be a multiple of the page size. + _seStepSize :: !Int, + -- | Maximum step to increment the database size. + _seMaxStepSize :: !Int } +-- | Database growth size increment. +-- This is currently set at 64MB, and must be a multiple of the page size. +defaultStepSize :: Int +defaultStepSize = 2 ^ (26 :: Int) -- 64MB + +-- | Maximum step to increment the database size. +defaultMaxStepSize :: Int +defaultMaxStepSize = 2 ^ (30 :: Int) -- 1GB + +-- | Default start environment size. +defaultEnvSize :: Int +defaultEnvSize = 2 ^ (27 :: Int) -- 128MB + makeLenses ''StoreEnv -- | Construct a new LMDB environment with associated locks that protect its use. -makeStoreEnv :: IO StoreEnv -makeStoreEnv = do +makeStoreEnv' :: Int -> Int -> IO StoreEnv +makeStoreEnv' _seStepSize _seMaxStepSize = do _seEnv <- mdb_env_create _seEnvLock <- initializeLock return StoreEnv{..} +makeStoreEnv :: IO StoreEnv +makeStoreEnv = makeStoreEnv' defaultStepSize defaultMaxStepSize + -- | Acquire exclusive access to the LMDB environment and perform the given action. -- The IO action should not leak the 'MDB_env'. withWriteStoreEnv :: StoreEnv -> (MDB_env -> IO a) -> IO a @@ -658,3 +688,40 @@ databaseSize :: db -> IO Word64 databaseSize txn dbi = fromIntegral . ms_entries <$> mdb_stat' txn (mdbDatabase dbi) + +-- | Increase the database size by at least the supplied size. +-- The size SHOULD be a multiple of 'dbStepSize', and MUST be a multiple of the page size. +resizeDatabaseHandlers :: (MonadIO m, MonadLogger m) => StoreEnv -> Int -> m () +resizeDatabaseHandlers env delta = do + envInfo <- liftIO $ mdb_env_info (env ^. seEnv) + let oldMapSize = fromIntegral $ me_mapsize envInfo + newMapSize = oldMapSize + delta + _storeEnv = env + logEvent LMDB LLDebug $ "Resizing database from " ++ show oldMapSize ++ " to " ++ show newMapSize + liftIO . withWriteStoreEnv env $ flip mdb_env_set_mapsize newMapSize + +-- | Run a read-only transaction. +asReadTransaction :: (MonadIO m) => StoreEnv -> (MDB_txn -> IO a) -> m a +asReadTransaction env t = do + liftIO $ transaction env True t + +-- | Run a write transaction. If the transaction fails due to the database being full, this resizes +-- the database and retries the transaction. +asWriteTransaction :: (MonadIO m, MonadLogger m) => StoreEnv -> (MDB_txn -> IO a) -> m a +asWriteTransaction env t = do + let doTransaction = transaction env False t + inner step = do + r <- liftIO $ tryJust selectDBFullError doTransaction + case r of + Left _ -> do + -- We resize by the step size initially, and by double for each successive + -- failure. + resizeDatabaseHandlers env step + inner (min (step * 2) (env ^. seMaxStepSize)) + Right res -> return res + inner $ env ^. seStepSize + where + -- only handle the db full error and propagate other exceptions. + selectDBFullError = \case + (LMDB_Error _ _ (Right MDB_MAP_FULL)) -> Just () + _ -> Nothing diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 911cdbec5c..05744f635a 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -165,7 +165,7 @@ writeAccountsCreated Accounts{..} = do Present accountsCreated -> do listOfAccountsCreated <- liftIO $ DiffMap.flatten accountsCreated liftIO $ atomicWriteIORef accountDiffMapRef Absent - LMDBAccountMap.insert listOfAccountsCreated + LMDBAccountMap.insertAccount listOfAccountsCreated -- Note. We're writing to the LMDB accountmap as part of the 'storeUpdate' implementation below. -- This in turn means that no associated metadata is being written to the LMDB database (i.e. the block hash) of the @@ -278,7 +278,7 @@ getAccountIndex addr Accounts{..} = do where -- Lookup the 'AccountIndex' in the lmdb backed account map. lookupDisk = - LMDBAccountMap.lookup addr >>= \case + LMDBAccountMap.lookupAccountIndex addr >>= \case Nothing -> return Nothing Just accIdx -> return $ Just accIdx @@ -369,7 +369,7 @@ updateAccountsAtIndex' fupd ai = fmap snd . updateAccountsAtIndex fupd' ai -- a concatenation of two lists of account addresses. allAccounts :: (SupportsPersistentAccount pv m) => Accounts pv -> m [(AccountAddress, AccountIndex)] allAccounts accounts = do - persistedAccs <- LMDBAccountMap.all + persistedAccs <- LMDBAccountMap.getAllAccounts mDiffMap <- liftIO $ readIORef (accountDiffMapRef accounts) case mDiffMap of Absent -> return persistedAccs @@ -418,7 +418,7 @@ allAccountsViaTable accts = do tryPopulateLMDBStore :: (SupportsPersistentAccount pv m) => Accounts pv -> m () tryPopulateLMDBStore accts = do isInitialized <- LMDBAccountMap.isInitialized - unless isInitialized (void $ LMDBAccountMap.insert =<< allAccountsViaTable accts) + unless isInitialized (void $ LMDBAccountMap.insertAccount =<< allAccountsViaTable accts) -- | See documentation of @migratePersistentBlockState@. migrateAccounts :: diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs index 388da62fc7..b36758d43a 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs @@ -317,21 +317,11 @@ metadataStoreName = "metadata" databaseCount :: Int databaseCount = 5 --- | Database growth size increment. --- This is currently set at 64MB, and must be a multiple of the page size. -dbStepSize :: Int -dbStepSize = 2 ^ (26 :: Int) -- 64MB - --- | Initial database size. --- This is currently set to be the same as 'dbStepSize'. -dbInitSize :: Int -dbInitSize = dbStepSize - -- | Initialize database handlers in ReadWrite mode. -- This simply loads the references and does not initialize the databases. --- The initial size is set to 64MB. +-- The initial size is set to 128MB. databaseHandlers :: FilePath -> IO (DatabaseHandlers pv st) -databaseHandlers treeStateDir = makeDatabaseHandlers treeStateDir False dbInitSize +databaseHandlers treeStateDir = makeDatabaseHandlers treeStateDir False defaultEnvSize -- | Initialize database handlers. -- The size will be rounded up to a multiple of 'dbStepSize'. @@ -342,14 +332,14 @@ makeDatabaseHandlers :: FilePath -> -- | Open read only Bool -> - -- | Initial database size + -- | Initital database size Int -> IO (DatabaseHandlers pv st) makeDatabaseHandlers treeStateDir readOnly initSize = do _storeEnv <- makeStoreEnv -- here nobody else has access to the environment, so we need not lock let env = _storeEnv ^. seEnv - mdb_env_set_mapsize env (initSize + dbStepSize - initSize `mod` dbStepSize) + mdb_env_set_mapsize env initSize mdb_env_set_maxdbs env databaseCount mdb_env_set_maxreaders env 126 -- TODO: Consider MDB_NOLOCK @@ -382,7 +372,7 @@ openReadOnlyDatabase :: openReadOnlyDatabase treeStateDir = do _storeEnv <- makeStoreEnv let env = _storeEnv ^. seEnv - mdb_env_set_mapsize env dbInitSize + mdb_env_set_mapsize env defaultStepSize mdb_env_set_maxdbs env databaseCount mdb_env_set_maxreaders env 126 -- TODO: Consider MDB_NOLOCK @@ -458,7 +448,7 @@ initializeDatabase gb stRef gbStateHash treeStateDir = do -- migrating a database from an earlier version. addDatabaseVersion :: (MonadLogger m, MonadIO m) => FilePath -> m () addDatabaseVersion treeStateDir = do - handlers :: DatabaseHandlers 'P1 () <- liftIO $ makeDatabaseHandlers treeStateDir False dbInitSize + handlers :: DatabaseHandlers 'P1 () <- liftIO $ makeDatabaseHandlers treeStateDir False defaultEnvSize handlers' <- execStateT ( resizeOnFull 4096 $ -- This size is mostly arbitrary, but should be enough to store the serialized metadata @@ -527,16 +517,6 @@ resizeOnResizedInternal se a = inner liftIO (withWriteStoreEnv se $ flip mdb_env_set_mapsize 0) inner -resizeDatabaseHandlers :: (MonadIO m, MonadLogger m) => DatabaseHandlers pv st -> Int -> m () -resizeDatabaseHandlers dbh size = do - envInfo <- liftIO $ mdb_env_info (dbh ^. storeEnv . seEnv) - let delta = size + (dbStepSize - size `mod` dbStepSize) - oldMapSize = fromIntegral $ me_mapsize envInfo - newMapSize = oldMapSize + delta - _storeEnv = dbh ^. storeEnv - 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. @@ -717,7 +697,7 @@ resizeOnFullInternal addSize dbh a = inner Left _ -> do -- Resize the database handlers, and try to add again in case the size estimate -- given by lmdbStoreTypeSize is off. - resizeDatabaseHandlers dbh addSize + resizeDatabaseHandlers (dbh ^. storeEnv) addSize inner Right res -> return res -- only handle the db full error and propagate other exceptions. diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs index f8baecfcb6..282b9a285a 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs @@ -249,20 +249,6 @@ metadataStoreName = "metadata" databaseCount :: Int databaseCount = 6 --- | Database growth size increment. --- This is currently set at 64MB, and must be a multiple of the page size. -dbStepSize :: Int -dbStepSize = 2 ^ (26 :: Int) -- 64MB - --- | Maximum step to increment the database size. -dbMaxStepSize :: Int -dbMaxStepSize = 2 ^ (30 :: Int) -- 1GB - --- | Initial database size. --- This is currently set to be the same as 'dbStepSize'. -dbInitSize :: Int -dbInitSize = dbStepSize - -- ** Helpers -- | Resize the LMDB map if the file size has changed. @@ -316,7 +302,7 @@ makeDatabaseHandlers treeStateDir readOnly initSize = do _storeEnv <- makeStoreEnv -- here nobody else has access to the environment, so we need not lock let env = _storeEnv ^. seEnv - mdb_env_set_mapsize env (initSize + dbStepSize - initSize `mod` dbStepSize) + mdb_env_set_mapsize env initSize mdb_env_set_maxdbs env databaseCount mdb_env_set_maxreaders env 126 mdb_env_open env treeStateDir [MDB_RDONLY | readOnly] @@ -366,7 +352,7 @@ makeDatabaseHandlers treeStateDir readOnly initSize = do openDatabase :: FilePath -> IO (DatabaseHandlers pv) openDatabase treeStateDir = do createDirectoryIfMissing False treeStateDir - makeDatabaseHandlers treeStateDir False dbInitSize + makeDatabaseHandlers treeStateDir False defaultEnvSize -- | Close the database. The database should not be used after it is closed. closeDatabase :: DatabaseHandlers pv -> IO () @@ -419,7 +405,7 @@ openReadOnlyDatabase :: openReadOnlyDatabase treeStateDir = do _storeEnv <- makeStoreEnv let env = _storeEnv ^. seEnv - mdb_env_set_mapsize env dbInitSize + mdb_env_set_mapsize env defaultEnvSize mdb_env_set_maxdbs env databaseCount mdb_env_set_maxreaders env 126 mdb_env_open env treeStateDir [MDB_RDONLY] @@ -486,34 +472,6 @@ deriving instance (MonadReader r m) => MonadReader r (DiskLLDBM pv m) instance (IsProtocolVersion pv) => MonadProtocolVersion (DiskLLDBM pv m) where type MPV (DiskLLDBM pv m) = pv --- | Run a read-only transaction. -asReadTransaction :: (MonadIO m, MonadReader r m, HasDatabaseHandlers r pv) => (DatabaseHandlers pv -> MDB_txn -> IO a) -> DiskLLDBM pv m a -asReadTransaction t = do - dbh <- view databaseHandlers - liftIO $ transaction (dbh ^. storeEnv) True $ t dbh - --- | Run a write transaction. If the transaction fails due to the database being full, this resizes --- the database and retries the transaction. -asWriteTransaction :: (MonadIO m, MonadReader r m, HasDatabaseHandlers r pv, MonadLogger m) => (DatabaseHandlers pv -> MDB_txn -> IO a) -> DiskLLDBM pv m a -asWriteTransaction t = do - dbh <- view databaseHandlers - let doTransaction = transaction (dbh ^. storeEnv) False $ t dbh - inner step = do - r <- liftIO $ tryJust selectDBFullError doTransaction - case r of - Left _ -> do - -- We resize by the step size initially, and by double for each successive - -- failure. - resizeDatabaseHandlers dbh step - inner (min (step * 2) dbMaxStepSize) - Right res -> return res - inner dbStepSize - where - -- only handle the db full error and propagate other exceptions. - selectDBFullError = \case - (LMDB_Error _ _ (Right MDB_MAP_FULL)) -> Just () - _ -> Nothing - -- | Helper function for implementing 'writeFinalizedBlocks'. writeFinalizedBlocksHelper :: (HasDatabaseHandlers dbh pv, IsProtocolVersion pv) => @@ -597,27 +555,40 @@ instance ) => MonadTreeStateStore (DiskLLDBM pv m) where - lookupBlock bh = asReadTransaction $ \dbh txn -> - loadRecord txn (dbh ^. blockStore) bh - memberBlock bh = asReadTransaction $ \dbh txn -> - isRecordPresent txn (dbh ^. blockStore) bh + lookupBlock bh = do + dbh <- ask + asReadTransaction (dbh ^. storeEnv) $ \txn -> + loadRecord txn (dbh ^. blockStore) bh + memberBlock bh = do + dbh <- ask + asReadTransaction (dbh ^. storeEnv) $ \txn -> + isRecordPresent txn (dbh ^. blockStore) bh lookupFirstBlock = lookupBlockByHeight 0 - lookupLastFinalizedBlock = asReadTransaction $ \dbh txn -> - withCursor txn (dbh ^. finalizedBlockIndex) (getCursor CursorLast) >>= \case - Just (Right (_, bh)) -> - loadRecord txn (dbh ^. blockStore) bh - _ -> return Nothing - lookupBlockByHeight height = asReadTransaction $ \dbh txn -> - loadRecord txn (dbh ^. finalizedBlockIndex) height >>= \case - Just bh -> loadRecord txn (dbh ^. blockStore) bh - _ -> return Nothing - lookupTransaction txHash = asReadTransaction $ \dbh txn -> - loadRecord txn (dbh ^. transactionStatusStore) txHash - memberTransaction txHash = asReadTransaction $ \dbh txn -> - isRecordPresent txn (dbh ^. transactionStatusStore) txHash + lookupLastFinalizedBlock = do + dbh <- ask + asReadTransaction (dbh ^. storeEnv) $ \txn -> + withCursor txn (dbh ^. finalizedBlockIndex) (getCursor CursorLast) >>= \case + Just (Right (_, bh)) -> + loadRecord txn (dbh ^. blockStore) bh + _ -> return Nothing + lookupBlockByHeight height = do + dbh <- ask + asReadTransaction (dbh ^. storeEnv) $ \txn -> + loadRecord txn (dbh ^. finalizedBlockIndex) height >>= \case + Just bh -> loadRecord txn (dbh ^. blockStore) bh + _ -> return Nothing + lookupTransaction txHash = do + dbh <- ask + asReadTransaction (dbh ^. storeEnv) $ \txn -> + loadRecord txn (dbh ^. transactionStatusStore) txHash + memberTransaction txHash = do + dbh <- ask + asReadTransaction (dbh ^. storeEnv) $ \txn -> + isRecordPresent txn (dbh ^. transactionStatusStore) txHash writeFinalizedBlocks finBlocks finEntry = do - delBlocks <- asWriteTransaction $ writeFinalizedBlocksHelper finBlocks finEntry + dbh <- ask + delBlocks <- asWriteTransaction (dbh ^. storeEnv) $ writeFinalizedBlocksHelper finBlocks finEntry dbh logEvent LMDB LLTrace $ "Finalized blocks: " ++ show (getHash @BlockHash <$> finBlocks) @@ -626,7 +597,8 @@ instance return () writeCertifiedBlock certBlock qc = do - asWriteTransaction $ writeCertifiedBlockHelper certBlock qc + dbh <- ask + asWriteTransaction (dbh ^. storeEnv) $ writeCertifiedBlockHelper certBlock qc dbh logEvent LMDB LLTrace $ "Certified block: " ++ show (qcBlock qc) @@ -635,7 +607,8 @@ instance ++ ")" writeCertifiedBlockWithFinalization finBlocks certBlock finEntry = do - delBlocks <- asWriteTransaction $ \dbh txn -> do + dbh <- ask + delBlocks <- asWriteTransaction (dbh ^. storeEnv) $ \txn -> do delBlocks <- writeFinalizedBlocksHelper finBlocks finEntry dbh txn writeCertifiedBlockHelper certBlock (feSuccessorQuorumCertificate finEntry) dbh txn return delBlocks @@ -651,32 +624,40 @@ instance ++ show (blockHeight certBlock) ++ ")" - lookupLatestFinalizationEntry = asReadTransaction $ \dbh txn -> - loadRecord txn (dbh ^. latestFinalizationEntryStore) CSKLatestFinalizationEntry + lookupLatestFinalizationEntry = do + dbh <- ask + asReadTransaction (dbh ^. storeEnv) $ \txn -> + loadRecord txn (dbh ^. latestFinalizationEntryStore) CSKLatestFinalizationEntry - lookupCertifiedBlocks = asReadTransaction $ \dbh txn -> do - withCursor txn (dbh ^. nonFinalizedQuorumCertificateStore) $ \cursor -> do - let loop l Nothing = return l - loop _ (Just (Left e)) = throwM . DatabaseInvariantViolation $ e - loop l (Just (Right (_, qc))) = do - loadRecord txn (dbh ^. blockStore) (qcBlock qc) >>= \case - Nothing -> - throwM . DatabaseInvariantViolation $ - "Missing block for QC " - <> show (qcBlock qc) - <> " in round " - <> show (qcRound qc) - Just block -> - loop ((block, qc) : l) =<< getCursor CursorPrevious cursor - loop [] =<< getCursor CursorLast cursor - - lookupCurrentRoundStatus = asReadTransaction $ \dbh txn -> - loadRecord txn (dbh ^. roundStatusStore) CSKRoundStatus >>= \case - Just rs -> return rs - _ -> throwM (DatabaseInvariantViolation "Missing current round status") - - writeCurrentRoundStatus rs = asWriteTransaction $ \dbh txn -> - storeReplaceRecord txn (dbh ^. roundStatusStore) CSKRoundStatus rs + lookupCertifiedBlocks = do + dbh <- ask + asReadTransaction (dbh ^. storeEnv) $ \txn -> do + withCursor txn (dbh ^. nonFinalizedQuorumCertificateStore) $ \cursor -> do + let loop l Nothing = return l + loop _ (Just (Left e)) = throwM . DatabaseInvariantViolation $ e + loop l (Just (Right (_, qc))) = do + loadRecord txn (dbh ^. blockStore) (qcBlock qc) >>= \case + Nothing -> + throwM . DatabaseInvariantViolation $ + "Missing block for QC " + <> show (qcBlock qc) + <> " in round " + <> show (qcRound qc) + Just block -> + loop ((block, qc) : l) =<< getCursor CursorPrevious cursor + loop [] =<< getCursor CursorLast cursor + + lookupCurrentRoundStatus = do + dbh <- ask + asReadTransaction (dbh ^. storeEnv) $ \txn -> + loadRecord txn (dbh ^. roundStatusStore) CSKRoundStatus >>= \case + Just rs -> return rs + _ -> throwM (DatabaseInvariantViolation "Missing current round status") + + writeCurrentRoundStatus rs = do + dbh <- ask + asWriteTransaction (dbh ^. storeEnv) $ \txn -> + storeReplaceRecord txn (dbh ^. roundStatusStore) CSKRoundStatus rs -- | Initialise the low-level database by writing out the genesis block, initial round status and -- version metadata. @@ -688,16 +669,18 @@ initialiseLowLevelDB :: -- | Initial persistent round status. PersistentRoundStatus -> DiskLLDBM pv m () -initialiseLowLevelDB genesisBlock roundStatus = asWriteTransaction $ \dbh txn -> do - storeReplaceRecord txn (dbh ^. blockStore) (getHash genesisBlock) genesisBlock - storeReplaceRecord txn (dbh ^. finalizedBlockIndex) 0 (getHash genesisBlock) - storeReplaceRecord txn (dbh ^. roundStatusStore) CSKRoundStatus roundStatus - let metadata = - VersionMetadata - { vmDatabaseVersion = 1, - vmProtocolVersion = demoteProtocolVersion (protocolVersion @pv) - } - storeReplaceRecord txn (dbh ^. metadataStore) versionMetadata $ S.encode metadata +initialiseLowLevelDB genesisBlock roundStatus = do + dbh <- ask + asWriteTransaction (dbh ^. storeEnv) $ \txn -> do + storeReplaceRecord txn (dbh ^. blockStore) (getHash genesisBlock) genesisBlock + storeReplaceRecord txn (dbh ^. finalizedBlockIndex) 0 (getHash genesisBlock) + storeReplaceRecord txn (dbh ^. roundStatusStore) CSKRoundStatus roundStatus + let metadata = + VersionMetadata + { vmDatabaseVersion = 1, + vmProtocolVersion = demoteProtocolVersion (protocolVersion @pv) + } + storeReplaceRecord txn (dbh ^. metadataStore) versionMetadata $ S.encode metadata -- | A result of a roll back. data RollbackResult = forall (pv :: ProtocolVersion). @@ -765,7 +748,8 @@ rollBackBlocksUntil checkState = do -- returns the @RollbackResult@. DiskLLDBM pv m RollbackResult checkCertified lastFinRound bestState = do - mHighestQC <- asReadTransaction $ \dbh txn -> + dbh <- ask + mHighestQC <- asReadTransaction (dbh ^. storeEnv) $ \txn -> withCursor txn (dbh ^. nonFinalizedQuorumCertificateStore) @@ -799,7 +783,8 @@ rollBackBlocksUntil checkState = do -- returns the @RollbackResult@. DiskLLDBM pv m RollbackResult checkCertifiedWithQC lastFinRound bestState !count accsCreated qc = do - mBlock <- asReadTransaction $ \dbh txn -> + dbh <- ask + mBlock <- asReadTransaction (dbh ^. storeEnv) $ \txn -> loadRecord txn (dbh ^. blockStore) (qcBlock qc) case mBlock of Nothing -> @@ -819,7 +804,7 @@ rollBackBlocksUntil checkState = do -- Record the accounts created in the rolled back certified block. let accountsToDelete = mapMaybe getAccountAddressFromDeployment (blockTransactions block) -- Delete the block and the QC - asWriteTransaction $ \dbh txn -> do + asWriteTransaction (dbh ^. storeEnv) $ \txn -> do void $ deleteRecord txn @@ -854,7 +839,8 @@ rollBackBlocksUntil checkState = do checkCertifiedPreviousRound lastFinRound bestState count accsCreated currentRound | currentRound <= lastFinRound = return $ RollbackResult count bestState accsCreated | otherwise = do - mNextQC <- asReadTransaction $ \dbh txn -> + dbh <- ask + mNextQC <- asReadTransaction (dbh ^. storeEnv) $ \txn -> loadRecord txn (dbh ^. nonFinalizedQuorumCertificateStore) currentRound case mNextQC of Nothing -> @@ -863,7 +849,8 @@ rollBackBlocksUntil checkState = do checkCertifiedWithQC lastFinRound bestState count accsCreated qc -- Purge all of the certified blocks. Returns the number of blocks rolled back. purgeCertified = do - (count, hashes, accsToDelete) <- asWriteTransaction $ \dbh txn -> do + dbh <- ask + (count, hashes, accsToDelete) <- asWriteTransaction (dbh ^. storeEnv) $ \txn -> do withCursor txn (dbh ^. nonFinalizedQuorumCertificateStore) $ \cursor -> do let loop !count accsToDelete hashes Nothing = return (count, hashes, accsToDelete) loop _ _ _ (Just (Left e)) = throwM . DatabaseRecoveryFailure $ e @@ -889,7 +876,8 @@ rollBackBlocksUntil checkState = do when (blockRound lastFin == 0) $ throwM . DatabaseRecoveryFailure $ "Genesis block state could not be recovered." - (count', hashes, newLastFin) <- asWriteTransaction $ \dbh txn -> do + dbh <- ask + (count', hashes, newLastFin) <- asWriteTransaction (dbh ^. storeEnv) $ \txn -> do let loop :: -- Current count of blocks rolled back Int -> diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs index 47a76d0fbf..4b0bad4d32 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-deprecations #-} module GlobalStateTests.Accounts where From 4d44d5d09dd4a2719d294977fb271d0428e5fe76 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Thu, 2 Nov 2023 14:49:07 +0100 Subject: [PATCH 54/92] Simplify accaddr lookup from credential deployment when rolling back. --- .../src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs index 282b9a285a..05047530f2 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs @@ -760,12 +760,7 @@ rollBackBlocksUntil checkState = do Just (Right (_, qc)) -> checkCertifiedWithQC lastFinRound bestState 0 [] qc -- Get the account address of a credential deployment. getAccountAddressFromDeployment bi = case bi of - WithMetadata{wmdData = CredentialDeployment{biCred = AccountCreation{..}}} -> - case credential of - (InitialACWP InitialCredentialDeploymentInfo{..}) -> - Just $ initialCredentialAccountAddress icdiValues - (NormalACWP CredentialDeploymentInformation{..}) -> - Just $ credentialAccountAddress cdiValues + WithMetadata{wmdData = CredentialDeployment{biCred = AccountCreation{..}}} -> (Just . addressFromRegId . credId) credential _ -> Nothing -- Given the round and QC for a certified block, check that the block's state can be -- loaded, and then iterate for the previous round. From 3aa908f8f2b28bc77c9621f045145d42ca017f77 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Thu, 2 Nov 2023 15:54:26 +0100 Subject: [PATCH 55/92] Make tests compile again. --- .../GlobalState/AccountMap/DifferenceMap.hs | 4 +-- .../GlobalState/Persistent/Accounts.hs | 2 +- .../GlobalStateTests/DifferenceMap.hs | 17 ++++++----- .../GlobalStateTests/LMDBAccountMap.hs | 30 +++++++++---------- 4 files changed, 27 insertions(+), 26 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index 8363f34416..aaa093f612 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -73,5 +73,5 @@ lookup addr = check -- | Insert an account into the difference map. -- Note that it is up to the caller to ensure only the canonical 'AccountAddress' is being inserted. -insert :: AccountAddressEq -> AccountIndex -> DifferenceMap -> DifferenceMap -insert addr accIndex m = m{dmAccounts = HM.insert addr accIndex $ dmAccounts m} +insert :: AccountAddress -> AccountIndex -> DifferenceMap -> DifferenceMap +insert addr accIndex m = m{dmAccounts = HM.insert (accountAddressEmbed addr) accIndex $ dmAccounts m} diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 05744f635a..68b02d5234 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -239,7 +239,7 @@ putNewAccount !acct a0@Accounts{..} = do liftIO $ atomicWriteIORef accountDiffMapRef (Present newDiffMap) return (Just accIdx, a0{accountTable = newAccountTable}) where - addToDiffMap = DiffMap.insert (accountAddressEmbed addr) + addToDiffMap = DiffMap.insert addr -- | Construct an 'Accounts' from a list of accounts. Inserted in the order of the list. fromList :: (SupportsPersistentAccount pv m) => [PersistentAccount (AccountVersionFor pv)] -> m (Accounts pv) diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs index 49cf7c8184..fcc688eb81 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs @@ -11,6 +11,7 @@ import Data.IORef import System.Random import qualified Concordium.GlobalState.AccountMap.DifferenceMap as DiffMap +import Concordium.KonsensusV1.Types import Test.HUnit import Test.Hspec @@ -22,7 +23,7 @@ dummyPair seed = (fst $ randomAccountAddress (mkStdGen seed), AccountIndex $ fro -- | Test that an account can be inserted and looked up in the 'DiffMap.DifferenceMap'. testInsertLookupAccount :: Assertion testInsertLookupAccount = do - emptyParentMap <- mkParentPointer Nothing + emptyParentMap <- mkParentPointer Absent let diffMap = uncurry DiffMap.insert acc $ DiffMap.empty emptyParentMap DiffMap.lookup (fst acc) diffMap >>= \case Nothing -> assertFailure "account should be present in diff map" @@ -31,17 +32,17 @@ testInsertLookupAccount = do acc = dummyPair 1 -- | Create a parent pointer for the provided difference map. -mkParentPointer :: Maybe DiffMap.DifferenceMap -> IO (IORef (Maybe DiffMap.DifferenceMap)) +mkParentPointer :: Option DiffMap.DifferenceMap -> IO (IORef (Option DiffMap.DifferenceMap)) mkParentPointer diffMap = newIORef diffMap >>= return -- | Testing lookups in flat and nested difference maps. testLookups :: Assertion testLookups = do - emptyParentMap <- mkParentPointer Nothing + emptyParentMap <- mkParentPointer Absent let diffMap1 = uncurry DiffMap.insert (dummyPair 1) $ DiffMap.empty emptyParentMap - diffMap1Pointer <- mkParentPointer $ Just diffMap1 + diffMap1Pointer <- mkParentPointer $ Present diffMap1 let diffMap2 = uncurry DiffMap.insert (dummyPair 2) (DiffMap.empty diffMap1Pointer) - diffMap2Pointer <- mkParentPointer $ Just diffMap2 + diffMap2Pointer <- mkParentPointer $ Present diffMap2 let diffMap3 = uncurry DiffMap.insert (dummyPair 3) (DiffMap.empty diffMap2Pointer) checkExists (dummyPair 1) diffMap1 checkExists (dummyPair 1) diffMap2 @@ -58,11 +59,11 @@ testLookups = do -- | Test flattening a difference map i.e. return all accounts as one flat map. testFlatten :: Assertion testFlatten = do - emptyParentMap <- mkParentPointer Nothing + emptyParentMap <- mkParentPointer Absent let diffMap1 = uncurry DiffMap.insert (dummyPair 1) $ DiffMap.empty emptyParentMap - diffMap1Pointer <- mkParentPointer $ Just diffMap1 + diffMap1Pointer <- mkParentPointer $ Present diffMap1 let diffMap2 = uncurry DiffMap.insert (dummyPair 2) (DiffMap.empty diffMap1Pointer) - diffMap2Pointer <- mkParentPointer $ Just diffMap2 + diffMap2Pointer <- mkParentPointer $ Present diffMap2 let diffMap3 = uncurry DiffMap.insert (dummyPair 3) (DiffMap.empty diffMap2Pointer) assertEqual "accounts should be the same" (map dummyPair [1 .. 3]) =<< DiffMap.flatten diffMap3 diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs index 6e71fd683b..852ac19409 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs @@ -35,7 +35,7 @@ runTest :: IO a runTest dirName action = withTempDirectory "" dirName $ \path -> bracket - (LMDBAccountMap.makeDatabaseHandlers path False 1000 :: IO LMDBAccountMap.DatabaseHandlers) + (LMDBAccountMap.makeDatabaseHandlers path False :: IO LMDBAccountMap.DatabaseHandlers) LMDBAccountMap.closeDatabase (\dbh -> runSilentLogger $ runReaderT (LMDBAccountMap.runAccountMapStoreMonad action) dbh) @@ -49,7 +49,7 @@ testCheckNotInitialized = runTest "notinitialized" $ do testCheckDbInitialized :: Assertion testCheckDbInitialized = runTest "initialized" $ do -- initialize the database - void $ LMDBAccountMap.insert [dummyPair 1] + void $ LMDBAccountMap.insertAccount [dummyPair 1] isInitialized <- LMDBAccountMap.isInitialized liftIO $ assertBool "database should have been initialized" isInitialized @@ -57,10 +57,10 @@ testCheckDbInitialized = runTest "initialized" $ do testInsertAndLookupAccounts :: Assertion testInsertAndLookupAccounts = runTest "insertandlookups" $ do let accounts = dummyPair <$> [1 .. 42] - void $ LMDBAccountMap.insert accounts + void $ LMDBAccountMap.insertAccount accounts forM_ accounts $ \(accAddr, accIndex) -> do - LMDBAccountMap.lookup accAddr >>= \case + LMDBAccountMap.lookupAccountIndex accAddr >>= \case Nothing -> liftIO $ assertFailure $ "account was not present " <> show accAddr <> " account index " <> show accIndex Just foundAccountIndex -> liftIO $ assertEqual "account indices should be the same" accIndex foundAccountIndex @@ -68,8 +68,8 @@ testInsertAndLookupAccounts = runTest "insertandlookups" $ do testLookupAccountViaAlias :: Assertion testLookupAccountViaAlias = runTest "lookupviaalias" $ do -- initialize the database - void $ LMDBAccountMap.insert [acc] - LMDBAccountMap.lookup (createAlias (fst acc) 42) >>= \case + void $ LMDBAccountMap.insertAccount [acc] + LMDBAccountMap.lookupAccountIndex (createAlias (fst acc) 42) >>= \case Nothing -> liftIO $ assertFailure "account could not be looked up via alias" Just accIndex -> liftIO $ assertEqual "account indices should match" (snd acc) accIndex where @@ -79,15 +79,15 @@ testLookupAccountViaAlias = runTest "lookupviaalias" $ do testGetAllAccounts :: Assertion testGetAllAccounts = runTest "allaccounts" $ do -- initialize the database - void $ LMDBAccountMap.insert $ dummyPair <$> [0 .. 42] - void $ LMDBAccountMap.insert $ dummyPair <$> [42 .. 84] - allAccounts <- LMDBAccountMap.all + void $ LMDBAccountMap.insertAccount $ dummyPair <$> [0 .. 42] + void $ LMDBAccountMap.insertAccount $ dummyPair <$> [42 .. 84] + allAccounts <- LMDBAccountMap.getAllAccounts when (length allAccounts /= 85) $ liftIO $ assertFailure $ "unexpected number of accounts: " <> (show . length) allAccounts <> " should be " <> show (85 :: Int) forM_ (dummyPair <$> [0 .. 84]) $ \(accAddr, _) -> do - isPresent <- isJust <$> LMDBAccountMap.lookup accAddr + isPresent <- isJust <$> LMDBAccountMap.lookupAccountIndex accAddr liftIO $ assertBool "account should be present" isPresent -- | Test that accounts can be rolled back i.e. deleted from the LMDB store and that @@ -95,17 +95,17 @@ testGetAllAccounts = runTest "allaccounts" $ do testRollback :: Assertion testRollback = runTest "rollback" $ do -- initialize the database. - void $ LMDBAccountMap.insert [dummyPair 1] - void $ LMDBAccountMap.insert [dummyPair 2] + void $ LMDBAccountMap.insertAccount [dummyPair 1] + void $ LMDBAccountMap.insertAccount [dummyPair 2] -- roll back one block. - LMDBAccountMap.lookup (fst $ dummyPair 2) >>= \case + LMDBAccountMap.lookupAccountIndex (fst $ dummyPair 2) >>= \case Nothing -> liftIO $ assertFailure "account should be present" Just _ -> do void $ LMDBAccountMap.unsafeRollback [fst $ dummyPair 2] - LMDBAccountMap.lookup (fst $ dummyPair 2) >>= \case + LMDBAccountMap.lookupAccountIndex (fst $ dummyPair 2) >>= \case Just _ -> liftIO $ assertFailure "account should have been deleted" Nothing -> - LMDBAccountMap.lookup (fst $ dummyPair 1) >>= \case + LMDBAccountMap.lookupAccountIndex (fst $ dummyPair 1) >>= \case Nothing -> liftIO $ assertFailure "Accounts from first block should still remain in the lmdb store" Just accIdx -> liftIO $ assertEqual "The account index of the first account should be the same" (snd $ dummyPair 1) accIdx From b419f1f3a397ac347e9a6458dfff3b7046a33fe6 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Thu, 2 Nov 2023 20:25:29 +0100 Subject: [PATCH 56/92] Get tests back on track! --- .../Concordium/GlobalState/AccountMap/LMDB.hs | 2 +- .../Concordium/GlobalState/LMDB/Helpers.hs | 16 ++++++- .../GlobalState/Persistent/Accounts.hs | 20 ++++----- .../Concordium/GlobalState/Persistent/LMDB.hs | 31 ++------------ .../src/Concordium/ImportExport.hs | 21 ++++++---- .../KonsensusV1/TreeState/LowLevel/LMDB.hs | 42 ++----------------- .../ConcordiumTests/KonsensusV1/LMDB.hs | 2 +- .../globalstate/GlobalStateTests/Accounts.hs | 2 + .../GlobalStateTests/DifferenceMap.hs | 6 +-- 9 files changed, 48 insertions(+), 94 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index 0ddef103eb..9049ee5121 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -225,7 +225,7 @@ instance where doInsert handlers txn accounts = do forM_ accounts $ \(accAddr, accIndex) -> do - storeRecord txn (handlers ^. dbhAccountMapStore) accAddr accIndex + storeReplaceRecord txn (handlers ^. dbhAccountMapStore) accAddr accIndex lookupAccountIndex a@(AccountAddress accAddr) = do dbh <- ask diff --git a/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs b/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs index 81525b8cc9..b99133b0ea 100644 --- a/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs +++ b/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs @@ -18,6 +18,7 @@ module Concordium.GlobalState.LMDB.Helpers ( defaultStepSize, defaultEnvSize, resizeDatabaseHandlers, + resizeOnResized, -- * Database queries and updates. MDBDatabase (..), @@ -48,7 +49,7 @@ module Concordium.GlobalState.LMDB.Helpers ( unsafeByteStringFromMDB_val, withMDB_val, - -- * Helpers + -- * Helpers for reading and writing to a lmdb store. asReadTransaction, asWriteTransaction, ) @@ -57,8 +58,9 @@ where import Concordium.Logger import Control.Concurrent (runInBoundThread, yield) import Control.Concurrent.MVar -import Control.Exception +import Control.Exception (assert) import Control.Monad +import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Trans.Except import Data.ByteString @@ -700,6 +702,16 @@ resizeDatabaseHandlers env delta = do logEvent LMDB LLDebug $ "Resizing database from " ++ show oldMapSize ++ " to " ++ show newMapSize liftIO . withWriteStoreEnv env $ flip mdb_env_set_mapsize newMapSize +-- | Perform a database action and resize the LMDB map if the file size has changed. +resizeOnResized :: (MonadIO m, MonadCatch m) => StoreEnv -> m a -> m a +resizeOnResized se a = inner + where + inner = handleJust checkResized onResized a + checkResized LMDB_Error{..} = guard (e_code == Right MDB_MAP_RESIZED) + onResized _ = do + liftIO (withWriteStoreEnv se $ flip mdb_env_set_mapsize 0) + inner + -- | Run a read-only transaction. asReadTransaction :: (MonadIO m) => StoreEnv -> (MDB_txn -> IO a) -> m a asReadTransaction env t = do diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 68b02d5234..b63f29b8b2 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -155,8 +155,10 @@ type SupportsPersistentAccount pv m = instance (SupportsPersistentAccount pv m) => MHashableTo m H.Hash (Accounts pv) where getHashM Accounts{..} = getHashM accountTable --- | Get the accounts created for this block or any non-persisted parent block. +-- | Write accounts created for this block or any non-persisted parent block. -- Note that this also empties the difference map for this block. +-- +-- This MUST be called when finalizing the block state. writeAccountsCreated :: (SupportsPersistentAccount pv m) => Accounts pv -> m () writeAccountsCreated Accounts{..} = do mAccountsCreated <- liftIO $ readIORef accountDiffMapRef @@ -167,12 +169,6 @@ writeAccountsCreated Accounts{..} = do liftIO $ atomicWriteIORef accountDiffMapRef Absent LMDBAccountMap.insertAccount listOfAccountsCreated --- Note. We're writing to the LMDB accountmap as part of the 'storeUpdate' implementation below. --- This in turn means that no associated metadata is being written to the LMDB database (i.e. the block hash) of the --- persisted block. If we need this, then the write to the LMDB database could be done in 'saveBlockState' and the 'DifferenceMap' should be retained up --- to that point. --- It shouldn't be necessary with this additional metadata as when (potentially) certified blocks are being rolled back, so are the --- accounts created in those, in turn this means that the LMDB account map will have entries for all accounts present in the last finalized block. instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where storeUpdate Accounts{..} = do (pTable, accountTable') <- storeUpdate accountTable @@ -227,19 +223,17 @@ putNewAccount !acct a0@Accounts{..} = do False -> do (accIdx, newAccountTable) <- L.append acct accountTable mAccountDiffMap <- liftIO $ readIORef accountDiffMapRef - newDiffMap <- case mAccountDiffMap of + accountDiffMapRef' <- case mAccountDiffMap of Absent -> do -- create a difference map for this block state with a @Nothing@ as the parent. freshDifferenceMap <- liftIO $ newIORef (Absent :: Option DiffMap.DifferenceMap) - return $ addToDiffMap accIdx $ DiffMap.empty freshDifferenceMap + return $ DiffMap.insert addr accIdx $ DiffMap.empty freshDifferenceMap Present accDiffMap -> do -- reuse the already existing difference map for this block state. - return $ addToDiffMap accIdx accDiffMap + return $ DiffMap.insert addr accIdx accDiffMap -- we write to the difference map atomically here as there might be concurrent readers. - liftIO $ atomicWriteIORef accountDiffMapRef (Present newDiffMap) + liftIO $ atomicWriteIORef accountDiffMapRef (Present accountDiffMapRef') return (Just accIdx, a0{accountTable = newAccountTable}) - where - addToDiffMap = DiffMap.insert addr -- | Construct an 'Accounts' from a list of accounts. Inserted in the order of the list. fromList :: (SupportsPersistentAccount pv m) => [PersistentAccount (AccountVersionFor pv)] -> m (Accounts pv) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs index b36758d43a..c97bc4711a 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs @@ -66,7 +66,7 @@ import Concordium.Types.Transactions import Control.Arrow ((&&&)) import Control.Concurrent (runInBoundThread) import Control.Monad -import Control.Monad.Catch (MonadCatch, handleJust, tryJust) +import Control.Monad.Catch (tryJust) import Control.Monad.IO.Class import Control.Monad.State import qualified Data.ByteString as BS @@ -377,7 +377,7 @@ openReadOnlyDatabase treeStateDir = do mdb_env_set_maxreaders env 126 -- TODO: Consider MDB_NOLOCK mdb_env_open env treeStateDir [MDB_RDONLY] - (_metadataStore, mversion) <- resizeOnResizedInternal _storeEnv $ transaction _storeEnv True $ \txn -> do + (_metadataStore, mversion) <- resizeOnResized _storeEnv $ transaction _storeEnv True $ \txn -> do _metadataStore <- MetadataStore <$> mdb_dbi_open' txn (Just metadataStoreName) [] mversion <- loadRecord txn _metadataStore versionMetadata return (_metadataStore, mversion) @@ -391,7 +391,7 @@ openReadOnlyDatabase treeStateDir = do -- version. case promoteProtocolVersion vmProtocolVersion of SomeProtocolVersion (_ :: SProtocolVersion pv) -> - resizeOnResizedInternal _storeEnv $ transaction _storeEnv True $ \txn -> do + resizeOnResized _storeEnv $ transaction _storeEnv True $ \txn -> do _blockStore <- BlockStore <$> mdb_dbi_open' txn (Just blockStoreName) [] _finalizationRecordStore <- FinalizationRecordStore <$> mdb_dbi_open' txn (Just finalizationRecordStoreName) [] _finalizedByHeightStore <- FinalizedByHeightStore <$> mdb_dbi_open' txn (Just finalizedByHeightStoreName) [] @@ -490,33 +490,10 @@ checkDatabaseVersion db = _ -> Left $ "expected " ++ show expectedVersion ++ " but the version could not be deserialized" -- | Close down the database, freeing the file handles. +-- The use of withWriteStoreEnv ensures that there are no outstanding transactions and cursors are closed. closeDatabase :: DatabaseHandlers pv st -> IO () closeDatabase db = runInBoundThread $ withWriteStoreEnv (db ^. storeEnv) mdb_env_close --- The use of withWriteStoreEnv ensures that there are no outstanding transactions and cursors are closed. - --- | Resize the LMDB map if the file size has changed. --- This is used to allow a secondary process that is reading the database --- to handle resizes to the database that are made by the writer. --- The supplied action will be executed. If it fails with an 'MDB_MAP_RESIZED' --- error, then the map will be resized and the action retried. -resizeOnResized :: (MonadIO m, MonadState s m, HasDatabaseHandlers pv st s, MonadCatch m) => m a -> m a -resizeOnResized a = do - dbh <- use dbHandlers - resizeOnResizedInternal (dbh ^. storeEnv) a - --- | Perform a database action and resize the LMDB map if the file size has changed. The difference --- with `resizeOnResized` is that this function takes database handlers as an argument, instead of --- reading their value from `HasDatabaseHandlers`. -resizeOnResizedInternal :: (MonadIO m, MonadCatch m) => StoreEnv -> m a -> m a -resizeOnResizedInternal se a = inner - where - inner = handleJust checkResized onResized a - checkResized LMDB_Error{..} = guard (e_code == Right MDB_MAP_RESIZED) - onResized _ = do - liftIO (withWriteStoreEnv se $ flip mdb_env_set_mapsize 0) - inner - -- | 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. diff --git a/concordium-consensus/src/Concordium/ImportExport.hs b/concordium-consensus/src/Concordium/ImportExport.hs index d19ead9dde..91148ad5d9 100644 --- a/concordium-consensus/src/Concordium/ImportExport.hs +++ b/concordium-consensus/src/Concordium/ImportExport.hs @@ -44,7 +44,7 @@ import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Reader -import Control.Monad.State (MonadState, evalStateT) +import Control.Monad.State (MonadState, evalStateT, gets) import Control.Monad.Trans.Except import qualified Data.Attoparsec.Text as AP import Data.Bits @@ -69,6 +69,7 @@ import Concordium.Common.Version import Concordium.GlobalState.Block import Concordium.GlobalState.BlockPointer import Concordium.GlobalState.Finalization +import qualified Concordium.GlobalState.LMDB.Helpers as LMDBHelpers import Concordium.GlobalState.Persistent.LMDB import qualified Concordium.KonsensusV1.TreeState.LowLevel as KonsensusV1 import qualified Concordium.KonsensusV1.TreeState.LowLevel.LMDB as KonsensusV1 @@ -445,7 +446,8 @@ exportConsensusV0Blocks :: -- and the resulting 'BlockIndex' (the entries that have been added). m (Bool, BlockIndex) exportConsensusV0Blocks firstBlock outDir chunkSize genIndex startHeight blockIndex lastWrittenChunkM = do - mgenFinRec <- resizeOnResized $ readFinalizationRecord 0 + env <- _storeEnv <$> gets _dbsHandlers + mgenFinRec <- resizeOnResized env $ readFinalizationRecord 0 case mgenFinRec of Nothing -> do logEvent External LLError "No finalization record found in database for finalization index 0." @@ -471,7 +473,7 @@ exportConsensusV0Blocks firstBlock outDir chunkSize genIndex startHeight blockIn return (True, Empty) else do let getBlockAt height = - resizeOnResized (readFinalizedBlockAtHeight height) >>= \case + resizeOnResized env (readFinalizedBlockAtHeight height) >>= \case Nothing -> return Nothing Just StoredBlockWithStateHash{..} | NormalBlock normalBlock <- sbBlock sbshStoredBlock -> do let serializedBlock = runPut $ putVersionedBlock (protocolVersion @pv) normalBlock @@ -485,7 +487,7 @@ exportConsensusV0Blocks firstBlock outDir chunkSize genIndex startHeight blockIn getFinalizationAt mFinIndex = case mFinIndex of Nothing -> return Nothing Just finIndex -> - resizeOnResized (readFinalizationRecord finIndex) >>= \case + resizeOnResized env (readFinalizationRecord finIndex) >>= \case Nothing -> return Nothing Just fr -> return . Just $ runPut $ putVersionedFinalizationRecordV0 fr chunks <- @@ -545,7 +547,8 @@ exportConsensusV1Blocks :: -- and the resulting 'BlockIndex' (the entries that have been added). m (Bool, BlockIndex) exportConsensusV1Blocks outDir chunkSize genIndex startHeight blockIndex lastWrittenChunkM = do - KonsensusV1.resizeOnResized KonsensusV1.lookupFirstBlock >>= \case + env <- view KonsensusV1.storeEnv + LMDBHelpers.resizeOnResized env KonsensusV1.lookupFirstBlock >>= \case Nothing -> do logEvent External LLError "Could not read from database." return (True, Empty) @@ -557,14 +560,15 @@ exportConsensusV1Blocks outDir chunkSize genIndex startHeight blockIndex lastWri logEvent External LLError "Genesis hash does not match the recently exported block index." return (True, Empty) else do - KonsensusV1.resizeOnResized KonsensusV1.lookupLastFinalizedBlock >>= \case + LMDBHelpers.resizeOnResized env KonsensusV1.lookupLastFinalizedBlock >>= \case Nothing -> do logEvent External LLError "Cannot read last block of the database." return (True, Empty) Just sb -> do let getBlockAt :: BlockHeight -> m (Maybe (BS.ByteString, BlockHash)) getBlockAt height = - KonsensusV1.resizeOnResized + LMDBHelpers.resizeOnResized + env (KonsensusV1.lookupBlockByHeight height) >>= \case Nothing -> return Nothing @@ -577,7 +581,8 @@ exportConsensusV1Blocks outDir chunkSize genIndex startHeight blockIndex lastWri -- the finalization entry. getFinalizationAt :: BlockHash -> m (Maybe BS.ByteString) getFinalizationAt bh = - KonsensusV1.resizeOnResized + LMDBHelpers.resizeOnResized + env KonsensusV1.lookupLatestFinalizationEntry >>= \case Nothing -> return Nothing diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs index 05047530f2..9e384bd782 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs @@ -249,46 +249,10 @@ metadataStoreName = "metadata" databaseCount :: Int databaseCount = 6 --- ** Helpers - --- | Resize the LMDB map if the file size has changed. --- This is used to allow a secondary process that is reading the database --- to handle resizes to the database that are made by the writer. --- The supplied action will be executed. If it fails with an 'MDB_MAP_RESIZED' --- error, then the map will be resized and the action retried. -resizeOnResized :: (MonadIO m, MonadReader r m, HasDatabaseHandlers r pv, MonadCatch m) => m a -> m a -resizeOnResized a = do - dbh <- view databaseHandlers - resizeOnResizedInternal (dbh ^. storeEnv) a - --- | Perform a database action and resize the LMDB map if the file size has changed. The difference --- with `resizeOnResized` is that this function takes database handlers as an argument, instead of --- reading their value from `HasDatabaseHandlers`. -resizeOnResizedInternal :: (MonadIO m, MonadCatch m) => StoreEnv -> m a -> m a -resizeOnResizedInternal se a = inner - where - inner = handleJust checkResized onResized a - checkResized LMDB_Error{..} = guard (e_code == Right MDB_MAP_RESIZED) - onResized _ = do - liftIO (withWriteStoreEnv se $ flip mdb_env_set_mapsize 0) - inner - --- | Increase the database size by at least the supplied size. --- The size SHOULD be a multiple of 'dbStepSize', and MUST be a multiple of the page size. -resizeDatabaseHandlers :: (MonadIO m, MonadLogger m) => DatabaseHandlers pv -> Int -> m () -resizeDatabaseHandlers dbh delta = do - envInfo <- liftIO $ mdb_env_info (dbh ^. storeEnv . seEnv) - let oldMapSize = fromIntegral $ me_mapsize envInfo - newMapSize = oldMapSize + delta - _storeEnv = dbh ^. storeEnv - logEvent LMDB LLDebug $ "Resizing database from " ++ show oldMapSize ++ " to " ++ show newMapSize - liftIO . withWriteStoreEnv (dbh ^. storeEnv) $ flip mdb_env_set_mapsize newMapSize - -- ** Initialization -- | Initialize database handlers. --- The size will be rounded up to a multiple of 'dbStepSize'. --- (This ensures in particular that the size is a multiple of the page size, which is required by +-- (The provided @initSize@ must be a multiple of the page size, which is required by -- LMDB.) makeDatabaseHandlers :: -- | Path of database @@ -409,7 +373,7 @@ openReadOnlyDatabase treeStateDir = do mdb_env_set_maxdbs env databaseCount mdb_env_set_maxreaders env 126 mdb_env_open env treeStateDir [MDB_RDONLY] - (_metadataStore, mversion) <- resizeOnResizedInternal _storeEnv $ transaction _storeEnv True $ \txn -> do + (_metadataStore, mversion) <- resizeOnResized _storeEnv $ transaction _storeEnv True $ \txn -> do _metadataStore <- MetadataStore <$> mdb_dbi_open' txn (Just metadataStoreName) [] mversion <- loadRecord txn _metadataStore versionMetadata return (_metadataStore, mversion) @@ -423,7 +387,7 @@ openReadOnlyDatabase treeStateDir = do -- version. case promoteProtocolVersion vmProtocolVersion of SomeProtocolVersion (_ :: SProtocolVersion pv) -> - resizeOnResizedInternal _storeEnv $ transaction _storeEnv True $ \txn -> do + resizeOnResized _storeEnv $ transaction _storeEnv True $ \txn -> do _blockStore <- BlockStore <$> mdb_dbi_open' diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/LMDB.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/LMDB.hs index 940ca460ed..323c86db1c 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/LMDB.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/LMDB.hs @@ -194,7 +194,7 @@ runLLMDBTest :: IO a runLLMDBTest name action = withTempDirectory "" name $ \path -> bracket - (makeDatabaseHandlers path False 1000 :: IO (DatabaseHandlers 'P6)) + (openDatabase path :: IO (DatabaseHandlers 'P6)) closeDatabase (\dbhandlers -> runSilentLogger $ runReaderT (runDiskLLDBM action) dbhandlers) diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs index 4b0bad4d32..de5544d4a5 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs @@ -208,9 +208,11 @@ runAccountAction (UpdateAccount addr upd) (ba, pa) = do return (ba', pa') runAccountAction FlushPersistent (ba, pa) = do (_, pa') <- storeUpdate pa + void $ P.writeAccountsCreated pa' return (ba, pa') runAccountAction ArchivePersistent (ba, pa) = do ppa <- fst <$> storeUpdate pa + void $ P.writeAccountsCreated pa pa' <- fromRight (error "couldn't deserialize archived persistent") $ S.runGet load (S.runPut ppa) return (ba, pa') runAccountAction (RegIdExists rid) (ba, pa) = do diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs index fcc688eb81..85511568cd 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs @@ -9,13 +9,13 @@ import Concordium.ID.Types (randomAccountAddress) import Concordium.Types import Data.IORef import System.Random +import Test.HUnit +import Test.Hspec +import Test.QuickCheck import qualified Concordium.GlobalState.AccountMap.DifferenceMap as DiffMap import Concordium.KonsensusV1.Types -import Test.HUnit -import Test.Hspec - -- | Create a pair consisting of an account address and an account index based on the provided seed. dummyPair :: Int -> (AccountAddress, AccountIndex) dummyPair seed = (fst $ randomAccountAddress (mkStdGen seed), AccountIndex $ fromIntegral seed) From 048143d179a6214a2fa0b491ed4916b85964020f Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Thu, 2 Nov 2023 22:02:07 +0100 Subject: [PATCH 57/92] Add more tests for DifferenceMap. --- .../GlobalStateTests/DifferenceMap.hs | 49 ++++++++++++++++++- 1 file changed, 48 insertions(+), 1 deletion(-) diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs index 85511568cd..da6ce73245 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs @@ -5,8 +5,12 @@ -- * Flattening the 'DiffMap.DifferenceMap'. module GlobalStateTests.DifferenceMap where -import Concordium.ID.Types (randomAccountAddress) +import Concordium.ID.Types (accountAddressSize, randomAccountAddress) import Concordium.Types +import Control.Monad +import Control.Monad.IO.Class +import qualified Data.FixedByteString as FBS +import qualified Data.HashMap.Strict as HM import Data.IORef import System.Random import Test.HUnit @@ -67,8 +71,51 @@ testFlatten = do let diffMap3 = uncurry DiffMap.insert (dummyPair 3) (DiffMap.empty diffMap2Pointer) assertEqual "accounts should be the same" (map dummyPair [1 .. 3]) =<< DiffMap.flatten diffMap3 +-- | Make the reference map for comparing lookups. +makeReference :: [(AccountAddress, AccountIndex)] -> HM.HashMap AccountAddress AccountIndex +makeReference = HM.fromList + +-- | Generate an 'AccountAddress' +genAccountAddress :: Gen AccountAddress +genAccountAddress = AccountAddress . FBS.pack <$> vector accountAddressSize + +-- | Generate account addresses, account indices and depth of the difference map. +genInputs :: Gen ([(AccountAddress, AccountIndex)], Int) +genInputs = sized $ \n -> do + let maxAccs = min n 10000 + len <- choose (0, maxAccs) + accs <- replicateM len ((,) <$> genAccountAddress <*> (AccountIndex <$> arbitrary)) + noDifferenceMaps <- choose (0, len) + return (accs, noDifferenceMaps) + +-- | Test insertions and lookups on the difference map. +insertionsAndLookups :: Spec +insertionsAndLookups = it "insertions and lookups" $ + withMaxSuccess 10000 $ + forAll genInputs $ \(inputs, noDifferenceMaps) -> do + let reference = HM.fromList inputs + emptyRef <- mkParentPointer Absent + diffMap <- populateDiffMap inputs noDifferenceMaps $ DiffMap.empty emptyRef + checkAll reference diffMap + where + checkAll ref diffMap = forM_ (HM.toList ref) (check diffMap) + check diffMap (accAddr, accIdx) = do + DiffMap.lookup accAddr diffMap >>= \case + Nothing -> liftIO $ assertFailure "account address should be present" + Just actualAccIdx -> liftIO $ assertEqual "account index should be equal" accIdx actualAccIdx + -- return the generated difference map(s) + populateDiffMap [] _ !accum = return accum + -- dump any remaining accounts at the top most difference map. + populateDiffMap ((accAddr, accIdx) : rest) 0 !accum = populateDiffMap rest 0 $ DiffMap.insert accAddr accIdx accum + -- create a new layer and insert an account. + populateDiffMap ((accAddr, accIdx) : rest) remaining !accum = do + pRef <- mkParentPointer (Present accum) + let accumDiffMap'' = DiffMap.insert accAddr accIdx $ DiffMap.empty pRef + populateDiffMap rest (remaining - 1) accumDiffMap'' + tests :: Spec tests = describe "AccountMap.DifferenceMap" $ do it "Test insert and lookup account" testInsertLookupAccount it "test lookups" testLookups it "Test flatten" testFlatten + insertionsAndLookups From 5394edfa4a23b221fb665372839be25a3ba06604 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Fri, 3 Nov 2023 00:07:20 +0100 Subject: [PATCH 58/92] Address review comments, moving Option out in its own module. --- .../GlobalState/AccountMap/DifferenceMap.hs | 11 +++-- .../Concordium/GlobalState/AccountMap/LMDB.hs | 43 +++++++++-------- .../src/Concordium/GlobalState/BlockState.hs | 7 +++ .../GlobalState/Persistent/Accounts.hs | 27 ++++++----- .../GlobalState/Persistent/BlockState.hs | 2 +- .../src/Concordium/KonsensusV1.hs | 1 + .../src/Concordium/KonsensusV1/Consensus.hs | 1 + .../KonsensusV1/Consensus/Blocks.hs | 1 + .../KonsensusV1/Consensus/CatchUp.hs | 1 + .../KonsensusV1/Consensus/CatchUp/Types.hs | 1 + .../KonsensusV1/Consensus/Finality.hs | 1 + .../KonsensusV1/Consensus/Timeout.hs | 1 + .../KonsensusV1/TreeState/Implementation.hs | 1 + .../KonsensusV1/TreeState/LowLevel/LMDB.hs | 1 + .../KonsensusV1/TreeState/StartUp.hs | 1 + .../Concordium/KonsensusV1/TreeState/Types.hs | 1 + .../src/Concordium/KonsensusV1/Types.hs | 46 +------------------ .../src/Concordium/MultiVersion.hs | 6 +-- .../src/Concordium/Queries.hs | 15 +++--- .../ConcordiumTests/KonsensusV1/CatchUp.hs | 1 + .../ConcordiumTests/KonsensusV1/Common.hs | 1 + .../ConcordiumTests/KonsensusV1/Consensus.hs | 1 + .../KonsensusV1/Consensus/Blocks.hs | 1 + .../ConcordiumTests/KonsensusV1/LMDB.hs | 1 + .../ConcordiumTests/KonsensusV1/Timeout.hs | 1 + .../KonsensusV1/TransactionProcessingTest.hs | 1 + .../KonsensusV1/TreeStateTest.hs | 1 + .../ConcordiumTests/KonsensusV1/Types.hs | 1 + .../GlobalStateTests/DifferenceMap.hs | 2 +- .../GlobalStateTests/LMDBAccountMap.hs | 14 +++--- 30 files changed, 92 insertions(+), 101 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index aaa093f612..362a217b0d 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -1,9 +1,8 @@ {-# LANGUAGE BangPatterns #-} -- | The 'DifferenceMap' stores accounts that have been created in a non-finalized block. --- When a block is being finalized (or certified for consensus version 1) --- then the associated 'DifferenceMap' must be written --- to disk via 'Concordium.GlobalState.AccountMap.LMDB.insert'. +-- When a block is finalized then the associated 'DifferenceMap' must be written +-- to disk via 'Concordium.GlobalState.AccountMap.LMDB.insertAccounts'. module Concordium.GlobalState.AccountMap.DifferenceMap where import Control.Monad.IO.Class @@ -12,7 +11,7 @@ import qualified Data.HashMap.Strict as HM import Data.IORef import Prelude hiding (lookup) -import Concordium.KonsensusV1.Types (Option (..)) +import Concordium.Option (Option (..)) import Concordium.Types -- | A difference map that indicates newly added accounts for @@ -23,7 +22,7 @@ data DifferenceMap = DifferenceMap dmAccounts :: !(HM.HashMap AccountAddressEq AccountIndex), -- | Parent map of non-finalized blocks. -- In other words, if the parent block is finalized, - -- then the parent map is @Nothing@ as the LMDB account map + -- then the parent map is @Absent@ as the LMDB account map -- should be consulted instead. -- This is an 'IORef' since the parent map may belong -- to multiple blocks if they have not yet been persisted. @@ -59,6 +58,8 @@ empty mParentDifferenceMap = -- difference maps using the account address equivalence class. -- Returns @Just AccountIndex@ if the account is present and -- otherwise @Nothing@. +-- Note that this implementation uses the 'AccountAddressEq' equivalence +-- class for looking up an 'AccountIndex'. lookup :: (MonadIO m) => AccountAddress -> DifferenceMap -> m (Maybe AccountIndex) lookup addr = check where diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index 9049ee5121..9bb262bf39 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -10,12 +10,12 @@ {-# LANGUAGE UndecidableInstances #-} -- | This module exposes an account map backed by a LMDB database. --- The ‘AccountMap’ is a simple key/value store where the keys consists of the +-- The account map is a simple key/value store where the keys consists of the -- canonical 'AccountAddress' and the values are the assoicated 'AccountIndex'. -- --- The LMDB account map only stores accounts that are persisted (created in a certified or finalized block). --- Non certified/finalized accounts are being kept in a 'DifferenceMap' which --- is being written to this LMDB account map when a block is being persisted. +-- The LMDB account map only stores accounts that are finalized. +-- Non finalized accounts are being kept in a 'DifferenceMap' which +-- is written to this LMDB account map when a block is persisted. -- -- As opposed to the account table of the block state this database does not -- include historical data i.e., the state of this database is from the perspective @@ -24,7 +24,7 @@ -- should use the account table. -- -- The account map is integrated with the block state “on-the-fly” meaning that --- whenver the node starts up and the ‘AccountMap’ is not populated, then it will be +-- whenever the node starts up and the account map is not populated, then it will be -- initialized on startup via the existing ‘PersistentAccountMap’. -- -- Invariants: @@ -72,15 +72,24 @@ instance Exception DatabaseInvariantViolation where -- An implementation should ensure atomicity of operations. -- -- Invariants: --- * All accounts in the store are in persisted blocks (finalized or certified). +-- * All accounts in the store are finalized. +-- * The store should only retain canoncial account addresses. class (Monad m) => MonadAccountMapStore m where -- | Inserts the accounts to the underlying store. - insertAccount :: [(AccountAddress, AccountIndex)] -> m () + -- Only canonical addresses should be added. + insertAccounts :: [(AccountAddress, AccountIndex)] -> m () - -- | Looks up the ‘AccountIndex’ for the provided ‘AccountAddress’ by using the - -- equivalence class 'AccountAddressEq'. + -- | Looks up the ‘AccountIndex’ for the provided ‘AccountAddress’. -- Returns @Just AccountIndex@ if the account is present in the ‘AccountMap’ -- and returns @Nothing@ if the account was not present. + -- + -- Note that an implementor must adhere to the following: + -- * For protocol versions that does not support account aliases, + -- then the provided @AccountAddress@ must match exactly the one + -- present in the store. + -- * For protocol versions that does support account aliases, + -- then it's sufficient if the first 29 bytes of the accont address + -- matches the 'AccountAddress' recorded. lookupAccountIndex :: AccountAddress -> m (Maybe AccountIndex) -- | Return all the canonical addresses and their associated account indices of accounts present @@ -91,11 +100,11 @@ class (Monad m) => MonadAccountMapStore m where isInitialized :: m Bool instance (Monad (t m), MonadTrans t, MonadAccountMapStore m) => MonadAccountMapStore (MGSTrans t m) where - insertAccount = lift . insertAccount + insertAccounts = lift . insertAccounts lookupAccountIndex = lift . lookupAccountIndex getAllAccounts = lift getAllAccounts isInitialized = lift isInitialized - {-# INLINE insertAccount #-} + {-# INLINE insertAccounts #-} {-# INLINE lookupAccountIndex #-} {-# INLINE getAllAccounts #-} {-# INLINE isInitialized #-} @@ -105,11 +114,11 @@ deriving via (MGSTrans (ExceptT e) m) instance (MonadAccountMapStore m) => Monad deriving via (MGSTrans (WriterT w) m) instance (Monoid w, MonadAccountMapStore m) => MonadAccountMapStore (WriterT w m) instance (MonadAccountMapStore m) => MonadAccountMapStore (PutT m) where - insertAccount = lift . insertAccount + insertAccounts = lift . insertAccounts lookupAccountIndex = lift . lookupAccountIndex getAllAccounts = lift getAllAccounts isInitialized = lift isInitialized - {-# INLINE insertAccount #-} + {-# INLINE insertAccounts #-} {-# INLINE lookupAccountIndex #-} {-# INLINE getAllAccounts #-} {-# INLINE isInitialized #-} @@ -219,13 +228,11 @@ instance ) => MonadAccountMapStore (AccountMapStoreMonad m) where - insertAccount differenceMap = do + insertAccounts accounts = do dbh <- ask - asWriteTransaction (dbh ^. dbhStoreEnv) $ \txn -> doInsert dbh txn differenceMap - where - doInsert handlers txn accounts = do + asWriteTransaction (dbh ^. dbhStoreEnv) $ \txn -> do forM_ accounts $ \(accAddr, accIndex) -> do - storeReplaceRecord txn (handlers ^. dbhAccountMapStore) accAddr accIndex + storeReplaceRecord txn (dbh ^. dbhAccountMapStore) accAddr accIndex lookupAccountIndex a@(AccountAddress accAddr) = do dbh <- ask diff --git a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs index ee8fdc3452..64cc0e8d41 100644 --- a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs @@ -1358,6 +1358,13 @@ class (BlockStateOperations m, FixedSizeSerialization (BlockStateRef m)) => Bloc -- changes to it must not affect 'BlockState', but an efficient -- implementation should expect that only a small subset of the state will -- change, and thus a variant of copy-on-write should be used. + -- + -- The caller of this function should adhere to the following precondition: + -- * This function must only be called on the best block or a block that is already + -- retained in memory. + -- This function loads the provided blockstate into memory (which is fine for the + -- best block, as it is already in memory) but it should be avoided for blocks + -- that are not already in memory. thawBlockState :: BlockState m -> m (UpdatableBlockState m) -- | Freeze a mutable block state instance. The mutable state instance will diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index b63f29b8b2..a487922f07 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -77,7 +77,7 @@ import qualified Concordium.GlobalState.Persistent.LFMBTree as L import qualified Concordium.GlobalState.Persistent.Trie as Trie import Concordium.ID.Parameters import qualified Concordium.ID.Types as ID -import Concordium.KonsensusV1.Types (Option (..)) +import Concordium.Option (Option (..)) import Concordium.Types import Concordium.Types.HashableTo import Concordium.Utils.Serialization.Put @@ -87,7 +87,6 @@ import Data.IORef import qualified Data.Map.Strict as Map import Data.Maybe import Data.Serialize -import Data.Word -- | Representation of the set of accounts on the chain. -- Each account has an 'AccountIndex' which is the order @@ -167,10 +166,16 @@ writeAccountsCreated Accounts{..} = do Present accountsCreated -> do listOfAccountsCreated <- liftIO $ DiffMap.flatten accountsCreated liftIO $ atomicWriteIORef accountDiffMapRef Absent - LMDBAccountMap.insertAccount listOfAccountsCreated + LMDBAccountMap.insertAccounts listOfAccountsCreated instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where storeUpdate Accounts{..} = do + -- put an empty 'OldMap.PersistentAccountMap'. + -- In earlier versions of the node the above mentioned account map was used, + -- but this is now superseded by the 'LMDBAccountMap.MonadAccountMapStore'. + -- We put this empty map here to remain backwards compatible. + -- This should be revised as part of a future protocol update when the database layout can be changed. + (emptyOldMap, _) <- storeUpdate $ OldMap.empty @pv @BufferedFix (pTable, accountTable') <- storeUpdate accountTable (pRegIdHistory, regIdHistory') <- storeUpdate accountRegIdHistory let newAccounts = @@ -179,13 +184,7 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where accountRegIdHistory = regIdHistory', .. } - - -- put an empty 'OldMap.PersistentAccountMap'. - -- In earlier versions of the node the above mentioned account map was used, - -- but this is now superseded by the 'LMDBAccountMap.MonadAccountMapStore'. - -- We put this (0 :: Int) here to remain backwards compatible as this simply indicates an empty map. - -- This should be revised as part of a future protocol update when the database layout can be changed. - return (put (0 :: Word64) >> pTable >> pRegIdHistory, newAccounts) + return (emptyOldMap >> pTable >> pRegIdHistory, newAccounts) load = do -- load the persistent account map and throw it away. We always put an empty one in, -- but that has not always been the case. But the 'OldMap.PersistentAccountMap' is now superseded by @@ -257,9 +256,9 @@ getAccountByCredId cid accs@Accounts{..} = Nothing -> return Nothing Just ai -> fmap (ai,) <$> indexedAccount ai accs --- | Get the account at a given index (if any). --- Note that this is looking up via the account alias mechanism introduced in protocol version 3 for all protocol versions. --- This is fine as there are no clashes and this approach simplifies the implementation. +-- | Get the 'AccountIndex' for the provided 'AccountAddress' (if any). +-- First try lookup in the in-memory difference map associated with the the provided 'Accounts pv', +-- if no account could be looked up, then we fall back to the lmdb backed account map. getAccountIndex :: (SupportsPersistentAccount pv m) => AccountAddress -> Accounts pv -> m (Maybe AccountIndex) getAccountIndex addr Accounts{..} = do mAccountDiffMap <- liftIO $ readIORef accountDiffMapRef @@ -412,7 +411,7 @@ allAccountsViaTable accts = do tryPopulateLMDBStore :: (SupportsPersistentAccount pv m) => Accounts pv -> m () tryPopulateLMDBStore accts = do isInitialized <- LMDBAccountMap.isInitialized - unless isInitialized (void $ LMDBAccountMap.insertAccount =<< allAccountsViaTable accts) + unless isInitialized (void $ LMDBAccountMap.insertAccounts =<< allAccountsViaTable accts) -- | See documentation of @migratePersistentBlockState@. migrateAccounts :: diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 12a7458064..25068601db 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -69,9 +69,9 @@ import Concordium.GlobalState.Types import qualified Concordium.GlobalState.Wasm as GSWasm import qualified Concordium.ID.Parameters as ID import qualified Concordium.ID.Types as ID -import Concordium.KonsensusV1.Types (Option (..)) import Concordium.Kontrol.Bakers import Concordium.Logger (MonadLogger) +import Concordium.Option (Option (..)) import Concordium.TimeMonad (TimeMonad) import Concordium.Types import Concordium.Types.Accounts (AccountBaker (..)) diff --git a/concordium-consensus/src/Concordium/KonsensusV1.hs b/concordium-consensus/src/Concordium/KonsensusV1.hs index 6e4c0d0efd..a3d2359ee2 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1.hs @@ -27,6 +27,7 @@ import qualified Concordium.KonsensusV1.TreeState.LowLevel as LowLevel import Concordium.KonsensusV1.TreeState.Types (bpState) import Concordium.KonsensusV1.Types import Concordium.Logger +import Concordium.Option import Concordium.Skov.Monad (UpdateResult (..), transactionVerificationResultToUpdateResult) import Concordium.TimeMonad import Concordium.TimerMonad diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Consensus.hs b/concordium-consensus/src/Concordium/KonsensusV1/Consensus.hs index 5c5a9a00c7..ce4f0973d9 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Consensus.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Consensus.hs @@ -34,6 +34,7 @@ import qualified Concordium.KonsensusV1.TreeState.LowLevel as LowLevel import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types import Concordium.Logger +import Concordium.Option import Concordium.Types.SeedState (currentLeadershipElectionNonce, triggerBlockTime) import Concordium.Types.UpdateQueues import Concordium.Types.Updates diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Blocks.hs b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Blocks.hs index 4485d80cc7..aa191beef7 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Blocks.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Blocks.hs @@ -49,6 +49,7 @@ import Concordium.KonsensusV1.TreeState.Implementation import qualified Concordium.KonsensusV1.TreeState.LowLevel as LowLevel import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types +import Concordium.Option import Concordium.Scheduler (FilteredTransactions (..)) import Concordium.TimerMonad import Concordium.Types.BakerIdentity diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/CatchUp.hs b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/CatchUp.hs index 65463f0a30..fff447fb07 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/CatchUp.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/CatchUp.hs @@ -62,6 +62,7 @@ import Concordium.KonsensusV1.TreeState.Implementation import qualified Concordium.KonsensusV1.TreeState.LowLevel as LowLevel import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types +import Concordium.Option import Concordium.TimeMonad import Concordium.TimerMonad import Concordium.Types.Parameters diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/CatchUp/Types.hs b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/CatchUp/Types.hs index 5a347c1e64..b30f5e4cbb 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/CatchUp/Types.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/CatchUp/Types.hs @@ -5,6 +5,7 @@ import qualified Data.Map.Strict as Map import Data.Serialize hiding (getListOf, putListOf) import Concordium.KonsensusV1.Types +import Concordium.Option import Concordium.Types import Concordium.Utils.Serialization import Control.Monad diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs index b80c07c056..ae7a579a7a 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs @@ -32,6 +32,7 @@ import Concordium.KonsensusV1.TreeState.Implementation import qualified Concordium.KonsensusV1.TreeState.LowLevel as LowLevel import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types +import Concordium.Option -- | Ensure that the given certified block is written to the low-level database. -- Check if the certified block causes its parent to become finalized. diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Timeout.hs b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Timeout.hs index 1b519d19f8..137683e8ad 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Timeout.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Timeout.hs @@ -35,6 +35,7 @@ import Concordium.KonsensusV1.TreeState.Implementation import qualified Concordium.KonsensusV1.TreeState.LowLevel as LowLevel import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types +import Concordium.Option import Concordium.TimerMonad -- | Reasons that a 'TimeoutMessage' can be rejected. diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Implementation.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Implementation.hs index 77f682f699..c922e85e0f 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Implementation.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Implementation.hs @@ -40,6 +40,7 @@ import qualified Data.Map.Strict as Map import qualified Data.Sequence as Seq import qualified Concordium.Genesis.Data.BaseV1 as Base +import Concordium.Option import Concordium.Types import Concordium.Types.Execution import Concordium.Types.HashableTo diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs index 9e384bd782..7f81c84735 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs @@ -36,6 +36,7 @@ import Concordium.Common.Version import qualified Concordium.Crypto.SHA256 as Hash import Concordium.ID.Types import Concordium.Logger +import Concordium.Option import Concordium.Types import Concordium.Types.HashableTo import Concordium.Types.Transactions diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs index 10a24208ee..6ef95e0412 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs @@ -35,6 +35,7 @@ import qualified Concordium.KonsensusV1.TreeState.LowLevel as LowLevel import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types import Concordium.Logger +import Concordium.Option import Concordium.TimeMonad import Concordium.TransactionVerification as TVer diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Types.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Types.hs index 0a2e6ef693..ba74556792 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Types.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Types.hs @@ -26,6 +26,7 @@ import Concordium.GlobalState.BakerInfo import qualified Concordium.GlobalState.Persistent.BlockState as PBS import Concordium.GlobalState.TransactionTable import Concordium.KonsensusV1.Types +import Concordium.Option (Option (..), ofOption) -- | Status information for a finalized transaction. data FinalizedTransactionStatus = FinalizedTransactionStatus diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Types.hs b/concordium-consensus/src/Concordium/KonsensusV1/Types.hs index dd4bb7806d..bfed113154 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Types.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Types.hs @@ -28,6 +28,7 @@ import qualified Concordium.Crypto.VRF as VRF import Concordium.Genesis.Data (Regenesis, firstGenesisBlockHash, regenesisBlockHash, regenesisCoreParametersV1) import Concordium.Genesis.Data.BaseV1 import qualified Concordium.GlobalState.Basic.BlockState.LFMBTree as LFMBT +import Concordium.Option import Concordium.Types import Concordium.Types.HashableTo import Concordium.Types.Parameters (IsConsensusV1) @@ -35,51 +36,6 @@ import Concordium.Types.Transactions import Concordium.Utils.BinarySearch import Concordium.Utils.Serialization --- | A strict version of 'Maybe'. -data Option a - = Absent - | Present !a - deriving (Eq, Ord, Show, Functor, Foldable, Traversable) - --- | Putter for an @Option a@. -putOptionOf :: Putter a -> Putter (Option a) -putOptionOf _ Absent = putWord8 0 -putOptionOf pa (Present a) = putWord8 1 >> pa a - --- | Getter for an @Option a@. -getOptionOf :: Get a -> Get (Option a) -getOptionOf ma = do - getWord8 >>= \case - 0 -> return Absent - 1 -> Present <$> ma - _ -> fail "invalid tag for Option" - --- | 'Serialize' instance for an @Option a@. -instance (Serialize a) => Serialize (Option a) where - put = putOptionOf put - get = getOptionOf get - --- | Returns 'True' if and only if the value is 'Present'. -isPresent :: Option a -> Bool -isPresent Absent = False -isPresent (Present _) = True - --- | Returns 'True' if and only if the value is 'Absent'. -isAbsent :: Option a -> Bool -isAbsent Absent = True -isAbsent (Present _) = False - --- | Get the contents of an 'Option' or the supplied default value if it is 'Absent'. -fromOption :: a -> Option a -> a -fromOption def Absent = def -fromOption _ (Present v) = v - --- | Deconstruct an 'Option', returning the first argument if it is 'Absent', and otherwise --- applying the second argument to the value if it is 'Present'. (Analogous to 'maybe'.) -ofOption :: b -> (a -> b) -> Option a -> b -ofOption ab _ Absent = ab -ofOption _ pr (Present v) = pr v - -- | The message that is signed by a finalizer to certify a block. data QuorumSignatureMessage = QuorumSignatureMessage { -- | Hash of the genesis block. diff --git a/concordium-consensus/src/Concordium/MultiVersion.hs b/concordium-consensus/src/Concordium/MultiVersion.hs index fe15d56f5a..345935aafc 100644 --- a/concordium-consensus/src/Concordium/MultiVersion.hs +++ b/concordium-consensus/src/Concordium/MultiVersion.hs @@ -65,8 +65,8 @@ import qualified Concordium.KonsensusV1.SkovMonad as SkovV1 import qualified Concordium.KonsensusV1.Transactions as SkovV1 import qualified Concordium.KonsensusV1.TreeState.LowLevel.LMDB as LowLevelDB import qualified Concordium.KonsensusV1.TreeState.Types as SkovV1 -import Concordium.KonsensusV1.Types (Option (..)) import qualified Concordium.KonsensusV1.Types as KonsensusV1 +import Concordium.Option import qualified Concordium.ProtocolUpdate.V0 as ProtocolUpdateV0 import qualified Concordium.ProtocolUpdate.V1 as ProtocolUpdateV1 import qualified Concordium.Skov as Skov @@ -291,7 +291,7 @@ skovV1Handlers gi genHeight = SkovV1.HandlerContext{..} let isHomeBaked = case nodeBakerIdMaybe of Nothing -> False Just nodeBakerId -> - KonsensusV1.Present nodeBakerId + Present nodeBakerId == (KonsensusV1.blockBaker <$> KonsensusV1.blockBakedData block) liftIO (notifyCallback (getHash block) height isHomeBaked) @@ -306,7 +306,7 @@ skovV1Handlers gi genHeight = SkovV1.HandlerContext{..} let isHomeBaked = case nodeBakerIdMaybe of Nothing -> False Just nodeBakerId -> - KonsensusV1.Present nodeBakerId + Present nodeBakerId == (KonsensusV1.blockBaker <$> KonsensusV1.blockBakedData bp) liftIO (notifyCallback (getHash bp) height isHomeBaked) checkForProtocolUpdateV1 diff --git a/concordium-consensus/src/Concordium/Queries.hs b/concordium-consensus/src/Concordium/Queries.hs index 2dec7bd473..3d6e9d6776 100644 --- a/concordium-consensus/src/Concordium/Queries.hs +++ b/concordium-consensus/src/Concordium/Queries.hs @@ -71,6 +71,7 @@ import qualified Concordium.KonsensusV1.Types as SkovV1 import Concordium.Kontrol import Concordium.Kontrol.BestBlock import Concordium.MultiVersion +import Concordium.Option import Concordium.Skov as Skov ( SkovQueryMonad (getBlocksAtHeight), evalSkovT, @@ -720,7 +721,7 @@ getBlockInfo = let biBlockArriveTime = SkovV1.blockArriveTime bp let biBlockSlot = Nothing -- no slots in consensus version 1 let biBlockSlotTime = timestampToUTCTime $ SkovV1.blockTimestamp bp - let biBlockBaker = SkovV1.ofOption Nothing (Just . SkovV1.blockBaker) $ SkovV1.blockBakedData bp + let biBlockBaker = ofOption Nothing (Just . SkovV1.blockBaker) $ SkovV1.blockBakedData bp let biTransactionCount = SkovV1.blockTransactionCount bp let biTransactionEnergyCost = SkovV1.blockEnergyCost bp let biTransactionsSize = fromIntegral $ SkovV1.blockTransactionsSize bp @@ -1640,9 +1641,9 @@ getBlockCertificates = liftSkovQueryBHI (\_ -> return $ Left BlockCertificatesIn qcAggregateSignature = QueriesKonsensusV1.QuorumCertificateSignature . (SkovV1.theQuorumSignature . SkovV1.qcAggregateSignature) $ qc, qcSignatories = finalizerSetToBakerIds committee (SkovV1.qcSignatories qc) } - mkTimeoutCertificateOut :: SkovV1.FinalizationCommittee -> SkovV1.Option SkovV1.TimeoutCertificate -> Maybe QueriesKonsensusV1.TimeoutCertificate - mkTimeoutCertificateOut _ SkovV1.Absent = Nothing - mkTimeoutCertificateOut committee (SkovV1.Present tc) = + mkTimeoutCertificateOut :: SkovV1.FinalizationCommittee -> Option SkovV1.TimeoutCertificate -> Maybe QueriesKonsensusV1.TimeoutCertificate + mkTimeoutCertificateOut _ Absent = Nothing + mkTimeoutCertificateOut committee (Present tc) = Just $ QueriesKonsensusV1.TimeoutCertificate { tcRound = SkovV1.tcRound tc, @@ -1651,9 +1652,9 @@ getBlockCertificates = liftSkovQueryBHI (\_ -> return $ Left BlockCertificatesIn tcFinalizerQCRoundsSecondEpoch = finalizerRound committee $ SkovV1.tcFinalizerQCRoundsSecondEpoch tc, tcAggregateSignature = QueriesKonsensusV1.TimeoutCertificateSignature . (SkovV1.theTimeoutSignature . SkovV1.tcAggregateSignature) $ tc } - mkEpochFinalizationEntryOut :: SkovV1.FinalizationCommittee -> SkovV1.Option SkovV1.FinalizationEntry -> Maybe QueriesKonsensusV1.EpochFinalizationEntry - mkEpochFinalizationEntryOut _ SkovV1.Absent = Nothing - mkEpochFinalizationEntryOut committee (SkovV1.Present SkovV1.FinalizationEntry{..}) = + mkEpochFinalizationEntryOut :: SkovV1.FinalizationCommittee -> Option SkovV1.FinalizationEntry -> Maybe QueriesKonsensusV1.EpochFinalizationEntry + mkEpochFinalizationEntryOut _ Absent = Nothing + mkEpochFinalizationEntryOut committee (Present SkovV1.FinalizationEntry{..}) = Just $ QueriesKonsensusV1.EpochFinalizationEntry { efeFinalizedQC = mkQuorumCertificateOut committee feFinalizedQuorumCertificate, diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/CatchUp.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/CatchUp.hs index 0472be2014..b70b832391 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/CatchUp.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/CatchUp.hs @@ -28,6 +28,7 @@ import Concordium.KonsensusV1.TestMonad import Concordium.KonsensusV1.TreeState.Implementation import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types +import Concordium.Option import ConcordiumTests.KonsensusV1.Consensus.Blocks import qualified ConcordiumTests.KonsensusV1.Consensus.Blocks as TestBlocks diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Common.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Common.hs index b1772abb1e..5e804b275a 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Common.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Common.hs @@ -12,6 +12,7 @@ import qualified Concordium.Crypto.DummyData as Dummy import qualified Concordium.Crypto.SHA256 as Hash import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types +import Concordium.Option import Concordium.Types import Concordium.Types.Transactions import ConcordiumTests.KonsensusV1.TreeStateTest hiding (tests) diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Consensus.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Consensus.hs index d9a713d02c..42e83cd9d3 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Consensus.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Consensus.hs @@ -23,6 +23,7 @@ import Concordium.KonsensusV1.TestMonad import Concordium.KonsensusV1.TreeState.Implementation import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types +import Concordium.Option import Concordium.Startup import Concordium.Types import qualified Concordium.Types.DummyData as Dummy diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Consensus/Blocks.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Consensus/Blocks.hs index 245d3464c1..5f5eb06ad0 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Consensus/Blocks.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Consensus/Blocks.hs @@ -44,6 +44,7 @@ import Concordium.KonsensusV1.TestMonad import Concordium.KonsensusV1.TreeState.Implementation import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types +import Concordium.Option import Concordium.Startup import Concordium.TimerMonad diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/LMDB.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/LMDB.hs index 323c86db1c..4355a76c86 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/LMDB.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/LMDB.hs @@ -29,6 +29,7 @@ import Concordium.KonsensusV1.TreeState.LowLevel.LMDB import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types import Concordium.Logger +import Concordium.Option import Concordium.Types import Concordium.Types.HashableTo import Concordium.Types.Transactions diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Timeout.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Timeout.hs index efb4723ad1..4cd0144a48 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Timeout.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Timeout.hs @@ -36,6 +36,7 @@ import Concordium.KonsensusV1.TreeState.Implementation import Concordium.KonsensusV1.TreeState.LowLevel.Memory import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types +import Concordium.Option import Concordium.Startup import Concordium.Types import Concordium.Types.BakerIdentity diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs index eec7a1e120..973d405ec3 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs @@ -53,6 +53,7 @@ import Concordium.GlobalState.Persistent.Genesis (genesisState) import Concordium.GlobalState.TransactionTable import Concordium.ID.Types (randomAccountAddress) import Concordium.Logger +import Concordium.Option import Concordium.Scheduler.DummyData import Concordium.TimeMonad import qualified Concordium.TransactionVerification as TVer diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TreeStateTest.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TreeStateTest.hs index 61a86e0660..6a89140557 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TreeStateTest.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TreeStateTest.hs @@ -102,6 +102,7 @@ import qualified Concordium.KonsensusV1.TreeState.LowLevel as LowLevel import Concordium.KonsensusV1.TreeState.LowLevel.Memory import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types +import Concordium.Option import qualified Concordium.TransactionVerification as TVer import Concordium.Types.Updates diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Types.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Types.hs index 0e6d6beb8e..b72b0f7830 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Types.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Types.hs @@ -25,6 +25,7 @@ import qualified Data.FixedByteString as FBS import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types +import Concordium.Option -- | Generate a 'FinalizerSet'. The size parameter determines the size of the committee that -- the finalizers are (nominally) sampled from. diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs index da6ce73245..b4c9be83b9 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs @@ -18,7 +18,7 @@ import Test.Hspec import Test.QuickCheck import qualified Concordium.GlobalState.AccountMap.DifferenceMap as DiffMap -import Concordium.KonsensusV1.Types +import Concordium.Option -- | Create a pair consisting of an account address and an account index based on the provided seed. dummyPair :: Int -> (AccountAddress, AccountIndex) diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs index 852ac19409..f76f78fcc1 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs @@ -49,7 +49,7 @@ testCheckNotInitialized = runTest "notinitialized" $ do testCheckDbInitialized :: Assertion testCheckDbInitialized = runTest "initialized" $ do -- initialize the database - void $ LMDBAccountMap.insertAccount [dummyPair 1] + void $ LMDBAccountMap.insertAccounts [dummyPair 1] isInitialized <- LMDBAccountMap.isInitialized liftIO $ assertBool "database should have been initialized" isInitialized @@ -57,7 +57,7 @@ testCheckDbInitialized = runTest "initialized" $ do testInsertAndLookupAccounts :: Assertion testInsertAndLookupAccounts = runTest "insertandlookups" $ do let accounts = dummyPair <$> [1 .. 42] - void $ LMDBAccountMap.insertAccount accounts + void $ LMDBAccountMap.insertAccounts accounts forM_ accounts $ \(accAddr, accIndex) -> do LMDBAccountMap.lookupAccountIndex accAddr >>= \case @@ -68,7 +68,7 @@ testInsertAndLookupAccounts = runTest "insertandlookups" $ do testLookupAccountViaAlias :: Assertion testLookupAccountViaAlias = runTest "lookupviaalias" $ do -- initialize the database - void $ LMDBAccountMap.insertAccount [acc] + void $ LMDBAccountMap.insertAccounts [acc] LMDBAccountMap.lookupAccountIndex (createAlias (fst acc) 42) >>= \case Nothing -> liftIO $ assertFailure "account could not be looked up via alias" Just accIndex -> liftIO $ assertEqual "account indices should match" (snd acc) accIndex @@ -79,8 +79,8 @@ testLookupAccountViaAlias = runTest "lookupviaalias" $ do testGetAllAccounts :: Assertion testGetAllAccounts = runTest "allaccounts" $ do -- initialize the database - void $ LMDBAccountMap.insertAccount $ dummyPair <$> [0 .. 42] - void $ LMDBAccountMap.insertAccount $ dummyPair <$> [42 .. 84] + void $ LMDBAccountMap.insertAccounts $ dummyPair <$> [0 .. 42] + void $ LMDBAccountMap.insertAccounts $ dummyPair <$> [42 .. 84] allAccounts <- LMDBAccountMap.getAllAccounts when (length allAccounts /= 85) $ liftIO $ @@ -95,8 +95,8 @@ testGetAllAccounts = runTest "allaccounts" $ do testRollback :: Assertion testRollback = runTest "rollback" $ do -- initialize the database. - void $ LMDBAccountMap.insertAccount [dummyPair 1] - void $ LMDBAccountMap.insertAccount [dummyPair 2] + void $ LMDBAccountMap.insertAccounts [dummyPair 1] + void $ LMDBAccountMap.insertAccounts [dummyPair 2] -- roll back one block. LMDBAccountMap.lookupAccountIndex (fst $ dummyPair 2) >>= \case Nothing -> liftIO $ assertFailure "account should be present" From b35327a7229738353c8db48804af1f32603ae302 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Fri, 3 Nov 2023 10:42:19 +0100 Subject: [PATCH 59/92] Add missing Concordium.Types.Option module --- .../GlobalState/AccountMap/DifferenceMap.hs | 2 +- .../GlobalState/Persistent/Accounts.hs | 2 +- .../GlobalState/Persistent/BlockState.hs | 2 +- .../src/Concordium/KonsensusV1.hs | 2 +- .../src/Concordium/KonsensusV1/Consensus.hs | 2 +- .../KonsensusV1/Consensus/Blocks.hs | 2 +- .../KonsensusV1/Consensus/CatchUp.hs | 2 +- .../KonsensusV1/Consensus/CatchUp/Types.hs | 2 +- .../KonsensusV1/Consensus/Finality.hs | 2 +- .../KonsensusV1/Consensus/Timeout.hs | 2 +- .../KonsensusV1/TreeState/Implementation.hs | 2 +- .../KonsensusV1/TreeState/LowLevel/LMDB.hs | 2 +- .../KonsensusV1/TreeState/StartUp.hs | 2 +- .../Concordium/KonsensusV1/TreeState/Types.hs | 2 +- .../src/Concordium/KonsensusV1/Types.hs | 3 +- .../src/Concordium/MultiVersion.hs | 2 +- .../src/Concordium/Queries.hs | 2 +- .../src/Concordium/Types/Option.hs | 60 +++++++++++++++++++ .../ConcordiumTests/KonsensusV1/CatchUp.hs | 2 +- .../ConcordiumTests/KonsensusV1/Common.hs | 2 +- .../ConcordiumTests/KonsensusV1/Consensus.hs | 2 +- .../KonsensusV1/Consensus/Blocks.hs | 2 +- .../ConcordiumTests/KonsensusV1/LMDB.hs | 2 +- .../ConcordiumTests/KonsensusV1/Timeout.hs | 2 +- .../KonsensusV1/TransactionProcessingTest.hs | 2 +- .../KonsensusV1/TreeStateTest.hs | 2 +- .../ConcordiumTests/KonsensusV1/Types.hs | 2 +- .../GlobalStateTests/DifferenceMap.hs | 2 +- 28 files changed, 87 insertions(+), 28 deletions(-) create mode 100644 concordium-consensus/src/Concordium/Types/Option.hs diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index 362a217b0d..633878144c 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -11,8 +11,8 @@ import qualified Data.HashMap.Strict as HM import Data.IORef import Prelude hiding (lookup) -import Concordium.Option (Option (..)) import Concordium.Types +import Concordium.Types.Option (Option (..)) -- | A difference map that indicates newly added accounts for -- a block identified by a 'BlockHash' and its associated 'BlockHeight'. diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index a487922f07..e8cbd19992 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -77,9 +77,9 @@ import qualified Concordium.GlobalState.Persistent.LFMBTree as L import qualified Concordium.GlobalState.Persistent.Trie as Trie import Concordium.ID.Parameters import qualified Concordium.ID.Types as ID -import Concordium.Option (Option (..)) import Concordium.Types import Concordium.Types.HashableTo +import Concordium.Types.Option (Option (..)) import Concordium.Utils.Serialization.Put import Control.Monad.Reader import Data.Foldable (foldlM) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 25068601db..f504a3d9d0 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -71,7 +71,6 @@ import qualified Concordium.ID.Parameters as ID import qualified Concordium.ID.Types as ID import Concordium.Kontrol.Bakers import Concordium.Logger (MonadLogger) -import Concordium.Option (Option (..)) import Concordium.TimeMonad (TimeMonad) import Concordium.Types import Concordium.Types.Accounts (AccountBaker (..)) @@ -81,6 +80,7 @@ import Concordium.Types.Execution (DelegationTarget (..), TransactionIndex, Tran import qualified Concordium.Types.Execution as Transactions import Concordium.Types.HashableTo import qualified Concordium.Types.IdentityProviders as IPS +import Concordium.Types.Option (Option (..)) import Concordium.Types.Queries (CurrentPaydayBakerPoolStatus (..), PoolStatus (..), RewardStatus' (..), makePoolPendingChange) import Concordium.Types.SeedState import qualified Concordium.Types.Transactions as Transactions diff --git a/concordium-consensus/src/Concordium/KonsensusV1.hs b/concordium-consensus/src/Concordium/KonsensusV1.hs index a3d2359ee2..c35e3d66d3 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1.hs @@ -27,11 +27,11 @@ import qualified Concordium.KonsensusV1.TreeState.LowLevel as LowLevel import Concordium.KonsensusV1.TreeState.Types (bpState) import Concordium.KonsensusV1.Types import Concordium.Logger -import Concordium.Option import Concordium.Skov.Monad (UpdateResult (..), transactionVerificationResultToUpdateResult) import Concordium.TimeMonad import Concordium.TimerMonad import Concordium.Types +import Concordium.Types.Option import Concordium.Types.Parameters -- | Handle receiving a finalization message (either a 'QuorumMessage' or a 'TimeoutMessage'). diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Consensus.hs b/concordium-consensus/src/Concordium/KonsensusV1/Consensus.hs index ce4f0973d9..e4e605dd80 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Consensus.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Consensus.hs @@ -34,7 +34,7 @@ import qualified Concordium.KonsensusV1.TreeState.LowLevel as LowLevel import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types import Concordium.Logger -import Concordium.Option +import Concordium.Types.Option import Concordium.Types.SeedState (currentLeadershipElectionNonce, triggerBlockTime) import Concordium.Types.UpdateQueues import Concordium.Types.Updates diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Blocks.hs b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Blocks.hs index aa191beef7..54accf05a8 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Blocks.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Blocks.hs @@ -49,10 +49,10 @@ import Concordium.KonsensusV1.TreeState.Implementation import qualified Concordium.KonsensusV1.TreeState.LowLevel as LowLevel import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types -import Concordium.Option import Concordium.Scheduler (FilteredTransactions (..)) import Concordium.TimerMonad import Concordium.Types.BakerIdentity +import Concordium.Types.Option -- | A block that has passed initial verification, but must still be executed, added to the state, -- and (potentially) signed as a finalizer. diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/CatchUp.hs b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/CatchUp.hs index fff447fb07..cea82c00f2 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/CatchUp.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/CatchUp.hs @@ -62,9 +62,9 @@ import Concordium.KonsensusV1.TreeState.Implementation import qualified Concordium.KonsensusV1.TreeState.LowLevel as LowLevel import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types -import Concordium.Option import Concordium.TimeMonad import Concordium.TimerMonad +import Concordium.Types.Option import Concordium.Types.Parameters -- | 'CatchUpPartialResponse' represents a stream of blocks to send as a response to a catch-up diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/CatchUp/Types.hs b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/CatchUp/Types.hs index b30f5e4cbb..9c8f6b3265 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/CatchUp/Types.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/CatchUp/Types.hs @@ -5,8 +5,8 @@ import qualified Data.Map.Strict as Map import Data.Serialize hiding (getListOf, putListOf) import Concordium.KonsensusV1.Types -import Concordium.Option import Concordium.Types +import Concordium.Types.Option import Concordium.Utils.Serialization import Control.Monad diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs index ae7a579a7a..ec03ffc466 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs @@ -32,7 +32,7 @@ import Concordium.KonsensusV1.TreeState.Implementation import qualified Concordium.KonsensusV1.TreeState.LowLevel as LowLevel import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types -import Concordium.Option +import Concordium.Types.Option -- | Ensure that the given certified block is written to the low-level database. -- Check if the certified block causes its parent to become finalized. diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Timeout.hs b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Timeout.hs index 137683e8ad..28f68485c7 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Timeout.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Timeout.hs @@ -35,8 +35,8 @@ import Concordium.KonsensusV1.TreeState.Implementation import qualified Concordium.KonsensusV1.TreeState.LowLevel as LowLevel import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types -import Concordium.Option import Concordium.TimerMonad +import Concordium.Types.Option -- | Reasons that a 'TimeoutMessage' can be rejected. data ReceiveTimeoutMessageRejectReason diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Implementation.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Implementation.hs index c922e85e0f..e38f3db0fa 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Implementation.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Implementation.hs @@ -40,10 +40,10 @@ import qualified Data.Map.Strict as Map import qualified Data.Sequence as Seq import qualified Concordium.Genesis.Data.BaseV1 as Base -import Concordium.Option import Concordium.Types import Concordium.Types.Execution import Concordium.Types.HashableTo +import Concordium.Types.Option import Concordium.Types.Transactions import Concordium.Types.Updates import Concordium.Utils diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs index 7f81c84735..a2e10f092f 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs @@ -36,9 +36,9 @@ import Concordium.Common.Version import qualified Concordium.Crypto.SHA256 as Hash import Concordium.ID.Types import Concordium.Logger -import Concordium.Option import Concordium.Types import Concordium.Types.HashableTo +import Concordium.Types.Option import Concordium.Types.Transactions import Concordium.GlobalState.LMDB.Helpers diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs index 6ef95e0412..8f572f2b2e 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs @@ -35,9 +35,9 @@ import qualified Concordium.KonsensusV1.TreeState.LowLevel as LowLevel import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types import Concordium.Logger -import Concordium.Option import Concordium.TimeMonad import Concordium.TransactionVerification as TVer +import Concordium.Types.Option -- | Generate the 'EpochBakers' for a genesis block. genesisEpochBakers :: diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Types.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Types.hs index ba74556792..7746b43cd4 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Types.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/Types.hs @@ -26,7 +26,7 @@ import Concordium.GlobalState.BakerInfo import qualified Concordium.GlobalState.Persistent.BlockState as PBS import Concordium.GlobalState.TransactionTable import Concordium.KonsensusV1.Types -import Concordium.Option (Option (..), ofOption) +import Concordium.Types.Option (Option (..), ofOption) -- | Status information for a finalized transaction. data FinalizedTransactionStatus = FinalizedTransactionStatus diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Types.hs b/concordium-consensus/src/Concordium/KonsensusV1/Types.hs index bfed113154..881c806f3f 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Types.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Types.hs @@ -1,7 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -28,9 +27,9 @@ import qualified Concordium.Crypto.VRF as VRF import Concordium.Genesis.Data (Regenesis, firstGenesisBlockHash, regenesisBlockHash, regenesisCoreParametersV1) import Concordium.Genesis.Data.BaseV1 import qualified Concordium.GlobalState.Basic.BlockState.LFMBTree as LFMBT -import Concordium.Option import Concordium.Types import Concordium.Types.HashableTo +import Concordium.Types.Option import Concordium.Types.Parameters (IsConsensusV1) import Concordium.Types.Transactions import Concordium.Utils.BinarySearch diff --git a/concordium-consensus/src/Concordium/MultiVersion.hs b/concordium-consensus/src/Concordium/MultiVersion.hs index 345935aafc..45ee9d3ceb 100644 --- a/concordium-consensus/src/Concordium/MultiVersion.hs +++ b/concordium-consensus/src/Concordium/MultiVersion.hs @@ -66,7 +66,6 @@ import qualified Concordium.KonsensusV1.Transactions as SkovV1 import qualified Concordium.KonsensusV1.TreeState.LowLevel.LMDB as LowLevelDB import qualified Concordium.KonsensusV1.TreeState.Types as SkovV1 import qualified Concordium.KonsensusV1.Types as KonsensusV1 -import Concordium.Option import qualified Concordium.ProtocolUpdate.V0 as ProtocolUpdateV0 import qualified Concordium.ProtocolUpdate.V1 as ProtocolUpdateV1 import qualified Concordium.Skov as Skov @@ -74,6 +73,7 @@ import Concordium.TimeMonad import Concordium.TimerMonad import qualified Concordium.TransactionVerification as TVer import Concordium.Types.CatchUp +import Concordium.Types.Option -- | Handler configuration for supporting protocol updates. -- This handler defines an instance of 'HandlerConfigHandlers' that responds to finalization events diff --git a/concordium-consensus/src/Concordium/Queries.hs b/concordium-consensus/src/Concordium/Queries.hs index 3d6e9d6776..e8de4433d0 100644 --- a/concordium-consensus/src/Concordium/Queries.hs +++ b/concordium-consensus/src/Concordium/Queries.hs @@ -71,11 +71,11 @@ import qualified Concordium.KonsensusV1.Types as SkovV1 import Concordium.Kontrol import Concordium.Kontrol.BestBlock import Concordium.MultiVersion -import Concordium.Option import Concordium.Skov as Skov ( SkovQueryMonad (getBlocksAtHeight), evalSkovT, ) +import Concordium.Types.Option import Control.Monad.State.Class import Data.Time diff --git a/concordium-consensus/src/Concordium/Types/Option.hs b/concordium-consensus/src/Concordium/Types/Option.hs new file mode 100644 index 0000000000..49a13bb6b3 --- /dev/null +++ b/concordium-consensus/src/Concordium/Types/Option.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DeriveTraversable #-} +-- | This module provides a strict version of 'Maybe'. +module Concordium.Types.Option ( + -- * Strict version of 'Maybe'. + Option(..), + -- * Auxiliary functions + putOptionOf, + getOptionOf, + isPresent, + isAbsent, + fromOption, + ofOption + ) where + +import Data.Serialize + +-- | A strict version of 'Maybe'. +data Option a + = Absent + | Present !a + deriving (Eq, Ord, Show, Functor, Foldable, Traversable) + +-- | Putter for an @Option a@. +putOptionOf :: Putter a -> Putter (Option a) +putOptionOf _ Absent = putWord8 0 +putOptionOf pa (Present a) = putWord8 1 >> pa a + +-- | Getter for an @Option a@. +getOptionOf :: Get a -> Get (Option a) +getOptionOf ma = do + getWord8 >>= \case + 0 -> return Absent + 1 -> Present <$> ma + _ -> fail "invalid tag for Option" + +-- | 'Serialize' instance for an @Option a@. +instance (Serialize a) => Serialize (Option a) where + put = putOptionOf put + get = getOptionOf get + +-- | Returns 'True' if and only if the value is 'Present'. +isPresent :: Option a -> Bool +isPresent Absent = False +isPresent (Present _) = True + +-- | Returns 'True' if and only if the value is 'Absent'. +isAbsent :: Option a -> Bool +isAbsent Absent = True +isAbsent (Present _) = False + +-- | Get the contents of an 'Option' or the supplied default value if it is 'Absent'. +fromOption :: a -> Option a -> a +fromOption def Absent = def +fromOption _ (Present v) = v + +-- | Deconstruct an 'Option', returning the first argument if it is 'Absent', and otherwise +-- applying the second argument to the value if it is 'Present'. (Analogous to 'maybe'.) +ofOption :: b -> (a -> b) -> Option a -> b +ofOption ab _ Absent = ab +ofOption _ pr (Present v) = pr v diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/CatchUp.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/CatchUp.hs index b70b832391..c984b8ccb6 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/CatchUp.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/CatchUp.hs @@ -28,7 +28,7 @@ import Concordium.KonsensusV1.TestMonad import Concordium.KonsensusV1.TreeState.Implementation import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types -import Concordium.Option +import Concordium.Types.Option import ConcordiumTests.KonsensusV1.Consensus.Blocks import qualified ConcordiumTests.KonsensusV1.Consensus.Blocks as TestBlocks diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Common.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Common.hs index 5e804b275a..3dedffdb00 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Common.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Common.hs @@ -12,8 +12,8 @@ import qualified Concordium.Crypto.DummyData as Dummy import qualified Concordium.Crypto.SHA256 as Hash import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types -import Concordium.Option import Concordium.Types +import Concordium.Types.Option import Concordium.Types.Transactions import ConcordiumTests.KonsensusV1.TreeStateTest hiding (tests) diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Consensus.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Consensus.hs index 42e83cd9d3..831701f4b4 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Consensus.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Consensus.hs @@ -23,10 +23,10 @@ import Concordium.KonsensusV1.TestMonad import Concordium.KonsensusV1.TreeState.Implementation import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types -import Concordium.Option import Concordium.Startup import Concordium.Types import qualified Concordium.Types.DummyData as Dummy +import Concordium.Types.Option import ConcordiumTests.KonsensusV1.TreeStateTest (dummyBlock) genesisData :: GenesisData 'P6 diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Consensus/Blocks.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Consensus/Blocks.hs index 5f5eb06ad0..fab6774f13 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Consensus/Blocks.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Consensus/Blocks.hs @@ -44,9 +44,9 @@ import Concordium.KonsensusV1.TestMonad import Concordium.KonsensusV1.TreeState.Implementation import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types -import Concordium.Option import Concordium.Startup import Concordium.TimerMonad +import Concordium.Types.Option maxBaker :: (Integral a) => a maxBaker = 5 diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/LMDB.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/LMDB.hs index 4355a76c86..b7fc4d2912 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/LMDB.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/LMDB.hs @@ -29,9 +29,9 @@ import Concordium.KonsensusV1.TreeState.LowLevel.LMDB import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types import Concordium.Logger -import Concordium.Option import Concordium.Types import Concordium.Types.HashableTo +import Concordium.Types.Option import Concordium.Types.Transactions -- | A dummy UTCTime used for tests where the actual value is not significant. diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Timeout.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Timeout.hs index 4cd0144a48..df41f647ee 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Timeout.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Timeout.hs @@ -36,11 +36,11 @@ import Concordium.KonsensusV1.TreeState.Implementation import Concordium.KonsensusV1.TreeState.LowLevel.Memory import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types -import Concordium.Option import Concordium.Startup import Concordium.Types import Concordium.Types.BakerIdentity import qualified Concordium.Types.DummyData as Dummy +import Concordium.Types.Option import ConcordiumTests.KonsensusV1.Common import ConcordiumTests.KonsensusV1.TreeStateTest hiding (tests) import ConcordiumTests.KonsensusV1.Types hiding (tests) diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs index 973d405ec3..bda0b2a449 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs @@ -53,7 +53,6 @@ import Concordium.GlobalState.Persistent.Genesis (genesisState) import Concordium.GlobalState.TransactionTable import Concordium.ID.Types (randomAccountAddress) import Concordium.Logger -import Concordium.Option import Concordium.Scheduler.DummyData import Concordium.TimeMonad import qualified Concordium.TransactionVerification as TVer @@ -62,6 +61,7 @@ import Concordium.Types.AnonymityRevokers import Concordium.Types.Execution import Concordium.Types.HashableTo import Concordium.Types.IdentityProviders +import Concordium.Types.Option import Concordium.Types.Parameters import Concordium.Types.Transactions diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TreeStateTest.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TreeStateTest.hs index 6a89140557..d84a32e079 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TreeStateTest.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TreeStateTest.hs @@ -102,8 +102,8 @@ import qualified Concordium.KonsensusV1.TreeState.LowLevel as LowLevel import Concordium.KonsensusV1.TreeState.LowLevel.Memory import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types -import Concordium.Option import qualified Concordium.TransactionVerification as TVer +import Concordium.Types.Option import Concordium.Types.Updates -- We derive these instances here so we don't accidentally end up using them in production. diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Types.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Types.hs index b72b0f7830..69486ceb5f 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Types.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Types.hs @@ -25,7 +25,7 @@ import qualified Data.FixedByteString as FBS import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types -import Concordium.Option +import Concordium.Types.Option -- | Generate a 'FinalizerSet'. The size parameter determines the size of the committee that -- the finalizers are (nominally) sampled from. diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs index b4c9be83b9..fc9a549fb8 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs @@ -18,7 +18,7 @@ import Test.Hspec import Test.QuickCheck import qualified Concordium.GlobalState.AccountMap.DifferenceMap as DiffMap -import Concordium.Option +import Concordium.Types.Option -- | Create a pair consisting of an account address and an account index based on the provided seed. dummyPair :: Int -> (AccountAddress, AccountIndex) From a7df5ce5b40d6af0226c6639deb43088af0a3b3c Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Fri, 3 Nov 2023 15:25:19 +0100 Subject: [PATCH 60/92] Only finalized accounts are being persisted in the lmdb account map. Fix getAllAccounts query. --- .../Concordium/GlobalState/AccountMap/LMDB.hs | 60 +++++++++++++---- .../src/Concordium/GlobalState/BlockState.hs | 16 ++--- .../GlobalState/Persistent/Accounts.hs | 50 +++++++------- .../GlobalState/Persistent/BlockState.hs | 31 ++++----- .../GlobalState/Persistent/TreeState.hs | 6 +- .../KonsensusV1/Consensus/Finality.hs | 23 +++++-- .../src/Concordium/KonsensusV1/SkovMonad.hs | 10 ++- .../src/Concordium/KonsensusV1/TestMonad.hs | 5 +- .../src/Concordium/Queries.hs | 66 +++++++------------ .../src/Concordium/Types/Option.hs | 22 ++++--- .../globalstate/GlobalStateTests/Accounts.hs | 2 - 11 files changed, 161 insertions(+), 130 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index 9bb262bf39..bf03d85644 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DerivingVia #-} @@ -77,7 +78,9 @@ instance Exception DatabaseInvariantViolation where class (Monad m) => MonadAccountMapStore m where -- | Inserts the accounts to the underlying store. -- Only canonical addresses should be added. - insertAccounts :: [(AccountAddress, AccountIndex)] -> m () + -- The provided @BlockHash@ must correspond the to hash of the + -- last finalized block where the inputted accounts comes from. + insertAccounts :: StateHash -> [(AccountAddress, AccountIndex)] -> m () -- | Looks up the ‘AccountIndex’ for the provided ‘AccountAddress’. -- Returns @Just AccountIndex@ if the account is present in the ‘AccountMap’ @@ -93,16 +96,17 @@ class (Monad m) => MonadAccountMapStore m where lookupAccountIndex :: AccountAddress -> m (Maybe AccountIndex) -- | Return all the canonical addresses and their associated account indices of accounts present - -- in the store. - getAllAccounts :: m [(AccountAddress, AccountIndex)] + -- in the store where their @AccountIndex@ is less or equal to the provided @AccountIndex@. + -- In particular the provided @AccountIndex@ should match the size of the account table minus one. + getAllAccounts :: AccountIndex -> m [(AccountAddress, AccountIndex)] -- | Checks whether the lmdb store is initialized or not. isInitialized :: m Bool instance (Monad (t m), MonadTrans t, MonadAccountMapStore m) => MonadAccountMapStore (MGSTrans t m) where - insertAccounts = lift . insertAccounts + insertAccounts lfb accs = lift $ insertAccounts lfb accs lookupAccountIndex = lift . lookupAccountIndex - getAllAccounts = lift getAllAccounts + getAllAccounts = lift . getAllAccounts isInitialized = lift isInitialized {-# INLINE insertAccounts #-} {-# INLINE lookupAccountIndex #-} @@ -114,9 +118,9 @@ deriving via (MGSTrans (ExceptT e) m) instance (MonadAccountMapStore m) => Monad deriving via (MGSTrans (WriterT w) m) instance (Monoid w, MonadAccountMapStore m) => MonadAccountMapStore (WriterT w m) instance (MonadAccountMapStore m) => MonadAccountMapStore (PutT m) where - insertAccounts = lift . insertAccounts + insertAccounts lfb accs = lift $ insertAccounts lfb accs lookupAccountIndex = lift . lookupAccountIndex - getAllAccounts = lift getAllAccounts + getAllAccounts = lift . getAllAccounts isInitialized = lift isInitialized {-# INLINE insertAccounts #-} {-# INLINE lookupAccountIndex #-} @@ -128,13 +132,26 @@ instance (MonadAccountMapStore m) => MonadAccountMapStore (PutT m) where -- | Store that retains the account address -> account index mappings. newtype AccountMapStore = AccountMapStore MDB_dbi' +-- | Store that retains the hash and height of the block that was inserted last. +newtype LfbHashStore = LfbHashStore MDB_dbi' + accountMapStoreName :: String accountMapStoreName = "accounts" +lfbHashStoreName :: String +lfbHashStoreName = "lfb" + instance MDBDatabase AccountMapStore where type DBKey AccountMapStore = AccountAddress type DBValue AccountMapStore = AccountIndex +lfbKey :: DBKey LfbHashStore +lfbKey = "lfb" + +instance MDBDatabase LfbHashStore where + type DBKey LfbHashStore = BS.ByteString + type DBValue LfbHashStore = StateHash + -- | Datbase handlers to interact with the account map lmdb -- database. Create via 'makeDatabasehandlers'. data DatabaseHandlers = DatabaseHandlers @@ -142,14 +159,16 @@ data DatabaseHandlers = DatabaseHandlers _dbhStoreEnv :: !StoreEnv, -- | The only store for this lmdb database. -- The account map functions as a persistent @AccountAddress -> Maybe AccountIndex@ mapping. - _dbhAccountMapStore :: !AccountMapStore + _dbhAccountMapStore :: !AccountMapStore, + -- | Hash of the state of the last finalized block which was used for inserting accounts. + _dbhLfbHash :: !LfbHashStore } makeClassy ''DatabaseHandlers -- | The number of stores in the LMDB environment for 'DatabaseHandlers'. databaseCount :: Int -databaseCount = 1 +databaseCount = 2 -- ** Initialization @@ -178,6 +197,12 @@ makeDatabaseHandlers accountMapDir readOnly = do txn (Just accountMapStoreName) [MDB_CREATE | not readOnly] + _dbhLfbHash <- + LfbHashStore + <$> mdb_dbi_open' + txn + (Just accountMapStoreName) + [MDB_CREATE | not readOnly] return DatabaseHandlers{..} -- | Create the lmdb stores and return back database handlers for interacting with it. @@ -228,11 +253,12 @@ instance ) => MonadAccountMapStore (AccountMapStoreMonad m) where - insertAccounts accounts = do + insertAccounts lfb accounts = do dbh <- ask asWriteTransaction (dbh ^. dbhStoreEnv) $ \txn -> do forM_ accounts $ \(accAddr, accIndex) -> do storeReplaceRecord txn (dbh ^. dbhAccountMapStore) accAddr accIndex + storeReplaceRecord txn (dbh ^. dbhLfbHash) lfbKey lfb lookupAccountIndex a@(AccountAddress accAddr) = do dbh <- ask @@ -266,9 +292,19 @@ instance accLookupKey = BS.take prefixAccountAddressSize $ FBS.toByteString accAddr checkEquivalence x y = accountAddressEmbed x == accountAddressEmbed y - getAllAccounts = do + getAllAccounts maxAccountIndex = do dbh <- ask - asReadTransaction (dbh ^. dbhStoreEnv) $ \txn -> loadAll txn (dbh ^. dbhAccountMapStore) + asReadTransaction (dbh ^. dbhStoreEnv) $ \txn -> + withCursor txn (dbh ^. dbhAccountMapStore) $ \cursor -> + let go !accum Nothing = return accum + go !accum (Just (Right acc@(_, accIdx))) = do + -- We only accumulate accounts which have an @AccountIndex@ at most + -- the provided one. + if accIdx <= maxAccountIndex + then go (acc : accum) =<< getCursor CursorNext cursor + else go accum =<< getCursor CursorNext cursor + go _ (Just (Left err)) = throwM $ DatabaseInvariantViolation err + in go [] =<< getCursor CursorFirst cursor isInitialized = do dbh <- ask diff --git a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs index 64cc0e8d41..ff97dffae8 100644 --- a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs @@ -509,16 +509,10 @@ class (ContractStateOperations m, AccountOperations m, ModuleQuery m) => BlockSt -- | Get the list of addresses of modules existing in the given block state. getModuleList :: BlockState m -> m [ModuleRef] - -- | Get the list of account addresses existing in the given block state, - -- Note that this function also includes any created - but not persisted accounts - -- for the provided block and any non-persisted blocks. + -- | Get the list of account addresses existing in the given block state. -- This returns the canonical addresses. getAccountList :: BlockState m -> m [AccountAddress] - -- | Get the list of account addresses existing in the given historical block state. - -- This returns the canonical addresses. - getAccountListHistorical :: BlockState m -> m [AccountAddress] - -- | Get the list of contract instances existing in the given block state. -- The list should be returned in ascending order of addresses. getContractInstanceList :: BlockState m -> m [ContractAddress] @@ -1389,6 +1383,12 @@ class (BlockStateOperations m, FixedSizeSerialization (BlockStateRef m)) => Bloc -- | Ensure that a block state is stored and return a reference to it. saveBlockState :: BlockState m -> m (BlockStateRef m) + -- | Ensure that any accounts created in a block is persisted. + -- This should be called when a block is being finalized. + -- + -- Precondition: The block state must be in memory and it must not have been archived. + saveAccounts :: BlockState m -> m () + -- | Load a block state from a reference, given its state hash if provided, -- otherwise calculate the state hash upon loading. -- In particular the 'StateHash' should be supplied if loading a non-genesis block state. @@ -1441,7 +1441,6 @@ instance (Monad (t m), MonadTrans t, BlockStateQuery m) => BlockStateQuery (MGST getContractInstance s = lift . getContractInstance s getModuleList = lift . getModuleList getAccountList = lift . getAccountList - getAccountListHistorical = lift . getAccountListHistorical getContractInstanceList = lift . getContractInstanceList getSeedState = lift . getSeedState getCurrentEpochBakers = lift . getCurrentEpochBakers @@ -1682,6 +1681,7 @@ instance (Monad (t m), MonadTrans t, BlockStateStorage m) => BlockStateStorage ( purgeBlockState = lift . purgeBlockState archiveBlockState = lift . archiveBlockState saveBlockState = lift . saveBlockState + saveAccounts = lift . saveAccounts loadBlockState hsh = lift . loadBlockState hsh serializeBlockState = lift . serializeBlockState blockStateLoadCallback = lift blockStateLoadCallback diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index e8cbd19992..bf3c7cd9cf 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -157,16 +157,17 @@ instance (SupportsPersistentAccount pv m) => MHashableTo m H.Hash (Accounts pv) -- | Write accounts created for this block or any non-persisted parent block. -- Note that this also empties the difference map for this block. -- --- This MUST be called when finalizing the block state. -writeAccountsCreated :: (SupportsPersistentAccount pv m) => Accounts pv -> m () -writeAccountsCreated Accounts{..} = do +-- Precondition: This MUST be called when finalizing the block state, and the +-- provided @BlockHash@ must correespond to the hash of the finalized block. +writeAccountsCreated :: (SupportsPersistentAccount pv m) => StateHash -> Accounts pv -> m () +writeAccountsCreated bh Accounts{..} = do mAccountsCreated <- liftIO $ readIORef accountDiffMapRef case mAccountsCreated of Absent -> return () Present accountsCreated -> do listOfAccountsCreated <- liftIO $ DiffMap.flatten accountsCreated liftIO $ atomicWriteIORef accountDiffMapRef Absent - LMDBAccountMap.insertAccounts listOfAccountsCreated + LMDBAccountMap.insertAccounts bh listOfAccountsCreated instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where storeUpdate Accounts{..} = do @@ -362,7 +363,8 @@ updateAccountsAtIndex' fupd ai = fmap snd . updateAccountsAtIndex fupd' ai -- a concatenation of two lists of account addresses. allAccounts :: (SupportsPersistentAccount pv m) => Accounts pv -> m [(AccountAddress, AccountIndex)] allAccounts accounts = do - persistedAccs <- LMDBAccountMap.getAllAccounts + -- Get all persisted accounts from the account map up to and including the last account of the account table. + persistedAccs <- LMDBAccountMap.getAllAccounts $ (AccountIndex . L.size) (accountTable accounts) - 1 mDiffMap <- liftIO $ readIORef (accountDiffMapRef accounts) case mDiffMap of Absent -> return persistedAccs @@ -390,28 +392,28 @@ foldAccounts f a accts = L.mfold f a (accountTable accts) foldAccountsDesc :: (SupportsPersistentAccount pv m) => (a -> PersistentAccount (AccountVersionFor pv) -> m a) -> a -> Accounts pv -> m a foldAccountsDesc f a accts = L.mfoldDesc f a (accountTable accts) --- | Get all account addresses and their associated 'AccountIndex' via the account table in ascending order --- of account index. --- Note. This function should only be used when querying a historical block. When querying with respect to the "best block" then --- use 'allAccounts'. -allAccountsViaTable :: (SupportsPersistentAccount pv m) => Accounts pv -> m [(AccountAddress, AccountIndex)] -allAccountsViaTable accts = do - addresses <- - foldAccountsDesc - ( \accum pacc -> do - !addr <- accountCanonicalAddress pacc - return $ addr : accum - ) - [] - accts - return $ zip addresses [0 ..] - -- | If the LMDB account map is not already initialized, then this function populates the LMDB account map via the provided provided 'Accounts'. -- Otherwise, this function does nothing. -tryPopulateLMDBStore :: (SupportsPersistentAccount pv m) => Accounts pv -> m () -tryPopulateLMDBStore accts = do +-- +-- Precondition: The provided @BlockHash@ must correspond to the last finalized block when calling this function. +tryPopulateLMDBStore :: (SupportsPersistentAccount pv m) => StateHash -> Accounts pv -> m () +tryPopulateLMDBStore h accts = do isInitialized <- LMDBAccountMap.isInitialized - unless isInitialized (void $ LMDBAccountMap.insertAccounts =<< allAccountsViaTable accts) + unless isInitialized (void $ LMDBAccountMap.insertAccounts h =<< allAccountsViaTable) + where + -- Get all accounts from the account table. + allAccountsViaTable = do + addresses <- + -- We fold in ascending order of the @AccountIndex@ + -- so we @zip@ it correctly when returning @[(AccountAddress, AccountIndex)]@ + foldAccounts + ( \(!accum) pacc -> do + !addr <- accountCanonicalAddress pacc + return $ addr : accum + ) + [] + accts + return $ zip addresses [0 ..] -- | See documentation of @migratePersistentBlockState@. migrateAccounts :: diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index f504a3d9d0..718658a7b7 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -2239,16 +2239,6 @@ doAccountList pbs = do bsp <- loadPBS pbs Accounts.accountAddresses (bspAccounts bsp) --- | This function should be used when querying all accounts for a --- block that is only on disk, hence the 'historical' part. --- For blocks only retained in memory, then this function will not return accounts created --- in this block or any parent blocks that have not yet been written to disk. --- Use 'doGetAccountList' when querying the "best" block. -doGetAccountListHistorical :: (SupportsPersistentState pv m) => PersistentBlockState pv -> m [AccountAddress] -doGetAccountListHistorical pbs = do - bsp <- loadPBS pbs - map fst <$> Accounts.allAccountsViaTable (bspAccounts bsp) - doRegIdExists :: (SupportsPersistentState pv m) => PersistentBlockState pv -> ID.CredentialRegistrationID -> m Bool doRegIdExists pbs regid = do bsp <- loadPBS pbs @@ -3401,7 +3391,6 @@ instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateQuery (P getContractInstance = doGetInstance . hpbsPointers getModuleList = doGetModuleList . hpbsPointers getAccountList = doAccountList . hpbsPointers - getAccountListHistorical = doGetAccountListHistorical . hpbsPointers getContractInstanceList = doContractInstanceList . hpbsPointers getSeedState = doGetSeedState . hpbsPointers getCurrentEpochFinalizationCommitteeParameters = doGetCurrentEpochFinalizationCommitteeParameters . hpbsPointers @@ -3577,17 +3566,19 @@ instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateStorage saveBlockState HashedPersistentBlockState{..} = do inner <- liftIO $ readIORef hpbsPointers + (!inner', !ref) <- flushBufferedRef inner + liftIO $ writeIORef hpbsPointers inner' + flushStore + return ref + + saveAccounts HashedPersistentBlockState{..} = do -- this load should be cheap as the blockstate is in memory. accs <- bspAccounts <$> loadPBS hpbsPointers -- write the accounts that was created in the block and - -- potentially non-persisted parent blocks. + -- potentially non-finalized parent blocks. -- Note that this also empties the difference map for the -- block. - void $ Accounts.writeAccountsCreated accs - (!inner', !ref) <- flushBufferedRef inner - liftIO $ writeIORef hpbsPointers inner' - flushStore - return ref + void $ Accounts.writeAccountsCreated hpbsHash accs loadBlockState hpbsHashM ref = do hpbsPointers <- liftIO $ newIORef $ blobRefToBufferedRef ref @@ -3777,9 +3768,9 @@ cacheState hpbs = do return () doTryPopulateAccountMap :: (SupportsPersistentState pv m) => HashedPersistentBlockState pv -> m () -doTryPopulateAccountMap hpbs = do - BlockStatePointers{..} <- loadPBS (hpbsPointers hpbs) - LMDBAccountMap.tryPopulateLMDBStore bspAccounts +doTryPopulateAccountMap HashedPersistentBlockState{..} = do + BlockStatePointers{..} <- loadPBS hpbsPointers + LMDBAccountMap.tryPopulateLMDBStore hpbsHash bspAccounts -- | Cache the block state and get the initial (empty) transaction table with the next account nonces -- and update sequence numbers populated. diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs index f290140d34..acf04055d2 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs @@ -718,7 +718,11 @@ instance markFinalized bh fr = use (skovPersistentData . blockTable . liveMap . at' bh) >>= \case Just (BlockAlive bp) -> do - st <- saveBlockState (_bpState bp) + st <- do + -- Save the block state and write the accounts out to disk. + ref <- saveBlockState (_bpState bp) + void $ saveAccounts (_bpState bp) + return ref -- NB: Removing the block from the in-memory cache only makes -- sense if no block lookups are done between the call to this -- function and 'wrapUpFinalization'. This is currently the case, diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs index ec03ffc466..8aab82d4cb 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs @@ -71,7 +71,7 @@ processCertifiedBlock cb@CertifiedBlock{..} then do -- We do not need to update the last finalized block, but we do need to store this -- as a certified block. - storedBlock <- makeStoredBlock cbQuorumBlock + storedBlock <- makeStoredBlock False cbQuorumBlock LowLevel.writeCertifiedBlock storedBlock cbQuorumCertificate else do let !newFinalizedPtr = parentOfLive sd cbQuorumBlock @@ -84,7 +84,7 @@ processCertifiedBlock cb@CertifiedBlock{..} processFinalizationHelper newFinalizedPtr newFinalizationEntry (Just cb) shrinkTimeout cbQuorumBlock | otherwise = unlessStored $ do - storedBlock <- makeStoredBlock cbQuorumBlock + storedBlock <- makeStoredBlock False cbQuorumBlock LowLevel.writeCertifiedBlock storedBlock cbQuorumCertificate where unlessStored a = do @@ -190,14 +190,25 @@ processFinalizationEntry newFinalizedPtr newFinalizationEntry = -- | Write a block's state out to the block state database and construct a 'LowLevel.StoredBlock' -- that can be written to the tree state database. +-- +-- If the provided block is finalized then also any accounts created for the block +-- will be persisted. makeStoredBlock :: ( GSTypes.BlockState m ~ PBS.HashedPersistentBlockState (MPV m), BlockStateStorage m ) => + -- | @True@ if the block is finalized, @False@ if it is certified. + Bool -> BlockPointer (MPV m) -> m (LowLevel.StoredBlock (MPV m)) -makeStoredBlock blockPtr = do - statePointer <- saveBlockState (bpState blockPtr) +makeStoredBlock finalized blockPtr = do + statePointer <- + if finalized + then do + ref <- saveBlockState (bpState blockPtr) + saveAccounts (bpState blockPtr) + return ref + else saveBlockState (bpState blockPtr) return LowLevel.StoredBlock { stbInfo = blockMetadata blockPtr, @@ -302,11 +313,11 @@ processFinalizationHelper newFinalizedBlock newFinalizationEntry mCertifiedBlock -- Store the blocks and finalization entry in the low-level tree state database, including -- indexing the finalized transactions. -- Store the finalized blocks in the low-level tree state database. - finalizedBlocks <- mapM makeStoredBlock prFinalized + finalizedBlocks <- mapM (makeStoredBlock True) prFinalized case mCertifiedBlock of Nothing -> LowLevel.writeFinalizedBlocks finalizedBlocks newFinalizationEntry Just certifiedBlock -> do - storedCertifiedBlock <- makeStoredBlock (cbQuorumBlock certifiedBlock) + storedCertifiedBlock <- makeStoredBlock False (cbQuorumBlock certifiedBlock) LowLevel.writeCertifiedBlockWithFinalization finalizedBlocks storedCertifiedBlock diff --git a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs index e9280f850a..e3e2a7dc31 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs @@ -583,7 +583,10 @@ initialiseNewSkovV1 genData bakerCtx handlerCtx unliftSkov gsConfig@GlobalStateC Left err -> throwM (InvalidGenesisData err) Right genState -> return genState logEvent GlobalState LLTrace "Writing persistent global state" - stateRef <- saveBlockState pbs + stateRef <- do + ref <- saveBlockState pbs + saveAccounts pbs + return ref logEvent GlobalState LLTrace "Creating persistent global state context" let genHash = genesisBlockHash genData let genMeta = @@ -716,7 +719,10 @@ migrateSkovV1 regenesis migration gsConfig@GlobalStateConfig{..} oldPbsc oldBloc initGS :: InitMonad pv (SkovData pv) initGS = do newState <- newInitialBlockState - stateRef <- saveBlockState newState + stateRef <- do + ref <- saveBlockState newState + saveAccounts newState + return ref chainParams <- getChainParameters newState genEpochBakers <- genesisEpochBakers newState let genMeta = regenesisMetadata (getHash newState) regenesis diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs index 1cb2bebc74..5cd71b3741 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs @@ -171,7 +171,10 @@ runTestMonad _tcBakerContext _tcCurrentTime genData (TestMonad a) = _nextEpochBakers = nextBF, _nextPayday = payday } - genStateRef <- saveBlockState genState + genStateRef <- do + ref <- saveBlockState genState + saveAccounts genState + return ref return (genState, genStateRef, initTT, genTimeoutBase, genEpochBakers) let genMetadata = GenesisMetadata diff --git a/concordium-consensus/src/Concordium/Queries.hs b/concordium-consensus/src/Concordium/Queries.hs index e8de4433d0..3e652a6986 100644 --- a/concordium-consensus/src/Concordium/Queries.hs +++ b/concordium-consensus/src/Concordium/Queries.hs @@ -244,7 +244,7 @@ liftSkovQueryBHI :: ) -> BlockHashInput -> MVR finconf (BHIQueryResponse a) -liftSkovQueryBHI av1 av2 = liftSkovQueryBHIAndVersion (\_ bp _ -> av1 bp) (\_ bp _ _ -> av2 bp) +liftSkovQueryBHI av1 av2 = liftSkovQueryBHIAndVersion (const av1) (\_ bp _ -> av2 bp) -- | Try a 'BlockHashInput' based state query on the latest skov version. If a specific -- block hash is given we work backwards through consensus versions until we @@ -268,10 +268,6 @@ liftSkovQueryStateBHI stateQuery = bestBlockConsensusV1 :: (MonadState (SkovV1.SkovData pv) m) => m (SkovV1.BlockPointer pv) bestBlockConsensusV1 = SkovV1.cbQuorumBlock <$> use (SkovV1.roundStatus . SkovV1.rsHighestCertifiedBlock) --- | Whether the queried block is historical or the most recent one. -data BlockContext = BCBest | BCHistorical - deriving (Show, Eq) - -- | Try a 'BlockHashInput' based query on the latest skov version, provided with the configuration. -- If a specific block hash is given we work backwards through consensus versions until we -- find the specified block or run out of versions. @@ -286,7 +282,6 @@ liftSkovQueryBHIAndVersion :: ) => EVersionedConfiguration finconf -> BlockPointerType (VersionedSkovV0M finconf pv) -> - BlockContext -> VersionedSkovV0M finconf pv a ) -> -- | Query to run at consensus version 1. @@ -297,7 +292,6 @@ liftSkovQueryBHIAndVersion :: EVersionedConfiguration finconf -> SkovV1.BlockPointer pv -> Bool -> - BlockContext -> VersionedSkovV1M finconf pv a ) -> BlockHashInput -> @@ -313,17 +307,13 @@ liftSkovQueryBHIAndVersion av0 av1 bhi = do mvr vc -- consensus version 0 - ( do - resolveBlock bh >>= \case - Nothing -> return Nothing - Just bp -> Just <$> av0 vc bp BCHistorical - ) + (mapM (av0 vc) =<< resolveBlock bh) -- consensus version 1 ( do status <- SkovV1.getBlockStatus bh =<< get case status of - SkovV1.BlockAlive bp -> Just <$> av1 vc bp False BCHistorical - SkovV1.BlockFinalized bp -> Just <$> av1 vc bp True BCHistorical + SkovV1.BlockAlive bp -> Just <$> av1 vc bp False + SkovV1.BlockFinalized bp -> Just <$> av1 vc bp True _ -> return Nothing ) ) @@ -343,17 +333,13 @@ liftSkovQueryBHIAndVersion av0 av1 bhi = do mvr evc -- consensus version 0 - ( do - resolveBlock bh >>= \case - Nothing -> return Nothing - Just bp -> Just <$> av0 evc bp BCHistorical - ) + (mapM (av0 evc) =<< resolveBlock bh) -- consensus version 1 ( do status <- SkovV1.getBlockStatus bh =<< get case status of - SkovV1.BlockAlive bp -> Just <$> av1 evc bp False BCHistorical - SkovV1.BlockFinalized bp -> Just <$> av1 evc bp True BCHistorical + SkovV1.BlockAlive bp -> Just <$> av1 evc bp False + SkovV1.BlockFinalized bp -> Just <$> av1 evc bp True _ -> return Nothing ) return $ case maybeValue of @@ -367,17 +353,17 @@ liftSkovQueryBHIAndVersion av0 av1 bhi = do liftSkovQueryLatest ( do -- consensus version 0 - (bp, blockContext) <- case other of - Best -> (,BCBest) <$> bestBlock - LastFinal -> (,BCHistorical) <$> lastFinalizedBlock - (bpHash bp,) . Just <$> av0 evc bp blockContext + bp <- case other of + Best -> bestBlock + LastFinal -> lastFinalizedBlock + (bpHash bp,) . Just <$> av0 evc bp ) ( do -- consensus version 1 - (bp, finalized, blockContext) <- case other of - Best -> (,False,BCBest) <$> bestBlockConsensusV1 - LastFinal -> (,True,BCHistorical) <$> use SkovV1.lastFinalized - (getHash bp,) . Just <$> av1 evc bp finalized blockContext + (bp, finalized) <- case other of + Best -> (,False) <$> bestBlockConsensusV1 + LastFinal -> (,True) <$> use SkovV1.lastFinalized + (getHash bp,) . Just <$> av1 evc bp finalized ) return $ case maybeValue of Just v -> BQRBlock bh v @@ -662,7 +648,7 @@ getNextAccountNonce accountAddress = getBlockInfo :: BlockHashInput -> MVR finconf (BHIQueryResponse BlockInfo) getBlockInfo = liftSkovQueryBHIAndVersion - ( \evc bp _ -> do + ( \evc bp -> do let biBlockHash = getHash bp let biGenesisIndex = evcIndex evc biBlockParent <- @@ -697,7 +683,7 @@ getBlockInfo = let biEpoch = Nothing return BlockInfo{..} ) - ( \evc bp biFinalized _ -> do + ( \evc bp biFinalized -> do let biBlockHash = getHash bp let biGenesisIndex = evcIndex evc biBlockParent <- @@ -1028,15 +1014,7 @@ getAncestors bhi count = -- | Get a list of all accounts in the block state. getAccountList :: BlockHashInput -> MVR finconf (BHIQueryResponse [AccountAddress]) -getAccountList = - liftSkovQueryBHIAndVersion - (\_ bpt context -> getAccounts context =<< blockState bpt) - (\_ bpt _ context -> getAccounts context =<< blockState bpt) - where - getAccounts context bState = - case context of - BCBest -> BS.getAccountList bState - BCHistorical -> BS.getAccountListHistorical bState +getAccountList = liftSkovQueryStateBHI BS.getAccountList -- | Get a list of all smart contract instances in the block state. getInstanceList :: BlockHashInput -> MVR finconf (BHIQueryResponse [ContractAddress]) @@ -1289,14 +1267,14 @@ getFirstBlockEpoch (EpochOfBlock blockInput) = do where unBHIResponse BQRNoBlock = Left EQEBlockNotFound unBHIResponse (BQRBlock _ res) = res - epochOfBlockV0 curVersionIndex evc b _ = + epochOfBlockV0 curVersionIndex evc b = getFirstFinalizedOfEpoch (Right b) <&> \case Left FutureEpoch | evcIndex evc == curVersionIndex -> Left EQEFutureEpoch | otherwise -> Left EQEInvalidEpoch Left EmptyEpoch -> Left EQEBlockNotFound Right epochBlock -> Right (getHash epochBlock) - epochOfBlockV1 curVersionIndex evc b _ _ = + epochOfBlockV1 curVersionIndex evc b _ = (SkovV1.getFirstFinalizedBlockOfEpoch (Right b) =<< get) <&> \case Nothing | evcIndex evc == curVersionIndex -> Left EQEFutureEpoch @@ -1346,8 +1324,8 @@ getWinningBakersEpoch (EpochOfBlock blockInput) = do let curVersionIndex = fromIntegral (Vec.length versions - 1) res <- liftSkovQueryBHIAndVersion - (\_ _ _ -> return (Left EQEInvalidGenesisIndex)) - ( \evc b _ _ -> do + (\_ _ -> return (Left EQEInvalidGenesisIndex)) + ( \evc b _ -> do mwbs <- ConsensusV1.getWinningBakersForEpoch (SkovV1.blockEpoch b) =<< get return $! case mwbs of Nothing diff --git a/concordium-consensus/src/Concordium/Types/Option.hs b/concordium-consensus/src/Concordium/Types/Option.hs index 49a13bb6b3..de28932584 100644 --- a/concordium-consensus/src/Concordium/Types/Option.hs +++ b/concordium-consensus/src/Concordium/Types/Option.hs @@ -1,16 +1,18 @@ {-# LANGUAGE DeriveTraversable #-} + -- | This module provides a strict version of 'Maybe'. module Concordium.Types.Option ( - -- * Strict version of 'Maybe'. - Option(..), - -- * Auxiliary functions - putOptionOf, - getOptionOf, - isPresent, - isAbsent, - fromOption, - ofOption - ) where + -- * Strict version of 'Maybe'. + Option (..), + + -- * Auxiliary functions + putOptionOf, + getOptionOf, + isPresent, + isAbsent, + fromOption, + ofOption, +) where import Data.Serialize diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs index de5544d4a5..9d9d510998 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs @@ -68,8 +68,6 @@ checkBinaryM bop x y sbop sx sy = do checkEquivalent :: (P.SupportsPersistentAccount PV m, av ~ AccountVersionFor PV) => B.Accounts PV -> P.Accounts PV -> m () checkEquivalent ba pa = do addrsAndIndices <- P.allAccounts pa - viaTable <- P.allAccountsViaTable pa - checkBinary (==) (Map.fromList viaTable) (Map.fromList addrsAndIndices) "==" "Account table" "Persistent account map" checkBinary (==) (AccountMap.toMapPure (B.accountMap ba)) (Map.fromList addrsAndIndices) "==" "Basic account map" "Persistent account map" let bat = BAT.toList (B.accountTable ba) pat <- L.toAscPairList (P.accountTable pa) From 535ee11de5914b0b50a50319ad600392f667814d Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Sat, 4 Nov 2023 07:54:18 +0100 Subject: [PATCH 61/92] Reconstruct difference maps for certified blocks on startup. --- .../GlobalState/AccountMap/DifferenceMap.hs | 47 +++++++++++++++- .../Concordium/GlobalState/AccountMap/LMDB.hs | 21 ++----- .../src/Concordium/GlobalState/BlockState.hs | 16 ++++++ .../GlobalState/Persistent/Accounts.hs | 31 +++++++--- .../GlobalState/Persistent/BlockState.hs | 4 ++ .../src/Concordium/KonsensusV1/SkovMonad.hs | 2 - .../KonsensusV1/TreeState/LowLevel/LMDB.hs | 56 ++++++------------- .../KonsensusV1/TreeState/StartUp.hs | 27 +++++++-- 8 files changed, 134 insertions(+), 70 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index 633878144c..3e81135a15 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -3,7 +3,35 @@ -- | The 'DifferenceMap' stores accounts that have been created in a non-finalized block. -- When a block is finalized then the associated 'DifferenceMap' must be written -- to disk via 'Concordium.GlobalState.AccountMap.LMDB.insertAccounts'. -module Concordium.GlobalState.AccountMap.DifferenceMap where +module Concordium.GlobalState.AccountMap.DifferenceMap ( + -- * The difference map definition. + DifferenceMap (..), + + -- * A mutable reference to a 'DifferenceMap'. + DifferenceMapReference, + + -- * The empty reference + emptyReference, + + -- * Get a list of all @(AccountAddress, AccountIndex)@ pairs for the + + -- provided 'DifferenceMap' and all parent maps. + flatten, + + -- * Create an empty 'DifferenceMap' + empty, + + -- * Insert an account into the 'DifferenceMap'. + fromList, + + -- * Lookup in a difference map (and potential parent maps) whether + + -- it yields the 'AccountIndex' for the provided 'AccountAddress'. + insert, + + -- * Set the accounts int he 'DifferenceMap'. + lookup, +) where import Control.Monad.IO.Class import Data.Bifunctor @@ -14,6 +42,13 @@ import Prelude hiding (lookup) import Concordium.Types import Concordium.Types.Option (Option (..)) +-- | A mutable reference to a 'DiffMap.DifferenceMap'. +type DifferenceMapReference = IORef (Option DifferenceMap) + +-- | The empty reference +emptyReference :: (MonadIO m) => m (IORef (Option DifferenceMap)) +emptyReference = liftIO $ newIORef Absent + -- | A difference map that indicates newly added accounts for -- a block identified by a 'BlockHash' and its associated 'BlockHeight'. -- The difference map only contains accounts that were added since the '_dmParentMapRef'. @@ -28,7 +63,7 @@ data DifferenceMap = DifferenceMap -- to multiple blocks if they have not yet been persisted. -- So the 'IORef' enables us to when persisting a block, -- then we also clear the 'DifferenceMap' for the child block. - dmParentMapRef :: !(IORef (Option DifferenceMap)) + dmParentMapRef :: !DifferenceMapReference } deriving (Eq) @@ -76,3 +111,11 @@ lookup addr = check -- Note that it is up to the caller to ensure only the canonical 'AccountAddress' is being inserted. insert :: AccountAddress -> AccountIndex -> DifferenceMap -> DifferenceMap insert addr accIndex m = m{dmAccounts = HM.insert (accountAddressEmbed addr) accIndex $ dmAccounts m} + +-- | Create a 'DifferenceMap' with the provided parent and list of account addresses and account indices. +fromList :: IORef (Option DifferenceMap) -> [(AccountAddress, AccountIndex)] -> DifferenceMap +fromList parentRef listOfAccountsAndIndices = + DifferenceMap + { dmAccounts = HM.fromList $ map (first accountAddressEmbed) listOfAccountsAndIndices, + dmParentMapRef = parentRef + } diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index bf03d85644..ee48ef5fef 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -16,20 +16,21 @@ -- -- The LMDB account map only stores accounts that are finalized. -- Non finalized accounts are being kept in a 'DifferenceMap' which --- is written to this LMDB account map when a block is persisted. +-- is written to this LMDB account map when a block is finalized. +-- +-- This also means that accounts once put in the account map, then +-- they can never be deleted again (hence they're finalized). -- -- As opposed to the account table of the block state this database does not -- include historical data i.e., the state of this database is from the perspective -- of the last finalized block always. --- For querying historical data (e.g. which accounts existed in a given block) then one --- should use the account table. -- -- The account map is integrated with the block state “on-the-fly” meaning that -- whenever the node starts up and the account map is not populated, then it will be -- initialized on startup via the existing ‘PersistentAccountMap’. -- -- Invariants: --- * Only accounts that are in either certified or finalized blocks are present in the ‘AccountMap’ +-- * Only accounts that are in finalized blocks are present in the ‘AccountMap’ module Concordium.GlobalState.AccountMap.LMDB where import Control.Concurrent @@ -97,7 +98,6 @@ class (Monad m) => MonadAccountMapStore m where -- | Return all the canonical addresses and their associated account indices of accounts present -- in the store where their @AccountIndex@ is less or equal to the provided @AccountIndex@. - -- In particular the provided @AccountIndex@ should match the size of the account table minus one. getAllAccounts :: AccountIndex -> m [(AccountAddress, AccountIndex)] -- | Checks whether the lmdb store is initialized or not. @@ -228,17 +228,6 @@ newtype AccountMapStoreMonad (m :: Type -> Type) (a :: Type) = AccountMapStoreMo deriving instance (MonadProtocolVersion m) => MonadProtocolVersion (AccountMapStoreMonad m) --- | Delete the provided accounts from the LMDB store. --- --- This function should only be used when rolling back certified blocks. When rolling back finalized blocks, --- no accounts should be deleted as they are already confirmed to be finalized. -unsafeRollback :: (MonadIO m, MonadLogger m, MonadReader r m, HasDatabaseHandlers r) => [AccountAddress] -> m () -unsafeRollback accounts = do - handlers <- ask - let env = handlers ^. dbhStoreEnv - runAccountMapStoreMonad $ asWriteTransaction env $ \txn -> do - forM_ accounts $ \accAddr -> deleteRecord txn (handlers ^. dbhAccountMapStore) accAddr - -- | When looking up accounts we perform a prefix search as we -- store the canonical account addresses in the lmdb store and we -- need to be able to lookup account aliases. diff --git a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs index ff97dffae8..6d1ea4b6c3 100644 --- a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs @@ -62,6 +62,7 @@ import Data.Word import qualified Concordium.Crypto.SHA256 as H import Concordium.GlobalState.Account +import qualified Concordium.GlobalState.AccountMap.DifferenceMap as DiffMap import Concordium.GlobalState.Classes import Concordium.GlobalState.Persistent.BlobStore import qualified Concordium.GlobalState.Wasm as GSWasm @@ -1389,6 +1390,19 @@ class (BlockStateOperations m, FixedSizeSerialization (BlockStateRef m)) => Bloc -- Precondition: The block state must be in memory and it must not have been archived. saveAccounts :: BlockState m -> m () + -- | Reconstructs the account difference map and return it. + -- Preconditions: + -- * This function MUST only be called on a certified block. + -- * This function MUST only be called on a block state that does not already + -- * have a difference map. + -- * The provided list of accounts MUST correspond to the accounts created in the block, + -- and the account addresses in the list MUST be by order of creation. + -- * The provided difference map (if any) MUST be the one of the parent block. + -- + -- This function should only be used when starting from an already initialized state, and hence + -- we need to reconstruct the difference map since the accounts are not yet finalized. + reconstructAccountDifferenceMap :: BlockState m -> DiffMap.DifferenceMapReference -> [AccountAddress] -> m DiffMap.DifferenceMapReference + -- | Load a block state from a reference, given its state hash if provided, -- otherwise calculate the state hash upon loading. -- In particular the 'StateHash' should be supplied if loading a non-genesis block state. @@ -1682,6 +1696,7 @@ instance (Monad (t m), MonadTrans t, BlockStateStorage m) => BlockStateStorage ( archiveBlockState = lift . archiveBlockState saveBlockState = lift . saveBlockState saveAccounts = lift . saveAccounts + reconstructAccountDifferenceMap bs parentMap accs = lift $ reconstructAccountDifferenceMap bs parentMap accs loadBlockState hsh = lift . loadBlockState hsh serializeBlockState = lift . serializeBlockState blockStateLoadCallback = lift blockStateLoadCallback @@ -1695,6 +1710,7 @@ instance (Monad (t m), MonadTrans t, BlockStateStorage m) => BlockStateStorage ( {-# INLINE purgeBlockState #-} {-# INLINE archiveBlockState #-} {-# INLINE saveBlockState #-} + {-# INLINE reconstructAccountDifferenceMap #-} {-# INLINE loadBlockState #-} {-# INLINE serializeBlockState #-} {-# INLINE blockStateLoadCallback #-} diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index bf3c7cd9cf..616b58fd78 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -49,7 +49,7 @@ -- -- General flow -- The account map resides in its own lmdb database and functions across protocol versions. --- For non-persisted blocks, then the ‘DifferenceMap’ is either @IORef Nothing@ or @IORef (Just DifferenceMap)@ depending on whether the block is written to disk. +-- For non-persisted blocks, then the ‘DifferenceMap’ is 'DiffMap.DifferenceMapReference' i.e., either @IORef Nothing@ or @IORef (Just DifferenceMap)@ depending on whether the block is written to disk. -- The 'putNewAccount' function creates a new 'DifferenceMap' on demand, hence a new 'Accounts' is initialized with a @accountDiffMap@ set to @IORef Nothing@. -- Subsequent accounts created are then being added to the difference map created by the first invocation of 'putNewAccount'. -- Blocks that are persisted always have a @IORef Nothing@ 'accountDiffMapRef'. @@ -135,7 +135,7 @@ data Accounts (pv :: ProtocolVersion) = Accounts -- The 'DiffMap.DifferenceMap' is wrapped in an 'IORef' because it is inherited -- by child blocks, and so when this block state is persisted then we need to clear it -- for any children block states. - accountDiffMapRef :: !(IORef (Option DiffMap.DifferenceMap)) + accountDiffMapRef :: !DiffMap.DifferenceMapReference } instance (IsProtocolVersion pv) => Show (Accounts pv) where @@ -169,6 +169,14 @@ writeAccountsCreated bh Accounts{..} = do liftIO $ atomicWriteIORef accountDiffMapRef Absent LMDBAccountMap.insertAccounts bh listOfAccountsCreated +-- | Create and set the 'DiffMap.DifferenceMap' for the provided @Accounts pv@. +-- Precondition: The provided @IORef (Option (DiffMap.DifferenceMap))@ MUST correspond to the parent map. +reconstructDifferenceMap :: (SupportsPersistentAccount pv m) => DiffMap.DifferenceMapReference -> [AccountAddress] -> Accounts pv -> m DiffMap.DifferenceMapReference +reconstructDifferenceMap parentRef listOfAccounts Accounts{..} = do + let diffMap' = DiffMap.fromList parentRef $ zip listOfAccounts $ map AccountIndex [L.size accountTable + 1 ..] + liftIO $ atomicWriteIORef accountDiffMapRef $ Present diffMap' + return accountDiffMapRef + instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where storeUpdate Accounts{..} = do -- put an empty 'OldMap.PersistentAccountMap'. @@ -197,7 +205,7 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where return $ do accountTable <- maccountTable accountRegIdHistory <- mrRIH - accountDiffMapRef <- liftIO $ newIORef Absent + accountDiffMapRef <- liftIO DiffMap.emptyReference return $ Accounts{..} instance (SupportsPersistentAccount pv m, av ~ AccountVersionFor pv) => Cacheable1 m (Accounts pv) (PersistentAccount av) where @@ -210,7 +218,7 @@ instance (SupportsPersistentAccount pv m, av ~ AccountVersionFor pv) => Cacheabl -- to an empty 'DiffMap.DifferenceMap'. emptyAccounts :: (MonadIO m) => m (Accounts pv) emptyAccounts = do - accountDiffMapRef <- liftIO $ newIORef Absent + accountDiffMapRef <- liftIO DiffMap.emptyReference return $ Accounts L.empty Trie.empty accountDiffMapRef -- | Add a new account. Returns @Just idx@ if the new account is fresh, i.e., the address does not exist, @@ -226,7 +234,7 @@ putNewAccount !acct a0@Accounts{..} = do accountDiffMapRef' <- case mAccountDiffMap of Absent -> do -- create a difference map for this block state with a @Nothing@ as the parent. - freshDifferenceMap <- liftIO $ newIORef (Absent :: Option DiffMap.DifferenceMap) + freshDifferenceMap <- liftIO DiffMap.emptyReference return $ DiffMap.insert addr accIdx $ DiffMap.empty freshDifferenceMap Present accDiffMap -> do -- reuse the already existing difference map for this block state. @@ -270,11 +278,20 @@ getAccountIndex addr Accounts{..} = do Just accIdx -> return $ Just accIdx Nothing -> lookupDisk where - -- Lookup the 'AccountIndex' in the lmdb backed account map. + -- Lookup the 'AccountIndex' in the lmdb backed account map, + -- and make sure it's within the bounds of the account table. + -- We do the bounds check as it could be that the lmdb backed account map + -- yields accounts which are not yet present in the @accountTable@. + -- In particular this can be the case if finalized blocks has been rolled + -- back as part of database recovery. + checkBounds (AccountIndex k) = k <= L.size accountTable - 1 lookupDisk = LMDBAccountMap.lookupAccountIndex addr >>= \case Nothing -> return Nothing - Just accIdx -> return $ Just accIdx + Just accIdx -> + if checkBounds accIdx + then return $ Just accIdx + else return Nothing -- | Retrieve an account with the given address. -- Returns @Nothing@ if no such account exists. diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 718658a7b7..88974db7b3 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -3580,6 +3580,10 @@ instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateStorage -- block. void $ Accounts.writeAccountsCreated hpbsHash accs + reconstructAccountDifferenceMap HashedPersistentBlockState{..} parentDifferenceMap listOfAccounts = do + accs <- bspAccounts <$> loadPBS hpbsPointers + Accounts.reconstructDifferenceMap parentDifferenceMap listOfAccounts accs + loadBlockState hpbsHashM ref = do hpbsPointers <- liftIO $ newIORef $ blobRefToBufferedRef ref case hpbsHashM of diff --git a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs index e3e2a7dc31..64e4fa2954 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs @@ -519,8 +519,6 @@ initialiseExistingSkovV1 bakerCtx handlerCtx unliftSkov GlobalStateConfig{..} = ++ show rbrCount ++ " blocks. Truncating block state database." liftIO $ truncateBlobStore (bscBlobStore . PBS.pbscBlobStore $ pbsc) rbrBestState - logEvent Skov LLWarning $ "Deleting " <> show (length rbrAccountsForDeletion) <> " from account map." - runReaderT (LMDBAccountMap.unsafeRollback rbrAccountsForDeletion) pbsc let initContext = InitContext pbsc skovLldb (initialSkovData, effectiveProtocolUpdate) <- runInitMonad diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs index a2e10f092f..92f47fb8c6 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs @@ -26,7 +26,6 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Data.Data import Data.List (intercalate) -import Data.Maybe (mapMaybe) import qualified Data.Serialize as S import Database.LMDB.Raw import Lens.Micro.Platform @@ -34,12 +33,10 @@ import System.Directory import Concordium.Common.Version import qualified Concordium.Crypto.SHA256 as Hash -import Concordium.ID.Types import Concordium.Logger import Concordium.Types import Concordium.Types.HashableTo import Concordium.Types.Option -import Concordium.Types.Transactions import Concordium.GlobalState.LMDB.Helpers import Concordium.KonsensusV1.TreeState.LowLevel @@ -653,10 +650,7 @@ data RollbackResult = forall (pv :: ProtocolVersion). { -- | Number of blocks rolled back. rbrCount :: !Int, -- | Reference to the best block after the rollback. - rbrBestState :: !(BlockStateRef pv), - -- | Accounts that were created in (certified) blocks that are rolled back. - -- These must be deleted. - rbrAccountsForDeletion :: ![AccountAddress] + rbrBestState :: !(BlockStateRef pv) } -- | Remove certified and finalized blocks from the database whose states cannot be loaded. @@ -700,9 +694,9 @@ rollBackBlocksUntil checkState = do else do -- The last finalized block is not intact, so roll back all of the -- certified blocks, then roll back finalized blocks. - (count, accsCreated) <- purgeCertified + count <- purgeCertified (count', bstState) <- rollFinalized count lastFin - return $ RollbackResult count' bstState accsCreated + return $ RollbackResult count' bstState where -- Check the non-finalized certified blocks, from the highest round backwards. checkCertified :: @@ -720,13 +714,9 @@ rollBackBlocksUntil checkState = do (dbh ^. nonFinalizedQuorumCertificateStore) (getCursor CursorLast) case mHighestQC of - Nothing -> return $ RollbackResult 0 bestState [] + Nothing -> return $ RollbackResult 0 bestState Just (Left e) -> throwM . DatabaseRecoveryFailure $ e - Just (Right (_, qc)) -> checkCertifiedWithQC lastFinRound bestState 0 [] qc - -- Get the account address of a credential deployment. - getAccountAddressFromDeployment bi = case bi of - WithMetadata{wmdData = CredentialDeployment{biCred = AccountCreation{..}}} -> (Just . addressFromRegId . credId) credential - _ -> Nothing + Just (Right (_, qc)) -> checkCertifiedWithQC lastFinRound bestState 0 qc -- Given the round and QC for a certified block, check that the block's state can be -- loaded, and then iterate for the previous round. checkCertifiedWithQC :: @@ -736,13 +726,11 @@ rollBackBlocksUntil checkState = do BlockStateRef pv -> -- number of blocks rolled back so far Int -> - -- accounts created in the certified blocks - [AccountAddress] -> -- QC for certified block to check QuorumCertificate -> -- returns the @RollbackResult@. DiskLLDBM pv m RollbackResult - checkCertifiedWithQC lastFinRound bestState !count accsCreated qc = do + checkCertifiedWithQC lastFinRound bestState !count qc = do dbh <- ask mBlock <- asReadTransaction (dbh ^. storeEnv) $ \txn -> loadRecord txn (dbh ^. blockStore) (qcBlock qc) @@ -758,11 +746,8 @@ rollBackBlocksUntil checkState = do lastFinRound (max bestState (stbStatePointer block)) count - accsCreated (qcRound qc - 1) else do - -- Record the accounts created in the rolled back certified block. - let accountsToDelete = mapMaybe getAccountAddressFromDeployment (blockTransactions block) -- Delete the block and the QC asWriteTransaction (dbh ^. storeEnv) $ \txn -> do void $ @@ -780,7 +765,6 @@ rollBackBlocksUntil checkState = do lastFinRound bestState (count + 1) - (accsCreated ++ accountsToDelete) (qcRound qc - 1) -- Step the non-finalized certified block check to the previous round. checkCertifiedPreviousRound :: @@ -790,46 +774,40 @@ rollBackBlocksUntil checkState = do BlockStateRef pv -> -- number of blocks rolled back so far Int -> - -- Accounts created in the certified blocks - [AccountAddress] -> -- round to check for Round -> -- returns the @RollbackResult@. DiskLLDBM pv m RollbackResult - checkCertifiedPreviousRound lastFinRound bestState count accsCreated currentRound - | currentRound <= lastFinRound = return $ RollbackResult count bestState accsCreated + checkCertifiedPreviousRound lastFinRound bestState count currentRound + | currentRound <= lastFinRound = return $ RollbackResult count bestState | otherwise = do dbh <- ask mNextQC <- asReadTransaction (dbh ^. storeEnv) $ \txn -> loadRecord txn (dbh ^. nonFinalizedQuorumCertificateStore) currentRound case mNextQC of Nothing -> - checkCertifiedPreviousRound lastFinRound bestState count accsCreated (currentRound - 1) + checkCertifiedPreviousRound lastFinRound bestState count (currentRound - 1) Just qc -> - checkCertifiedWithQC lastFinRound bestState count accsCreated qc + checkCertifiedWithQC lastFinRound bestState count qc -- Purge all of the certified blocks. Returns the number of blocks rolled back. purgeCertified = do dbh <- ask - (count, hashes, accsToDelete) <- asWriteTransaction (dbh ^. storeEnv) $ \txn -> do + (count, hashes) <- asWriteTransaction (dbh ^. storeEnv) $ \txn -> do withCursor txn (dbh ^. nonFinalizedQuorumCertificateStore) $ \cursor -> do - let loop !count accsToDelete hashes Nothing = return (count, hashes, accsToDelete) - loop _ _ _ (Just (Left e)) = throwM . DatabaseRecoveryFailure $ e - loop !count accsToDelete hashes (Just (Right (_, qc))) = do - accsToDelete' <- - loadRecord txn (dbh ^. blockStore) (qcBlock qc) >>= \case - Nothing -> return [] - Just block -> return $ mapMaybe getAccountAddressFromDeployment (blockTransactions block) + let loop !count hashes Nothing = return (count, hashes) + loop _ _ (Just (Left e)) = throwM . DatabaseRecoveryFailure $ e + loop !count hashes (Just (Right (_, qc))) = do _ <- deleteRecord txn (dbh ^. blockStore) (qcBlock qc) -- Delete the QC entry. deleteAtCursor cursor - loop (count + 1) (accsToDelete <> accsToDelete') (qcBlock qc : hashes) =<< getCursor CursorNext cursor - loop 0 [] [] =<< getCursor CursorFirst cursor + loop (count + 1) (qcBlock qc : hashes) =<< getCursor CursorNext cursor + loop 0 [] =<< getCursor CursorFirst cursor logEvent LMDB LLDebug $ "The block state for the last finalized block was corrupted. \ \The following certified blocks were deleted: " <> intercalate ", " (show <$> hashes) <> "." - return (count, accsToDelete) + return count -- Roll back finalized blocks until the last explicitly finalized block where the state -- check passes. rollFinalized count lastFin = do diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs index 8f572f2b2e..75c18c733d 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs @@ -9,6 +9,7 @@ import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.State.Strict import qualified Data.Map.Strict as Map +import Data.Maybe import qualified Data.Sequence as Seq import Lens.Micro.Platform @@ -21,12 +22,14 @@ import Concordium.Types.UpdateQueues import Concordium.Types.Updates import Concordium.Utils +import qualified Concordium.GlobalState.AccountMap.DifferenceMap as DiffMap import Concordium.GlobalState.BlockState import Concordium.GlobalState.Parameters hiding (getChainParameters) import qualified Concordium.GlobalState.Persistent.BlockState as PBS import qualified Concordium.GlobalState.Statistics as Stats import qualified Concordium.GlobalState.TransactionTable as TT import qualified Concordium.GlobalState.Types as GSTypes +import Concordium.ID.Types import Concordium.KonsensusV1.Consensus import Concordium.KonsensusV1.Consensus.Timeout import Concordium.KonsensusV1.Transactions @@ -38,6 +41,7 @@ import Concordium.Logger import Concordium.TimeMonad import Concordium.TransactionVerification as TVer import Concordium.Types.Option +import Concordium.Types.Transactions -- | Generate the 'EpochBakers' for a genesis block. genesisEpochBakers :: @@ -294,8 +298,9 @@ loadSkovData _runtimeParameters didRollback = do -- | Load the certified blocks from the low-level database into the tree state. -- This caches their block states, adds them to the block table and branches, -- adds their transactions to the transaction table and pending transaction table, --- updates the highest certified block, and records block signature witnesses and --- checked quorum certificates for the blocks. +-- updates the highest certified block, records block signature witnesses and +-- checked quorum certificates for the blocks, and inserts any created accounts into +-- the account difference maps for the certified blocks. -- -- This also sets the previous round timeout if the low level state records that it timed out. -- It also puts the latest timeout message in the set of timeout messages for the current round @@ -317,7 +322,12 @@ loadCertifiedBlocks :: m () loadCertifiedBlocks = do certBlocks <- LowLevel.lookupCertifiedBlocks - mapM_ loadCertBlock certBlocks + -- The first certified block will have the empty parent difference map reference. + emptyParent <- liftIO DiffMap.emptyReference + -- Load all certified blocks + -- This sets the skov state, puts transactions in the transaction table, + -- and reconstructs the account map difference maps for the certified blocks. + foldM_ (flip loadCertBlock) emptyParent certBlocks oLastTimeout <- use $ persistentRoundStatus . prsLatestTimeout forM_ oLastTimeout $ \lastTimeout -> do curRound <- use $ roundStatus . rsCurrentRound @@ -418,8 +428,16 @@ loadCertifiedBlocks = do when (tmRound (tmBody tm) == rs ^. rsCurrentRound) $ do forM_ (updateTimeoutMessages Absent tm) $ \tms -> currentTimeoutMessages .= Present tms where - loadCertBlock (storedBlock, qc) = do + -- Get the account address from a credential deployment. + getAccountAddressFromDeployment bi = case bi of + WithMetadata{wmdData = CredentialDeployment{biCred = AccountCreation{..}}} -> (Just . addressFromRegId . credId) credential + _ -> Nothing + loadCertBlock (storedBlock, qc) parentDifferenceMapReference = do blockPointer <- mkBlockPointer storedBlock + -- As only finalized accounts are stored in the account map, then + -- we need to reconstruct the 'DiffMap.DifferenceMap' here for the certified block we're loading. + let accountsToInsert = mapMaybe getAccountAddressFromDeployment (blockTransactions storedBlock) + newDifferenceMap <- reconstructAccountDifferenceMap (bpState blockPointer) parentDifferenceMapReference accountsToInsert cacheBlockState (bpState blockPointer) blockTable . liveMap . at' (getHash blockPointer) ?=! blockPointer addToBranches blockPointer @@ -450,6 +468,7 @@ loadCertifiedBlocks = do roundBakerExistingBlock (blockRound signedBlock) (blockBaker signedBlock) ?= toBlockSignatureWitness signedBlock recordCheckedQuorumCertificate qc + return newDifferenceMap -- Set the previous round timeout. setLastTimeout lastTimeout certBlock = do From 56b7c1327f9a3a1a27fffa732df3e0528b32faee Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Sat, 4 Nov 2023 07:54:54 +0100 Subject: [PATCH 62/92] storeRecord instead of storeReplaceRecord for insertions into lmdb account map. --- .../src/Concordium/GlobalState/AccountMap/LMDB.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index ee48ef5fef..17919cd380 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -246,7 +246,7 @@ instance dbh <- ask asWriteTransaction (dbh ^. dbhStoreEnv) $ \txn -> do forM_ accounts $ \(accAddr, accIndex) -> do - storeReplaceRecord txn (dbh ^. dbhAccountMapStore) accAddr accIndex + storeRecord txn (dbh ^. dbhAccountMapStore) accAddr accIndex storeReplaceRecord txn (dbh ^. dbhLfbHash) lfbKey lfb lookupAccountIndex a@(AccountAddress accAddr) = do From ec7d48bd39aca3ad9f06811f29878470f052501b Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Sat, 4 Nov 2023 11:22:37 +0100 Subject: [PATCH 63/92] Lookup account index with and without alias support. --- .../GlobalState/AccountMap/DifferenceMap.hs | 69 ++++++++++++------- .../Concordium/GlobalState/AccountMap/LMDB.hs | 53 +++++++------- .../GlobalState/Persistent/Accounts.hs | 29 ++++---- 3 files changed, 85 insertions(+), 66 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index 3e81135a15..fcb98b867c 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -4,37 +4,38 @@ -- When a block is finalized then the associated 'DifferenceMap' must be written -- to disk via 'Concordium.GlobalState.AccountMap.LMDB.insertAccounts'. module Concordium.GlobalState.AccountMap.DifferenceMap ( - -- * The difference map definition. - DifferenceMap (..), + -- * Definitions - -- * A mutable reference to a 'DifferenceMap'. + -- The difference map definition. + DifferenceMap (..), + -- A mutable reference to a 'DifferenceMap'. DifferenceMapReference, - -- * The empty reference - emptyReference, - - -- * Get a list of all @(AccountAddress, AccountIndex)@ pairs for the + -- * Auxiliary functions + -- The empty reference + emptyReference, + -- Get a list of all @(AccountAddress, AccountIndex)@ pairs for the -- provided 'DifferenceMap' and all parent maps. flatten, - - -- * Create an empty 'DifferenceMap' + -- Create an empty 'DifferenceMap' empty, - - -- * Insert an account into the 'DifferenceMap'. + -- Set the accounts int he 'DifferenceMap'. fromList, - - -- * Lookup in a difference map (and potential parent maps) whether - - -- it yields the 'AccountIndex' for the provided 'AccountAddress'. + -- Insert an account into the 'DifferenceMap'. insert, - - -- * Set the accounts int he 'DifferenceMap'. - lookup, + -- Lookup in a difference map (and potential parent maps) whether + -- it yields the 'AccountIndex' for the provided 'AccountAddress' or any + -- alias of it. + lookupViaEquivalenceClass, + -- Lookup in a difference map (and potential parent maps) whether + -- it yields the 'AccountIndex' for the provided 'AccountAddress'. + lookupExact, ) where import Control.Monad.IO.Class import Data.Bifunctor +import Data.Foldable import qualified Data.HashMap.Strict as HM import Data.IORef import Prelude hiding (lookup) @@ -93,13 +94,13 @@ empty mParentDifferenceMap = -- difference maps using the account address equivalence class. -- Returns @Just AccountIndex@ if the account is present and -- otherwise @Nothing@. --- Note that this implementation uses the 'AccountAddressEq' equivalence --- class for looking up an 'AccountIndex'. -lookup :: (MonadIO m) => AccountAddress -> DifferenceMap -> m (Maybe AccountIndex) -lookup addr = check +-- Precondition: As this implementation uses the 'AccountAddressEq' equivalence +-- class for looking up an 'AccountIndex', then it MUST only be used +-- when account aliases are supported. +lookupViaEquivalenceClass :: (MonadIO m) => AccountAddressEq -> DifferenceMap -> m (Maybe AccountIndex) +lookupViaEquivalenceClass addr = check where - k = accountAddressEmbed addr - check diffMap = case HM.lookup k (dmAccounts diffMap) of + check diffMap = case HM.lookup addr (dmAccounts diffMap) of Nothing -> do mParentMap <- liftIO $ readIORef (dmParentMapRef diffMap) case mParentMap of @@ -107,6 +108,26 @@ lookup addr = check Present parentMap -> check parentMap Just accIdx -> return $ Just accIdx +-- | Lookup an account in the difference map or any of the parent +-- difference maps via an exactness check. +-- Returns @Just AccountIndex@ if the account is present and +-- otherwise @Nothing@. +-- Precondition: As this implementation checks for exactness of the provided +-- @AccountAddress@ then it MUST only be used when account aliases are NOT supported. +-- +-- Implementation note: It is not as sufficient as 'lookupViaEquivalenceClass' as it folds over the accounts, +-- but this should be fine as the maps are generally very small. +lookupExact :: (MonadIO m) => AccountAddress -> DifferenceMap -> m (Maybe AccountIndex) +lookupExact addr diffMap = + foldl' + ( \_ (accAddr, accIdx) -> + if addr == accAddr + then return $ Just accIdx + else return Nothing + ) + (pure Nothing) + =<< flatten diffMap + -- | Insert an account into the difference map. -- Note that it is up to the caller to ensure only the canonical 'AccountAddress' is being inserted. insert :: AccountAddress -> AccountIndex -> DifferenceMap -> DifferenceMap diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index 17919cd380..c77040193a 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -83,18 +83,15 @@ class (Monad m) => MonadAccountMapStore m where -- last finalized block where the inputted accounts comes from. insertAccounts :: StateHash -> [(AccountAddress, AccountIndex)] -> m () - -- | Looks up the ‘AccountIndex’ for the provided ‘AccountAddress’. + -- | Looks up the ‘AccountIndex’ for the provided ‘AccountAddressEq’. -- Returns @Just AccountIndex@ if the account is present in the ‘AccountMap’ -- and returns @Nothing@ if the account was not present. - -- - -- Note that an implementor must adhere to the following: - -- * For protocol versions that does not support account aliases, - -- then the provided @AccountAddress@ must match exactly the one - -- present in the store. - -- * For protocol versions that does support account aliases, - -- then it's sufficient if the first 29 bytes of the accont address - -- matches the 'AccountAddress' recorded. - lookupAccountIndex :: AccountAddress -> m (Maybe AccountIndex) + lookupAccountIndexViaEquivalence :: AccountAddressEq -> m (Maybe AccountIndex) + + -- | Looks up the ‘AccountIndex’ for the provided ‘AccountAddressEq’. + -- Returns @Just AccountIndex@ if the account is present in the ‘AccountMap’ + -- and returns @Nothing@ if the account was not present. + lookupAccountIndexViaExactness :: AccountAddress -> m (Maybe AccountIndex) -- | Return all the canonical addresses and their associated account indices of accounts present -- in the store where their @AccountIndex@ is less or equal to the provided @AccountIndex@. @@ -105,11 +102,13 @@ class (Monad m) => MonadAccountMapStore m where instance (Monad (t m), MonadTrans t, MonadAccountMapStore m) => MonadAccountMapStore (MGSTrans t m) where insertAccounts lfb accs = lift $ insertAccounts lfb accs - lookupAccountIndex = lift . lookupAccountIndex + lookupAccountIndexViaEquivalence = lift . lookupAccountIndexViaEquivalence + lookupAccountIndexViaExactness = lift . lookupAccountIndexViaExactness getAllAccounts = lift . getAllAccounts isInitialized = lift isInitialized {-# INLINE insertAccounts #-} - {-# INLINE lookupAccountIndex #-} + {-# INLINE lookupAccountIndexViaEquivalence #-} + {-# INLINE lookupAccountIndexViaExactness #-} {-# INLINE getAllAccounts #-} {-# INLINE isInitialized #-} @@ -119,11 +118,13 @@ deriving via (MGSTrans (WriterT w) m) instance (Monoid w, MonadAccountMapStore m instance (MonadAccountMapStore m) => MonadAccountMapStore (PutT m) where insertAccounts lfb accs = lift $ insertAccounts lfb accs - lookupAccountIndex = lift . lookupAccountIndex + lookupAccountIndexViaEquivalence = lift . lookupAccountIndexViaEquivalence + lookupAccountIndexViaExactness = lift . lookupAccountIndexViaExactness getAllAccounts = lift . getAllAccounts isInitialized = lift isInitialized {-# INLINE insertAccounts #-} - {-# INLINE lookupAccountIndex #-} + {-# INLINE lookupAccountIndexViaEquivalence #-} + {-# INLINE lookupAccountIndexViaExactness #-} {-# INLINE getAllAccounts #-} {-# INLINE isInitialized #-} @@ -249,7 +250,7 @@ instance storeRecord txn (dbh ^. dbhAccountMapStore) accAddr accIndex storeReplaceRecord txn (dbh ^. dbhLfbHash) lfbKey lfb - lookupAccountIndex a@(AccountAddress accAddr) = do + lookupAccountIndexViaEquivalence a@(AccountAddressEq (AccountAddress accAddr)) = do dbh <- ask asReadTransaction (dbh ^. dbhStoreEnv) $ \txn -> withCursor txn (dbh ^. dbhAccountMapStore) $ \cursor -> do @@ -262,24 +263,18 @@ instance -- prefix lookup in the lmdb database, so if the account does not exist -- then the lmdb query would return the "next" account address -- by lexicographic order of account address. - if eqCheck a foundAccAddr + if a == accountAddressEmbed foundAccAddr then return $ Just accIdx else return Nothing where - -- If account aliases are supported then we check if - -- the found addresses matches the one we looked for via - -- the equivalence class 'AddressAccountEq'. - -- If account aliases are not supported then we check if the - -- found account address matches via exactness. - eqCheck actual found = - -- if supportsAccountAliases (protocolVersion @(MPV m)) - checkEquivalence actual found -- then checkEquivalence actual found - -- else actual == found - -- The key to use for looking up an account. - -- We do a prefix lookup on the first 29 bytes of the account address as - -- the last 3 bytes are reserved for aliases. + -- The key to use for looking up an account. + -- We do a prefix lookup on the first 29 bytes of the account address as + -- the last 3 bytes are reserved for aliases. accLookupKey = BS.take prefixAccountAddressSize $ FBS.toByteString accAddr - checkEquivalence x y = accountAddressEmbed x == accountAddressEmbed y + + lookupAccountIndexViaExactness addr = do + dbh <- ask + asReadTransaction (dbh ^. dbhStoreEnv) $ \txn -> loadRecord txn (dbh ^. dbhAccountMapStore) addr getAllAccounts maxAccountIndex = do dbh <- ask diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 616b58fd78..49ccc467a2 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -252,8 +252,6 @@ fromList accs = do insert accounts account = snd <$> putNewAccount account accounts -- | Determine if an account with the given address exists. --- Note that this is looking up via the account alias mechanism introduced in protocol version 3 for all protocol versions. --- This is fine as there are no clashes and this approach simplifies the implementation. exists :: (SupportsPersistentAccount pv m) => AccountAddress -> Accounts pv -> m Bool exists addr accts = isJust <$> getAccountIndex addr accts @@ -268,15 +266,22 @@ getAccountByCredId cid accs@Accounts{..} = -- | Get the 'AccountIndex' for the provided 'AccountAddress' (if any). -- First try lookup in the in-memory difference map associated with the the provided 'Accounts pv', -- if no account could be looked up, then we fall back to the lmdb backed account map. -getAccountIndex :: (SupportsPersistentAccount pv m) => AccountAddress -> Accounts pv -> m (Maybe AccountIndex) +-- +-- If account alises are supported then the equivalence class 'AccountAddressEq' is used for determining +-- whether the provided @AccountAddress@ is in the map, otherwise we check for exactness. +getAccountIndex :: forall pv m. (SupportsPersistentAccount pv m) => AccountAddress -> Accounts pv -> m (Maybe AccountIndex) getAccountIndex addr Accounts{..} = do mAccountDiffMap <- liftIO $ readIORef accountDiffMapRef case mAccountDiffMap of Absent -> lookupDisk Present accDiffMap -> - DiffMap.lookup addr accDiffMap >>= \case - Just accIdx -> return $ Just accIdx - Nothing -> lookupDisk + if supportsAccountAliases (protocolVersion @pv) + then DiffMap.lookupViaEquivalenceClass (accountAddressEmbed addr) accDiffMap >>= \case + Just accIdx -> return $ Just accIdx + Nothing -> lookupDisk + else DiffMap.lookupExact addr accDiffMap >>= \case + Just accIdx -> return $ Just accIdx + Nothing -> lookupDisk where -- Lookup the 'AccountIndex' in the lmdb backed account map, -- and make sure it's within the bounds of the account table. @@ -284,14 +289,12 @@ getAccountIndex addr Accounts{..} = do -- yields accounts which are not yet present in the @accountTable@. -- In particular this can be the case if finalized blocks has been rolled -- back as part of database recovery. - checkBounds (AccountIndex k) = k <= L.size accountTable - 1 + withSafeBounds Nothing = Nothing + withSafeBounds (Just accIdx@(AccountIndex k)) = if k <= L.size accountTable - 1 then Just accIdx else Nothing lookupDisk = - LMDBAccountMap.lookupAccountIndex addr >>= \case - Nothing -> return Nothing - Just accIdx -> - if checkBounds accIdx - then return $ Just accIdx - else return Nothing + if supportsAccountAliases (protocolVersion @pv) + then withSafeBounds <$> LMDBAccountMap.lookupAccountIndexViaEquivalence (accountAddressEmbed addr) + else withSafeBounds <$> LMDBAccountMap.lookupAccountIndexViaExactness addr -- | Retrieve an account with the given address. -- Returns @Nothing@ if no such account exists. From adde583d04acc4544a104c6324bbee2b7922d736 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Sun, 5 Nov 2023 08:37:32 +0100 Subject: [PATCH 64/92] Cleanup and fix tests. --- .../GlobalState/AccountMap/DifferenceMap.hs | 21 ++++---- .../Concordium/GlobalState/AccountMap/LMDB.hs | 33 +++--------- .../GlobalState/Persistent/Accounts.hs | 51 +++++++++---------- .../GlobalState/Persistent/BlockState.hs | 4 +- .../GlobalStateTests/DifferenceMap.hs | 17 +++++-- .../GlobalStateTests/LMDBAccountMap.hs | 49 ++++++++---------- .../tests/scheduler/SchedulerTests/Helpers.hs | 4 +- 7 files changed, 78 insertions(+), 101 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index fcb98b867c..bb9cf3a947 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -114,19 +114,16 @@ lookupViaEquivalenceClass addr = check -- otherwise @Nothing@. -- Precondition: As this implementation checks for exactness of the provided -- @AccountAddress@ then it MUST only be used when account aliases are NOT supported. --- --- Implementation note: It is not as sufficient as 'lookupViaEquivalenceClass' as it folds over the accounts, --- but this should be fine as the maps are generally very small. +-- Note that this implementation is very inefficient for large difference maps and thus should be revised +-- if the credential deployments limit gets revised significantly. lookupExact :: (MonadIO m) => AccountAddress -> DifferenceMap -> m (Maybe AccountIndex) -lookupExact addr diffMap = - foldl' - ( \_ (accAddr, accIdx) -> - if addr == accAddr - then return $ Just accIdx - else return Nothing - ) - (pure Nothing) - =<< flatten diffMap +lookupExact addr diffMap = do + listOfAccs <- flatten diffMap + case find isEq listOfAccs of + Nothing -> return Nothing + Just (_, accIdx) -> return $ Just accIdx + where + isEq (accAddr, _) = addr == accAddr -- | Insert an account into the difference map. -- Note that it is up to the caller to ensure only the canonical 'AccountAddress' is being inserted. diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index c77040193a..277ecbedcc 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -79,9 +79,7 @@ instance Exception DatabaseInvariantViolation where class (Monad m) => MonadAccountMapStore m where -- | Inserts the accounts to the underlying store. -- Only canonical addresses should be added. - -- The provided @BlockHash@ must correspond the to hash of the - -- last finalized block where the inputted accounts comes from. - insertAccounts :: StateHash -> [(AccountAddress, AccountIndex)] -> m () + insertAccounts :: [(AccountAddress, AccountIndex)] -> m () -- | Looks up the ‘AccountIndex’ for the provided ‘AccountAddressEq’. -- Returns @Just AccountIndex@ if the account is present in the ‘AccountMap’ @@ -101,7 +99,7 @@ class (Monad m) => MonadAccountMapStore m where isInitialized :: m Bool instance (Monad (t m), MonadTrans t, MonadAccountMapStore m) => MonadAccountMapStore (MGSTrans t m) where - insertAccounts lfb accs = lift $ insertAccounts lfb accs + insertAccounts accs = lift $ insertAccounts accs lookupAccountIndexViaEquivalence = lift . lookupAccountIndexViaEquivalence lookupAccountIndexViaExactness = lift . lookupAccountIndexViaExactness getAllAccounts = lift . getAllAccounts @@ -117,7 +115,7 @@ deriving via (MGSTrans (ExceptT e) m) instance (MonadAccountMapStore m) => Monad deriving via (MGSTrans (WriterT w) m) instance (Monoid w, MonadAccountMapStore m) => MonadAccountMapStore (WriterT w m) instance (MonadAccountMapStore m) => MonadAccountMapStore (PutT m) where - insertAccounts lfb accs = lift $ insertAccounts lfb accs + insertAccounts accs = lift $ insertAccounts accs lookupAccountIndexViaEquivalence = lift . lookupAccountIndexViaEquivalence lookupAccountIndexViaExactness = lift . lookupAccountIndexViaExactness getAllAccounts = lift . getAllAccounts @@ -133,9 +131,6 @@ instance (MonadAccountMapStore m) => MonadAccountMapStore (PutT m) where -- | Store that retains the account address -> account index mappings. newtype AccountMapStore = AccountMapStore MDB_dbi' --- | Store that retains the hash and height of the block that was inserted last. -newtype LfbHashStore = LfbHashStore MDB_dbi' - accountMapStoreName :: String accountMapStoreName = "accounts" @@ -146,13 +141,6 @@ instance MDBDatabase AccountMapStore where type DBKey AccountMapStore = AccountAddress type DBValue AccountMapStore = AccountIndex -lfbKey :: DBKey LfbHashStore -lfbKey = "lfb" - -instance MDBDatabase LfbHashStore where - type DBKey LfbHashStore = BS.ByteString - type DBValue LfbHashStore = StateHash - -- | Datbase handlers to interact with the account map lmdb -- database. Create via 'makeDatabasehandlers'. data DatabaseHandlers = DatabaseHandlers @@ -160,16 +148,14 @@ data DatabaseHandlers = DatabaseHandlers _dbhStoreEnv :: !StoreEnv, -- | The only store for this lmdb database. -- The account map functions as a persistent @AccountAddress -> Maybe AccountIndex@ mapping. - _dbhAccountMapStore :: !AccountMapStore, - -- | Hash of the state of the last finalized block which was used for inserting accounts. - _dbhLfbHash :: !LfbHashStore + _dbhAccountMapStore :: !AccountMapStore } makeClassy ''DatabaseHandlers -- | The number of stores in the LMDB environment for 'DatabaseHandlers'. databaseCount :: Int -databaseCount = 2 +databaseCount = 1 -- ** Initialization @@ -198,12 +184,6 @@ makeDatabaseHandlers accountMapDir readOnly = do txn (Just accountMapStoreName) [MDB_CREATE | not readOnly] - _dbhLfbHash <- - LfbHashStore - <$> mdb_dbi_open' - txn - (Just accountMapStoreName) - [MDB_CREATE | not readOnly] return DatabaseHandlers{..} -- | Create the lmdb stores and return back database handlers for interacting with it. @@ -243,12 +223,11 @@ instance ) => MonadAccountMapStore (AccountMapStoreMonad m) where - insertAccounts lfb accounts = do + insertAccounts accounts = do dbh <- ask asWriteTransaction (dbh ^. dbhStoreEnv) $ \txn -> do forM_ accounts $ \(accAddr, accIndex) -> do storeRecord txn (dbh ^. dbhAccountMapStore) accAddr accIndex - storeReplaceRecord txn (dbh ^. dbhLfbHash) lfbKey lfb lookupAccountIndexViaEquivalence a@(AccountAddressEq (AccountAddress accAddr)) = do dbh <- ask diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 49ccc467a2..db22a11b0d 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -16,10 +16,9 @@ -- it is kept in memory for the block until it either gets finalized or pruned. -- If a block is pruned then the retaining pointers are dropped and thus the block and associated ‘DifferenceMap’ is evicted from memory. -- --- A thawed block is behind a ‘BufferedRef’, this ‘BufferedRef’ is written to disk upon finalization --- (or certification for consensus version 1). -- This in return invokes ‘storeUpdate’ for all underlying references for the block state, for the particular block. --- When the accounts structure is being written to disk so is the ‘DifferenceMap’ and it is then being emptied. +-- When the accounts structure is finalized, then 'writeAccountsCreated' must be invoked in order to store the newly created accounts +-- in the LMDB backed account map. -- When thawing from a non-persisted block then the difference map is being inherited by the new thawed updatable block, -- thus the difference map potentially forms a chain of difference map "down" until the highest persisted block. -- @@ -31,25 +30,19 @@ -- If the map is not populated then it is being populated by traversing the account table -- and writing all @AccountAddress -> AccountIndex@ mappings into -- the lmdb store in one transaction and then it proceeds as normal. --- On the other hand, if the lmdb backed account map is already populated then the startup procedure will skip the populating step. +-- On the other hand, if the lmdb backed account map is already populated then the startup procedure will skip the populating step ('tryPopulateLMDBStore'). +-- +-- For consensus version 1, then the assoicated 'DiffMap.DifferenceMap' is reconstructed via 'reconstructDifferenceMap' for certified blocks. -- -- When starting up from a fresh genesis configuration then as part of creating the genesis state, -- then the difference map is being built containing all accounts present in the genesis configuration. -- When the genesis block is being written to disk, then so is the ‘DifferenceMap’ -- via the ‘storeUpdate’ implementation of the accounts structure. -- --- * Rollbacks --- For consensus version 0 no actions are required when rolling back blocks. --- That is because we only ever store finalized blocks in this consensus version, --- then there is no need to actually roll back any of the account present in the lmdb backed account map (as the accounts are finalized). --- --- For consensus version 1 we also store certified blocks in addition to the finalized blocks. --- Thus we have to roll back accounts that have been added to a certified block that is being rolled back. --- We do not need to roll back accounts that have been added as part of finalized blocks in this consensus version as explained above for consensus version 0. --- -- General flow -- The account map resides in its own lmdb database and functions across protocol versions. --- For non-persisted blocks, then the ‘DifferenceMap’ is 'DiffMap.DifferenceMapReference' i.e., either @IORef Nothing@ or @IORef (Just DifferenceMap)@ depending on whether the block is written to disk. +-- For non-persisted blocks, then the ‘DifferenceMap’ is 'DiffMap.DifferenceMapReference', +-- i.e. either @IORef Nothing@ or @IORef (Just DifferenceMap)@ depending on whether the block is written to disk. -- The 'putNewAccount' function creates a new 'DifferenceMap' on demand, hence a new 'Accounts' is initialized with a @accountDiffMap@ set to @IORef Nothing@. -- Subsequent accounts created are then being added to the difference map created by the first invocation of 'putNewAccount'. -- Blocks that are persisted always have a @IORef Nothing@ 'accountDiffMapRef'. @@ -58,7 +51,7 @@ -- -- (The ‘DifferenceMap’ consists of a @Map AccountAddress AccountIndes@ which retains the accounts that have been added to the chain for the associated block. -- Moreover the ‘DifferenceMap’ potentially retains a pointer to a so-called parent ‘DifferenceMap’. --- I.e. @Maybe DifferenceMap@. If this is @Nothing@ then it means that the parent block is certified or finalized. +-- I.e. @Maybe DifferenceMap@. If this is @Nothing@ then it means that the parent block is finalized or no accounts have been added. -- If the parent map yields a ‘DifferenceMap’ then the parent block is not persisted yet, and so the ‘DifferenceMap’ uses this parent map -- for keeping track of non persisted accounts for supporting e.g. queries via the ‘AccountAddress’. module Concordium.GlobalState.Persistent.Accounts where @@ -159,15 +152,15 @@ instance (SupportsPersistentAccount pv m) => MHashableTo m H.Hash (Accounts pv) -- -- Precondition: This MUST be called when finalizing the block state, and the -- provided @BlockHash@ must correespond to the hash of the finalized block. -writeAccountsCreated :: (SupportsPersistentAccount pv m) => StateHash -> Accounts pv -> m () -writeAccountsCreated bh Accounts{..} = do +writeAccountsCreated :: (SupportsPersistentAccount pv m) => Accounts pv -> m () +writeAccountsCreated Accounts{..} = do mAccountsCreated <- liftIO $ readIORef accountDiffMapRef case mAccountsCreated of Absent -> return () Present accountsCreated -> do listOfAccountsCreated <- liftIO $ DiffMap.flatten accountsCreated liftIO $ atomicWriteIORef accountDiffMapRef Absent - LMDBAccountMap.insertAccounts bh listOfAccountsCreated + LMDBAccountMap.insertAccounts listOfAccountsCreated -- | Create and set the 'DiffMap.DifferenceMap' for the provided @Accounts pv@. -- Precondition: The provided @IORef (Option (DiffMap.DifferenceMap))@ MUST correspond to the parent map. @@ -275,13 +268,15 @@ getAccountIndex addr Accounts{..} = do case mAccountDiffMap of Absent -> lookupDisk Present accDiffMap -> - if supportsAccountAliases (protocolVersion @pv) - then DiffMap.lookupViaEquivalenceClass (accountAddressEmbed addr) accDiffMap >>= \case - Just accIdx -> return $ Just accIdx - Nothing -> lookupDisk - else DiffMap.lookupExact addr accDiffMap >>= \case - Just accIdx -> return $ Just accIdx - Nothing -> lookupDisk + if supportsAccountAliases (protocolVersion @pv) + then + DiffMap.lookupViaEquivalenceClass (accountAddressEmbed addr) accDiffMap >>= \case + Just accIdx -> return $ Just accIdx + Nothing -> lookupDisk + else + DiffMap.lookupExact addr accDiffMap >>= \case + Just accIdx -> return $ Just accIdx + Nothing -> lookupDisk where -- Lookup the 'AccountIndex' in the lmdb backed account map, -- and make sure it's within the bounds of the account table. @@ -416,10 +411,10 @@ foldAccountsDesc f a accts = L.mfoldDesc f a (accountTable accts) -- Otherwise, this function does nothing. -- -- Precondition: The provided @BlockHash@ must correspond to the last finalized block when calling this function. -tryPopulateLMDBStore :: (SupportsPersistentAccount pv m) => StateHash -> Accounts pv -> m () -tryPopulateLMDBStore h accts = do +tryPopulateLMDBStore :: (SupportsPersistentAccount pv m) => Accounts pv -> m () +tryPopulateLMDBStore accts = do isInitialized <- LMDBAccountMap.isInitialized - unless isInitialized (void $ LMDBAccountMap.insertAccounts h =<< allAccountsViaTable) + unless isInitialized (void $ LMDBAccountMap.insertAccounts =<< allAccountsViaTable) where -- Get all accounts from the account table. allAccountsViaTable = do diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 88974db7b3..c62b68e65d 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -3578,7 +3578,7 @@ instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateStorage -- potentially non-finalized parent blocks. -- Note that this also empties the difference map for the -- block. - void $ Accounts.writeAccountsCreated hpbsHash accs + void $ Accounts.writeAccountsCreated accs reconstructAccountDifferenceMap HashedPersistentBlockState{..} parentDifferenceMap listOfAccounts = do accs <- bspAccounts <$> loadPBS hpbsPointers @@ -3774,7 +3774,7 @@ cacheState hpbs = do doTryPopulateAccountMap :: (SupportsPersistentState pv m) => HashedPersistentBlockState pv -> m () doTryPopulateAccountMap HashedPersistentBlockState{..} = do BlockStatePointers{..} <- loadPBS hpbsPointers - LMDBAccountMap.tryPopulateLMDBStore hpbsHash bspAccounts + LMDBAccountMap.tryPopulateLMDBStore bspAccounts -- | Cache the block state and get the initial (empty) transaction table with the next account nonces -- and update sequence numbers populated. diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs index fc9a549fb8..dddb3c6c04 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs @@ -24,12 +24,23 @@ import Concordium.Types.Option dummyPair :: Int -> (AccountAddress, AccountIndex) dummyPair seed = (fst $ randomAccountAddress (mkStdGen seed), AccountIndex $ fromIntegral seed) +-- | Test for looking up both via equivalence class and by exactness. +-- Precondition: The provided @AccountAddress@ MUST be the canonical address, +-- and it should be present in the underlying store. +-- The equivalence lookup always looks up by an alias. +testDoLookup :: (MonadIO m) => AccountAddress -> DiffMap.DifferenceMap -> m (Maybe AccountIndex) +testDoLookup accAddr diffMap = do + res1 <- DiffMap.lookupViaEquivalenceClass (accountAddressEmbed $ createAlias accAddr 42) diffMap + res2 <- DiffMap.lookupExact accAddr diffMap + liftIO $ assertEqual "results should be the same" res1 res2 + return res1 + -- | Test that an account can be inserted and looked up in the 'DiffMap.DifferenceMap'. testInsertLookupAccount :: Assertion testInsertLookupAccount = do emptyParentMap <- mkParentPointer Absent let diffMap = uncurry DiffMap.insert acc $ DiffMap.empty emptyParentMap - DiffMap.lookup (fst acc) diffMap >>= \case + testDoLookup (fst acc) diffMap >>= \case Nothing -> assertFailure "account should be present in diff map" Just accIdx -> assertEqual "account should be there" (snd acc) accIdx where @@ -56,7 +67,7 @@ testLookups = do checkExists (dummyPair 3) diffMap3 where checkExists pair diffMap = - DiffMap.lookup (fst pair) diffMap >>= \case + testDoLookup (fst pair) diffMap >>= \case Nothing -> assertFailure "account should be present" Just accIdx -> assertEqual "wrong account index" (snd pair) accIdx @@ -100,7 +111,7 @@ insertionsAndLookups = it "insertions and lookups" $ where checkAll ref diffMap = forM_ (HM.toList ref) (check diffMap) check diffMap (accAddr, accIdx) = do - DiffMap.lookup accAddr diffMap >>= \case + testDoLookup accAddr diffMap >>= \case Nothing -> liftIO $ assertFailure "account address should be present" Just actualAccIdx -> liftIO $ assertEqual "account index should be equal" accIdx actualAccIdx -- return the generated difference map(s) diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs index f76f78fcc1..d304d4d4ce 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs @@ -11,9 +11,11 @@ module GlobalStateTests.LMDBAccountMap where import Control.Exception (bracket) import Control.Monad.Reader -import Data.Maybe (isJust) +import Data.Maybe (isJust, isNothing) import System.IO.Temp import System.Random +import Test.HUnit +import Test.Hspec import Concordium.ID.Types (randomAccountAddress) import Concordium.Logger @@ -21,9 +23,6 @@ import Concordium.Types import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap -import Test.HUnit -import Test.Hspec - -- | Create a pair consisting of an account address and an account index based on the provided seed. dummyPair :: Int -> (AccountAddress, AccountIndex) dummyPair seed = (fst $ randomAccountAddress (mkStdGen seed), AccountIndex $ fromIntegral seed) @@ -39,6 +38,17 @@ runTest dirName action = withTempDirectory "" dirName $ \path -> LMDBAccountMap.closeDatabase (\dbh -> runSilentLogger $ runReaderT (LMDBAccountMap.runAccountMapStoreMonad action) dbh) +-- | Test for looking up both via equivalence class and by exactness. +-- Precondition: The provided @AccountAddress@ MUST be the canonical address, +-- and it should be present in the underlying store. +-- The equivalence lookup always goes through an alias. +testDoLookup :: (MonadIO m, LMDBAccountMap.MonadAccountMapStore m) => AccountAddress -> m (Maybe AccountIndex) +testDoLookup accAddr = do + res1 <- LMDBAccountMap.lookupAccountIndexViaExactness accAddr + res2 <- LMDBAccountMap.lookupAccountIndexViaEquivalence (accountAddressEmbed $ createAlias accAddr 42) + liftIO $ assertEqual "Results should be the same" res1 res2 + return res1 + -- | Test that a database is not initialized. testCheckNotInitialized :: Assertion testCheckNotInitialized = runTest "notinitialized" $ do @@ -60,7 +70,7 @@ testInsertAndLookupAccounts = runTest "insertandlookups" $ do void $ LMDBAccountMap.insertAccounts accounts forM_ accounts $ \(accAddr, accIndex) -> do - LMDBAccountMap.lookupAccountIndex accAddr >>= \case + testDoLookup accAddr >>= \case Nothing -> liftIO $ assertFailure $ "account was not present " <> show accAddr <> " account index " <> show accIndex Just foundAccountIndex -> liftIO $ assertEqual "account indices should be the same" accIndex foundAccountIndex @@ -69,7 +79,10 @@ testLookupAccountViaAlias :: Assertion testLookupAccountViaAlias = runTest "lookupviaalias" $ do -- initialize the database void $ LMDBAccountMap.insertAccounts [acc] - LMDBAccountMap.lookupAccountIndex (createAlias (fst acc) 42) >>= \case + let alias = createAlias (fst acc) 42 + exactLookup <- isNothing <$> LMDBAccountMap.lookupAccountIndexViaExactness alias + liftIO $ assertBool "Alias lookup should've failed" exactLookup + LMDBAccountMap.lookupAccountIndexViaEquivalence (accountAddressEmbed alias) >>= \case Nothing -> liftIO $ assertFailure "account could not be looked up via alias" Just accIndex -> liftIO $ assertEqual "account indices should match" (snd acc) accIndex where @@ -81,34 +94,15 @@ testGetAllAccounts = runTest "allaccounts" $ do -- initialize the database void $ LMDBAccountMap.insertAccounts $ dummyPair <$> [0 .. 42] void $ LMDBAccountMap.insertAccounts $ dummyPair <$> [42 .. 84] - allAccounts <- LMDBAccountMap.getAllAccounts + allAccounts <- LMDBAccountMap.getAllAccounts (AccountIndex 85) when (length allAccounts /= 85) $ liftIO $ assertFailure $ "unexpected number of accounts: " <> (show . length) allAccounts <> " should be " <> show (85 :: Int) forM_ (dummyPair <$> [0 .. 84]) $ \(accAddr, _) -> do - isPresent <- isJust <$> LMDBAccountMap.lookupAccountIndex accAddr + isPresent <- isJust <$> testDoLookup accAddr liftIO $ assertBool "account should be present" isPresent --- | Test that accounts can be rolled back i.e. deleted from the LMDB store and that --- the metadata is updated also. -testRollback :: Assertion -testRollback = runTest "rollback" $ do - -- initialize the database. - void $ LMDBAccountMap.insertAccounts [dummyPair 1] - void $ LMDBAccountMap.insertAccounts [dummyPair 2] - -- roll back one block. - LMDBAccountMap.lookupAccountIndex (fst $ dummyPair 2) >>= \case - Nothing -> liftIO $ assertFailure "account should be present" - Just _ -> do - void $ LMDBAccountMap.unsafeRollback [fst $ dummyPair 2] - LMDBAccountMap.lookupAccountIndex (fst $ dummyPair 2) >>= \case - Just _ -> liftIO $ assertFailure "account should have been deleted" - Nothing -> - LMDBAccountMap.lookupAccountIndex (fst $ dummyPair 1) >>= \case - Nothing -> liftIO $ assertFailure "Accounts from first block should still remain in the lmdb store" - Just accIdx -> liftIO $ assertEqual "The account index of the first account should be the same" (snd $ dummyPair 1) accIdx - tests :: Spec tests = describe "AccountMap.LMDB" $ do it "Test checking db is not initialized" testCheckNotInitialized @@ -116,4 +110,3 @@ tests = describe "AccountMap.LMDB" $ do it "Test inserts and lookups" testInsertAndLookupAccounts it "Test getting all accounts" testGetAllAccounts it "Test looking up account via alias" testLookupAccountViaAlias - it "Test rollback accounts" testRollback diff --git a/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs b/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs index 3970716bb8..8314414815 100644 --- a/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs +++ b/concordium-consensus/tests/scheduler/SchedulerTests/Helpers.hs @@ -150,8 +150,9 @@ createTestBlockStateWithAccounts accounts = do DummyData.dummyArs keys DummyData.dummyChainParameters - -- save the block state so accounts are written to the lmdb account map. + -- save block state and accounts. void $ BS.saveBlockState bs + void $ BS.saveAccounts bs return bs where keys = Types.withIsAuthorizationsVersionForPV (Types.protocolVersion @pv) $ DummyData.dummyKeyCollection @@ -384,6 +385,7 @@ reloadBlockState :: reloadBlockState persistentState = do frozen <- BS.freezeBlockState persistentState br <- BS.saveBlockState frozen + void $ BS.saveAccounts frozen BS.thawBlockState =<< BS.loadBlockState ((Just . BS.hpbsHash) frozen) br -- | Takes a function for checking the block state, which is then run on the block state, the block From 6f4865d1ab6d4d8564ca465c6f654d9b8595b307 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Tue, 7 Nov 2023 11:02:40 +0100 Subject: [PATCH 65/92] Address review comments. --- .../GlobalState/AccountMap/DifferenceMap.hs | 12 +++---- .../Concordium/GlobalState/AccountMap/LMDB.hs | 10 ++---- .../src/Concordium/GlobalState/BlockState.hs | 9 +---- .../Concordium/GlobalState/LMDB/Helpers.hs | 32 ++++++++++------- .../GlobalState/Persistent/Accounts.hs | 34 +++++++++++-------- .../GlobalState/Persistent/BlockState.hs | 27 +++++---------- .../Concordium/GlobalState/Persistent/LMDB.hs | 8 ++--- .../src/Concordium/ImportExport.hs | 6 ++-- .../src/Concordium/KonsensusV1/SkovMonad.hs | 4 +-- .../KonsensusV1/TreeState/StartUp.hs | 2 +- 10 files changed, 66 insertions(+), 78 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index bb9cf3a947..8fbfb309c1 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -13,8 +13,8 @@ module Concordium.GlobalState.AccountMap.DifferenceMap ( -- * Auxiliary functions - -- The empty reference - emptyReference, + -- Create a new empty mutable reference. + newEmptyReference, -- Get a list of all @(AccountAddress, AccountIndex)@ pairs for the -- provided 'DifferenceMap' and all parent maps. flatten, @@ -46,9 +46,9 @@ import Concordium.Types.Option (Option (..)) -- | A mutable reference to a 'DiffMap.DifferenceMap'. type DifferenceMapReference = IORef (Option DifferenceMap) --- | The empty reference -emptyReference :: (MonadIO m) => m (IORef (Option DifferenceMap)) -emptyReference = liftIO $ newIORef Absent +-- | Create a new empty reference. +newEmptyReference :: (MonadIO m) => m DifferenceMapReference +newEmptyReference = liftIO $ newIORef Absent -- | A difference map that indicates newly added accounts for -- a block identified by a 'BlockHash' and its associated 'BlockHeight'. @@ -83,7 +83,7 @@ flatten dmap = map (first aaeAddress) <$> go dmap [] -- | Create a new empty 'DifferenceMap' potentially based on the difference map of -- the parent. -empty :: IORef (Option DifferenceMap) -> DifferenceMap +empty :: DifferenceMapReference -> DifferenceMap empty mParentDifferenceMap = DifferenceMap { dmAccounts = HM.empty, diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index 277ecbedcc..651566c711 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -86,7 +86,7 @@ class (Monad m) => MonadAccountMapStore m where -- and returns @Nothing@ if the account was not present. lookupAccountIndexViaEquivalence :: AccountAddressEq -> m (Maybe AccountIndex) - -- | Looks up the ‘AccountIndex’ for the provided ‘AccountAddressEq’. + -- | Looks up the ‘AccountIndex’ for the provided ‘AccountAddress'. -- Returns @Just AccountIndex@ if the account is present in the ‘AccountMap’ -- and returns @Nothing@ if the account was not present. lookupAccountIndexViaExactness :: AccountAddress -> m (Maybe AccountIndex) @@ -209,12 +209,6 @@ newtype AccountMapStoreMonad (m :: Type -> Type) (a :: Type) = AccountMapStoreMo deriving instance (MonadProtocolVersion m) => MonadProtocolVersion (AccountMapStoreMonad m) --- | When looking up accounts we perform a prefix search as we --- store the canonical account addresses in the lmdb store and we --- need to be able to lookup account aliases. -prefixAccountAddressSize :: Int -prefixAccountAddressSize = 29 - instance ( MonadReader r m, HasDatabaseHandlers r, @@ -249,7 +243,7 @@ instance -- The key to use for looking up an account. -- We do a prefix lookup on the first 29 bytes of the account address as -- the last 3 bytes are reserved for aliases. - accLookupKey = BS.take prefixAccountAddressSize $ FBS.toByteString accAddr + accLookupKey = BS.take accountAddressPrefixSize $ FBS.toByteString accAddr lookupAccountIndexViaExactness addr = do dbh <- ask diff --git a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs index 6d1ea4b6c3..ed26002951 100644 --- a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs @@ -1353,13 +1353,6 @@ class (BlockStateOperations m, FixedSizeSerialization (BlockStateRef m)) => Bloc -- changes to it must not affect 'BlockState', but an efficient -- implementation should expect that only a small subset of the state will -- change, and thus a variant of copy-on-write should be used. - -- - -- The caller of this function should adhere to the following precondition: - -- * This function must only be called on the best block or a block that is already - -- retained in memory. - -- This function loads the provided blockstate into memory (which is fine for the - -- best block, as it is already in memory) but it should be avoided for blocks - -- that are not already in memory. thawBlockState :: BlockState m -> m (UpdatableBlockState m) -- | Freeze a mutable block state instance. The mutable state instance will @@ -1429,7 +1422,7 @@ class (BlockStateOperations m, FixedSizeSerialization (BlockStateRef m)) => Bloc cacheBlockStateAndGetTransactionTable :: BlockState m -> m TransactionTable -- | Populate the LMDB account map if it has not already been initialized. - -- If the lmdb store has already been intialized, then this function does nothing. + -- If the lmdb store has already been initialized, then this function does nothing. -- This function must only be invoked when starting up when then account table already -- contains accounts but these are not reflected in the lmdb backed account map. -- diff --git a/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs b/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs index b99133b0ea..2f7c1c869c 100644 --- a/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs +++ b/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs @@ -11,10 +11,12 @@ -- provide a type-safe abstraction over cursors. module Concordium.GlobalState.LMDB.Helpers ( -- * Database environment. - StoreEnv, + StoreEnv (..), makeStoreEnv, withWriteStoreEnv, seEnv, + seStepSize, + seMaxStepSize, defaultStepSize, defaultEnvSize, resizeDatabaseHandlers, @@ -285,12 +287,14 @@ data StoreEnv = StoreEnv -- we must ensure that there are no outstanding transactions. _seEnvLock :: !RWLock, -- | Database growth size increment. - -- This is currently set at 64MB, and must be a multiple of the page size. + -- Must be a multiple of the page size. _seStepSize :: !Int, -- | Maximum step to increment the database size. _seMaxStepSize :: !Int } +makeLenses ''StoreEnv + -- | Database growth size increment. -- This is currently set at 64MB, and must be a multiple of the page size. defaultStepSize :: Int @@ -304,10 +308,15 @@ defaultMaxStepSize = 2 ^ (30 :: Int) -- 1GB defaultEnvSize :: Int defaultEnvSize = 2 ^ (27 :: Int) -- 128MB -makeLenses ''StoreEnv - -- | Construct a new LMDB environment with associated locks that protect its use. -makeStoreEnv' :: Int -> Int -> IO StoreEnv +makeStoreEnv' :: + -- | Initial database growth when resizing the environment. + -- Precondition: Must be a multiple of the OS page size. + Int -> + -- | Maximum database growth size. + Int -> + -- | The resulting environment 'StoreEnv'. + IO StoreEnv makeStoreEnv' _seStepSize _seMaxStepSize = do _seEnv <- mdb_env_create _seEnvLock <- initializeLock @@ -454,11 +463,8 @@ data CursorMove -- | Move a cursor and read the key and value at the new location. getPrimitiveCursor :: CursorMove -> PrimitiveCursor -> IO (Maybe (MDB_val, MDB_val)) getPrimitiveCursor movement PrimitiveCursor{..} = do - res <- case mKey of - Nothing -> mdb_cursor_get' moveOp pcCursor pcKeyPtr pcValPtr - Just k -> do - poke pcKeyPtr k - mdb_cursor_get' moveOp pcCursor pcKeyPtr pcValPtr + mapM_ (poke pcKeyPtr) mKey + res <- mdb_cursor_get' moveOp pcCursor pcKeyPtr pcValPtr if res then do key <- peek pcKeyPtr @@ -692,12 +698,14 @@ databaseSize :: databaseSize txn dbi = fromIntegral . ms_entries <$> mdb_stat' txn (mdbDatabase dbi) -- | Increase the database size by at least the supplied size. --- The size SHOULD be a multiple of 'dbStepSize', and MUST be a multiple of the page size. +-- The provided size will be rounded up to a multiple of 'seStepSize'. +-- This ensures that the new size is a multiple of the page size, which is required by lmdb. resizeDatabaseHandlers :: (MonadIO m, MonadLogger m) => StoreEnv -> Int -> m () resizeDatabaseHandlers env delta = do envInfo <- liftIO $ mdb_env_info (env ^. seEnv) let oldMapSize = fromIntegral $ me_mapsize envInfo - newMapSize = oldMapSize + delta + stepSize = env ^. seStepSize + newMapSize = oldMapSize + (delta + stepSize - delta `mod` stepSize) _storeEnv = env logEvent LMDB LLDebug $ "Resizing database from " ++ show oldMapSize ++ " to " ++ show newMapSize liftIO . withWriteStoreEnv env $ flip mdb_env_set_mapsize newMapSize diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index db22a11b0d..d38377ab2c 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -120,8 +120,8 @@ data Accounts (pv :: ProtocolVersion) = Accounts accountRegIdHistory :: !(Trie.TrieN UnbufferedFix ID.RawCredentialRegistrationID AccountIndex), -- | An in-memory difference map used keeping track of accounts -- added in live blocks. - -- This is @Nothing@ if either the block is persisted or no accounts have been - -- added in the block. + -- This is @Absent@ if either the block is persisted, or no accounts have been + -- added for this block any parent non-persisted blocks. -- Otherwise if the block is not persisted and accounts have been added, then -- the 'DiffMap.DifferenceMap' yields the @AccountAddress -> AccountIndex@ mapping for -- accounts created in the block, where the account addresses are in canonical form. @@ -162,6 +162,14 @@ writeAccountsCreated Accounts{..} = do liftIO $ atomicWriteIORef accountDiffMapRef Absent LMDBAccountMap.insertAccounts listOfAccountsCreated +-- | Create a new @Accounts pv@ structure from the provided one. +-- This function creates a new 'DiffMap.DifferenceMap' for the resulting @Accounts pv@ which +-- has a reference to the provided @Accounts pv@. +mkNewChildDifferenceMap :: (SupportsPersistentAccount pv m) => Accounts pv -> m (Accounts pv) +mkNewChildDifferenceMap accts@Accounts{..} = do + newDiffMapRef <- liftIO $ newIORef $ Present $ DiffMap.empty accountDiffMapRef + return accts{accountDiffMapRef = newDiffMapRef} + -- | Create and set the 'DiffMap.DifferenceMap' for the provided @Accounts pv@. -- Precondition: The provided @IORef (Option (DiffMap.DifferenceMap))@ MUST correspond to the parent map. reconstructDifferenceMap :: (SupportsPersistentAccount pv m) => DiffMap.DifferenceMapReference -> [AccountAddress] -> Accounts pv -> m DiffMap.DifferenceMapReference @@ -198,7 +206,7 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where return $ do accountTable <- maccountTable accountRegIdHistory <- mrRIH - accountDiffMapRef <- liftIO DiffMap.emptyReference + accountDiffMapRef <- liftIO DiffMap.newEmptyReference return $ Accounts{..} instance (SupportsPersistentAccount pv m, av ~ AccountVersionFor pv) => Cacheable1 m (Accounts pv) (PersistentAccount av) where @@ -211,7 +219,7 @@ instance (SupportsPersistentAccount pv m, av ~ AccountVersionFor pv) => Cacheabl -- to an empty 'DiffMap.DifferenceMap'. emptyAccounts :: (MonadIO m) => m (Accounts pv) emptyAccounts = do - accountDiffMapRef <- liftIO DiffMap.emptyReference + accountDiffMapRef <- liftIO DiffMap.newEmptyReference return $ Accounts L.empty Trie.empty accountDiffMapRef -- | Add a new account. Returns @Just idx@ if the new account is fresh, i.e., the address does not exist, @@ -227,7 +235,7 @@ putNewAccount !acct a0@Accounts{..} = do accountDiffMapRef' <- case mAccountDiffMap of Absent -> do -- create a difference map for this block state with a @Nothing@ as the parent. - freshDifferenceMap <- liftIO DiffMap.emptyReference + freshDifferenceMap <- liftIO DiffMap.newEmptyReference return $ DiffMap.insert addr accIdx $ DiffMap.empty freshDifferenceMap Present accDiffMap -> do -- reuse the already existing difference map for this block state. @@ -416,19 +424,15 @@ tryPopulateLMDBStore accts = do isInitialized <- LMDBAccountMap.isInitialized unless isInitialized (void $ LMDBAccountMap.insertAccounts =<< allAccountsViaTable) where - -- Get all accounts from the account table. - allAccountsViaTable = do - addresses <- - -- We fold in ascending order of the @AccountIndex@ - -- so we @zip@ it correctly when returning @[(AccountAddress, AccountIndex)]@ - foldAccounts - ( \(!accum) pacc -> do + allAccountsViaTable = + fst + <$> foldAccounts + ( \(!accum, !nextix) pacc -> do !addr <- accountCanonicalAddress pacc - return $ addr : accum + return ((addr, nextix) : accum, nextix + 1) ) - [] + ([], 0) accts - return $ zip addresses [0 ..] -- | See documentation of @migratePersistentBlockState@. migrateAccounts :: diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index c62b68e65d..7acadb18b4 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -41,7 +41,6 @@ module Concordium.GlobalState.Persistent.BlockState ( import qualified Concordium.Crypto.SHA256 as H import qualified Concordium.Genesis.Data.P6 as P6 import Concordium.GlobalState.Account hiding (addIncomingEncryptedAmount, addToSelfEncryptedAmount) -import qualified Concordium.GlobalState.AccountMap.DifferenceMap as DiffMap import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import Concordium.GlobalState.BakerInfo import Concordium.GlobalState.BlockState @@ -80,7 +79,6 @@ import Concordium.Types.Execution (DelegationTarget (..), TransactionIndex, Tran import qualified Concordium.Types.Execution as Transactions import Concordium.Types.HashableTo import qualified Concordium.Types.IdentityProviders as IPS -import Concordium.Types.Option (Option (..)) import Concordium.Types.Queries (CurrentPaydayBakerPoolStatus (..), PoolStatus (..), RewardStatus' (..), makePoolPendingChange) import Concordium.Types.SeedState import qualified Concordium.Types.Transactions as Transactions @@ -3604,7 +3602,11 @@ instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateStorage cacheBlockState = cacheState cacheBlockStateAndGetTransactionTable = cacheStateAndGetTransactionTable - tryPopulateAccountMap = doTryPopulateAccountMap + tryPopulateAccountMap HashedPersistentBlockState{..} = do + -- load the top level references and write the accounts to the LMDB backed + -- account map (if this has not already been done). + BlockStatePointers{..} <- loadPBS hpbsPointers + LMDBAccountMap.tryPopulateLMDBStore bspAccounts -- | Migrate the block state from the representation used by protocol version -- @oldpv@ to the one used by protocol version @pv@. The migration is done gradually, @@ -3717,17 +3719,9 @@ doThawBlockState :: HashedPersistentBlockState pv -> m (PersistentBlockState pv) doThawBlockState HashedPersistentBlockState{..} = do - -- This load is cheap as the underlying block state is retained in memory as we're building from it, so it must be the "best" block. - bsp@BlockStatePointers{bspAccounts = a0@Accounts.Accounts{..}} <- loadPBS hpbsPointers - mDiffMap <- liftIO $ readIORef accountDiffMapRef - newDiffMapRef <- case mDiffMap of - -- reuse the reference pointing to @Nothing@. - Absent -> return accountDiffMapRef - Present _ -> do - -- create a new reference pointing to - -- a new difference map which inherits the parent difference map. - liftIO $ newIORef $ Present (DiffMap.empty accountDiffMapRef) - let bsp' = bsp{bspAccounts = a0{Accounts.accountDiffMapRef = newDiffMapRef}} + bsp@BlockStatePointers{..} <- loadPBS hpbsPointers + bspAccounts' <- Accounts.mkNewChildDifferenceMap bspAccounts + let bsp' = bsp{bspAccounts = bspAccounts'} liftIO $ newIORef =<< makeBufferedRef bsp' -- | Cache the block state. @@ -3771,11 +3765,6 @@ cacheState hpbs = do } return () -doTryPopulateAccountMap :: (SupportsPersistentState pv m) => HashedPersistentBlockState pv -> m () -doTryPopulateAccountMap HashedPersistentBlockState{..} = do - BlockStatePointers{..} <- loadPBS hpbsPointers - LMDBAccountMap.tryPopulateLMDBStore bspAccounts - -- | Cache the block state and get the initial (empty) transaction table with the next account nonces -- and update sequence numbers populated. cacheStateAndGetTransactionTable :: diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs index c97bc4711a..00e18c2bc0 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs @@ -25,7 +25,6 @@ module Concordium.GlobalState.Persistent.LMDB ( closeDatabase, addDatabaseVersion, checkDatabaseVersion, - resizeOnResized, finalizedByHeightStore, StoredBlock (..), StoredBlockWithStateHash (..), @@ -324,7 +323,7 @@ databaseHandlers :: FilePath -> IO (DatabaseHandlers pv st) databaseHandlers treeStateDir = makeDatabaseHandlers treeStateDir False defaultEnvSize -- | Initialize database handlers. --- The size will be rounded up to a multiple of 'dbStepSize'. +-- The size will be rounded up to a multiple of 'seStepSize'. -- (This ensures in particular that the size is a multiple of the page size, which is required by -- LMDB.) makeDatabaseHandlers :: @@ -339,7 +338,8 @@ makeDatabaseHandlers treeStateDir readOnly initSize = do _storeEnv <- makeStoreEnv -- here nobody else has access to the environment, so we need not lock let env = _storeEnv ^. seEnv - mdb_env_set_mapsize env initSize + stepSize = _storeEnv ^. seStepSize + mdb_env_set_mapsize env (initSize + stepSize - initSize `mod` stepSize) mdb_env_set_maxdbs env databaseCount mdb_env_set_maxreaders env 126 -- TODO: Consider MDB_NOLOCK @@ -372,7 +372,7 @@ openReadOnlyDatabase :: openReadOnlyDatabase treeStateDir = do _storeEnv <- makeStoreEnv let env = _storeEnv ^. seEnv - mdb_env_set_mapsize env defaultStepSize + mdb_env_set_mapsize env defaultEnvSize mdb_env_set_maxdbs env databaseCount mdb_env_set_maxreaders env 126 -- TODO: Consider MDB_NOLOCK diff --git a/concordium-consensus/src/Concordium/ImportExport.hs b/concordium-consensus/src/Concordium/ImportExport.hs index 91148ad5d9..26b7f30988 100644 --- a/concordium-consensus/src/Concordium/ImportExport.hs +++ b/concordium-consensus/src/Concordium/ImportExport.hs @@ -447,7 +447,7 @@ exportConsensusV0Blocks :: m (Bool, BlockIndex) exportConsensusV0Blocks firstBlock outDir chunkSize genIndex startHeight blockIndex lastWrittenChunkM = do env <- _storeEnv <$> gets _dbsHandlers - mgenFinRec <- resizeOnResized env $ readFinalizationRecord 0 + mgenFinRec <- LMDBHelpers.resizeOnResized env $ readFinalizationRecord 0 case mgenFinRec of Nothing -> do logEvent External LLError "No finalization record found in database for finalization index 0." @@ -473,7 +473,7 @@ exportConsensusV0Blocks firstBlock outDir chunkSize genIndex startHeight blockIn return (True, Empty) else do let getBlockAt height = - resizeOnResized env (readFinalizedBlockAtHeight height) >>= \case + LMDBHelpers.resizeOnResized env (readFinalizedBlockAtHeight height) >>= \case Nothing -> return Nothing Just StoredBlockWithStateHash{..} | NormalBlock normalBlock <- sbBlock sbshStoredBlock -> do let serializedBlock = runPut $ putVersionedBlock (protocolVersion @pv) normalBlock @@ -487,7 +487,7 @@ exportConsensusV0Blocks firstBlock outDir chunkSize genIndex startHeight blockIn getFinalizationAt mFinIndex = case mFinIndex of Nothing -> return Nothing Just finIndex -> - resizeOnResized env (readFinalizationRecord finIndex) >>= \case + LMDBHelpers.resizeOnResized env (readFinalizationRecord finIndex) >>= \case Nothing -> return Nothing Just fr -> return . Just $ runPut $ putVersionedFinalizationRecordV0 fr chunks <- diff --git a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs index 64e4fa2954..5cd8f1e9ac 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs @@ -526,9 +526,9 @@ initialiseExistingSkovV1 bakerCtx handlerCtx unliftSkov GlobalStateConfig{..} = initContext -- initialize the account map if it has not already been so. let lfbState = initialSkovData ^. lastFinalized . to bpState - logEvent Skov LLDebug "Try initialize LMDB account map" + logEvent Skov LLDebug "Initializing LMDB account map" void $ flip runReaderT pbsc $ PBS.runPersistentBlockStateMonad (PBS.tryPopulateAccountMap lfbState) - logEvent Skov LLDebug "Finsihed initializing LMDB account map" + logEvent Skov LLDebug "Finished initializing LMDB account map" let !es = ExistingSkov { esContext = diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs index 75c18c733d..0a875c4c78 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs @@ -323,7 +323,7 @@ loadCertifiedBlocks :: loadCertifiedBlocks = do certBlocks <- LowLevel.lookupCertifiedBlocks -- The first certified block will have the empty parent difference map reference. - emptyParent <- liftIO DiffMap.emptyReference + emptyParent <- liftIO DiffMap.newEmptyReference -- Load all certified blocks -- This sets the skov state, puts transactions in the transaction table, -- and reconstructs the account map difference maps for the certified blocks. From e53dc9de1fdcaf6a508515a33806b2a1ea28a433 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Tue, 7 Nov 2023 11:11:56 +0100 Subject: [PATCH 66/92] Fix curly quotes in documentation. --- .../GlobalState/Persistent/Accounts.hs | 22 +++++++++---------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index d38377ab2c..c88e11eb4b 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -12,11 +12,11 @@ -- | -- * Adding accounts --- When an account is added (via ‘putNewAccount’) then it is first added to the ‘DifferenceMap’, +-- When an account is added (via 'putNewAccount') then it is first added to the ‘DifferenceMap', -- it is kept in memory for the block until it either gets finalized or pruned. --- If a block is pruned then the retaining pointers are dropped and thus the block and associated ‘DifferenceMap’ is evicted from memory. +-- If a block is pruned then the retaining pointers are dropped and thus the block and associated ‘DifferenceMap' is evicted from memory. -- --- This in return invokes ‘storeUpdate’ for all underlying references for the block state, for the particular block. +-- This in return invokes ‘storeUpdate' for all underlying references for the block state, for the particular block. -- When the accounts structure is finalized, then 'writeAccountsCreated' must be invoked in order to store the newly created accounts -- in the LMDB backed account map. -- When thawing from a non-persisted block then the difference map is being inherited by the new thawed updatable block, @@ -36,24 +36,24 @@ -- -- When starting up from a fresh genesis configuration then as part of creating the genesis state, -- then the difference map is being built containing all accounts present in the genesis configuration. --- When the genesis block is being written to disk, then so is the ‘DifferenceMap’ --- via the ‘storeUpdate’ implementation of the accounts structure. +-- When the genesis block is being written to disk, then so is the ‘DifferenceMap' +-- via the ‘storeUpdate' implementation of the accounts structure. -- -- General flow -- The account map resides in its own lmdb database and functions across protocol versions. --- For non-persisted blocks, then the ‘DifferenceMap’ is 'DiffMap.DifferenceMapReference', +-- For non-persisted blocks, then the ‘DifferenceMap' is 'DiffMap.DifferenceMapReference', -- i.e. either @IORef Nothing@ or @IORef (Just DifferenceMap)@ depending on whether the block is written to disk. -- The 'putNewAccount' function creates a new 'DifferenceMap' on demand, hence a new 'Accounts' is initialized with a @accountDiffMap@ set to @IORef Nothing@. -- Subsequent accounts created are then being added to the difference map created by the first invocation of 'putNewAccount'. -- Blocks that are persisted always have a @IORef Nothing@ 'accountDiffMapRef'. -- --- The lmdb backed account map consists of a single lmdb store indexed by AccountAddresses and values are the associated ‘AccountIndex’ for each account. +-- The lmdb backed account map consists of a single lmdb store indexed by AccountAddresses and values are the associated ‘AccountIndex' for each account. -- --- (The ‘DifferenceMap’ consists of a @Map AccountAddress AccountIndes@ which retains the accounts that have been added to the chain for the associated block. --- Moreover the ‘DifferenceMap’ potentially retains a pointer to a so-called parent ‘DifferenceMap’. +-- (The ‘DifferenceMap' consists of a @Map AccountAddress AccountIndes@ which retains the accounts that have been added to the chain for the associated block. +-- Moreover the ‘DifferenceMap' potentially retains a pointer to a so-called parent ‘DifferenceMap'. -- I.e. @Maybe DifferenceMap@. If this is @Nothing@ then it means that the parent block is finalized or no accounts have been added. --- If the parent map yields a ‘DifferenceMap’ then the parent block is not persisted yet, and so the ‘DifferenceMap’ uses this parent map --- for keeping track of non persisted accounts for supporting e.g. queries via the ‘AccountAddress’. +-- If the parent map yields a ‘DifferenceMap' then the parent block is not persisted yet, and so the ‘DifferenceMap' uses this parent map +-- for keeping track of non persisted accounts for supporting e.g. queries via the ‘AccountAddress'. module Concordium.GlobalState.Persistent.Accounts where import qualified Concordium.Crypto.SHA256 as H From bd84caefd15c165f8ece2990a5baf1510b60bdd7 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Tue, 7 Nov 2023 13:01:17 +0100 Subject: [PATCH 67/92] Address review comments. --- .../GlobalState/AccountMap/DifferenceMap.hs | 11 +++++++---- .../src/Concordium/GlobalState/AccountMap/LMDB.hs | 4 ++-- .../src/Concordium/GlobalState/BlockState.hs | 4 ++-- .../src/Concordium/GlobalState/Persistent/Accounts.hs | 7 +++---- .../Concordium/GlobalState/Persistent/BlockState.hs | 2 +- .../src/Concordium/KonsensusV1/SkovMonad.hs | 5 +---- .../src/Concordium/KonsensusV1/TreeState/StartUp.hs | 2 +- .../KonsensusV1/TransactionProcessingTest.hs | 6 +++--- 8 files changed, 20 insertions(+), 21 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index 8fbfb309c1..25d81621f4 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -44,6 +44,11 @@ import Concordium.Types import Concordium.Types.Option (Option (..)) -- | A mutable reference to a 'DiffMap.DifferenceMap'. +-- This is an 'IORef' since the parent map may belong +-- to multiple blocks if they have not yet been persisted. +-- +-- The 'IORef' enables us to clear any child difference maps +-- when a block is finalized. type DifferenceMapReference = IORef (Option DifferenceMap) -- | Create a new empty reference. @@ -60,16 +65,14 @@ data DifferenceMap = DifferenceMap -- In other words, if the parent block is finalized, -- then the parent map is @Absent@ as the LMDB account map -- should be consulted instead. - -- This is an 'IORef' since the parent map may belong - -- to multiple blocks if they have not yet been persisted. - -- So the 'IORef' enables us to when persisting a block, - -- then we also clear the 'DifferenceMap' for the child block. dmParentMapRef :: !DifferenceMapReference } deriving (Eq) -- | Gather all accounts from the provided 'DifferenceMap' and its parent maps. -- Accounts are returned in ascending order of their 'AccountAddress'. +-- +-- Note. This function does not guarantee the order of the returned pairs. flatten :: (MonadIO m) => DifferenceMap -> m [(AccountAddress, AccountIndex)] flatten dmap = map (first aaeAddress) <$> go dmap [] where diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index 651566c711..acd78071ed 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -75,7 +75,7 @@ instance Exception DatabaseInvariantViolation where -- -- Invariants: -- * All accounts in the store are finalized. --- * The store should only retain canoncial account addresses. +-- * The store should only retain canonical account addresses. class (Monad m) => MonadAccountMapStore m where -- | Inserts the accounts to the underlying store. -- Only canonical addresses should be added. @@ -204,7 +204,7 @@ closeDatabase dbHandlers = runInBoundThread $ mdb_env_close $ dbHandlers ^. dbhS -- | The 'AccountMapStoreMonad' for interacting with the LMDB database. newtype AccountMapStoreMonad (m :: Type -> Type) (a :: Type) = AccountMapStoreMonad {runAccountMapStoreMonad :: m a} - deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadLogger, MonadReader r, MonadState s, TimeMonad) via m + deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadLogger, MonadReader r, MonadState s, TimeMonad) deriving (MonadTrans) via IdentityT deriving instance (MonadProtocolVersion m) => MonadProtocolVersion (AccountMapStoreMonad m) diff --git a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs index 31882d32c3..4d697bf7d8 100644 --- a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs @@ -1386,7 +1386,7 @@ class (BlockStateOperations m, FixedSizeSerialization (BlockStateRef m)) => Bloc -- | Ensure that a block state is stored and return a reference to it. saveBlockState :: BlockState m -> m (BlockStateRef m) - -- | Ensure that any accounts created in a block is persisted. + -- | Ensure that any accounts created in a block are persisted. -- This should be called when a block is being finalized. -- -- Precondition: The block state must be in memory and it must not have been archived. @@ -1700,7 +1700,7 @@ instance (Monad (t m), MonadTrans t, BlockStateStorage m) => BlockStateStorage ( archiveBlockState = lift . archiveBlockState saveBlockState = lift . saveBlockState saveAccounts = lift . saveAccounts - reconstructAccountDifferenceMap bs parentMap accs = lift $ reconstructAccountDifferenceMap bs parentMap accs + reconstructAccountDifferenceMap bs parentMap = lift . reconstructAccountDifferenceMap bs parentMap loadBlockState hsh = lift . loadBlockState hsh serializeBlockState = lift . serializeBlockState blockStateLoadCallback = lift blockStateLoadCallback diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index c88e11eb4b..8e4979362e 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -206,7 +206,7 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where return $ do accountTable <- maccountTable accountRegIdHistory <- mrRIH - accountDiffMapRef <- liftIO DiffMap.newEmptyReference + accountDiffMapRef <- DiffMap.newEmptyReference return $ Accounts{..} instance (SupportsPersistentAccount pv m, av ~ AccountVersionFor pv) => Cacheable1 m (Accounts pv) (PersistentAccount av) where @@ -215,8 +215,7 @@ instance (SupportsPersistentAccount pv m, av ~ AccountVersionFor pv) => Cacheabl return accts{accountTable = acctTable} --- | Create a new empty 'Accounts' structure with a pointer --- to an empty 'DiffMap.DifferenceMap'. +-- | Create a new empty 'Accounts' structure. emptyAccounts :: (MonadIO m) => m (Accounts pv) emptyAccounts = do accountDiffMapRef <- liftIO DiffMap.newEmptyReference @@ -290,7 +289,7 @@ getAccountIndex addr Accounts{..} = do -- and make sure it's within the bounds of the account table. -- We do the bounds check as it could be that the lmdb backed account map -- yields accounts which are not yet present in the @accountTable@. - -- In particular this can be the case if finalized blocks has been rolled + -- In particular this can be the case if finalized blocks have been rolled -- back as part of database recovery. withSafeBounds Nothing = Nothing withSafeBounds (Just accIdx@(AccountIndex k)) = if k <= L.size accountTable - 1 then Just accIdx else Nothing diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 4bf71e0ae4..5905b4b68f 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -3587,7 +3587,7 @@ instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateStorage saveAccounts HashedPersistentBlockState{..} = do -- this load should be cheap as the blockstate is in memory. accs <- bspAccounts <$> loadPBS hpbsPointers - -- write the accounts that was created in the block and + -- write the accounts that were created in the block and -- potentially non-finalized parent blocks. -- Note that this also empties the difference map for the -- block. diff --git a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs index 5cd8f1e9ac..7e1fcfff89 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs @@ -717,10 +717,7 @@ migrateSkovV1 regenesis migration gsConfig@GlobalStateConfig{..} oldPbsc oldBloc initGS :: InitMonad pv (SkovData pv) initGS = do newState <- newInitialBlockState - stateRef <- do - ref <- saveBlockState newState - saveAccounts newState - return ref + stateRef <- saveBlockState newState chainParams <- getChainParameters newState genEpochBakers <- genesisEpochBakers newState let genMeta = regenesisMetadata (getHash newState) regenesis diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs index 0a875c4c78..7f0fd7f52e 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs @@ -323,7 +323,7 @@ loadCertifiedBlocks :: loadCertifiedBlocks = do certBlocks <- LowLevel.lookupCertifiedBlocks -- The first certified block will have the empty parent difference map reference. - emptyParent <- liftIO DiffMap.newEmptyReference + emptyParent <- DiffMap.newEmptyReference -- Load all certified blocks -- This sets the skov state, puts transactions in the transaction table, -- and reconstructs the account map difference maps for the certified blocks. diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs index bda0b2a449..dd2a55ef9b 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs @@ -132,13 +132,13 @@ instance (MonadReader r m) => MonadReader r (FixedTimeT m) where local f (FixedTime k) = FixedTime $ local f . k newtype NoLoggerT m a = NoLoggerT {runNoLoggerT :: m a} - deriving (Functor, Applicative, Monad, MonadIO, MonadReader r, MonadFail) + deriving (Functor, Applicative, Monad, MonadIO, MonadReader r, MonadFail, TimeMonad, MonadState s) instance (Monad m) => MonadLogger (NoLoggerT m) where logEvent _ _ _ = return () -deriving instance (TimeMonad m) => TimeMonad (NoLoggerT m) -deriving instance (MonadState s m) => MonadState s (NoLoggerT m) +-- deriving instance (TimeMonad m) => TimeMonad (NoLoggerT m) +-- deriving instance (MonadState s m) => MonadState s (NoLoggerT m) -- | A test monad that is suitable for testing transaction processing -- as it derives the required capabilities. From 55f25cb0a485771a5b5b9bdb4f4a93085f48eef2 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Tue, 7 Nov 2023 15:14:19 +0100 Subject: [PATCH 68/92] Address review comments. --- .../GlobalState/AccountMap/DifferenceMap.hs | 53 ++++++++++--------- .../GlobalState/Persistent/Accounts.hs | 44 +++++++++------ .../GlobalState/Persistent/BlockState.hs | 2 +- 3 files changed, 58 insertions(+), 41 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index 25d81621f4..b423c5b3df 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -34,8 +34,7 @@ module Concordium.GlobalState.AccountMap.DifferenceMap ( ) where import Control.Monad.IO.Class -import Data.Bifunctor -import Data.Foldable +import Data.Tuple (swap) import qualified Data.HashMap.Strict as HM import Data.IORef import Prelude hiding (lookup) @@ -59,8 +58,9 @@ newEmptyReference = liftIO $ newIORef Absent -- a block identified by a 'BlockHash' and its associated 'BlockHeight'. -- The difference map only contains accounts that were added since the '_dmParentMapRef'. data DifferenceMap = DifferenceMap - { -- | Accounts added in a block. - dmAccounts :: !(HM.HashMap AccountAddressEq AccountIndex), + { -- | Accounts added in a block keyed by their equivalence class and + -- the @AccountIndex@ and canonical account adddress as values. + dmAccounts :: !(HM.HashMap AccountAddressEq (AccountIndex, AccountAddress)), -- | Parent map of non-finalized blocks. -- In other words, if the parent block is finalized, -- then the parent map is @Absent@ as the LMDB account map @@ -74,7 +74,7 @@ data DifferenceMap = DifferenceMap -- -- Note. This function does not guarantee the order of the returned pairs. flatten :: (MonadIO m) => DifferenceMap -> m [(AccountAddress, AccountIndex)] -flatten dmap = map (first aaeAddress) <$> go dmap [] +flatten dmap = go dmap [] where go diffMap !accum = do mParentMap <- liftIO $ readIORef (dmParentMapRef diffMap) @@ -82,7 +82,7 @@ flatten dmap = map (first aaeAddress) <$> go dmap [] Absent -> return collectedAccounts Present parentMap -> go parentMap collectedAccounts where - collectedAccounts = HM.toList (dmAccounts diffMap) <> accum + collectedAccounts = map swap (HM.elems $ dmAccounts diffMap) <> accum -- | Create a new empty 'DifferenceMap' potentially based on the difference map of -- the parent. @@ -93,15 +93,9 @@ empty mParentDifferenceMap = dmParentMapRef = mParentDifferenceMap } --- | Lookup an account in the difference map or any of the parent --- difference maps using the account address equivalence class. --- Returns @Just AccountIndex@ if the account is present and --- otherwise @Nothing@. --- Precondition: As this implementation uses the 'AccountAddressEq' equivalence --- class for looking up an 'AccountIndex', then it MUST only be used --- when account aliases are supported. -lookupViaEquivalenceClass :: (MonadIO m) => AccountAddressEq -> DifferenceMap -> m (Maybe AccountIndex) -lookupViaEquivalenceClass addr = check +-- | Internal helper function for looking up an entry in @dmAccounts@. +lookupViaEquivalenceClass' :: (MonadIO m) => AccountAddressEq -> DifferenceMap -> m (Maybe (AccountIndex, AccountAddress)) +lookupViaEquivalenceClass' addr = check where check diffMap = case HM.lookup addr (dmAccounts diffMap) of Nothing -> do @@ -111,6 +105,18 @@ lookupViaEquivalenceClass addr = check Present parentMap -> check parentMap Just accIdx -> return $ Just accIdx +-- | Lookup an account in the difference map or any of the parent +-- difference maps using the account address equivalence class. +-- Returns @Just AccountIndex@ if the account is present and +-- otherwise @Nothing@. +-- Precondition: As this implementation uses the 'AccountAddressEq' equivalence +-- class for looking up an 'AccountIndex', then it MUST only be used +-- when account aliases are supported. +lookupViaEquivalenceClass :: (MonadIO m) => AccountAddressEq -> DifferenceMap -> m (Maybe AccountIndex) +lookupViaEquivalenceClass addr dm = lookupViaEquivalenceClass' addr dm >>= \case + Nothing -> return Nothing + Just (accIdx, _) -> return $ Just accIdx + -- | Lookup an account in the difference map or any of the parent -- difference maps via an exactness check. -- Returns @Just AccountIndex@ if the account is present and @@ -120,23 +126,22 @@ lookupViaEquivalenceClass addr = check -- Note that this implementation is very inefficient for large difference maps and thus should be revised -- if the credential deployments limit gets revised significantly. lookupExact :: (MonadIO m) => AccountAddress -> DifferenceMap -> m (Maybe AccountIndex) -lookupExact addr diffMap = do - listOfAccs <- flatten diffMap - case find isEq listOfAccs of - Nothing -> return Nothing - Just (_, accIdx) -> return $ Just accIdx - where - isEq (accAddr, _) = addr == accAddr +lookupExact addr diffMap = lookupViaEquivalenceClass' (accountAddressEmbed addr) diffMap >>= \case + Nothing -> return Nothing + Just (accIdx, actualAddr) -> if actualAddr == addr then return $ Just accIdx else return Nothing -- | Insert an account into the difference map. -- Note that it is up to the caller to ensure only the canonical 'AccountAddress' is being inserted. insert :: AccountAddress -> AccountIndex -> DifferenceMap -> DifferenceMap -insert addr accIndex m = m{dmAccounts = HM.insert (accountAddressEmbed addr) accIndex $ dmAccounts m} +insert addr accIndex m = m{dmAccounts = HM.insert (accountAddressEmbed addr) (accIndex, addr) $ dmAccounts m} -- | Create a 'DifferenceMap' with the provided parent and list of account addresses and account indices. fromList :: IORef (Option DifferenceMap) -> [(AccountAddress, AccountIndex)] -> DifferenceMap fromList parentRef listOfAccountsAndIndices = DifferenceMap - { dmAccounts = HM.fromList $ map (first accountAddressEmbed) listOfAccountsAndIndices, + { dmAccounts = HM.fromList $ map mkKeyVal listOfAccountsAndIndices, dmParentMapRef = parentRef } + where + -- Make a key value pair to put in the @dmAccounts@. + mkKeyVal (accAddr, accIdx) = (accountAddressEmbed accAddr, (accIdx, accAddr)) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 8e4979362e..1ed5768d5d 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -13,10 +13,9 @@ -- | -- * Adding accounts -- When an account is added (via 'putNewAccount') then it is first added to the ‘DifferenceMap', --- it is kept in memory for the block until it either gets finalized or pruned. +-- it is kept in memory for the block until the block either gets finalized or pruned. -- If a block is pruned then the retaining pointers are dropped and thus the block and associated ‘DifferenceMap' is evicted from memory. -- --- This in return invokes ‘storeUpdate' for all underlying references for the block state, for the particular block. -- When the accounts structure is finalized, then 'writeAccountsCreated' must be invoked in order to store the newly created accounts -- in the LMDB backed account map. -- When thawing from a non-persisted block then the difference map is being inherited by the new thawed updatable block, @@ -118,16 +117,10 @@ data Accounts (pv :: ProtocolVersion) = Accounts accountTable :: !(LFMBTree' AccountIndex HashedBufferedRef (AccountRef (AccountVersionFor pv))), -- | Persisted representation of the map from registration ids to account indices. accountRegIdHistory :: !(Trie.TrieN UnbufferedFix ID.RawCredentialRegistrationID AccountIndex), - -- | An in-memory difference map used keeping track of accounts - -- added in live blocks. - -- This is @Absent@ if either the block is persisted, or no accounts have been - -- added for this block any parent non-persisted blocks. - -- Otherwise if the block is not persisted and accounts have been added, then - -- the 'DiffMap.DifferenceMap' yields the @AccountAddress -> AccountIndex@ mapping for - -- accounts created in the block, where the account addresses are in canonical form. - -- The 'DiffMap.DifferenceMap' is wrapped in an 'IORef' because it is inherited - -- by child blocks, and so when this block state is persisted then we need to clear it - -- for any children block states. + -- | An in-memory difference map used for keeping track of accounts that are + -- added in blocks which are not yet finalized. + -- In particular the difference map retains accounts created, but not + -- yet stored in the LMDB backed account map. accountDiffMapRef :: !DiffMap.DifferenceMapReference } @@ -171,10 +164,29 @@ mkNewChildDifferenceMap accts@Accounts{..} = do return accts{accountDiffMapRef = newDiffMapRef} -- | Create and set the 'DiffMap.DifferenceMap' for the provided @Accounts pv@. --- Precondition: The provided @IORef (Option (DiffMap.DifferenceMap))@ MUST correspond to the parent map. -reconstructDifferenceMap :: (SupportsPersistentAccount pv m) => DiffMap.DifferenceMapReference -> [AccountAddress] -> Accounts pv -> m DiffMap.DifferenceMapReference -reconstructDifferenceMap parentRef listOfAccounts Accounts{..} = do - let diffMap' = DiffMap.fromList parentRef $ zip listOfAccounts $ map AccountIndex [L.size accountTable + 1 ..] +-- The function is highly unsafe and can cause state invariant failures if not all of the +-- below preconditions are respected. +-- Precondition: +-- * The function assumes that the account table already yields every account added for the block state. +-- * The provided @IORef (Option (DiffMap.DifferenceMap))@ MUST correspond to the parent map. +-- * The provided list of accounts MUST be in ascending order of account index, hence the list of accounts +-- MUST be provided in the order of which the corresponding credential deployment transactions were executed. +unsafeReconstructDifferenceMap :: + (SupportsPersistentAccount pv m) => + -- | Reference to the parent difference map. + DiffMap.DifferenceMapReference -> + -- | Account addresses to add to the difference map. + [AccountAddress] -> + -- | The accounts to write difference map to. + Accounts pv -> + -- | Reference to the newly created difference map. + m DiffMap.DifferenceMapReference +unsafeReconstructDifferenceMap parentRef listOfAccounts Accounts{..} = do + -- As it is presumed that the account table already yields any accounts added, then + -- in order to the obtain the account indices we subtract the number of accounts missing + -- missing in the lmdb account map from the total number of accounts, hence obtaining the first @AccountIndex@ + -- to use for adding new accounts to the lmdb backed account map. + let diffMap' = DiffMap.fromList parentRef $ zip listOfAccounts $ map AccountIndex [(L.size accountTable - fromIntegral (length listOfAccounts)) ..] liftIO $ atomicWriteIORef accountDiffMapRef $ Present diffMap' return accountDiffMapRef diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index 5905b4b68f..bc0cae10bb 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -3595,7 +3595,7 @@ instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateStorage reconstructAccountDifferenceMap HashedPersistentBlockState{..} parentDifferenceMap listOfAccounts = do accs <- bspAccounts <$> loadPBS hpbsPointers - Accounts.reconstructDifferenceMap parentDifferenceMap listOfAccounts accs + Accounts.unsafeReconstructDifferenceMap parentDifferenceMap listOfAccounts accs loadBlockState hpbsHashM ref = do hpbsPointers <- liftIO $ newIORef $ blobRefToBufferedRef ref From 978000fbc60038ca37ca0baf6c9214a0f00e9477 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Tue, 7 Nov 2023 15:22:20 +0100 Subject: [PATCH 69/92] Populate lmdb account map when activating a skov state now instead of always trying when starting from an initial. --- .../src/Concordium/GlobalState.hs | 7 ------- .../GlobalState/AccountMap/DifferenceMap.hs | 16 +++++++++------- .../GlobalState/Persistent/TreeState.hs | 4 ++++ .../src/Concordium/KonsensusV1/SkovMonad.hs | 8 +++----- 4 files changed, 16 insertions(+), 19 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState.hs b/concordium-consensus/src/Concordium/GlobalState.hs index fde79c850a..c0516e3cb2 100644 --- a/concordium-consensus/src/Concordium/GlobalState.hs +++ b/concordium-consensus/src/Concordium/GlobalState.hs @@ -9,7 +9,6 @@ -- and shutdown. module Concordium.GlobalState where -import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Reader.Class @@ -17,7 +16,6 @@ import Control.Monad.Trans.Reader hiding (ask) import Data.Proxy import Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap -import Concordium.GlobalState.BlockPointer (_bpState) import Concordium.GlobalState.BlockState import Concordium.GlobalState.Parameters import Concordium.GlobalState.Persistent.Account (newAccountCache) @@ -82,11 +80,6 @@ initialiseExistingGlobalState _ GlobalStateConfig{..} = do skovData <- runLoggerT (loadSkovPersistentData dtdbRuntimeParameters dtdbTreeStateDirectory pbsc) logm `onException` closeBlobStore pbscBlobStore - -- initialize the account map if it has not already been so. - logm Skov LLDebug "Try initialize LMDB account map" - let lfbState = _bpState $ _lastFinalized skovData - void $ flip runLoggerT logm $ flip runReaderT pbsc $ runPersistentBlockStateMonad (tryPopulateAccountMap lfbState) - logm Skov LLDebug "Finished initializing LMDB account map" return (Just (pbsc, skovData)) else return Nothing diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index b423c5b3df..fc177f560b 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -34,9 +34,9 @@ module Concordium.GlobalState.AccountMap.DifferenceMap ( ) where import Control.Monad.IO.Class -import Data.Tuple (swap) import qualified Data.HashMap.Strict as HM import Data.IORef +import Data.Tuple (swap) import Prelude hiding (lookup) import Concordium.Types @@ -113,9 +113,10 @@ lookupViaEquivalenceClass' addr = check -- class for looking up an 'AccountIndex', then it MUST only be used -- when account aliases are supported. lookupViaEquivalenceClass :: (MonadIO m) => AccountAddressEq -> DifferenceMap -> m (Maybe AccountIndex) -lookupViaEquivalenceClass addr dm = lookupViaEquivalenceClass' addr dm >>= \case - Nothing -> return Nothing - Just (accIdx, _) -> return $ Just accIdx +lookupViaEquivalenceClass addr dm = + lookupViaEquivalenceClass' addr dm >>= \case + Nothing -> return Nothing + Just (accIdx, _) -> return $ Just accIdx -- | Lookup an account in the difference map or any of the parent -- difference maps via an exactness check. @@ -126,9 +127,10 @@ lookupViaEquivalenceClass addr dm = lookupViaEquivalenceClass' addr dm >>= \case -- Note that this implementation is very inefficient for large difference maps and thus should be revised -- if the credential deployments limit gets revised significantly. lookupExact :: (MonadIO m) => AccountAddress -> DifferenceMap -> m (Maybe AccountIndex) -lookupExact addr diffMap = lookupViaEquivalenceClass' (accountAddressEmbed addr) diffMap >>= \case - Nothing -> return Nothing - Just (accIdx, actualAddr) -> if actualAddr == addr then return $ Just accIdx else return Nothing +lookupExact addr diffMap = + lookupViaEquivalenceClass' (accountAddressEmbed addr) diffMap >>= \case + Nothing -> return Nothing + Just (accIdx, actualAddr) -> if actualAddr == addr then return $ Just accIdx else return Nothing -- | Insert an account into the difference map. -- Note that it is up to the caller to ensure only the canonical 'AccountAddress' is being inserted. diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs index acf04055d2..97f63167c5 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs @@ -508,6 +508,10 @@ activateSkovPersistentData pbsc uninitState = let bps = _bpState $ _lastFinalized uninitState tt <- cacheBlockStateAndGetTransactionTable bps logEvent GlobalState LLTrace "Done caching last finalized block" + -- initialize the account map if it has not already been so. + logEvent GlobalState LLDebug "Initializing LMDB account map" + void $ tryPopulateAccountMap bps + logEvent GlobalState LLDebug "Finished initializing LMDB account map" return $! uninitState{_transactionTable = tt} where runBlockState a = runReaderT (PBS.runPersistentBlockStateMonad @pv a) pbsc diff --git a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs index 7e1fcfff89..72af136e54 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs @@ -524,11 +524,6 @@ initialiseExistingSkovV1 bakerCtx handlerCtx unliftSkov GlobalStateConfig{..} = runInitMonad (loadSkovData gscRuntimeParameters (rbrCount > 0)) initContext - -- initialize the account map if it has not already been so. - let lfbState = initialSkovData ^. lastFinalized . to bpState - logEvent Skov LLDebug "Initializing LMDB account map" - void $ flip runReaderT pbsc $ PBS.runPersistentBlockStateMonad (PBS.tryPopulateAccountMap lfbState) - logEvent Skov LLDebug "Finished initializing LMDB account map" let !es = ExistingSkov { esContext = @@ -652,6 +647,9 @@ activateSkovV1State = do bps <- use $ lastFinalized . to bpState !tt <- cacheBlockStateAndGetTransactionTable bps transactionTable .= tt + logEvent GlobalState LLDebug "Initializing LMDB account map" + void $ PBS.tryPopulateAccountMap bps + logEvent GlobalState LLDebug "Finished initializing LMDB account map" logEvent GlobalState LLTrace "Loading certified blocks" loadCertifiedBlocks logEvent GlobalState LLTrace "Done activating global state" From 3ebd266b2bb021c8c884ccddb398da7fd67db907 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Tue, 7 Nov 2023 16:16:12 +0100 Subject: [PATCH 70/92] Added some documentation to lmdb env steps and default sizes. --- .../src/Concordium/GlobalState/AccountMap/LMDB.hs | 10 ++++++++-- .../src/Concordium/GlobalState/LMDB/Helpers.hs | 7 +++++++ 2 files changed, 15 insertions(+), 2 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index acd78071ed..0347259c3d 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -157,6 +157,12 @@ makeClassy ''DatabaseHandlers databaseCount :: Int databaseCount = 1 +-- | Database growth size increment. +-- This is currently set at 4MB, and must be a multiple of the page size. +-- For reference: ~ 90k accounts takes up around 7MB, so this should ensure not much resizing required. +dbStepSize :: Int +dbStepSize = 2 ^ (22 :: Int) -- 4MB + -- ** Initialization -- | Initialize database handlers. @@ -170,10 +176,10 @@ makeDatabaseHandlers :: Bool -> IO DatabaseHandlers makeDatabaseHandlers accountMapDir readOnly = do - _dbhStoreEnv <- makeStoreEnv + _dbhStoreEnv <- makeStoreEnv' dbStepSize defaultMaxStepSize -- here nobody else has access to the environment, so we need not lock let env = _dbhStoreEnv ^. seEnv - mdb_env_set_mapsize env defaultEnvSize + mdb_env_set_mapsize env dbStepSize mdb_env_set_maxdbs env databaseCount mdb_env_set_maxreaders env 126 mdb_env_open env accountMapDir [MDB_RDONLY | readOnly] diff --git a/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs b/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs index 2f7c1c869c..2f650fbfc2 100644 --- a/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs +++ b/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs @@ -13,11 +13,13 @@ module Concordium.GlobalState.LMDB.Helpers ( -- * Database environment. StoreEnv (..), makeStoreEnv, + makeStoreEnv', withWriteStoreEnv, seEnv, seStepSize, seMaxStepSize, defaultStepSize, + defaultMaxStepSize, defaultEnvSize, resizeDatabaseHandlers, resizeOnResized, @@ -301,6 +303,9 @@ defaultStepSize :: Int defaultStepSize = 2 ^ (26 :: Int) -- 64MB -- | Maximum step to increment the database size. +-- A ceiling that supposedly never gets hit. +-- We need some bound as we're growing the environment exponentially when +-- transactions fail and we resize recursively. defaultMaxStepSize :: Int defaultMaxStepSize = 2 ^ (30 :: Int) -- 1GB @@ -322,6 +327,8 @@ makeStoreEnv' _seStepSize _seMaxStepSize = do _seEnvLock <- initializeLock return StoreEnv{..} +-- | Construct a new LMDB environment with assoicated locks that protects it, +-- with default environment paremeters. makeStoreEnv :: IO StoreEnv makeStoreEnv = makeStoreEnv' defaultStepSize defaultMaxStepSize From 8339a1600e974748059e9941e764966a41ac439c Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Tue, 7 Nov 2023 16:45:22 +0100 Subject: [PATCH 71/92] Better documentation of lmdb env variables. --- .../src/Concordium/GlobalState/AccountMap/LMDB.hs | 2 +- .../src/Concordium/GlobalState/LMDB/Helpers.hs | 5 ----- .../src/Concordium/GlobalState/Persistent/LMDB.hs | 6 ++++++ .../src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs | 6 ++++++ 4 files changed, 13 insertions(+), 6 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index 0347259c3d..e9ce852308 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -194,7 +194,7 @@ makeDatabaseHandlers accountMapDir readOnly = do -- | Create the lmdb stores and return back database handlers for interacting with it. -- This simply loads the references and does not initialize the databases. --- The initial environment size is set to 128MB. +-- The initial environment size is set to 'dbStepSize' (4MB). -- Note that this function creates the directory for the database if not already present at the provided -- path and any missing parent directories. openDatabase :: FilePath -> IO DatabaseHandlers diff --git a/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs b/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs index 2f650fbfc2..1f177dfcb8 100644 --- a/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs +++ b/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs @@ -20,7 +20,6 @@ module Concordium.GlobalState.LMDB.Helpers ( seMaxStepSize, defaultStepSize, defaultMaxStepSize, - defaultEnvSize, resizeDatabaseHandlers, resizeOnResized, @@ -309,10 +308,6 @@ defaultStepSize = 2 ^ (26 :: Int) -- 64MB defaultMaxStepSize :: Int defaultMaxStepSize = 2 ^ (30 :: Int) -- 1GB --- | Default start environment size. -defaultEnvSize :: Int -defaultEnvSize = 2 ^ (27 :: Int) -- 128MB - -- | Construct a new LMDB environment with associated locks that protect its use. makeStoreEnv' :: -- | Initial database growth when resizing the environment. diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs index 00e18c2bc0..21ce8f3c3c 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs @@ -316,6 +316,12 @@ metadataStoreName = "metadata" databaseCount :: Int databaseCount = 5 +-- | Default start environment size. +-- Tree state database sizes for historical protocol versions have been between 7-60 times +-- the 'defaultEnvSize'. +defaultEnvSize :: Int +defaultEnvSize = 2 ^ (27 :: Int) -- 128MB + -- | Initialize database handlers in ReadWrite mode. -- This simply loads the references and does not initialize the databases. -- The initial size is set to 128MB. diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs index 92f47fb8c6..417448692a 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs @@ -308,6 +308,12 @@ makeDatabaseHandlers treeStateDir readOnly initSize = do [MDB_CREATE | not readOnly] return DatabaseHandlers{..} +-- | Default start environment size. +-- Tree state database sizes for historical protocol versions have been between 7-60 times +-- the 'defaultEnvSize'. +defaultEnvSize :: Int +defaultEnvSize = 2 ^ (27 :: Int) -- 128MB + -- | Initialize database handlers in ReadWrite mode. -- This simply loads the references and does not initialize the databases. -- The initial size is set to 64MB. From be523487f5128054b7b7ecc294c0524b311de7ee Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Tue, 7 Nov 2023 19:51:04 +0100 Subject: [PATCH 72/92] Address review comments. --- .../src/Concordium/GlobalState.hs | 27 ++++++++++--------- .../Concordium/GlobalState/Persistent/LMDB.hs | 5 ++-- .../GlobalState/Persistent/TreeState.hs | 21 ++++----------- .../Concordium/GlobalState/Persistent/Trie.hs | 2 +- .../src/Concordium/KonsensusV1/SkovMonad.hs | 22 +++++---------- .../src/Concordium/KonsensusV1/TestMonad.hs | 6 ++--- 6 files changed, 31 insertions(+), 52 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState.hs b/concordium-consensus/src/Concordium/GlobalState.hs index c0516e3cb2..c972d5005a 100644 --- a/concordium-consensus/src/Concordium/GlobalState.hs +++ b/concordium-consensus/src/Concordium/GlobalState.hs @@ -83,6 +83,16 @@ initialiseExistingGlobalState _ GlobalStateConfig{..} = do return (Just (pbsc, skovData)) else return Nothing +-- | Initialize a 'PersistentBlockStateContext' via the provided +-- 'GlobalStateConfig'. +initializePersistentBlockStateContext :: GlobalStateConfig -> IO (PersistentBlockStateContext pv) +initializePersistentBlockStateContext GlobalStateConfig{..} = liftIO $ do + pbscBlobStore <- createBlobStore dtdbBlockStateFile + pbscAccountCache <- newAccountCache (rpAccountsCacheSize dtdbRuntimeParameters) + pbscModuleCache <- Modules.newModuleCache (rpModulesCacheSize dtdbRuntimeParameters) + pbscAccountMap <- LMDBAccountMap.openDatabase dtdAccountMapDirectory + return PersistentBlockStateContext{..} + -- | Migrate an existing global state. This is only intended to be used on a -- protocol update and requires that the initial state for the new protocol -- version is prepared (see @TreeState.storeFinalState@). This function will @@ -112,13 +122,8 @@ migrateExistingState :: Regenesis pv -> -- | The return value is the context and state for the new chain. LogIO (GSContext pv, GSState pv) -migrateExistingState GlobalStateConfig{..} oldPbsc oldState migration genData = do - pbsc <- liftIO $ do - pbscBlobStore <- createBlobStore dtdbBlockStateFile - pbscAccountCache <- newAccountCache (rpAccountsCacheSize dtdbRuntimeParameters) - pbscModuleCache <- Modules.newModuleCache (rpModulesCacheSize dtdbRuntimeParameters) - pbscAccountMap <- LMDBAccountMap.openDatabase dtdAccountMapDirectory - return $ PersistentBlockStateContext{..} +migrateExistingState gsc@GlobalStateConfig{..} oldPbsc oldState migration genData = do + pbsc <- liftIO $ initializePersistentBlockStateContext gsc newInitialBlockState <- flip runBlobStoreT oldPbsc . flip runBlobStoreT pbsc $ do case _nextGenesisInitialState oldState of Nothing -> error "Precondition violation. Migration called in state without initial block state." @@ -144,12 +149,8 @@ migrateExistingState GlobalStateConfig{..} oldPbsc oldState migration genData = -- exists this will raise an exception. It is not necessary to call 'activateGlobalState' -- on the generated state, as this will establish the necessary invariants. initialiseNewGlobalState :: (IsProtocolVersion pv, IsConsensusV0 pv) => GenesisData pv -> GlobalStateConfig -> LogIO (GSContext pv, GSState pv) -initialiseNewGlobalState genData GlobalStateConfig{..} = do - pbscBlobStore <- liftIO $ createBlobStore dtdbBlockStateFile - pbscAccountCache <- liftIO $ newAccountCache (rpAccountsCacheSize dtdbRuntimeParameters) - pbscModuleCache <- liftIO $ Modules.newModuleCache (rpModulesCacheSize dtdbRuntimeParameters) - pbscAccountMap <- liftIO $ LMDBAccountMap.openDatabase dtdAccountMapDirectory - let pbsc = PersistentBlockStateContext{..} +initialiseNewGlobalState genData gsc@GlobalStateConfig{..} = do + pbsc@PersistentBlockStateContext{..} <- liftIO $ initializePersistentBlockStateContext gsc let initGS = do logEvent GlobalState LLTrace "Creating persistent global state" result <- genesisState genData diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs index 21ce8f3c3c..475889ee29 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs @@ -320,11 +320,10 @@ databaseCount = 5 -- Tree state database sizes for historical protocol versions have been between 7-60 times -- the 'defaultEnvSize'. defaultEnvSize :: Int -defaultEnvSize = 2 ^ (27 :: Int) -- 128MB +defaultEnvSize = 2 ^ (26 :: Int) -- 64MB -- | Initialize database handlers in ReadWrite mode. -- This simply loads the references and does not initialize the databases. --- The initial size is set to 128MB. databaseHandlers :: FilePath -> IO (DatabaseHandlers pv st) databaseHandlers treeStateDir = makeDatabaseHandlers treeStateDir False defaultEnvSize @@ -337,7 +336,7 @@ makeDatabaseHandlers :: FilePath -> -- | Open read only Bool -> - -- | Initital database size + -- | Initial database size Int -> IO (DatabaseHandlers pv st) makeDatabaseHandlers treeStateDir readOnly initSize = do diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs index 97f63167c5..2f0c035069 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/TreeState.hs @@ -358,24 +358,15 @@ checkExistingDatabase treeStateDir blockStateFile accountMapDir = do -- if all files exist we check whether they are both readable and writable. -- In case only one of them exists we raise an appropriate exception. We don't want to delete any data. if - | bsPathEx && tsPathEx && amPathEx -> do - -- check whether it is a normal file and whether we have the right permissions - checkRWFile blockStateFile BlockStatePermissionError - checkRWFile treeStateFile TreeStatePermissionError - checkRWFile accountMapFile AccountMapPermissionError - logEvent TreeState LLTrace "Existing database found." - logEvent TreeState LLTrace $ "TreeState filepath: " ++ show treeStateFile - logEvent TreeState LLTrace $ "BlockState filepath: " ++ show blockStateFile - logEvent TreeState LLTrace $ "AccountMap filepath: " ++ accountMapFile - return True | bsPathEx && tsPathEx -> do -- check whether it is a normal file and whether we have the right permissions checkRWFile blockStateFile BlockStatePermissionError checkRWFile treeStateFile TreeStatePermissionError + when amPathEx $ checkRWFile accountMapFile AccountMapPermissionError logEvent TreeState LLTrace "Existing database found." logEvent TreeState LLTrace $ "TreeState filepath: " ++ show treeStateFile logEvent TreeState LLTrace $ "BlockState filepath: " ++ show blockStateFile - logEvent TreeState LLTrace $ "AccountMap not found" + logEvent TreeState LLTrace $ if amPathEx then "AccountMap filepath: " ++ show accountMapFile else "AccountMap not found" return True | bsPathEx -> do logEvent GlobalState LLWarning "Block state file exists, but tree state database does not. Deleting the block state file." @@ -722,11 +713,9 @@ instance markFinalized bh fr = use (skovPersistentData . blockTable . liveMap . at' bh) >>= \case Just (BlockAlive bp) -> do - st <- do - -- Save the block state and write the accounts out to disk. - ref <- saveBlockState (_bpState bp) - void $ saveAccounts (_bpState bp) - return ref + -- Save the block state and write the accounts out to disk. + st <- saveBlockState (_bpState bp) + void $ saveAccounts (_bpState bp) -- NB: Removing the block from the in-memory cache only makes -- sense if no block lookups are done between the call to this -- function and 'wrapUpFinalization'. This is currently the case, diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Trie.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Trie.hs index 37091a0d34..f60d02ca6b 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Trie.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Trie.hs @@ -566,7 +566,7 @@ instance (Show v, FixShowable fix) => Show (TrieN fix k v) where show (TrieN _ t) = showFix showTrieFString t instance (BlobStorable m (fix (TrieF k v)), BlobStorable m v, Base (fix (TrieF k v)) ~ TrieF k v) => BlobStorable m (TrieN fix k v) where - storeUpdate v@EmptyTrieN = return (put (0 :: Word64), v) + storeUpdate v@EmptyTrieN = return (put (0 :: Int), v) storeUpdate (TrieN size t) = do (pt, t') <- storeUpdate t let bs = put size >> pt diff --git a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs index 72af136e54..7ce95cb567 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs @@ -496,17 +496,12 @@ initialiseExistingSkovV1 :: (forall a. SkovV1T pv m a -> IO a) -> GlobalStateConfig -> LogIO (Maybe (ExistingSkov pv m)) -initialiseExistingSkovV1 bakerCtx handlerCtx unliftSkov GlobalStateConfig{..} = do +initialiseExistingSkovV1 bakerCtx handlerCtx unliftSkov gsc@GlobalStateConfig{..} = do logEvent Skov LLDebug "Attempting to use existing global state." existingDB <- checkExistingDatabase gscTreeStateDirectory gscBlockStateFile gscAccountMapDirectory if existingDB then do - pbsc <- liftIO $ do - pbscAccountCache <- newAccountCache (rpAccountsCacheSize gscRuntimeParameters) - pbscModuleCache <- Modules.newModuleCache (rpModulesCacheSize gscRuntimeParameters) - pbscBlobStore <- loadBlobStore gscBlockStateFile - pbscAccountMap <- LMDBAccountMap.openDatabase gscAccountMapDirectory - return PersistentBlockStateContext{..} + pbsc <- liftIO $ newPersistentBlockStateContext gsc let initWithLLDB skovLldb = do checkDatabaseVersion skovLldb let checkBlockState bs = runReaderT (PBS.runPersistentBlockStateMonad (isValidBlobRef bs)) pbsc @@ -576,10 +571,8 @@ initialiseNewSkovV1 genData bakerCtx handlerCtx unliftSkov gsConfig@GlobalStateC Left err -> throwM (InvalidGenesisData err) Right genState -> return genState logEvent GlobalState LLTrace "Writing persistent global state" - stateRef <- do - ref <- saveBlockState pbs - saveAccounts pbs - return ref + stateRef <- saveBlockState pbs + saveAccounts pbs logEvent GlobalState LLTrace "Creating persistent global state context" let genHash = genesisBlockHash genData let genMeta = @@ -707,10 +700,9 @@ migrateSkovV1 regenesis migration gsConfig@GlobalStateConfig{..} oldPbsc oldBloc pbsc@PersistentBlockStateContext{..} <- newPersistentBlockStateContext gsConfig logEvent GlobalState LLDebug "Migrating existing global state." let newInitialBlockState :: InitMonad pv (HashedPersistentBlockState pv) - newInitialBlockState = do - flip runBlobStoreT oldPbsc . flip runBlobStoreT pbsc $ do - newState <- migratePersistentBlockState migration $ hpbsPointers oldBlockState - hashBlockState newState + newInitialBlockState = flip runBlobStoreT oldPbsc . flip runBlobStoreT pbsc $ do + newState <- migratePersistentBlockState migration $ hpbsPointers oldBlockState + hashBlockState newState let initGS :: InitMonad pv (SkovData pv) initGS = do diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs index 5cd71b3741..c0cfb1e73b 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TestMonad.hs @@ -171,10 +171,8 @@ runTestMonad _tcBakerContext _tcCurrentTime genData (TestMonad a) = _nextEpochBakers = nextBF, _nextPayday = payday } - genStateRef <- do - ref <- saveBlockState genState - saveAccounts genState - return ref + genStateRef <- saveBlockState genState + void $ saveAccounts genState return (genState, genStateRef, initTT, genTimeoutBase, genEpochBakers) let genMetadata = GenesisMetadata From 7a40fb47a4df6f7bf84bac0b0d4e5f43cd5cf0e4 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Wed, 8 Nov 2023 07:35:49 +0100 Subject: [PATCH 73/92] test --- .../GlobalState/AccountMap/DifferenceMap.hs | 5 +- .../GlobalStateTests/DifferenceMap.hs | 57 +++++++++++++++++-- 2 files changed, 55 insertions(+), 7 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index fc177f560b..0a197f6bd5 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -123,9 +123,8 @@ lookupViaEquivalenceClass addr dm = -- Returns @Just AccountIndex@ if the account is present and -- otherwise @Nothing@. -- Precondition: As this implementation checks for exactness of the provided --- @AccountAddress@ then it MUST only be used when account aliases are NOT supported. --- Note that this implementation is very inefficient for large difference maps and thus should be revised --- if the credential deployments limit gets revised significantly. +-- @AccountAddress@ then it MUST only be used when account aliases are NOT supported by the +-- protocol. lookupExact :: (MonadIO m) => AccountAddress -> DifferenceMap -> m (Maybe AccountIndex) lookupExact addr diffMap = lookupViaEquivalenceClass' (accountAddressEmbed addr) diffMap >>= \case diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs index dddb3c6c04..a637bf0f35 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs @@ -38,7 +38,7 @@ testDoLookup accAddr diffMap = do -- | Test that an account can be inserted and looked up in the 'DiffMap.DifferenceMap'. testInsertLookupAccount :: Assertion testInsertLookupAccount = do - emptyParentMap <- mkParentPointer Absent + emptyParentMap <- liftIO DiffMap.newEmptyReference let diffMap = uncurry DiffMap.insert acc $ DiffMap.empty emptyParentMap testDoLookup (fst acc) diffMap >>= \case Nothing -> assertFailure "account should be present in diff map" @@ -53,7 +53,7 @@ mkParentPointer diffMap = newIORef diffMap >>= return -- | Testing lookups in flat and nested difference maps. testLookups :: Assertion testLookups = do - emptyParentMap <- mkParentPointer Absent + emptyParentMap <- liftIO DiffMap.newEmptyReference let diffMap1 = uncurry DiffMap.insert (dummyPair 1) $ DiffMap.empty emptyParentMap diffMap1Pointer <- mkParentPointer $ Present diffMap1 let diffMap2 = uncurry DiffMap.insert (dummyPair 2) (DiffMap.empty diffMap1Pointer) @@ -74,13 +74,14 @@ testLookups = do -- | Test flattening a difference map i.e. return all accounts as one flat map. testFlatten :: Assertion testFlatten = do - emptyParentMap <- mkParentPointer Absent + emptyParentMap <- liftIO DiffMap.newEmptyReference let diffMap1 = uncurry DiffMap.insert (dummyPair 1) $ DiffMap.empty emptyParentMap diffMap1Pointer <- mkParentPointer $ Present diffMap1 let diffMap2 = uncurry DiffMap.insert (dummyPair 2) (DiffMap.empty diffMap1Pointer) diffMap2Pointer <- mkParentPointer $ Present diffMap2 let diffMap3 = uncurry DiffMap.insert (dummyPair 3) (DiffMap.empty diffMap2Pointer) assertEqual "accounts should be the same" (map dummyPair [1 .. 3]) =<< DiffMap.flatten diffMap3 + -- | Make the reference map for comparing lookups. makeReference :: [(AccountAddress, AccountIndex)] -> HM.HashMap AccountAddress AccountIndex @@ -99,13 +100,19 @@ genInputs = sized $ \n -> do noDifferenceMaps <- choose (0, len) return (accs, noDifferenceMaps) +genInputs2 :: Gen [(AccountAddress, AccountIndex)] +genInputs2 = sized $ \n -> do + let maxAccs = min n 10000 + len <- choose (0, maxAccs) + replicateM len ((,) <$> genAccountAddress <*> (AccountIndex <$> arbitrary)) + -- | Test insertions and lookups on the difference map. insertionsAndLookups :: Spec insertionsAndLookups = it "insertions and lookups" $ withMaxSuccess 10000 $ forAll genInputs $ \(inputs, noDifferenceMaps) -> do let reference = HM.fromList inputs - emptyRef <- mkParentPointer Absent + emptyRef <- liftIO DiffMap.newEmptyReference diffMap <- populateDiffMap inputs noDifferenceMaps $ DiffMap.empty emptyRef checkAll reference diffMap where @@ -124,9 +131,51 @@ insertionsAndLookups = it "insertions and lookups" $ let accumDiffMap'' = DiffMap.insert accAddr accIdx $ DiffMap.empty pRef populateDiffMap rest (remaining - 1) accumDiffMap'' +-- | A test that makes sure if multiple difference maps are +-- derivied via a common parent, then additions in one branch +-- is not propagating to other branches. +testMultipleChildrenDifferenceMaps :: Assertion +testMultipleChildrenDifferenceMaps = do + emptyRoot <- liftIO DiffMap.newEmptyReference + -- The common parent + let parent = uncurry DiffMap.insert (dummyPair 1) $ DiffMap.empty emptyRoot + parentReference <- mkParentPointer $ Present parent + -- First branch + let branch0 = uncurry DiffMap.insert (dummyPair 2) $ DiffMap.empty parentReference + -- Second branch + let branch1 = uncurry DiffMap.insert (dummyPair 3) $ DiffMap.empty parentReference + + -- Account from common parent should exist in both branches. + checkExists (fst $ dummyPair 1) (snd $ dummyPair 1) branch0 + checkExists (fst $ dummyPair 1) (snd $ dummyPair 1) branch1 + -- Check that we cannot lookup elements from a different branch. + checkNotExists (fst $ dummyPair 2) branch1 + checkNotExists (fst $ dummyPair 3) branch0 + + where + checkExists addr expectedAccIdx diffMap = testDoLookup addr diffMap >>= \case + Just accIdx -> liftIO $ assertEqual "Account index should match" expectedAccIdx accIdx + Nothing -> liftIO $ assertFailure "Expected an entry" + checkNotExists addr diffMap = testDoLookup addr diffMap >>= \case + Just _ -> liftIO $ assertFailure "Did not expect an entry" + Nothing -> return () + +-- | Test the 'fromList' function. +testFromList :: Assertion +testFromList = do + emptyRoot <- liftIO DiffMap.newEmptyReference + -- check creating from empty list + let emptyDiffMap = DiffMap.empty emptyRoot + liftIO $ assertBool "fromList on empty list should yield the empty difference map" (emptyDiffMap == DiffMap.fromList emptyRoot []) + -- check for a difference map with 1 element. + let nonEmptyDiffMap = uncurry DiffMap.insert (dummyPair 1) $ DiffMap.empty emptyRoot + liftIO $ assertBool "fromList on empty list should yield the empty difference map" (nonEmptyDiffMap == DiffMap.fromList emptyRoot [dummyPair 1]) + tests :: Spec tests = describe "AccountMap.DifferenceMap" $ do it "Test insert and lookup account" testInsertLookupAccount it "test lookups" testLookups it "Test flatten" testFlatten + it "test lookups on branches" testMultipleChildrenDifferenceMaps + it "test fromList" testFromList insertionsAndLookups From f367133705c0ea1f6aad14743c97ac241f58311f Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Wed, 8 Nov 2023 07:36:10 +0100 Subject: [PATCH 74/92] Formatting. --- .../GlobalStateTests/DifferenceMap.hs | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs index a637bf0f35..2f01fc8bb2 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs @@ -81,7 +81,6 @@ testFlatten = do diffMap2Pointer <- mkParentPointer $ Present diffMap2 let diffMap3 = uncurry DiffMap.insert (dummyPair 3) (DiffMap.empty diffMap2Pointer) assertEqual "accounts should be the same" (map dummyPair [1 .. 3]) =<< DiffMap.flatten diffMap3 - -- | Make the reference map for comparing lookups. makeReference :: [(AccountAddress, AccountIndex)] -> HM.HashMap AccountAddress AccountIndex @@ -137,7 +136,7 @@ insertionsAndLookups = it "insertions and lookups" $ testMultipleChildrenDifferenceMaps :: Assertion testMultipleChildrenDifferenceMaps = do emptyRoot <- liftIO DiffMap.newEmptyReference - -- The common parent + -- The common parent let parent = uncurry DiffMap.insert (dummyPair 1) $ DiffMap.empty emptyRoot parentReference <- mkParentPointer $ Present parent -- First branch @@ -151,14 +150,15 @@ testMultipleChildrenDifferenceMaps = do -- Check that we cannot lookup elements from a different branch. checkNotExists (fst $ dummyPair 2) branch1 checkNotExists (fst $ dummyPair 3) branch0 - where - checkExists addr expectedAccIdx diffMap = testDoLookup addr diffMap >>= \case - Just accIdx -> liftIO $ assertEqual "Account index should match" expectedAccIdx accIdx - Nothing -> liftIO $ assertFailure "Expected an entry" - checkNotExists addr diffMap = testDoLookup addr diffMap >>= \case - Just _ -> liftIO $ assertFailure "Did not expect an entry" - Nothing -> return () + checkExists addr expectedAccIdx diffMap = + testDoLookup addr diffMap >>= \case + Just accIdx -> liftIO $ assertEqual "Account index should match" expectedAccIdx accIdx + Nothing -> liftIO $ assertFailure "Expected an entry" + checkNotExists addr diffMap = + testDoLookup addr diffMap >>= \case + Just _ -> liftIO $ assertFailure "Did not expect an entry" + Nothing -> return () -- | Test the 'fromList' function. testFromList :: Assertion @@ -170,7 +170,7 @@ testFromList = do -- check for a difference map with 1 element. let nonEmptyDiffMap = uncurry DiffMap.insert (dummyPair 1) $ DiffMap.empty emptyRoot liftIO $ assertBool "fromList on empty list should yield the empty difference map" (nonEmptyDiffMap == DiffMap.fromList emptyRoot [dummyPair 1]) - + tests :: Spec tests = describe "AccountMap.DifferenceMap" $ do it "Test insert and lookup account" testInsertLookupAccount From 726d0ad187443fa0bbdd1282dc187067e3d0a461 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Wed, 8 Nov 2023 12:36:22 +0100 Subject: [PATCH 75/92] Improve documentation and only create a new blobstore when required (consensus v1). --- .../src/Concordium/GlobalState.hs | 1 + .../src/Concordium/KonsensusV1/SkovMonad.hs | 17 ++++++++++------- 2 files changed, 11 insertions(+), 7 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState.hs b/concordium-consensus/src/Concordium/GlobalState.hs index c972d5005a..2eb72233db 100644 --- a/concordium-consensus/src/Concordium/GlobalState.hs +++ b/concordium-consensus/src/Concordium/GlobalState.hs @@ -85,6 +85,7 @@ initialiseExistingGlobalState _ GlobalStateConfig{..} = do -- | Initialize a 'PersistentBlockStateContext' via the provided -- 'GlobalStateConfig'. +-- This function attempts to create a new blob store. initializePersistentBlockStateContext :: GlobalStateConfig -> IO (PersistentBlockStateContext pv) initializePersistentBlockStateContext GlobalStateConfig{..} = liftIO $ do pbscBlobStore <- createBlobStore dtdbBlockStateFile diff --git a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs index 7ce95cb567..c34ab39c3b 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs @@ -501,7 +501,7 @@ initialiseExistingSkovV1 bakerCtx handlerCtx unliftSkov gsc@GlobalStateConfig{.. existingDB <- checkExistingDatabase gscTreeStateDirectory gscBlockStateFile gscAccountMapDirectory if existingDB then do - pbsc <- liftIO $ newPersistentBlockStateContext gsc + pbsc <- newPersistentBlockStateContext False gsc let initWithLLDB skovLldb = do checkDatabaseVersion skovLldb let checkBlockState bs = runReaderT (PBS.runPersistentBlockStateMonad (isValidBlobRef bs)) pbsc @@ -561,7 +561,7 @@ initialiseNewSkovV1 :: LogIO (SkovV1Context pv m, SkovV1State pv) initialiseNewSkovV1 genData bakerCtx handlerCtx unliftSkov gsConfig@GlobalStateConfig{..} = do logEvent Skov LLDebug "Creating new global state." - pbsc@PersistentBlockStateContext{..} <- newPersistentBlockStateContext gsConfig + pbsc@PersistentBlockStateContext{..} <- newPersistentBlockStateContext True gsConfig let initGS :: InitMonad pv (SkovData pv) initGS = do @@ -697,7 +697,7 @@ migrateSkovV1 :: -- | 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 - pbsc@PersistentBlockStateContext{..} <- newPersistentBlockStateContext gsConfig + pbsc@PersistentBlockStateContext{..} <- newPersistentBlockStateContext True gsConfig logEvent GlobalState LLDebug "Migrating existing global state." let newInitialBlockState :: InitMonad pv (HashedPersistentBlockState pv) newInitialBlockState = flip runBlobStoreT oldPbsc . flip runBlobStoreT pbsc $ do @@ -746,17 +746,20 @@ migrateSkovV1 regenesis migration gsConfig@GlobalStateConfig{..} oldPbsc oldBloc -- | Make a new 'PersistentBlockStateContext' based on the -- 'GlobalStateConfig' passed into this function. --- This function creates the block state file i.e. the blob store, --- the account cache and the module cache. +-- This function creates the block state file (the blob store) if @True@ is passed in, +-- otherwise it tries to reuse an existing blob store. +-- New account cache and the module cache are created. newPersistentBlockStateContext :: (IsProtocolVersion pv, MonadIO m) => + -- | Whether a new blobstore should be created or a current one should be reused. + Bool -> -- | The global state config to use -- for constructing the persistent block state context. GlobalStateConfig -> -- | The the persistent block state context. m (PersistentBlockStateContext pv) -newPersistentBlockStateContext GlobalStateConfig{..} = liftIO $ do - pbscBlobStore <- createBlobStore gscBlockStateFile +newPersistentBlockStateContext initialize GlobalStateConfig{..} = liftIO $ do + pbscBlobStore <- if initialize then createBlobStore gscBlockStateFile else loadBlobStore gscBlockStateFile pbscAccountCache <- newAccountCache $ rpAccountsCacheSize gscRuntimeParameters pbscModuleCache <- Modules.newModuleCache $ rpModulesCacheSize gscRuntimeParameters pbscAccountMap <- LMDBAccountMap.openDatabase gscAccountMapDirectory From 4bf7df7ce254cfcbd7d77af6e9080b099a152961 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Thu, 9 Nov 2023 15:06:57 +0100 Subject: [PATCH 76/92] More tests and address review comments. --- .../src/Concordium/GlobalState.hs | 4 +- .../GlobalState/AccountMap/DifferenceMap.hs | 19 +++- .../Concordium/GlobalState/AccountMap/LMDB.hs | 37 +++++--- .../src/Concordium/GlobalState/BlockState.hs | 17 +++- .../GlobalState/Persistent/Accounts.hs | 86 +++++++++++-------- .../GlobalState/Persistent/BlockState.hs | 2 +- .../KonsensusV1/Consensus/Finality.hs | 9 +- .../src/Concordium/KonsensusV1/SkovMonad.hs | 8 +- .../KonsensusV1/TreeState/LowLevel/LMDB.hs | 3 +- .../KonsensusV1/TransactionProcessingTest.hs | 3 - .../globalstate/GlobalStateTests/Accounts.hs | 34 +++++++- .../GlobalStateTests/LMDBAccountMap.hs | 29 ++++--- 12 files changed, 163 insertions(+), 88 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState.hs b/concordium-consensus/src/Concordium/GlobalState.hs index 2eb72233db..06b85ef7f4 100644 --- a/concordium-consensus/src/Concordium/GlobalState.hs +++ b/concordium-consensus/src/Concordium/GlobalState.hs @@ -87,7 +87,7 @@ initialiseExistingGlobalState _ GlobalStateConfig{..} = do -- 'GlobalStateConfig'. -- This function attempts to create a new blob store. initializePersistentBlockStateContext :: GlobalStateConfig -> IO (PersistentBlockStateContext pv) -initializePersistentBlockStateContext GlobalStateConfig{..} = liftIO $ do +initializePersistentBlockStateContext GlobalStateConfig{..} = do pbscBlobStore <- createBlobStore dtdbBlockStateFile pbscAccountCache <- newAccountCache (rpAccountsCacheSize dtdbRuntimeParameters) pbscModuleCache <- Modules.newModuleCache (rpModulesCacheSize dtdbRuntimeParameters) @@ -163,7 +163,7 @@ initialiseNewGlobalState genData gsc@GlobalStateConfig{..} = do logEvent GlobalState LLTrace "Creating persistent global state context" initialSkovPersistentData dtdbRuntimeParameters dtdbTreeStateDirectory (genesisConfiguration genData) pbs ser genTT Nothing isd <- - runReaderT (LMDBAccountMap.runAccountMapStoreMonad (runPersistentBlockStateMonad initGS)) pbsc + runReaderT (runPersistentBlockStateMonad initGS) pbsc `onException` liftIO (destroyBlobStore pbscBlobStore) return (pbsc, isd) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index 0a197f6bd5..344c3c9e3b 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -31,6 +31,8 @@ module Concordium.GlobalState.AccountMap.DifferenceMap ( -- Lookup in a difference map (and potential parent maps) whether -- it yields the 'AccountIndex' for the provided 'AccountAddress'. lookupExact, + -- Clear up the references of difference map(s). + clearReferences, ) where import Control.Monad.IO.Class @@ -122,9 +124,8 @@ lookupViaEquivalenceClass addr dm = -- difference maps via an exactness check. -- Returns @Just AccountIndex@ if the account is present and -- otherwise @Nothing@. --- Precondition: As this implementation checks for exactness of the provided --- @AccountAddress@ then it MUST only be used when account aliases are NOT supported by the --- protocol. +-- Note that this function also returns @Nothing@ if the provided 'AccountAddress.' +-- is an alias but not the canonical address. lookupExact :: (MonadIO m) => AccountAddress -> DifferenceMap -> m (Maybe AccountIndex) lookupExact addr diffMap = lookupViaEquivalenceClass' (accountAddressEmbed addr) diffMap >>= \case @@ -132,7 +133,7 @@ lookupExact addr diffMap = Just (accIdx, actualAddr) -> if actualAddr == addr then return $ Just accIdx else return Nothing -- | Insert an account into the difference map. --- Note that it is up to the caller to ensure only the canonical 'AccountAddress' is being inserted. +-- Note that it is up to the caller to ensure only the canonical 'AccountAddress' is inserted. insert :: AccountAddress -> AccountIndex -> DifferenceMap -> DifferenceMap insert addr accIndex m = m{dmAccounts = HM.insert (accountAddressEmbed addr) (accIndex, addr) $ dmAccounts m} @@ -146,3 +147,13 @@ fromList parentRef listOfAccountsAndIndices = where -- Make a key value pair to put in the @dmAccounts@. mkKeyVal (accAddr, accIdx) = (accountAddressEmbed accAddr, (accIdx, accAddr)) + +-- | Clear the reference to the parent difference map (if any). +-- Note that if there is a parent map then this function clears the remaining parent references +-- recursively. +clearReferences :: (MonadIO m) => DifferenceMap -> m () +clearReferences DifferenceMap{..} = do + oParentDiffMap <- liftIO $ readIORef dmParentMapRef + case oParentDiffMap of + Absent -> liftIO $ atomicWriteIORef dmParentMapRef Absent + Present diffMap -> clearReferences diffMap diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs index e9ce852308..174fe3ce85 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/LMDB.hs @@ -45,6 +45,7 @@ import qualified Data.ByteString as BS import Data.Data (Typeable) import qualified Data.FixedByteString as FBS import Data.Kind (Type) +import Data.Word import Database.LMDB.Raw import Lens.Micro.Platform import System.Directory @@ -89,26 +90,32 @@ class (Monad m) => MonadAccountMapStore m where -- | Looks up the ‘AccountIndex’ for the provided ‘AccountAddress'. -- Returns @Just AccountIndex@ if the account is present in the ‘AccountMap’ -- and returns @Nothing@ if the account was not present. + -- Note that this only returns a result for the canonical account address. lookupAccountIndexViaExactness :: AccountAddress -> m (Maybe AccountIndex) -- | Return all the canonical addresses and their associated account indices of accounts present -- in the store where their @AccountIndex@ is less or equal to the provided @AccountIndex@. getAllAccounts :: AccountIndex -> m [(AccountAddress, AccountIndex)] - -- | Checks whether the lmdb store is initialized or not. - isInitialized :: m Bool + -- | Get number of entries in the account map. + getNumberOfAccounts :: m Word64 + + -- | Clear and set the accounts to the ones provided. + reconstruct :: [(AccountAddress, AccountIndex)] -> m () instance (Monad (t m), MonadTrans t, MonadAccountMapStore m) => MonadAccountMapStore (MGSTrans t m) where insertAccounts accs = lift $ insertAccounts accs lookupAccountIndexViaEquivalence = lift . lookupAccountIndexViaEquivalence lookupAccountIndexViaExactness = lift . lookupAccountIndexViaExactness getAllAccounts = lift . getAllAccounts - isInitialized = lift isInitialized + getNumberOfAccounts = lift getNumberOfAccounts + reconstruct = lift . reconstruct {-# INLINE insertAccounts #-} {-# INLINE lookupAccountIndexViaEquivalence #-} {-# INLINE lookupAccountIndexViaExactness #-} {-# INLINE getAllAccounts #-} - {-# INLINE isInitialized #-} + {-# INLINE getNumberOfAccounts #-} + {-# INLINE reconstruct #-} deriving via (MGSTrans (StateT s) m) instance (MonadAccountMapStore m) => MonadAccountMapStore (StateT s m) deriving via (MGSTrans (ExceptT e) m) instance (MonadAccountMapStore m) => MonadAccountMapStore (ExceptT e m) @@ -119,24 +126,24 @@ instance (MonadAccountMapStore m) => MonadAccountMapStore (PutT m) where lookupAccountIndexViaEquivalence = lift . lookupAccountIndexViaEquivalence lookupAccountIndexViaExactness = lift . lookupAccountIndexViaExactness getAllAccounts = lift . getAllAccounts - isInitialized = lift isInitialized + getNumberOfAccounts = lift getNumberOfAccounts + reconstruct = lift . reconstruct {-# INLINE insertAccounts #-} {-# INLINE lookupAccountIndexViaEquivalence #-} {-# INLINE lookupAccountIndexViaExactness #-} {-# INLINE getAllAccounts #-} - {-# INLINE isInitialized #-} + {-# INLINE getNumberOfAccounts #-} + {-# INLINE reconstruct #-} -- * Database stores -- | Store that retains the account address -> account index mappings. newtype AccountMapStore = AccountMapStore MDB_dbi' +-- | Name of the table used for storing the map from account addresses to account indices. accountMapStoreName :: String accountMapStoreName = "accounts" -lfbHashStoreName :: String -lfbHashStoreName = "lfb" - instance MDBDatabase AccountMapStore where type DBKey AccountMapStore = AccountAddress type DBValue AccountMapStore = AccountIndex @@ -269,7 +276,13 @@ instance go _ (Just (Left err)) = throwM $ DatabaseInvariantViolation err in go [] =<< getCursor CursorFirst cursor - isInitialized = do + getNumberOfAccounts = do + dbh <- ask + asReadTransaction (dbh ^. dbhStoreEnv) $ \txn -> databaseSize txn (dbh ^. dbhAccountMapStore) + + reconstruct accounts = do dbh <- ask - size <- asReadTransaction (dbh ^. dbhStoreEnv) $ \txn -> databaseSize txn (dbh ^. dbhAccountMapStore) - return $ size /= 0 + asWriteTransaction (dbh ^. dbhStoreEnv) $ \txn -> do + deleteAll txn (dbh ^. dbhAccountMapStore) + forM_ accounts $ \(accAddr, accIndex) -> do + storeRecord txn (dbh ^. dbhAccountMapStore) accAddr accIndex diff --git a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs index 4d697bf7d8..5a4f33fa76 100644 --- a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs @@ -1393,17 +1393,28 @@ class (BlockStateOperations m, FixedSizeSerialization (BlockStateRef m)) => Bloc saveAccounts :: BlockState m -> m () -- | Reconstructs the account difference map and return it. + -- This function is used for blocks that are stored but are not finalized (in particular, certified blocks) + -- since only the accounts for finalized blocks are stored in the LMDB store. + -- -- Preconditions: -- * This function MUST only be called on a certified block. -- * This function MUST only be called on a block state that does not already - -- * have a difference map. + -- have a difference map. -- * The provided list of accounts MUST correspond to the accounts created in the block, -- and the account addresses in the list MUST be by order of creation. - -- * The provided difference map (if any) MUST be the one of the parent block. + -- * The provided difference map reference MUST be the one of the parent block. -- -- This function should only be used when starting from an already initialized state, and hence -- we need to reconstruct the difference map since the accounts are not yet finalized. - reconstructAccountDifferenceMap :: BlockState m -> DiffMap.DifferenceMapReference -> [AccountAddress] -> m DiffMap.DifferenceMapReference + reconstructAccountDifferenceMap :: + -- | The block state to reconstruct the difference map for. + BlockState m -> + -- | The difference map reference from the parent block's state. + DiffMap.DifferenceMapReference -> + -- | The account addresses created in the block, in order of creation. + [AccountAddress] -> + -- | Reference to the new difference map for the block. + m DiffMap.DifferenceMapReference -- | Load a block state from a reference, given its state hash if provided, -- otherwise calculate the state hash upon loading. diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 1ed5768d5d..bdf327d8ac 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -42,6 +42,9 @@ -- The account map resides in its own lmdb database and functions across protocol versions. -- For non-persisted blocks, then the ‘DifferenceMap' is 'DiffMap.DifferenceMapReference', -- i.e. either @IORef Nothing@ or @IORef (Just DifferenceMap)@ depending on whether the block is written to disk. +-- When a block state is thawed (made ready for modification), then a new 'DiffMap.DifferenceMap' is created for the @Accounts pv@ structure +-- of the 'UpdatableBlockState' which has a parent pointer on the 'DiffMap.DifferenceMap' of the block state that was thawed. +-- -- The 'putNewAccount' function creates a new 'DifferenceMap' on demand, hence a new 'Accounts' is initialized with a @accountDiffMap@ set to @IORef Nothing@. -- Subsequent accounts created are then being added to the difference map created by the first invocation of 'putNewAccount'. -- Blocks that are persisted always have a @IORef Nothing@ 'accountDiffMapRef'. @@ -142,22 +145,22 @@ instance (SupportsPersistentAccount pv m) => MHashableTo m H.Hash (Accounts pv) -- | Write accounts created for this block or any non-persisted parent block. -- Note that this also empties the difference map for this block. --- --- Precondition: This MUST be called when finalizing the block state, and the --- provided @BlockHash@ must correespond to the hash of the finalized block. +-- This function MUST be called whenver a block is finalized. writeAccountsCreated :: (SupportsPersistentAccount pv m) => Accounts pv -> m () writeAccountsCreated Accounts{..} = do mAccountsCreated <- liftIO $ readIORef accountDiffMapRef - case mAccountsCreated of - Absent -> return () - Present accountsCreated -> do - listOfAccountsCreated <- liftIO $ DiffMap.flatten accountsCreated - liftIO $ atomicWriteIORef accountDiffMapRef Absent - LMDBAccountMap.insertAccounts listOfAccountsCreated + forM_ mAccountsCreated $ \accountsCreated -> do + listOfAccountsCreated <- liftIO $ DiffMap.flatten accountsCreated + -- Write all accounts from the difference map to the lmdb backed account map. + LMDBAccountMap.insertAccounts listOfAccountsCreated + -- Finally, clear the difference map for this block state and all parent block states. + liftIO $ do + DiffMap.clearReferences accountsCreated + atomicWriteIORef accountDiffMapRef Absent -- | Create a new @Accounts pv@ structure from the provided one. -- This function creates a new 'DiffMap.DifferenceMap' for the resulting @Accounts pv@ which --- has a reference to the provided @Accounts pv@. +-- has a reference to the difference map of the provided @Accounts pv@. mkNewChildDifferenceMap :: (SupportsPersistentAccount pv m) => Accounts pv -> m (Accounts pv) mkNewChildDifferenceMap accts@Accounts{..} = do newDiffMapRef <- liftIO $ newIORef $ Present $ DiffMap.empty accountDiffMapRef @@ -168,10 +171,10 @@ mkNewChildDifferenceMap accts@Accounts{..} = do -- below preconditions are respected. -- Precondition: -- * The function assumes that the account table already yields every account added for the block state. --- * The provided @IORef (Option (DiffMap.DifferenceMap))@ MUST correspond to the parent map. +-- * The provided 'DiffMap.DifferenceMapReference@ MUST correspond to the parent map. -- * The provided list of accounts MUST be in ascending order of account index, hence the list of accounts -- MUST be provided in the order of which the corresponding credential deployment transactions were executed. -unsafeReconstructDifferenceMap :: +reconstructDifferenceMap :: (SupportsPersistentAccount pv m) => -- | Reference to the parent difference map. DiffMap.DifferenceMapReference -> @@ -181,22 +184,29 @@ unsafeReconstructDifferenceMap :: Accounts pv -> -- | Reference to the newly created difference map. m DiffMap.DifferenceMapReference -unsafeReconstructDifferenceMap parentRef listOfAccounts Accounts{..} = do +reconstructDifferenceMap parentRef listOfAccounts Accounts{..} = do -- As it is presumed that the account table already yields any accounts added, then -- in order to the obtain the account indices we subtract the number of accounts missing -- missing in the lmdb account map from the total number of accounts, hence obtaining the first @AccountIndex@ -- to use for adding new accounts to the lmdb backed account map. - let diffMap' = DiffMap.fromList parentRef $ zip listOfAccounts $ map AccountIndex [(L.size accountTable - fromIntegral (length listOfAccounts)) ..] + let diffMap' = DiffMap.fromList parentRef $ zip listOfAccounts [AccountIndex (L.size accountTable - fromIntegral (length listOfAccounts)) ..] liftIO $ atomicWriteIORef accountDiffMapRef $ Present diffMap' return accountDiffMapRef +-- | Determine whether the given protocol version requires an account map entry +-- in the storage of 'Accounts'. We require this for all protocol versions that exist +-- prior to the account map storage revision (i.e. 'P6' and earlier) for compatibility +-- with databases created by versions of the node that store the account map in +-- the block state. +storeRequiresAccountMap :: SProtocolVersion pv -> Bool +storeRequiresAccountMap spv = demoteProtocolVersion spv <= P6 + instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where storeUpdate Accounts{..} = do -- put an empty 'OldMap.PersistentAccountMap'. -- In earlier versions of the node the above mentioned account map was used, -- but this is now superseded by the 'LMDBAccountMap.MonadAccountMapStore'. - -- We put this empty map here to remain backwards compatible. - -- This should be revised as part of a future protocol update when the database layout can be changed. + -- We put this empty map here if the protocol version requires it in order to remain backwards compatible. (emptyOldMap, _) <- storeUpdate $ OldMap.empty @pv @BufferedFix (pTable, accountTable') <- storeUpdate accountTable (pRegIdHistory, regIdHistory') <- storeUpdate accountRegIdHistory @@ -206,13 +216,14 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where accountRegIdHistory = regIdHistory', .. } - return (emptyOldMap >> pTable >> pRegIdHistory, newAccounts) + let putf = do + when (storeRequiresAccountMap (protocolVersion @pv)) emptyOldMap + pTable + pRegIdHistory + return (putf, newAccounts) load = do - -- load the persistent account map and throw it away. We always put an empty one in, - -- but that has not always been the case. But the 'OldMap.PersistentAccountMap' is now superseded by - -- the LMDBAccountMap.MonadAccountMapStore. - -- This should be revised as part of a future protocol update when the database layout can be changed. - void (load :: Get (m (OldMap.PersistentAccountMap pv))) + when (storeRequiresAccountMap (protocolVersion @pv)) $ do + void (load :: Get (m (OldMap.PersistentAccountMap pv))) maccountTable <- load mrRIH <- load return $ do @@ -243,7 +254,7 @@ putNewAccount !acct a0@Accounts{..} = do False -> do (accIdx, newAccountTable) <- L.append acct accountTable mAccountDiffMap <- liftIO $ readIORef accountDiffMapRef - accountDiffMapRef' <- case mAccountDiffMap of + accountDiffMap' <- case mAccountDiffMap of Absent -> do -- create a difference map for this block state with a @Nothing@ as the parent. freshDifferenceMap <- liftIO DiffMap.newEmptyReference @@ -251,8 +262,7 @@ putNewAccount !acct a0@Accounts{..} = do Present accDiffMap -> do -- reuse the already existing difference map for this block state. return $ DiffMap.insert addr accIdx accDiffMap - -- we write to the difference map atomically here as there might be concurrent readers. - liftIO $ atomicWriteIORef accountDiffMapRef (Present accountDiffMapRef') + liftIO $ atomicWriteIORef accountDiffMapRef (Present accountDiffMap') return (Just accIdx, a0{accountTable = newAccountTable}) -- | Construct an 'Accounts' from a list of accounts. Inserted in the order of the list. @@ -397,13 +407,13 @@ updateAccountsAtIndex' fupd ai = fmap snd . updateAccountsAtIndex fupd' ai -- a concatenation of two lists of account addresses. allAccounts :: (SupportsPersistentAccount pv m) => Accounts pv -> m [(AccountAddress, AccountIndex)] allAccounts accounts = do - -- Get all persisted accounts from the account map up to and including the last account of the account table. - persistedAccs <- LMDBAccountMap.getAllAccounts $ (AccountIndex . L.size) (accountTable accounts) - 1 mDiffMap <- liftIO $ readIORef (accountDiffMapRef accounts) case mDiffMap of - Absent -> return persistedAccs + Absent -> LMDBAccountMap.getAllAccounts $ (AccountIndex . L.size) (accountTable accounts) - 1 Present accDiffMap -> do + -- Get all persisted accounts from the account map up to and including the last account of the account table minus what we found the in the difference map. flattenedDiffMapAccounts <- DiffMap.flatten accDiffMap + persistedAccs <- LMDBAccountMap.getAllAccounts $ (AccountIndex . L.size) (accountTable accounts) - (1 + fromIntegral (length flattenedDiffMapAccounts)) return $! persistedAccs <> flattenedDiffMapAccounts -- | Get a list of all account addresses. @@ -426,14 +436,22 @@ foldAccounts f a accts = L.mfold f a (accountTable accts) foldAccountsDesc :: (SupportsPersistentAccount pv m) => (a -> PersistentAccount (AccountVersionFor pv) -> m a) -> a -> Accounts pv -> m a foldAccountsDesc f a accts = L.mfoldDesc f a (accountTable accts) --- | If the LMDB account map is not already initialized, then this function populates the LMDB account map via the provided provided 'Accounts'. --- Otherwise, this function does nothing. --- --- Precondition: The provided @BlockHash@ must correspond to the last finalized block when calling this function. +-- | Initialize the LMDB account map if it is not already. +-- This puts in all accounts from the account table of the provided block state into the account map. +-- If there already are accounts present in the account map, then we check that the size of the account map +-- corresponds with number of accounts in the account table. +-- If the number of accounts in the account table and account map matches, then this function does nothing. +-- If they do not match, wipe the account map and recreate it from the account table. tryPopulateLMDBStore :: (SupportsPersistentAccount pv m) => Accounts pv -> m () tryPopulateLMDBStore accts = do - isInitialized <- LMDBAccountMap.isInitialized - unless isInitialized (void $ LMDBAccountMap.insertAccounts =<< allAccountsViaTable) + noLMDBAccounts <- LMDBAccountMap.getNumberOfAccounts + let expectedSize = L.size $ accountTable accts + when (noLMDBAccounts /= expectedSize) $ do + -- The number of accounts in the lmdb backed account map does not match + -- the number of accounts in the account table. + -- Clear the map and reconstruct it from the accounts table. + -- This ensures consistency across restarts between the last finalized block and the account map. + LMDBAccountMap.reconstruct =<< allAccountsViaTable where allAccountsViaTable = fst diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs index bc0cae10bb..5905b4b68f 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/BlockState.hs @@ -3595,7 +3595,7 @@ instance (IsProtocolVersion pv, PersistentState av pv r m) => BlockStateStorage reconstructAccountDifferenceMap HashedPersistentBlockState{..} parentDifferenceMap listOfAccounts = do accs <- bspAccounts <$> loadPBS hpbsPointers - Accounts.unsafeReconstructDifferenceMap parentDifferenceMap listOfAccounts accs + Accounts.reconstructDifferenceMap parentDifferenceMap listOfAccounts accs loadBlockState hpbsHashM ref = do hpbsPointers <- liftIO $ newIORef $ blobRefToBufferedRef ref diff --git a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs index 8aab82d4cb..6ba984f089 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/Consensus/Finality.hs @@ -202,13 +202,8 @@ makeStoredBlock :: BlockPointer (MPV m) -> m (LowLevel.StoredBlock (MPV m)) makeStoredBlock finalized blockPtr = do - statePointer <- - if finalized - then do - ref <- saveBlockState (bpState blockPtr) - saveAccounts (bpState blockPtr) - return ref - else saveBlockState (bpState blockPtr) + statePointer <- saveBlockState (bpState blockPtr) + when finalized $ saveAccounts (bpState blockPtr) return LowLevel.StoredBlock { stbInfo = blockMetadata blockPtr, diff --git a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs index c34ab39c3b..d25efb6d15 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/SkovMonad.hs @@ -471,18 +471,18 @@ data ExistingSkov pv m = ExistingSkov -- used for computations where both lmdb databases are required. data LMDBDatabases pv = LMDBDatabases { -- | the skov lmdb database - _lmdbSkovLmdb :: !(DatabaseHandlers pv), + _lmdbSkov :: !(DatabaseHandlers pv), -- | the account map lmdb database - _lmdbDSAccMap :: !LMDBAccountMap.DatabaseHandlers + _lmdbAccountMap :: !LMDBAccountMap.DatabaseHandlers } makeLenses ''LMDBDatabases instance HasDatabaseHandlers (LMDBDatabases pv) pv where - databaseHandlers = lmdbSkovLmdb + databaseHandlers = lmdbSkov instance LMDBAccountMap.HasDatabaseHandlers (LMDBDatabases pv) where - databaseHandlers = lmdbDSAccMap + databaseHandlers = lmdbAccountMap -- | Load an existing SkovV1 state. -- Returns 'Nothing' if there is no database to load. diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs index 417448692a..86abdf4dc6 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs @@ -685,8 +685,7 @@ rollBackBlocksUntil :: ) => -- | Callback for checking if the state at a given reference is valid. (BlockStateRef pv -> DiskLLDBM pv m Bool) -> - -- | Returns the number of blocks rolled back, the best state after the roll back and a list of - -- accounts created in certified blocks that was rolled back. + -- | Returns the number of blocks rolled back and the best state after the roll back. DiskLLDBM pv m RollbackResult rollBackBlocksUntil checkState = do lookupLastFinalizedBlock >>= \case diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs index dd2a55ef9b..d39a9ca44c 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs @@ -137,9 +137,6 @@ newtype NoLoggerT m a = NoLoggerT {runNoLoggerT :: m a} instance (Monad m) => MonadLogger (NoLoggerT m) where logEvent _ _ _ = return () --- deriving instance (TimeMonad m) => TimeMonad (NoLoggerT m) --- deriving instance (MonadState s m) => MonadState s (NoLoggerT m) - -- | A test monad that is suitable for testing transaction processing -- as it derives the required capabilities. -- I.e. 'BlockStateQuery' is supported via the 'PersistentBlockStateMonad and a 'MonadState' over the 'SkovData pv'. diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs index 9d9d510998..489773cf49 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/Accounts.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -13,6 +12,7 @@ import Concordium.Crypto.FFIDataTypes import qualified Concordium.Crypto.SHA256 as H import qualified Concordium.Crypto.SignatureScheme as Sig import qualified Concordium.GlobalState.AccountMap as AccountMap +import qualified Concordium.GlobalState.AccountMap.DifferenceMap as DiffMap import qualified Concordium.GlobalState.AccountMap.LMDB as LMDBAccountMap import Concordium.GlobalState.Basic.BlockState.Account as BA import Concordium.GlobalState.DummyData @@ -27,10 +27,14 @@ import qualified Concordium.ID.Types as ID import Concordium.Logger import Concordium.Types import Concordium.Types.HashableTo +import Concordium.Types.Option (Option (..)) import Control.Exception (bracket) import Control.Monad.Reader import Data.Either import qualified Data.FixedByteString as FBS +import qualified Data.HashMap.Strict as HM +import Data.IORef +import Data.List (sortOn) import qualified Data.Map.Strict as Map import Data.Serialize as S import qualified Data.Set as Set @@ -88,6 +92,7 @@ data AccountAction | RecordRegId ID.CredentialRegistrationID AccountIndex | FlushPersistent | ArchivePersistent + | Reconstruct randomizeAccount :: AccountAddress -> ID.CredentialPublicKeys -> Gen (Account (AccountVersionFor PV)) randomizeAccount _accountAddress _accountVerificationKeys = do @@ -120,7 +125,8 @@ randomActions = sized (ra Set.empty Map.empty) (ArchivePersistent :) <$> ra s rids (n - 1), exRandReg, recRandReg, - updateRandAcc + updateRandAcc, + (Reconstruct :) <$> ra s rids (n - 1) ] ++ if null s then [] @@ -182,8 +188,9 @@ runAccountAction :: (P.SupportsPersistentAccount PV m, av ~ AccountVersionFor PV runAccountAction (PutAccount acct) (ba, pa) = do let ba' = B.putNewAccount acct ba pAcct <- PA.makePersistentAccount acct - pa' <- P.putNewAccount pAcct pa - return (snd ba', snd pa') + pa' <- P.mkNewChildDifferenceMap pa + pa'' <- P.putNewAccount pAcct pa' + return (snd ba', snd pa'') runAccountAction (Exists addr) (ba, pa) = do let be = B.exists addr ba pe <- P.exists addr pa @@ -222,6 +229,25 @@ runAccountAction (RecordRegId rid ai) (ba, pa) = do let ba' = B.recordRegId (ID.toRawCredRegId rid) ai ba pa' <- P.recordRegId rid ai pa return (ba', pa') +runAccountAction Reconstruct (ba, pa) = do + oPaDiffMap <- liftIO $ readIORef $ P.accountDiffMapRef pa + -- Get the parent difference map reference and a list of accounts of the current difference map. + (parentDiffMapRef, diffMapAccs) <- case oPaDiffMap of + Absent -> do + ref <- liftIO DiffMap.newEmptyReference + return (ref, []) + Present paDiffMap -> do + let ref = DiffMap.dmParentMapRef paDiffMap + -- Note that we sort them by ascending account index such that the order + -- matches the insertion order. + accs = map snd $ sortOn fst $ HM.elems $ DiffMap.dmAccounts paDiffMap + return (ref, accs) + -- create pa' which is the same as pa, but with an empty difference map. + emptyRef <- liftIO DiffMap.newEmptyReference + let pa' = pa{P.accountDiffMapRef = emptyRef} + -- reconstruct pa into pa'. + void $ P.reconstructDifferenceMap parentDiffMapRef diffMapAccs pa' + return (ba, pa') emptyTest :: SpecWith (PersistentBlockStateContext PV) emptyTest = diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs index d304d4d4ce..697670a624 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/LMDBAccountMap.hs @@ -11,6 +11,7 @@ module GlobalStateTests.LMDBAccountMap where import Control.Exception (bracket) import Control.Monad.Reader +import qualified Data.HashMap.Strict as HM import Data.Maybe (isJust, isNothing) import System.IO.Temp import System.Random @@ -49,19 +50,13 @@ testDoLookup accAddr = do liftIO $ assertEqual "Results should be the same" res1 res2 return res1 --- | Test that a database is not initialized. -testCheckNotInitialized :: Assertion -testCheckNotInitialized = runTest "notinitialized" $ do - isInitialized <- LMDBAccountMap.isInitialized - liftIO $ assertBool "database should not have been initialized" $ not isInitialized - -- | Test that a database is initialized. -testCheckDbInitialized :: Assertion -testCheckDbInitialized = runTest "initialized" $ do +testCheckDBNoOfAccounts :: Assertion +testCheckDBNoOfAccounts = runTest "initialized" $ do -- initialize the database void $ LMDBAccountMap.insertAccounts [dummyPair 1] - isInitialized <- LMDBAccountMap.isInitialized - liftIO $ assertBool "database should have been initialized" isInitialized + noOfAccounts <- LMDBAccountMap.getNumberOfAccounts + liftIO $ assertEqual "database should have been initialized" 1 noOfAccounts -- | Test that inserts a set of accounts and afterwards asserts that they are present. testInsertAndLookupAccounts :: Assertion @@ -103,10 +98,20 @@ testGetAllAccounts = runTest "allaccounts" $ do isPresent <- isJust <$> testDoLookup accAddr liftIO $ assertBool "account should be present" isPresent +-- | Test reconstructing a lmdb evicts all former values and puts in the new ones. +testReconstruction :: Assertion +testReconstruction = runTest "reconstruction" $ do + void $ LMDBAccountMap.insertAccounts $ dummyPair <$> [0 .. 42] + accs0 <- LMDBAccountMap.getAllAccounts (AccountIndex 43) + liftIO $ assertEqual "accounts before reconstruction should be equal" (HM.fromList (dummyPair <$> [0 .. 42])) (HM.fromList accs0) + void $ LMDBAccountMap.reconstruct $ dummyPair <$> [100 .. 142] + accs1 <- LMDBAccountMap.getAllAccounts (AccountIndex 143) + liftIO $ assertEqual "accounts after reconstruction should match" (HM.fromList (dummyPair <$> [100 .. 142])) (HM.fromList accs1) + tests :: Spec tests = describe "AccountMap.LMDB" $ do - it "Test checking db is not initialized" testCheckNotInitialized - it "Test checking db is initialized" testCheckDbInitialized + it "Test checking db is initialized" testCheckDBNoOfAccounts it "Test inserts and lookups" testInsertAndLookupAccounts it "Test getting all accounts" testGetAllAccounts it "Test looking up account via alias" testLookupAccountViaAlias + it "Test reconstruction" testReconstruction From 39e39ceeb855489d8325db3b5a9663ace0584179 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Thu, 9 Nov 2023 16:13:35 +0100 Subject: [PATCH 77/92] More safety to 'getAccountIndex' in order to support dry runs. --- .../GlobalState/Persistent/Accounts.hs | 23 ++++++++++++++----- 1 file changed, 17 insertions(+), 6 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index bdf327d8ac..08a9ccff86 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -295,17 +295,21 @@ getAccountIndex :: forall pv m. (SupportsPersistentAccount pv m) => AccountAddre getAccountIndex addr Accounts{..} = do mAccountDiffMap <- liftIO $ readIORef accountDiffMapRef case mAccountDiffMap of - Absent -> lookupDisk + Absent -> lookupDisk 0 Present accDiffMap -> if supportsAccountAliases (protocolVersion @pv) then DiffMap.lookupViaEquivalenceClass (accountAddressEmbed addr) accDiffMap >>= \case Just accIdx -> return $ Just accIdx - Nothing -> lookupDisk + Nothing -> do + diffMapSize <- length <$> DiffMap.flatten accDiffMap + lookupDisk $ fromIntegral diffMapSize else DiffMap.lookupExact addr accDiffMap >>= \case Just accIdx -> return $ Just accIdx - Nothing -> lookupDisk + Nothing -> do + diffMapSize <- length <$> DiffMap.flatten accDiffMap + lookupDisk $ fromIntegral diffMapSize where -- Lookup the 'AccountIndex' in the lmdb backed account map, -- and make sure it's within the bounds of the account table. @@ -313,12 +317,19 @@ getAccountIndex addr Accounts{..} = do -- yields accounts which are not yet present in the @accountTable@. -- In particular this can be the case if finalized blocks have been rolled -- back as part of database recovery. - withSafeBounds Nothing = Nothing - withSafeBounds (Just accIdx@(AccountIndex k)) = if k <= L.size accountTable - 1 then Just accIdx else Nothing - lookupDisk = + -- + -- The extra @diffMapSize@ constraint is necessary in the case where a parent block to the last finalized block + -- is used for extending. This is normally not the case as blocks are typically built from the "best" block always. + -- + -- However for scenarios like dry runs, then we need this extra constraint, as otherwise an account created in the + -- in the dry run would point to an account created in a successor of the block that the dry run is extending. + lookupDisk diffMapSize = if supportsAccountAliases (protocolVersion @pv) then withSafeBounds <$> LMDBAccountMap.lookupAccountIndexViaEquivalence (accountAddressEmbed addr) else withSafeBounds <$> LMDBAccountMap.lookupAccountIndexViaExactness addr + where + withSafeBounds Nothing = Nothing + withSafeBounds (Just accIdx@(AccountIndex k)) = if k <= fromIntegral (L.size accountTable) - (1 + diffMapSize) then Just accIdx else Nothing -- | Retrieve an account with the given address. -- Returns @Nothing@ if no such account exists. From ab35db1a5e630598e77dabb5e6b5e60e7c042340 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Thu, 9 Nov 2023 16:58:42 +0100 Subject: [PATCH 78/92] Fix loading certfied blocks and reconstructing different maps. --- .../KonsensusV1/TreeState/StartUp.hs | 28 +++++++++++++++---- 1 file changed, 22 insertions(+), 6 deletions(-) diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs index 7f0fd7f52e..e398417c9f 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/StartUp.hs @@ -9,6 +9,7 @@ import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.State.Strict import qualified Data.Map.Strict as Map + import Data.Maybe import qualified Data.Sequence as Seq import Lens.Micro.Platform @@ -42,6 +43,7 @@ import Concordium.TimeMonad import Concordium.TransactionVerification as TVer import Concordium.Types.Option import Concordium.Types.Transactions +import qualified Data.HashMap.Strict as HM -- | Generate the 'EpochBakers' for a genesis block. genesisEpochBakers :: @@ -322,12 +324,10 @@ loadCertifiedBlocks :: m () loadCertifiedBlocks = do certBlocks <- LowLevel.lookupCertifiedBlocks - -- The first certified block will have the empty parent difference map reference. - emptyParent <- DiffMap.newEmptyReference -- Load all certified blocks -- This sets the skov state, puts transactions in the transaction table, -- and reconstructs the account map difference maps for the certified blocks. - foldM_ (flip loadCertBlock) emptyParent certBlocks + foldM_ (flip loadCertBlock) (HM.empty :: HM.HashMap BlockHash DiffMap.DifferenceMapReference) certBlocks oLastTimeout <- use $ persistentRoundStatus . prsLatestTimeout forM_ oLastTimeout $ \lastTimeout -> do curRound <- use $ roundStatus . rsCurrentRound @@ -432,12 +432,28 @@ loadCertifiedBlocks = do getAccountAddressFromDeployment bi = case bi of WithMetadata{wmdData = CredentialDeployment{biCred = AccountCreation{..}}} -> (Just . addressFromRegId . credId) credential _ -> Nothing - loadCertBlock (storedBlock, qc) parentDifferenceMapReference = do + loadCertBlock (storedBlock, qc) loadedBlocks = do blockPointer <- mkBlockPointer storedBlock -- As only finalized accounts are stored in the account map, then -- we need to reconstruct the 'DiffMap.DifferenceMap' here for the certified block we're loading. let accountsToInsert = mapMaybe getAccountAddressFromDeployment (blockTransactions storedBlock) - newDifferenceMap <- reconstructAccountDifferenceMap (bpState blockPointer) parentDifferenceMapReference accountsToInsert + -- If a parent cannot be looked up in the @loadedBlocks@ it must mean that parent block is finalized, + -- and as a result we simply set the parent reference for the difference map to be empty. + -- This is alright as the certified blocks we're folding over are in order of ascending round number. + parentDiffMapReference <- case blockBakedData storedBlock of + -- If the parent is a genesis block then there is no difference map for it. + Absent -> liftIO DiffMap.newEmptyReference + Present b -> do + let parentHash = qcBlock $ bbQuorumCertificate $ sbBlock b + -- If the parent cannot be looked up, then it must be finalized and hence no + -- difference map exists. + case HM.lookup parentHash loadedBlocks of + Nothing -> liftIO DiffMap.newEmptyReference + Just diffMapReference -> return diffMapReference + newDifferenceMap <- reconstructAccountDifferenceMap (bpState blockPointer) parentDiffMapReference accountsToInsert + -- append to the accummulator with this new difference map reference + let loadedBlocks' = HM.insert (getHash storedBlock) newDifferenceMap loadedBlocks + cacheBlockState (bpState blockPointer) blockTable . liveMap . at' (getHash blockPointer) ?=! blockPointer addToBranches blockPointer @@ -468,7 +484,7 @@ loadCertifiedBlocks = do roundBakerExistingBlock (blockRound signedBlock) (blockBaker signedBlock) ?= toBlockSignatureWitness signedBlock recordCheckedQuorumCertificate qc - return newDifferenceMap + return loadedBlocks' -- Set the previous round timeout. setLastTimeout lastTimeout certBlock = do From b187d39e574fe80ab621154360746f76e855e144 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Thu, 9 Nov 2023 21:51:39 +0100 Subject: [PATCH 79/92] e2e cred deployment scaffolding and first test. --- concordium-consensus/package.yaml | 34 +++ .../CredentialDeploymentTests.hs | 158 ++++++++++++++ .../tests/e2e/EndToEndTests/E2ETestData.hs | 193 ++++++++++++++++++ concordium-consensus/tests/e2e/Spec.hs | 21 ++ 4 files changed, 406 insertions(+) create mode 100644 concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs create mode 100644 concordium-consensus/tests/e2e/EndToEndTests/E2ETestData.hs create mode 100644 concordium-consensus/tests/e2e/Spec.hs diff --git a/concordium-consensus/package.yaml b/concordium-consensus/package.yaml index 91715ab15e..d82a277d41 100644 --- a/concordium-consensus/package.yaml +++ b/concordium-consensus/package.yaml @@ -331,6 +331,40 @@ tests: - template-haskell - temporary >= 1.3 + e2e: + main: Spec.hs + source-dirs: tests/e2e + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + - -Wall + - -Wcompat + - -fno-ignore-asserts + - -Wno-deprecations + when: + - condition: os(windows) + then: + ghc-options: -static + else: + when: + - condition: flag(dynamic) + then: + ghc-options: -dynamic + else: + ghc-options: -static + dependencies: + - concordium-consensus + - hspec >= 2.6 + - QuickCheck >= 2.12 + - hspec-expectations >= 0.8 + - containers + - time >= 1.8 + - random >= 1.1 + - HUnit >= 1.6 + - temporary >= 1.3 + - monad-loops + benchmarks: trie: main: TrieBench.hs diff --git a/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs b/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs new file mode 100644 index 0000000000..477002d585 --- /dev/null +++ b/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | End to end tests for credential deployments. +module EndToEndTests.CredentialDeploymentTests (tests) where + +import Control.Monad.IO.Class +import qualified Data.Map.Strict as Map +import qualified Data.Vector as Vec +import Lens.Micro.Platform +import System.Random +import Test.HUnit +import Test.Hspec + +import Concordium.Common.Time +import Concordium.Crypto.DummyData +import Concordium.Crypto.FFIDataTypes +import qualified Concordium.Crypto.SignatureScheme as SigScheme +import Concordium.GlobalState.BlockState +import Concordium.ID.Parameters +import Concordium.ID.Types +import Concordium.KonsensusV1.TestMonad +import Concordium.KonsensusV1.TreeState.Implementation +import Concordium.KonsensusV1.TreeState.Types +import Concordium.KonsensusV1.Types +import Concordium.Types +import Concordium.Types.Option +import Concordium.Types.Transactions +import EndToEndTests.E2ETestData + +-- | Make public keys for a credential deployment +mkCredentialPublicKeys :: CredentialPublicKeys +mkCredentialPublicKeys = makeCredentialPublicKeys [key] 1 + where + key = SigScheme.correspondingVerifyKey $ dummyKeyPair 1 + dummyKeyPair :: Int -> SigScheme.KeyPair + dummyKeyPair = uncurry SigScheme.KeyPairEd25519 . fst . randomEd25519KeyPair . mkStdGen + +-- | A credential deployment transaction. +credBi :: BlockItem +credBi = + credentialDeployment $ addMetadata (\x -> CredentialDeployment{biCred = x}) (tt + 1) accCreation + where + tt = utcTimeToTransactionTime testTime + regId seed = RegIdCred $ generateGroupElementFromSeed dummyGlobalContext seed + accCreation :: AccountCreation + accCreation = + AccountCreation + { messageExpiry = tt + 1, + credential = + InitialACWP + InitialCredentialDeploymentInfo + { icdiValues = + InitialCredentialDeploymentValues + { icdvAccount = mkCredentialPublicKeys, + icdvRegId = regId 42, + icdvIpId = IP_ID 0, + icdvPolicy = pol + }, + icdiSig = + IpCdiSignature + { theSignature = "invalid signature" + } + } + } + + pol = + Policy + { pValidTo = + YearMonth + { ymYear = 2070, + ymMonth = 1 + }, + pCreatedAt = + YearMonth + { ymYear = 2021, + ymMonth = 1 + }, + pItems = Map.empty + } + +-- | Valid block for round 1 with 1 credential deployment. +testBB1 :: BakedBlock +testBB1 = + BakedBlock + { bbRound = 1, + bbEpoch = 0, + bbTimestamp = 1_000, + bbBaker = bakerId, + bbQuorumCertificate = genesisQuorumCertificate genesisHash, + bbTimeoutCertificate = Absent, + bbEpochFinalizationEntry = Absent, + bbNonce = computeBlockNonce genesisLEN 1 (bakerVRFKey bakerId), + bbTransactions = Vec.fromList [credBi], + bbTransactionOutcomesHash = read "d270b085491bc5b52d7791e7364897b120002032ac8de60af8984890d02c0a03", + bbStateHash = read "ff2aae922111fb0b95d1736e02e641753bdf4e5b10d09ec2e9d9bf5096a09e96" + } + where + bakerId = 2 + +-- | Valid block for round 2. +testBB2 :: BakedBlock +testBB2 = + BakedBlock + { bbRound = 2, + bbEpoch = 0, + bbTimestamp = 3_000, + bbBaker = bakerId, + bbQuorumCertificate = validQCFor testBB1, + bbTimeoutCertificate = Absent, + bbEpochFinalizationEntry = Absent, + bbNonce = computeBlockNonce genesisLEN 2 (bakerVRFKey bakerId), + bbTransactions = Vec.empty, + bbTransactionOutcomesHash = read "375fef64a251f353d608171d283d00fe00aa0bd77596ba7703c810f48056ef89", + bbStateHash = read "22e786ad9aff80596e1b315b5d26b812693a804928c2709bd59ab6cee340b572" + } + where + bakerId = 4 + +-- | Valid block for round 3, finalizes round 'testBB1'. +testBB3 :: BakedBlock +testBB3 = + BakedBlock + { bbRound = 3, + bbEpoch = 0, + bbTimestamp = 5_000, + bbBaker = bakerId, + bbQuorumCertificate = validQCFor testBB2, + bbTimeoutCertificate = Absent, + bbEpochFinalizationEntry = Absent, + bbNonce = computeBlockNonce genesisLEN 3 (bakerVRFKey bakerId), + bbTransactions = Vec.empty, + bbTransactionOutcomesHash = read "375fef64a251f353d608171d283d00fe00aa0bd77596ba7703c810f48056ef89", + bbStateHash = read "0c6e7c833e91c8d04b15dc345faa3a6d80ee9b1ed1a16437d245931f2a97744f" + } + where + bakerId = 4 + +-- | A test that deploys a single credential. +testDeployCredential :: Assertion +testDeployCredential = runTestMonad noBaker testTime genesisData $ do + lfbState0 <- use (lastFinalized . to bpState) + noAccs0 <- length <$> getAccountList lfbState0 + let b1 = signedPB testBB1 + succeedReceiveBlock b1 + let b2 = signedPB testBB2 + succeedReceiveBlock b2 + -- b3 finalizes b1 as it carries a qc for b2 (which carries a qc for b1). + let b3 = signedPB testBB3 + succeedReceiveBlock b3 + -- check that the account is now present in the last finalized block. + lfbState1 <- use (lastFinalized . to bpState) + noAccs1 <- length <$> getAccountList lfbState1 + liftIO $ assertEqual "there should be one extra account" (noAccs0 + 1) noAccs1 + +tests :: Word -> Spec +tests _ = describe "EndToEndTests.CredentialDeployments" $ do + it "deploy and finalize one credential" testDeployCredential diff --git a/concordium-consensus/tests/e2e/EndToEndTests/E2ETestData.hs b/concordium-consensus/tests/e2e/EndToEndTests/E2ETestData.hs new file mode 100644 index 0000000000..21b72a3ad9 --- /dev/null +++ b/concordium-consensus/tests/e2e/EndToEndTests/E2ETestData.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} + +-- | Helpers for end-to-end tests. +module EndToEndTests.E2ETestData where + +import Data.Time +import Control.Monad.Writer.Class +import Control.Monad.State +import Control.Monad.IO.Class +import Data.Foldable +import qualified Data.Vector as Vec +import Test.HUnit +import Test.Hspec + +import Concordium.KonsensusV1.Consensus +import Concordium.GlobalState.Basic.BlockState.LFMBTree (hashAsLFMBT) +import qualified Concordium.Types.Transactions as Transactions +import Concordium.GlobalState.BlockState (TransactionSummaryV1) +import qualified Concordium.Crypto.SHA256 as H +import Concordium.Types.Option +import Concordium.KonsensusV1.TreeState.Implementation +import Concordium.KonsensusV1.Consensus.Blocks +import Concordium.KonsensusV1.TestMonad +import Concordium.KonsensusV1.TreeState.Types +import Concordium.Types.Transactions +import Concordium.Startup +import qualified Concordium.Genesis.Data.P6 as P6 +import Concordium.Genesis.Data +import qualified Concordium.GlobalState.DummyData as Dummy +import qualified Concordium.Types.DummyData as Dummy +import Concordium.Types.BakerIdentity +import qualified Concordium.Crypto.DummyData as Dummy +import Concordium.GlobalState.BakerInfo +import Concordium.Types +import Concordium.KonsensusV1.Types +import Concordium.Types.HashableTo + +-- * Helper definitions + +-- | Max bakers +noBakers :: (Integral a) => a +noBakers = 5 + +-- | Genesis time +genTime :: Timestamp +genTime = 0 + +-- | Epoch duration +genEpochDuration :: Duration +genEpochDuration = 3_600_000 + +-- | Genesis data used for E2E credential deployments +genesisData :: GenesisData 'P6 +bakers :: [(BakerIdentity, FullBakerInfo)] +(genesisData, bakers, _) = + makeGenesisDataV1 + genTime + (noBakers + 1) + genEpochDuration + Dummy.dummyCryptographicParameters + Dummy.dummyIdentityProviders + Dummy.dummyArs + [ foundationAcct + ] + Dummy.dummyKeyCollection + Dummy.dummyChainParameters + where + foundationAcct = + Dummy.createCustomAccount + 1_000_000_000_000 + (Dummy.deterministicKP 0) + (Dummy.accountAddressFrom 0) + + +-- | Hash of the genesis block. +genesisHash :: BlockHash +genesisHash = genesisBlockHash genesisData + +-- | Leadership election nonce at genesis +genesisLEN :: LeadershipElectionNonce +genesisLEN = genesisLeadershipElectionNonce $ P6.genesisInitialState $ unGDP6 genesisData + +-- | Baker context with baker @i@. +baker :: Int -> BakerContext +baker i = BakerContext $ Just $ fst $ bakers !! i + +-- | Private ED25519 key of the provided baker identifier. +bakerKey :: (Integral a) => a -> BakerSignPrivateKey +bakerKey i = bakerSignKey $ fst (bakers !! fromIntegral i) + +-- | Private BLS key of the provided baker identifier. +bakerAggKey :: (Integral a) => a -> BakerAggregationPrivateKey +bakerAggKey i = bakerAggregationKey $ fst (bakers !! fromIntegral i) + +-- | Private VRF key of the provided baker identifier. +bakerVRFKey :: (Integral a) => a -> BakerElectionPrivateKey +bakerVRFKey i = bakerElectionKey $ fst (bakers !! fromIntegral i) + +-- | Finalizer set of all finalizers. +allFinalizers :: FinalizerSet +allFinalizers = finalizerSet $ FinalizerIndex <$> [0 .. noBakers] + +-- | List of finalizers +theFinalizers :: [Int] +theFinalizers = [0 .. noBakers] + +-- | Make a valid 'QuorumCertificate' for the provided block. +validQCFor :: BakedBlock -> QuorumCertificate +validQCFor bb = + QuorumCertificate + { qcSignatories = allFinalizers, + qcRound = bbRound bb, + qcEpoch = bbEpoch bb, + qcBlock = block, + qcAggregateSignature = sig + } + where + block = getHash bb + qsm = + QuorumSignatureMessage + { qsmGenesis = genesisHash, + qsmBlock = block, + qsmRound = bbRound bb, + qsmEpoch = bbEpoch bb + } + sig = fold [signQuorumSignatureMessage qsm (bakerAggKey i) | i <- theFinalizers] + +-- | Make a valid signed block from the provided @BakedBlock@. +validSignBlock :: BakedBlock -> SignedBlock +validSignBlock bb = signBlock (bakerKey (bbBaker bb)) genesisHash bb + +-- | Make a valid signed pending block. +signedPB :: BakedBlock -> PendingBlock +signedPB bb = + PendingBlock + { pbReceiveTime = timestampToUTCTime $ bbTimestamp bb, + pbBlock = validSignBlock bb + } + +-- | Helper to compute the transaction outcomes hash for a given set of transaction outcomes and +-- special transaction outcomes. +transactionOutcomesHash :: + [TransactionSummaryV1] -> + [Transactions.SpecialTransactionOutcome] -> + Transactions.TransactionOutcomesHash +transactionOutcomesHash outcomes specialOutcomes = + Transactions.TransactionOutcomesHash $ + H.hashShort $ + "TransactionOutcomesHashV1" + <> H.hashToShortByteString out + <> H.hashToShortByteString special + where + lfmbHash :: (HashableTo H.Hash a) => [a] -> H.Hash + lfmbHash = hashAsLFMBT (H.hash "EmptyLFMBTree") . fmap getHash + out = lfmbHash outcomes + special = lfmbHash specialOutcomes + +-- | Compute the transaction outcomes hash for a block with no transactions. +emptyBlockTOH :: BakerId -> Transactions.TransactionOutcomesHash +emptyBlockTOH bid = transactionOutcomesHash [] [BlockAccrueReward 0 0 0 0 0 0 bid] + +-- | Baker context with no baker. +noBaker :: BakerContext +noBaker = BakerContext Nothing + +-- | Current time used for running (some) tests. 5 seconds after genesis. +testTime :: UTCTime +testTime = timestampToUTCTime 5_000 + +-- * Helper functions + +-- | Receive a block - assert success. +succeedReceiveBlock :: PendingBlock -> TestMonad 'P6 () +succeedReceiveBlock pb = do + res <- uponReceivingBlock pb + case res of + BlockResultSuccess vb -> do + ((), events) <- listen $ executeBlock vb + status <- getBlockStatus (getHash pb) =<< get + case status of + BlockAlive _ -> return () + BlockFinalized _ -> return () + _ -> liftIO . assertFailure $ "Expected BlockAlive after executeBlock, but found: " ++ show status ++ "\n" ++ show pb + case events of + (OnBlock (NormalBlock b) : _) + | b == pbBlock pb -> return () + (OnFinalize _ : OnBlock (NormalBlock b) : _) + | b == pbBlock pb -> return () + _ -> liftIO . assertFailure $ "Expected OnBlock event on executeBlock, but saw: " ++ show events + _ -> liftIO . assertFailure $ "Expected BlockResultSuccess after uponReceivingBlock, but found: " ++ show res ++ "\n" ++ show pb + diff --git a/concordium-consensus/tests/e2e/Spec.hs b/concordium-consensus/tests/e2e/Spec.hs new file mode 100644 index 0000000000..015db18624 --- /dev/null +++ b/concordium-consensus/tests/e2e/Spec.hs @@ -0,0 +1,21 @@ +module Main where + +import Data.List (stripPrefix) +import Data.Semigroup +import qualified EndToEndTests.CredentialDeploymentTests (tests) +import System.Environment +import Test.Hspec + +atLevel :: (Word -> IO ()) -> IO () +atLevel a = do + args0 <- getArgs + let (args1, mlevel) = mconcat $ map lvlArg args0 + withArgs args1 $ a $! maybe 1 getLast mlevel + where + lvlArg s = case stripPrefix "--level=" s of + Nothing -> ([s], Nothing) + Just r -> ([], Just $! Last $! (read r :: Word)) + +main :: IO () +main = atLevel $ \lvl -> hspec $ do + EndToEndTests.CredentialDeploymentTests.tests lvl From 638fed1bddc2fb7a3ab8baf113083842e49604b5 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Thu, 9 Nov 2023 21:52:26 +0100 Subject: [PATCH 80/92] formatting. --- .../tests/e2e/EndToEndTests/E2ETestData.hs | 40 +++++++++---------- 1 file changed, 19 insertions(+), 21 deletions(-) diff --git a/concordium-consensus/tests/e2e/EndToEndTests/E2ETestData.hs b/concordium-consensus/tests/e2e/EndToEndTests/E2ETestData.hs index 21b72a3ad9..452d847857 100644 --- a/concordium-consensus/tests/e2e/EndToEndTests/E2ETestData.hs +++ b/concordium-consensus/tests/e2e/EndToEndTests/E2ETestData.hs @@ -1,41 +1,41 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DataKinds #-} -- | Helpers for end-to-end tests. -module EndToEndTests.E2ETestData where +module EndToEndTests.E2ETestData where -import Data.Time -import Control.Monad.Writer.Class -import Control.Monad.State import Control.Monad.IO.Class +import Control.Monad.State +import Control.Monad.Writer.Class import Data.Foldable +import Data.Time import qualified Data.Vector as Vec import Test.HUnit import Test.Hspec -import Concordium.KonsensusV1.Consensus +import qualified Concordium.Crypto.DummyData as Dummy +import qualified Concordium.Crypto.SHA256 as H +import Concordium.Genesis.Data +import qualified Concordium.Genesis.Data.P6 as P6 +import Concordium.GlobalState.BakerInfo import Concordium.GlobalState.Basic.BlockState.LFMBTree (hashAsLFMBT) -import qualified Concordium.Types.Transactions as Transactions import Concordium.GlobalState.BlockState (TransactionSummaryV1) -import qualified Concordium.Crypto.SHA256 as H -import Concordium.Types.Option -import Concordium.KonsensusV1.TreeState.Implementation +import qualified Concordium.GlobalState.DummyData as Dummy +import Concordium.KonsensusV1.Consensus import Concordium.KonsensusV1.Consensus.Blocks import Concordium.KonsensusV1.TestMonad +import Concordium.KonsensusV1.TreeState.Implementation import Concordium.KonsensusV1.TreeState.Types -import Concordium.Types.Transactions +import Concordium.KonsensusV1.Types import Concordium.Startup -import qualified Concordium.Genesis.Data.P6 as P6 -import Concordium.Genesis.Data -import qualified Concordium.GlobalState.DummyData as Dummy -import qualified Concordium.Types.DummyData as Dummy -import Concordium.Types.BakerIdentity -import qualified Concordium.Crypto.DummyData as Dummy -import Concordium.GlobalState.BakerInfo import Concordium.Types -import Concordium.KonsensusV1.Types +import Concordium.Types.BakerIdentity +import qualified Concordium.Types.DummyData as Dummy import Concordium.Types.HashableTo +import Concordium.Types.Option +import Concordium.Types.Transactions +import qualified Concordium.Types.Transactions as Transactions -- * Helper definitions @@ -73,7 +73,6 @@ bakers :: [(BakerIdentity, FullBakerInfo)] (Dummy.deterministicKP 0) (Dummy.accountAddressFrom 0) - -- | Hash of the genesis block. genesisHash :: BlockHash genesisHash = genesisBlockHash genesisData @@ -190,4 +189,3 @@ succeedReceiveBlock pb = do | b == pbBlock pb -> return () _ -> liftIO . assertFailure $ "Expected OnBlock event on executeBlock, but saw: " ++ show events _ -> liftIO . assertFailure $ "Expected BlockResultSuccess after uponReceivingBlock, but found: " ++ show res ++ "\n" ++ show pb - From 1f3e5dab9512306031aad1ac06675326276d7039 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Fri, 10 Nov 2023 09:46:33 +0100 Subject: [PATCH 81/92] Fix test. --- .../CredentialDeploymentTests.hs | 58 +++++++------------ .../tests/e2e/EndToEndTests/E2ETestData.hs | 3 - 2 files changed, 21 insertions(+), 40 deletions(-) diff --git a/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs b/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs index 477002d585..427d41b2cf 100644 --- a/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs +++ b/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs @@ -1,10 +1,14 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} -- | End to end tests for credential deployments. module EndToEndTests.CredentialDeploymentTests (tests) where import Control.Monad.IO.Class +import qualified Data.Aeson as AE +import qualified Data.ByteString.Lazy as BSL +import Data.FileEmbed import qualified Data.Map.Strict as Map import qualified Data.Vector as Vec import Lens.Micro.Platform @@ -13,6 +17,7 @@ import Test.HUnit import Test.Hspec import Concordium.Common.Time +import Concordium.Common.Version import Concordium.Crypto.DummyData import Concordium.Crypto.FFIDataTypes import qualified Concordium.Crypto.SignatureScheme as SigScheme @@ -44,40 +49,19 @@ credBi = tt = utcTimeToTransactionTime testTime regId seed = RegIdCred $ generateGroupElementFromSeed dummyGlobalContext seed accCreation :: AccountCreation - accCreation = - AccountCreation - { messageExpiry = tt + 1, - credential = - InitialACWP - InitialCredentialDeploymentInfo - { icdiValues = - InitialCredentialDeploymentValues - { icdvAccount = mkCredentialPublicKeys, - icdvRegId = regId 42, - icdvIpId = IP_ID 0, - icdvPolicy = pol - }, - icdiSig = - IpCdiSignature - { theSignature = "invalid signature" - } - } - } + accCreation = icdi1 - pol = - Policy - { pValidTo = - YearMonth - { ymYear = 2070, - ymMonth = 1 - }, - pCreatedAt = - YearMonth - { ymYear = 2021, - ymMonth = 1 - }, - pItems = Map.empty - } +-- | Helper for reading an 'AccountCreation' from a 'ByteString'. +readAccountCreation :: BSL.ByteString -> AccountCreation +readAccountCreation bs = + case AE.eitherDecode bs of + Left err -> error $ "Cannot read account creation " ++ err + Right d -> if vVersion d == 0 then vValue d else error "Incorrect account creation version." + +-- | A valid initial credential deployment. +{-# WARNING icdi1 "Do not use in production." #-} +icdi1 :: AccountCreation +icdi1 = readAccountCreation . BSL.fromStrict $ $(makeRelativeToProject "testdata/initial-credential-1.json" >>= embedFile) -- | Valid block for round 1 with 1 credential deployment. testBB1 :: BakedBlock @@ -92,8 +76,8 @@ testBB1 = bbEpochFinalizationEntry = Absent, bbNonce = computeBlockNonce genesisLEN 1 (bakerVRFKey bakerId), bbTransactions = Vec.fromList [credBi], - bbTransactionOutcomesHash = read "d270b085491bc5b52d7791e7364897b120002032ac8de60af8984890d02c0a03", - bbStateHash = read "ff2aae922111fb0b95d1736e02e641753bdf4e5b10d09ec2e9d9bf5096a09e96" + bbTransactionOutcomesHash = read "b9444648bf759471276fdba1930af0c543847d22de89c27939791898d757516d", + bbStateHash = read "b8bc96ec5f162db36784ea96ec29e3e8ad92abff341a6847e3bf524fdada28ff" } where bakerId = 2 @@ -112,7 +96,7 @@ testBB2 = bbNonce = computeBlockNonce genesisLEN 2 (bakerVRFKey bakerId), bbTransactions = Vec.empty, bbTransactionOutcomesHash = read "375fef64a251f353d608171d283d00fe00aa0bd77596ba7703c810f48056ef89", - bbStateHash = read "22e786ad9aff80596e1b315b5d26b812693a804928c2709bd59ab6cee340b572" + bbStateHash = read "798d5089818bcc7b8873e2585fb4fbf3d4dceffca32531259f466e7c435c8817" } where bakerId = 4 @@ -131,7 +115,7 @@ testBB3 = bbNonce = computeBlockNonce genesisLEN 3 (bakerVRFKey bakerId), bbTransactions = Vec.empty, bbTransactionOutcomesHash = read "375fef64a251f353d608171d283d00fe00aa0bd77596ba7703c810f48056ef89", - bbStateHash = read "0c6e7c833e91c8d04b15dc345faa3a6d80ee9b1ed1a16437d245931f2a97744f" + bbStateHash = read "4da0deab5b564cd77c617a2ac7dc8a6064f87e99b09e58c87b5f9e687db2197a" } where bakerId = 4 diff --git a/concordium-consensus/tests/e2e/EndToEndTests/E2ETestData.hs b/concordium-consensus/tests/e2e/EndToEndTests/E2ETestData.hs index 452d847857..2e81b039d6 100644 --- a/concordium-consensus/tests/e2e/EndToEndTests/E2ETestData.hs +++ b/concordium-consensus/tests/e2e/EndToEndTests/E2ETestData.hs @@ -10,9 +10,7 @@ import Control.Monad.State import Control.Monad.Writer.Class import Data.Foldable import Data.Time -import qualified Data.Vector as Vec import Test.HUnit -import Test.Hspec import qualified Concordium.Crypto.DummyData as Dummy import qualified Concordium.Crypto.SHA256 as H @@ -33,7 +31,6 @@ import Concordium.Types import Concordium.Types.BakerIdentity import qualified Concordium.Types.DummyData as Dummy import Concordium.Types.HashableTo -import Concordium.Types.Option import Concordium.Types.Transactions import qualified Concordium.Types.Transactions as Transactions From 8eca8254751078740f9ca97d547b45d519ca3fa5 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Fri, 10 Nov 2023 09:47:21 +0100 Subject: [PATCH 82/92] cleanup --- .../e2e/EndToEndTests/CredentialDeploymentTests.hs | 12 ------------ 1 file changed, 12 deletions(-) diff --git a/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs b/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs index 427d41b2cf..a8c52bd728 100644 --- a/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs +++ b/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs @@ -9,14 +9,12 @@ import Control.Monad.IO.Class import qualified Data.Aeson as AE import qualified Data.ByteString.Lazy as BSL import Data.FileEmbed -import qualified Data.Map.Strict as Map import qualified Data.Vector as Vec import Lens.Micro.Platform import System.Random import Test.HUnit import Test.Hspec -import Concordium.Common.Time import Concordium.Common.Version import Concordium.Crypto.DummyData import Concordium.Crypto.FFIDataTypes @@ -33,22 +31,12 @@ import Concordium.Types.Option import Concordium.Types.Transactions import EndToEndTests.E2ETestData --- | Make public keys for a credential deployment -mkCredentialPublicKeys :: CredentialPublicKeys -mkCredentialPublicKeys = makeCredentialPublicKeys [key] 1 - where - key = SigScheme.correspondingVerifyKey $ dummyKeyPair 1 - dummyKeyPair :: Int -> SigScheme.KeyPair - dummyKeyPair = uncurry SigScheme.KeyPairEd25519 . fst . randomEd25519KeyPair . mkStdGen - -- | A credential deployment transaction. credBi :: BlockItem credBi = credentialDeployment $ addMetadata (\x -> CredentialDeployment{biCred = x}) (tt + 1) accCreation where tt = utcTimeToTransactionTime testTime - regId seed = RegIdCred $ generateGroupElementFromSeed dummyGlobalContext seed - accCreation :: AccountCreation accCreation = icdi1 -- | Helper for reading an 'AccountCreation' from a 'ByteString'. From 25c7ccf42863c6706aa0d76ae5bdf1c3e01e022a Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Fri, 10 Nov 2023 12:57:10 +0100 Subject: [PATCH 83/92] Test for branching and credential deployments. --- .../CredentialDeploymentTests.hs | 240 ++++++++++++++++-- .../tests/e2e/EndToEndTests/E2ETestData.hs | 27 ++ 2 files changed, 246 insertions(+), 21 deletions(-) diff --git a/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs b/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs index a8c52bd728..08dd2ae505 100644 --- a/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs +++ b/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs @@ -5,40 +5,30 @@ -- | End to end tests for credential deployments. module EndToEndTests.CredentialDeploymentTests (tests) where +import Concordium.Utils import Control.Monad.IO.Class +import Control.Monad.State import qualified Data.Aeson as AE import qualified Data.ByteString.Lazy as BSL import Data.FileEmbed import qualified Data.Vector as Vec import Lens.Micro.Platform -import System.Random import Test.HUnit import Test.Hspec import Concordium.Common.Version -import Concordium.Crypto.DummyData -import Concordium.Crypto.FFIDataTypes -import qualified Concordium.Crypto.SignatureScheme as SigScheme import Concordium.GlobalState.BlockState -import Concordium.ID.Parameters import Concordium.ID.Types import Concordium.KonsensusV1.TestMonad import Concordium.KonsensusV1.TreeState.Implementation import Concordium.KonsensusV1.TreeState.Types import Concordium.KonsensusV1.Types import Concordium.Types +import Concordium.Types.HashableTo import Concordium.Types.Option import Concordium.Types.Transactions import EndToEndTests.E2ETestData --- | A credential deployment transaction. -credBi :: BlockItem -credBi = - credentialDeployment $ addMetadata (\x -> CredentialDeployment{biCred = x}) (tt + 1) accCreation - where - tt = utcTimeToTransactionTime testTime - accCreation = icdi1 - -- | Helper for reading an 'AccountCreation' from a 'ByteString'. readAccountCreation :: BSL.ByteString -> AccountCreation readAccountCreation bs = @@ -46,10 +36,39 @@ readAccountCreation bs = Left err -> error $ "Cannot read account creation " ++ err Right d -> if vVersion d == 0 then vValue d else error "Incorrect account creation version." --- | A valid initial credential deployment. -{-# WARNING icdi1 "Do not use in production." #-} -icdi1 :: AccountCreation -icdi1 = readAccountCreation . BSL.fromStrict $ $(makeRelativeToProject "testdata/initial-credential-1.json" >>= embedFile) +-- 3 valid credentials +{-# WARNING cred1 "Do not use in production." #-} +cred1 :: AccountCreation +cred1 = readAccountCreation . BSL.fromStrict $ $(makeRelativeToProject "testdata/initial-credential-1.json" >>= embedFile) + +{-# WARNING cred2 "Do not use in production." #-} +cred2 :: AccountCreation +cred2 = readAccountCreation . BSL.fromStrict $ $(makeRelativeToProject "testdata/initial-credential-2.json" >>= embedFile) + +{-# WARNING cred3 "Do not use in production." #-} +cred3 :: AccountCreation +cred3 = readAccountCreation . BSL.fromStrict $ $(makeRelativeToProject "testdata/credential-1.json" >>= embedFile) + +-- | A credential deployment transaction yielding cred1. +credBi1 :: BlockItem +credBi1 = + credentialDeployment $ addMetadata (\x -> CredentialDeployment{biCred = x}) (tt + 1) cred1 + where + tt = utcTimeToTransactionTime testTime + +-- | A credential deployment transaction yielding cred2. +credBi2 :: BlockItem +credBi2 = + credentialDeployment $ addMetadata (\x -> CredentialDeployment{biCred = x}) (tt + 1) cred2 + where + tt = utcTimeToTransactionTime testTime + +-- | A credential deployment transaction yielding cred3 +credBi3 :: BlockItem +credBi3 = + credentialDeployment $ addMetadata (\x -> CredentialDeployment{biCred = x}) (tt + 1) cred3 + where + tt = utcTimeToTransactionTime testTime -- | Valid block for round 1 with 1 credential deployment. testBB1 :: BakedBlock @@ -63,7 +82,7 @@ testBB1 = bbTimeoutCertificate = Absent, bbEpochFinalizationEntry = Absent, bbNonce = computeBlockNonce genesisLEN 1 (bakerVRFKey bakerId), - bbTransactions = Vec.fromList [credBi], + bbTransactions = Vec.fromList [credBi1], bbTransactionOutcomesHash = read "b9444648bf759471276fdba1930af0c543847d22de89c27939791898d757516d", bbStateHash = read "b8bc96ec5f162db36784ea96ec29e3e8ad92abff341a6847e3bf524fdada28ff" } @@ -71,6 +90,7 @@ testBB1 = bakerId = 2 -- | Valid block for round 2. +-- This block carries a QC for 'testBB1' thus certifying it. testBB2 :: BakedBlock testBB2 = BakedBlock @@ -89,7 +109,8 @@ testBB2 = where bakerId = 4 --- | Valid block for round 3, finalizes round 'testBB1'. +-- | Valid block for round 3, finalizes 'testBB1' as this block +-- carries a QC for 'testBB2'. testBB3 :: BakedBlock testBB3 = BakedBlock @@ -108,7 +129,7 @@ testBB3 = where bakerId = 4 --- | A test that deploys a single credential. +-- | A test that deploys a single credential, and it ends up in the last finalized block. testDeployCredential :: Assertion testDeployCredential = runTestMonad noBaker testTime genesisData $ do lfbState0 <- use (lastFinalized . to bpState) @@ -123,8 +144,185 @@ testDeployCredential = runTestMonad noBaker testTime genesisData $ do -- check that the account is now present in the last finalized block. lfbState1 <- use (lastFinalized . to bpState) noAccs1 <- length <$> getAccountList lfbState1 - liftIO $ assertEqual "there should be one extra account" (noAccs0 + 1) noAccs1 + liftIO $ assertEqual "there should be one extra account in lfb" (noAccs0 + 1) noAccs1 + +-- | Valid block for round 2. +-- This block has one credential deployment. +-- This block carries a QC for 'testBB1' thus certifying it. +testBB2' :: BakedBlock +testBB2' = + BakedBlock + { bbRound = 2, + bbEpoch = 0, + bbTimestamp = 3_000, + bbBaker = bakerId, + bbQuorumCertificate = validQCFor testBB1, + bbTimeoutCertificate = Absent, + bbEpochFinalizationEntry = Absent, + bbNonce = computeBlockNonce genesisLEN 2 (bakerVRFKey bakerId), + bbTransactions = Vec.fromList [credBi2], + bbTransactionOutcomesHash = read "abc4628869bb526115226dd01ad54bf33f54609fa770d50a9242aaf009f42fa1", + bbStateHash = read "e3cf3b280159bc20645738fb1343486d16104989a524fb5feb59ac1b0b7af9ad" + } + where + bakerId = 4 + +-- | Valid block for round 3, carries a TC for round 2. +-- This block has one credential deployment. +testBB3' :: BakedBlock +testBB3' = + BakedBlock + { bbRound = 3, + bbEpoch = 0, + bbTimestamp = 5_000, + bbBaker = bakerId, + bbQuorumCertificate = validQCFor testBB1, + bbTimeoutCertificate = Present (validTimeoutFor (validQCFor testBB1) 2), + bbEpochFinalizationEntry = Absent, + bbNonce = computeBlockNonce genesisLEN 3 (bakerVRFKey bakerId), + bbTransactions = Vec.fromList [credBi3], + bbTransactionOutcomesHash = read "3af8504795a03353248be256f66366263f7484c814c5a26760210bbdfd609003", + bbStateHash = read "67eb8f778a4a43efa80c73a954110154ae417e21d43c33b857b962af36913e29" + } + where + bakerId = 4 + +testBB4 :: BakedBlock +testBB4 = + BakedBlock + { bbRound = 4, + bbEpoch = 0, + bbTimestamp = 7_000, + bbBaker = bakerId, + bbQuorumCertificate = validQCFor testBB3', + bbTimeoutCertificate = Absent, + bbEpochFinalizationEntry = Absent, + bbNonce = computeBlockNonce genesisLEN 4 (bakerVRFKey bakerId), + bbTransactions = Vec.empty, + bbTransactionOutcomesHash = read "b0972dd7af05ed6feaa40099fffa9c5c5e0ba9741938166cdb57584780688743", + bbStateHash = read "9e698b9c6425b382d8fda5584f530688c237ad013e8aaf848fea274e50244111" + } + where + bakerId = 3 + +testBB5 :: BakedBlock +testBB5 = + BakedBlock + { bbRound = 5, + bbEpoch = 0, + bbTimestamp = 9_000, + bbBaker = bakerId, + bbQuorumCertificate = validQCFor testBB4, + bbTimeoutCertificate = Absent, + bbEpochFinalizationEntry = Absent, + bbNonce = computeBlockNonce genesisLEN 5 (bakerVRFKey bakerId), + bbTransactions = Vec.empty, + bbTransactionOutcomesHash = read "b0972dd7af05ed6feaa40099fffa9c5c5e0ba9741938166cdb57584780688743", + bbStateHash = read "d9dd62c227d1cbc0d42da0d90bfc11d61533d058cc54b0745d6a597039dbe0ec" + } + where + bakerId = 3 + +-- | Compute the 'AccountCreation' from the provided 'AccountCreation'. +getAccAddress :: AccountCreation -> AccountAddress +getAccAddress accCreation = case credential accCreation of + InitialACWP x -> initialCredentialAccountAddress $ icdiValues x + NormalACWP x -> credentialAccountAddress $ cdiValues x + +-- | Test that two credential deployments (each on their own branch and with same block height) does not: +-- * Alter the state of the parent block (a new child difference map and assoicated reference is created). +testDeployCredentialBranching :: Assertion +testDeployCredentialBranching = runTestMonad noBaker testTime genesisData $ do + genesisState <- use (lastFinalized . to bpState) + noGenesisAccs <- length <$> getAccountList genesisState + let b1 = signedPB testBB1 + succeedReceiveBlock b1 + -- Branch + let b2 = signedPB testBB2' + succeedReceiveBlock b2 + -- Another branch. + let b3 = signedPB testBB3' + succeedReceiveBlock b3 + + sd <- get + + -- Check that only the first credential deployed is present in block b1. + case sd ^. blockTable . liveMap . at' (getHash b1) of + Nothing -> liftIO $ assertFailure "failed getting bp1" + Just bp1 -> do + noAccountsBp1 <- length <$> getAccountList (bpState bp1) + liftIO $ assertEqual "check that there is one extra account" (noGenesisAccs + 1) noAccountsBp1 + getAccount (bpState bp1) (getAccAddress cred1) >>= \case + Nothing -> liftIO $ assertFailure "Should yield cred1" + Just (accIndex, _) -> liftIO $ assertEqual "incorrect account index" noGenesisAccs (fromIntegral accIndex) + + getAccount (bpState bp1) (getAccAddress cred2) >>= \case + Nothing -> return () + Just _ -> liftIO $ assertFailure "cred2 should not be present" + + getAccount (bpState bp1) (getAccAddress cred3) >>= \case + Nothing -> return () + Just _ -> liftIO $ assertFailure "cred3 should not be present" + + -- Check that cred1 and cred2 is present in b2 (but not cred3) + case sd ^. blockTable . liveMap . at' (getHash b2) of + Nothing -> liftIO $ assertFailure "failed getting bp1" + Just bp2 -> do + noAccountsBp2 <- length <$> getAccountList (bpState bp2) + liftIO $ assertEqual "check that there is one extra account" (noGenesisAccs + 2) noAccountsBp2 + getAccount (bpState bp2) (getAccAddress cred1) >>= \case + Nothing -> liftIO $ assertFailure "Should yield cred1" + Just (accIndex, _) -> liftIO $ assertEqual "incorrect account index" noGenesisAccs (fromIntegral accIndex) + + getAccount (bpState bp2) (getAccAddress cred2) >>= \case + Nothing -> liftIO $ assertFailure "Should yield cred2" + Just (accIndex, _) -> liftIO $ assertEqual "incorrect account index" (noGenesisAccs + 1) (fromIntegral accIndex) + + getAccount (bpState bp2) (getAccAddress cred3) >>= \case + Nothing -> return () + Just _ -> liftIO $ assertFailure $ "cred3 should not be present: " <> show (getAccAddress cred3) <> " " <> show (getAccAddress cred2) + + -- Check that cred1 and cred3 is present in b3 (but not cred2) + case sd ^. blockTable . liveMap . at' (getHash b3) of + Nothing -> liftIO $ assertFailure "failed getting bp1" + Just bp3 -> do + noAccountsBp3 <- length <$> getAccountList (bpState bp3) + liftIO $ assertEqual "check that there is one extra account" (noGenesisAccs + 2) noAccountsBp3 + getAccount (bpState bp3) (getAccAddress cred1) >>= \case + Nothing -> liftIO $ assertFailure "Should yield cred1" + Just (accIndex, _) -> liftIO $ assertEqual "incorrect account index" noGenesisAccs (fromIntegral accIndex) + + getAccount (bpState bp3) (getAccAddress cred3) >>= \case + Nothing -> liftIO $ assertFailure "Should yield cred3" + Just (accIndex, _) -> liftIO $ assertEqual "incorrect account index" (noGenesisAccs + 1) (fromIntegral accIndex) + + getAccount (bpState bp3) (getAccAddress cred2) >>= \case + Nothing -> return () + Just _ -> liftIO $ assertFailure $ "cred2 should not be present: " <> show (getAccAddress cred3) <> " " <> show (getAccAddress cred2) + + -- finalize bp3 and make sure that the state of the lfb matches b3. + let b4 = signedPB testBB4 + succeedReceiveBlock b4 + let b5 = signedPB testBB5 + succeedReceiveBlock b5 + + lfbState <- use (lastFinalized . to bpState) + noAccountsLfb <- length <$> getAccountList lfbState + liftIO $ assertEqual "check that there is one extra account" (noGenesisAccs + 2) noAccountsLfb + + getAccount lfbState (getAccAddress cred1) >>= \case + Nothing -> liftIO $ assertFailure "Should yield cred1" + Just (accIndex, _) -> liftIO $ assertEqual "incorrect account index" noGenesisAccs (fromIntegral accIndex) + + getAccount lfbState (getAccAddress cred3) >>= \case + Nothing -> liftIO $ assertFailure "Should yield cred3" + Just (accIndex, _) -> liftIO $ assertEqual "incorrect account index" (noGenesisAccs + 1) (fromIntegral accIndex) + + getAccount lfbState (getAccAddress cred2) >>= \case + Nothing -> return () + Just _ -> liftIO $ assertFailure $ "cred2 should not be present: " <> show (getAccAddress cred3) <> " " <> show (getAccAddress cred2) tests :: Word -> Spec tests _ = describe "EndToEndTests.CredentialDeployments" $ do it "deploy and finalize one credential" testDeployCredential + it "deploy two credentials in two branches" testDeployCredentialBranching diff --git a/concordium-consensus/tests/e2e/EndToEndTests/E2ETestData.hs b/concordium-consensus/tests/e2e/EndToEndTests/E2ETestData.hs index 2e81b039d6..8e409a132b 100644 --- a/concordium-consensus/tests/e2e/EndToEndTests/E2ETestData.hs +++ b/concordium-consensus/tests/e2e/EndToEndTests/E2ETestData.hs @@ -9,6 +9,7 @@ import Control.Monad.IO.Class import Control.Monad.State import Control.Monad.Writer.Class import Data.Foldable +import qualified Data.Map.Strict as Map import Data.Time import Test.HUnit @@ -123,6 +124,32 @@ validQCFor bb = } sig = fold [signQuorumSignatureMessage qsm (bakerAggKey i) | i <- theFinalizers] +validTimeoutForFinalizers :: [Int] -> QuorumCertificate -> Round -> TimeoutCertificate +validTimeoutForFinalizers finalizers qc rnd = + TimeoutCertificate + { tcRound = rnd, + tcMinEpoch = qcEpoch qc, + tcFinalizerQCRoundsFirstEpoch = FinalizerRounds (Map.singleton (qcRound qc) finSet), + tcFinalizerQCRoundsSecondEpoch = FinalizerRounds Map.empty, + tcAggregateSignature = + fold + [signTimeoutSignatureMessage tsm (bakerAggKey i) | i <- finalizers] + } + where + finSet = finalizerSet $ FinalizerIndex . fromIntegral <$> finalizers + tsm = + TimeoutSignatureMessage + { tsmGenesis = genesisHash, + tsmRound = rnd, + tsmQCRound = qcRound qc, + tsmQCEpoch = qcEpoch qc + } + +-- | Create a valid timeout message given a QC and a round. +-- All finalizers sign the certificate and they all have the QC as their highest QC. +validTimeoutFor :: QuorumCertificate -> Round -> TimeoutCertificate +validTimeoutFor = validTimeoutForFinalizers theFinalizers + -- | Make a valid signed block from the provided @BakedBlock@. validSignBlock :: BakedBlock -> SignedBlock validSignBlock bb = signBlock (bakerKey (bbBaker bb)) genesisHash bb From 6b2814cbe2ef9e0deefea6d88817edaf299320ad Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Mon, 13 Nov 2023 10:50:47 +0100 Subject: [PATCH 84/92] Address review comments. --- .../src/Concordium/GlobalState.hs | 6 +++- .../GlobalState/AccountMap/DifferenceMap.hs | 8 +++-- .../Concordium/GlobalState/LMDB/Helpers.hs | 7 ++++ .../GlobalState/Persistent/Accounts.hs | 33 +++++++++++-------- .../Concordium/GlobalState/Persistent/LMDB.hs | 6 ---- .../KonsensusV1/TreeState/LowLevel/LMDB.hs | 8 ----- .../KonsensusV1/TransactionProcessingTest.hs | 1 - .../CredentialDeploymentTests.hs | 2 +- 8 files changed, 38 insertions(+), 33 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState.hs b/concordium-consensus/src/Concordium/GlobalState.hs index 06b85ef7f4..a2e8144f04 100644 --- a/concordium-consensus/src/Concordium/GlobalState.hs +++ b/concordium-consensus/src/Concordium/GlobalState.hs @@ -30,9 +30,13 @@ import Concordium.Types.ProtocolVersion -- | Configuration that uses the disk implementation for both the tree state -- and the block state data GlobalStateConfig = GlobalStateConfig - { dtdbRuntimeParameters :: !RuntimeParameters, + { -- | Runtime parameters. + dtdbRuntimeParameters :: !RuntimeParameters, + -- | Path to the tree state database. dtdbTreeStateDirectory :: !FilePath, + -- | Path to the block state database. dtdbBlockStateFile :: !FilePath, + -- | Path to the account map database. dtdAccountMapDirectory :: !FilePath } diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index 344c3c9e3b..c7fb07e329 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -155,5 +155,9 @@ clearReferences :: (MonadIO m) => DifferenceMap -> m () clearReferences DifferenceMap{..} = do oParentDiffMap <- liftIO $ readIORef dmParentMapRef case oParentDiffMap of - Absent -> liftIO $ atomicWriteIORef dmParentMapRef Absent - Present diffMap -> clearReferences diffMap + Absent -> return () + Present diffMap -> do + -- Clear this parent reference. + liftIO $ atomicWriteIORef dmParentMapRef Absent + -- Continue and check if the parent should have cleared it parent(s). + clearReferences diffMap diff --git a/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs b/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs index 1f177dfcb8..45302a5426 100644 --- a/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs +++ b/concordium-consensus/src/Concordium/GlobalState/LMDB/Helpers.hs @@ -18,6 +18,7 @@ module Concordium.GlobalState.LMDB.Helpers ( seEnv, seStepSize, seMaxStepSize, + defaultEnvSize, defaultStepSize, defaultMaxStepSize, resizeDatabaseHandlers, @@ -296,6 +297,12 @@ data StoreEnv = StoreEnv makeLenses ''StoreEnv +-- | Default start environment size. +-- Tree state database sizes for historical protocol versions have been between 7-60 times +-- the 'defaultEnvSize'. +defaultEnvSize :: Int +defaultEnvSize = 2 ^ (27 :: Int) -- 128MB + -- | Database growth size increment. -- This is currently set at 64MB, and must be a multiple of the page size. defaultStepSize :: Int diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 08a9ccff86..750eea559f 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -31,7 +31,7 @@ -- the lmdb store in one transaction and then it proceeds as normal. -- On the other hand, if the lmdb backed account map is already populated then the startup procedure will skip the populating step ('tryPopulateLMDBStore'). -- --- For consensus version 1, then the assoicated 'DiffMap.DifferenceMap' is reconstructed via 'reconstructDifferenceMap' for certified blocks. +-- For consensus version 1, then the associated 'DiffMap.DifferenceMap' is reconstructed via 'reconstructDifferenceMap' for certified blocks. -- -- When starting up from a fresh genesis configuration then as part of creating the genesis state, -- then the difference map is being built containing all accounts present in the genesis configuration. @@ -51,10 +51,13 @@ -- -- The lmdb backed account map consists of a single lmdb store indexed by AccountAddresses and values are the associated ‘AccountIndex' for each account. -- --- (The ‘DifferenceMap' consists of a @Map AccountAddress AccountIndes@ which retains the accounts that have been added to the chain for the associated block. --- Moreover the ‘DifferenceMap' potentially retains a pointer to a so-called parent ‘DifferenceMap'. --- I.e. @Maybe DifferenceMap@. If this is @Nothing@ then it means that the parent block is finalized or no accounts have been added. --- If the parent map yields a ‘DifferenceMap' then the parent block is not persisted yet, and so the ‘DifferenceMap' uses this parent map +-- (The ‘DifferenceMap' consists of a @Map AccountAddressEq (AccountIndex, AccountAddress)@ which retains the accounts that have been added to the chain for the associated block. +-- The equivalence class 'AccountAddressEq' is used for looking up accounts in the 'DifferenceMap'. The values are pairs @(AccountIndex, AccountAddress)@ where the +-- 'AccountIndex' determines the location of the associated account in the account table. The second component (the 'AccountAddress) is the canonical account address of +-- the account i.e. the account address that is derived from the reg id. +-- Note that the ‘DifferenceMap' can potentially retain a pointer to a parent ‘DifferenceMap', i.e. @Maybe DifferenceMap@. +-- If this is @Nothing@ then it means that the parent block is finalized or no accounts have been added. +-- If the parent map yields a ‘DifferenceMap' then the parent block is not finalized yet, and so the ‘DifferenceMap' uses this parent map -- for keeping track of non persisted accounts for supporting e.g. queries via the ‘AccountAddress'. module Concordium.GlobalState.Persistent.Accounts where @@ -167,10 +170,13 @@ mkNewChildDifferenceMap accts@Accounts{..} = do return accts{accountDiffMapRef = newDiffMapRef} -- | Create and set the 'DiffMap.DifferenceMap' for the provided @Accounts pv@. +-- This function constructs the difference map for the block such that the assoicated difference map +-- and lmdb backed account map are consistent with the account table. +-- -- The function is highly unsafe and can cause state invariant failures if not all of the -- below preconditions are respected. -- Precondition: --- * The function assumes that the account table already yields every account added for the block state. +-- * The function assumes that the account table already contains every account added for the block state. -- * The provided 'DiffMap.DifferenceMapReference@ MUST correspond to the parent map. -- * The provided list of accounts MUST be in ascending order of account index, hence the list of accounts -- MUST be provided in the order of which the corresponding credential deployment transactions were executed. @@ -179,6 +185,7 @@ reconstructDifferenceMap :: -- | Reference to the parent difference map. DiffMap.DifferenceMapReference -> -- | Account addresses to add to the difference map. + -- The list MUST be in ascending order of 'AccountIndex'. [AccountAddress] -> -- | The accounts to write difference map to. Accounts pv -> @@ -222,6 +229,8 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where pRegIdHistory return (putf, newAccounts) load = do + -- If we're on protocol version 6 or older, then load the persistent account map and throw it away as + -- the 'OldMap.PersistentAccountMap' is now superseded by the LMDBAccountMap.MonadAccountMapStore. when (storeRequiresAccountMap (protocolVersion @pv)) $ do void (load :: Get (m (OldMap.PersistentAccountMap pv))) maccountTable <- load @@ -256,7 +265,7 @@ putNewAccount !acct a0@Accounts{..} = do mAccountDiffMap <- liftIO $ readIORef accountDiffMapRef accountDiffMap' <- case mAccountDiffMap of Absent -> do - -- create a difference map for this block state with a @Nothing@ as the parent. + -- create a difference map for this block state with an @Absent@ as the parent. freshDifferenceMap <- liftIO DiffMap.newEmptyReference return $ DiffMap.insert addr accIdx $ DiffMap.empty freshDifferenceMap Present accDiffMap -> do @@ -318,11 +327,8 @@ getAccountIndex addr Accounts{..} = do -- In particular this can be the case if finalized blocks have been rolled -- back as part of database recovery. -- - -- The extra @diffMapSize@ constraint is necessary in the case where a parent block to the last finalized block - -- is used for extending. This is normally not the case as blocks are typically built from the "best" block always. - -- - -- However for scenarios like dry runs, then we need this extra constraint, as otherwise an account created in the - -- in the dry run would point to an account created in a successor of the block that the dry run is extending. + -- If an account is not present in the difference map, then it must have an account index where + -- @account index < number of accounts in account table - number of accounts in the difference map(s).@ lookupDisk diffMapSize = if supportsAccountAliases (protocolVersion @pv) then withSafeBounds <$> LMDBAccountMap.lookupAccountIndexViaEquivalence (accountAddressEmbed addr) @@ -414,8 +420,7 @@ updateAccountsAtIndex' fupd ai = fmap snd . updateAccountsAtIndex fupd' ai fupd' = fmap ((),) . fupd -- | Get a list of all account addresses and their associated account indices. --- There are no guarantees of the order of the list. This is because the resulting list is potentially --- a concatenation of two lists of account addresses. +-- There are no guarantees of the order of the list. allAccounts :: (SupportsPersistentAccount pv m) => Accounts pv -> m [(AccountAddress, AccountIndex)] allAccounts accounts = do mDiffMap <- liftIO $ readIORef (accountDiffMapRef accounts) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs index 475889ee29..15dfe2221b 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/LMDB.hs @@ -316,12 +316,6 @@ metadataStoreName = "metadata" databaseCount :: Int databaseCount = 5 --- | Default start environment size. --- Tree state database sizes for historical protocol versions have been between 7-60 times --- the 'defaultEnvSize'. -defaultEnvSize :: Int -defaultEnvSize = 2 ^ (26 :: Int) -- 64MB - -- | Initialize database handlers in ReadWrite mode. -- This simply loads the references and does not initialize the databases. databaseHandlers :: FilePath -> IO (DatabaseHandlers pv st) diff --git a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs index 86abdf4dc6..4b1b271100 100644 --- a/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs +++ b/concordium-consensus/src/Concordium/KonsensusV1/TreeState/LowLevel/LMDB.hs @@ -308,15 +308,8 @@ makeDatabaseHandlers treeStateDir readOnly initSize = do [MDB_CREATE | not readOnly] return DatabaseHandlers{..} --- | Default start environment size. --- Tree state database sizes for historical protocol versions have been between 7-60 times --- the 'defaultEnvSize'. -defaultEnvSize :: Int -defaultEnvSize = 2 ^ (27 :: Int) -- 128MB - -- | Initialize database handlers in ReadWrite mode. -- This simply loads the references and does not initialize the databases. --- The initial size is set to 64MB. openDatabase :: FilePath -> IO (DatabaseHandlers pv) openDatabase treeStateDir = do createDirectoryIfMissing False treeStateDir @@ -849,7 +842,6 @@ rollBackBlocksUntil checkState = do let finHash = getHash fin _ <- deleteRecord txn (dbh ^. blockStore) finHash _ <- deleteRecord txn (dbh ^. finalizedBlockIndex) (blockHeight fin) - forM_ (blockTransactions fin) $ deleteRecord txn (dbh ^. transactionStatusStore) . getHash mparent <- loadRecord txn (dbh ^. blockStore) (blockParent block) diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs index d39a9ca44c..0d2a3adc77 100644 --- a/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs +++ b/concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} diff --git a/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs b/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs index 08dd2ae505..823e78ecf5 100644 --- a/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs +++ b/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs @@ -230,7 +230,7 @@ getAccAddress accCreation = case credential accCreation of NormalACWP x -> credentialAccountAddress $ cdiValues x -- | Test that two credential deployments (each on their own branch and with same block height) does not: --- * Alter the state of the parent block (a new child difference map and assoicated reference is created). +-- * Alter the state of the parent block (a new child difference map and associated reference is created). testDeployCredentialBranching :: Assertion testDeployCredentialBranching = runTestMonad noBaker testTime genesisData $ do genesisState <- use (lastFinalized . to bpState) From bb4a9c2cf3d05782ab67e88d1a05ef57a0c802b3 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Mon, 13 Nov 2023 11:38:53 +0100 Subject: [PATCH 85/92] Cache difference map size in order to avoid flattening. --- .../GlobalState/AccountMap/DifferenceMap.hs | 49 +++++++++++------ .../GlobalState/Persistent/Accounts.hs | 14 ++--- .../GlobalStateTests/DifferenceMap.hs | 53 ++++++++++++------- 3 files changed, 76 insertions(+), 40 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index c7fb07e329..453636bcdc 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -18,7 +18,10 @@ module Concordium.GlobalState.AccountMap.DifferenceMap ( -- Get a list of all @(AccountAddress, AccountIndex)@ pairs for the -- provided 'DifferenceMap' and all parent maps. flatten, - -- Create an empty 'DifferenceMap' + -- Get the number of accounts present in the provided + -- difference map or any of its parents. + getNumberOfAccounts, + -- Create an empty 'DifferenceMap'. empty, -- Set the accounts int he 'DifferenceMap'. fromList, @@ -39,10 +42,11 @@ import Control.Monad.IO.Class import qualified Data.HashMap.Strict as HM import Data.IORef import Data.Tuple (swap) +import Data.Word import Prelude hiding (lookup) import Concordium.Types -import Concordium.Types.Option (Option (..)) +import Concordium.Types.Option (Option (..), ofOption) -- | A mutable reference to a 'DiffMap.DifferenceMap'. -- This is an 'IORef' since the parent map may belong @@ -60,7 +64,9 @@ newEmptyReference = liftIO $ newIORef Absent -- a block identified by a 'BlockHash' and its associated 'BlockHeight'. -- The difference map only contains accounts that were added since the '_dmParentMapRef'. data DifferenceMap = DifferenceMap - { -- | Accounts added in a block keyed by their equivalence class and + { -- | Number of accounts in the parent map(s). + dmAccountsInParent :: !Word64, + -- | Accounts added in a block keyed by their equivalence class and -- the @AccountIndex@ and canonical account adddress as values. dmAccounts :: !(HM.HashMap AccountAddressEq (AccountIndex, AccountAddress)), -- | Parent map of non-finalized blocks. @@ -71,6 +77,11 @@ data DifferenceMap = DifferenceMap } deriving (Eq) +-- | Get the number of accounts present in the provided 'DifferenceMap' +-- and its parent(s). +getNumberOfAccounts :: DifferenceMap -> Word64 +getNumberOfAccounts DifferenceMap{..} = dmAccountsInParent + (fromIntegral $! HM.size dmAccounts) + -- | Gather all accounts from the provided 'DifferenceMap' and its parent maps. -- Accounts are returned in ascending order of their 'AccountAddress'. -- @@ -88,12 +99,16 @@ flatten dmap = go dmap [] -- | Create a new empty 'DifferenceMap' potentially based on the difference map of -- the parent. -empty :: DifferenceMapReference -> DifferenceMap -empty mParentDifferenceMap = - DifferenceMap - { dmAccounts = HM.empty, - dmParentMapRef = mParentDifferenceMap - } +empty :: (MonadIO m) => DifferenceMapReference -> m DifferenceMap +empty parentRef = do + parentDiffMap <- liftIO $ readIORef parentRef + let accsInParent = ofOption 0 getNumberOfAccounts parentDiffMap + return + DifferenceMap + { dmAccountsInParent = accsInParent, + dmAccounts = HM.empty, + dmParentMapRef = parentRef + } -- | Internal helper function for looking up an entry in @dmAccounts@. lookupViaEquivalenceClass' :: (MonadIO m) => AccountAddressEq -> DifferenceMap -> m (Maybe (AccountIndex, AccountAddress)) @@ -138,12 +153,16 @@ insert :: AccountAddress -> AccountIndex -> DifferenceMap -> DifferenceMap insert addr accIndex m = m{dmAccounts = HM.insert (accountAddressEmbed addr) (accIndex, addr) $ dmAccounts m} -- | Create a 'DifferenceMap' with the provided parent and list of account addresses and account indices. -fromList :: IORef (Option DifferenceMap) -> [(AccountAddress, AccountIndex)] -> DifferenceMap -fromList parentRef listOfAccountsAndIndices = - DifferenceMap - { dmAccounts = HM.fromList $ map mkKeyVal listOfAccountsAndIndices, - dmParentMapRef = parentRef - } +fromList :: (MonadIO m) => IORef (Option DifferenceMap) -> [(AccountAddress, AccountIndex)] -> m DifferenceMap +fromList parentRef listOfAccountsAndIndices = do + parentDiffMap <- liftIO $ readIORef parentRef + let accsInParent = ofOption 0 dmAccountsInParent parentDiffMap + return + DifferenceMap + { dmAccountsInParent = accsInParent, + dmAccounts = HM.fromList $ map mkKeyVal listOfAccountsAndIndices, + dmParentMapRef = parentRef + } where -- Make a key value pair to put in the @dmAccounts@. mkKeyVal (accAddr, accIdx) = (accountAddressEmbed accAddr, (accIdx, accAddr)) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 750eea559f..23301b818e 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -166,7 +166,8 @@ writeAccountsCreated Accounts{..} = do -- has a reference to the difference map of the provided @Accounts pv@. mkNewChildDifferenceMap :: (SupportsPersistentAccount pv m) => Accounts pv -> m (Accounts pv) mkNewChildDifferenceMap accts@Accounts{..} = do - newDiffMapRef <- liftIO $ newIORef $ Present $ DiffMap.empty accountDiffMapRef + emptyDiffMap <- DiffMap.empty accountDiffMapRef + newDiffMapRef <- liftIO $ newIORef $ Present emptyDiffMap return accts{accountDiffMapRef = newDiffMapRef} -- | Create and set the 'DiffMap.DifferenceMap' for the provided @Accounts pv@. @@ -196,7 +197,7 @@ reconstructDifferenceMap parentRef listOfAccounts Accounts{..} = do -- in order to the obtain the account indices we subtract the number of accounts missing -- missing in the lmdb account map from the total number of accounts, hence obtaining the first @AccountIndex@ -- to use for adding new accounts to the lmdb backed account map. - let diffMap' = DiffMap.fromList parentRef $ zip listOfAccounts [AccountIndex (L.size accountTable - fromIntegral (length listOfAccounts)) ..] + diffMap' <- DiffMap.fromList parentRef $ zip listOfAccounts [AccountIndex (L.size accountTable - fromIntegral (length listOfAccounts)) ..] liftIO $ atomicWriteIORef accountDiffMapRef $ Present diffMap' return accountDiffMapRef @@ -267,7 +268,8 @@ putNewAccount !acct a0@Accounts{..} = do Absent -> do -- create a difference map for this block state with an @Absent@ as the parent. freshDifferenceMap <- liftIO DiffMap.newEmptyReference - return $ DiffMap.insert addr accIdx $ DiffMap.empty freshDifferenceMap + emptyDiffMap <- DiffMap.empty freshDifferenceMap + return $ DiffMap.insert addr accIdx emptyDiffMap Present accDiffMap -> do -- reuse the already existing difference map for this block state. return $ DiffMap.insert addr accIdx accDiffMap @@ -311,14 +313,12 @@ getAccountIndex addr Accounts{..} = do DiffMap.lookupViaEquivalenceClass (accountAddressEmbed addr) accDiffMap >>= \case Just accIdx -> return $ Just accIdx Nothing -> do - diffMapSize <- length <$> DiffMap.flatten accDiffMap - lookupDisk $ fromIntegral diffMapSize + lookupDisk $! DiffMap.getNumberOfAccounts accDiffMap else DiffMap.lookupExact addr accDiffMap >>= \case Just accIdx -> return $ Just accIdx Nothing -> do - diffMapSize <- length <$> DiffMap.flatten accDiffMap - lookupDisk $ fromIntegral diffMapSize + lookupDisk $! DiffMap.getNumberOfAccounts accDiffMap where -- Lookup the 'AccountIndex' in the lmdb backed account map, -- and make sure it's within the bounds of the account table. diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs index 2f01fc8bb2..b252eec7d1 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs @@ -39,7 +39,8 @@ testDoLookup accAddr diffMap = do testInsertLookupAccount :: Assertion testInsertLookupAccount = do emptyParentMap <- liftIO DiffMap.newEmptyReference - let diffMap = uncurry DiffMap.insert acc $ DiffMap.empty emptyParentMap + emptyDiffMap <- liftIO $ DiffMap.empty emptyParentMap + let diffMap = uncurry DiffMap.insert acc emptyDiffMap testDoLookup (fst acc) diffMap >>= \case Nothing -> assertFailure "account should be present in diff map" Just accIdx -> assertEqual "account should be there" (snd acc) accIdx @@ -54,11 +55,14 @@ mkParentPointer diffMap = newIORef diffMap >>= return testLookups :: Assertion testLookups = do emptyParentMap <- liftIO DiffMap.newEmptyReference - let diffMap1 = uncurry DiffMap.insert (dummyPair 1) $ DiffMap.empty emptyParentMap + emptyDiffMap <- liftIO $ DiffMap.empty emptyParentMap + let diffMap1 = uncurry DiffMap.insert (dummyPair 1) emptyDiffMap diffMap1Pointer <- mkParentPointer $ Present diffMap1 - let diffMap2 = uncurry DiffMap.insert (dummyPair 2) (DiffMap.empty diffMap1Pointer) + emptyDiffMap2 <- DiffMap.empty diffMap1Pointer + let diffMap2 = uncurry DiffMap.insert (dummyPair 2) emptyDiffMap2 diffMap2Pointer <- mkParentPointer $ Present diffMap2 - let diffMap3 = uncurry DiffMap.insert (dummyPair 3) (DiffMap.empty diffMap2Pointer) + emptyDiffMap3 <- DiffMap.empty diffMap2Pointer + let diffMap3 = uncurry DiffMap.insert (dummyPair 3) emptyDiffMap3 checkExists (dummyPair 1) diffMap1 checkExists (dummyPair 1) diffMap2 checkExists (dummyPair 2) diffMap2 @@ -75,11 +79,14 @@ testLookups = do testFlatten :: Assertion testFlatten = do emptyParentMap <- liftIO DiffMap.newEmptyReference - let diffMap1 = uncurry DiffMap.insert (dummyPair 1) $ DiffMap.empty emptyParentMap + emptyDiffMap <- DiffMap.empty emptyParentMap + let diffMap1 = uncurry DiffMap.insert (dummyPair 1) emptyDiffMap diffMap1Pointer <- mkParentPointer $ Present diffMap1 - let diffMap2 = uncurry DiffMap.insert (dummyPair 2) (DiffMap.empty diffMap1Pointer) + emptyDiffMap2 <- DiffMap.empty diffMap1Pointer + let diffMap2 = uncurry DiffMap.insert (dummyPair 2) emptyDiffMap2 diffMap2Pointer <- mkParentPointer $ Present diffMap2 - let diffMap3 = uncurry DiffMap.insert (dummyPair 3) (DiffMap.empty diffMap2Pointer) + emptyDiffMap3 <- DiffMap.empty diffMap2Pointer + let diffMap3 = uncurry DiffMap.insert (dummyPair 3) emptyDiffMap3 assertEqual "accounts should be the same" (map dummyPair [1 .. 3]) =<< DiffMap.flatten diffMap3 -- | Make the reference map for comparing lookups. @@ -112,8 +119,10 @@ insertionsAndLookups = it "insertions and lookups" $ forAll genInputs $ \(inputs, noDifferenceMaps) -> do let reference = HM.fromList inputs emptyRef <- liftIO DiffMap.newEmptyReference - diffMap <- populateDiffMap inputs noDifferenceMaps $ DiffMap.empty emptyRef + emptyDiffMap <- liftIO $ DiffMap.empty emptyRef + diffMap <- populateDiffMap inputs noDifferenceMaps emptyDiffMap checkAll reference diffMap + liftIO $ assertEqual "Sizes should be the same" (HM.size reference) (fromIntegral $ DiffMap.getNumberOfAccounts diffMap) where checkAll ref diffMap = forM_ (HM.toList ref) (check diffMap) check diffMap (accAddr, accIdx) = do @@ -127,7 +136,8 @@ insertionsAndLookups = it "insertions and lookups" $ -- create a new layer and insert an account. populateDiffMap ((accAddr, accIdx) : rest) remaining !accum = do pRef <- mkParentPointer (Present accum) - let accumDiffMap'' = DiffMap.insert accAddr accIdx $ DiffMap.empty pRef + e <- liftIO $ DiffMap.empty pRef + let accumDiffMap'' = DiffMap.insert accAddr accIdx e populateDiffMap rest (remaining - 1) accumDiffMap'' -- | A test that makes sure if multiple difference maps are @@ -136,13 +146,16 @@ insertionsAndLookups = it "insertions and lookups" $ testMultipleChildrenDifferenceMaps :: Assertion testMultipleChildrenDifferenceMaps = do emptyRoot <- liftIO DiffMap.newEmptyReference + e <- liftIO $ DiffMap.empty emptyRoot -- The common parent - let parent = uncurry DiffMap.insert (dummyPair 1) $ DiffMap.empty emptyRoot + let parent = uncurry DiffMap.insert (dummyPair 1) e parentReference <- mkParentPointer $ Present parent -- First branch - let branch0 = uncurry DiffMap.insert (dummyPair 2) $ DiffMap.empty parentReference + e' <- liftIO $ DiffMap.empty parentReference + let branch0 = uncurry DiffMap.insert (dummyPair 2) e' -- Second branch - let branch1 = uncurry DiffMap.insert (dummyPair 3) $ DiffMap.empty parentReference + e'' <- liftIO $ DiffMap.empty parentReference + let branch1 = uncurry DiffMap.insert (dummyPair 3) e'' -- Account from common parent should exist in both branches. checkExists (fst $ dummyPair 1) (snd $ dummyPair 1) branch0 @@ -162,14 +175,18 @@ testMultipleChildrenDifferenceMaps = do -- | Test the 'fromList' function. testFromList :: Assertion -testFromList = do - emptyRoot <- liftIO DiffMap.newEmptyReference +testFromList = liftIO $ do + emptyRoot <- DiffMap.newEmptyReference -- check creating from empty list - let emptyDiffMap = DiffMap.empty emptyRoot - liftIO $ assertBool "fromList on empty list should yield the empty difference map" (emptyDiffMap == DiffMap.fromList emptyRoot []) + emptyDiffMap <- DiffMap.empty emptyRoot + emptyDmapFromList <- DiffMap.fromList emptyRoot [] + liftIO $ assertBool "fromList on empty list should yield the empty difference map" (emptyDiffMap == emptyDmapFromList) -- check for a difference map with 1 element. - let nonEmptyDiffMap = uncurry DiffMap.insert (dummyPair 1) $ DiffMap.empty emptyRoot - liftIO $ assertBool "fromList on empty list should yield the empty difference map" (nonEmptyDiffMap == DiffMap.fromList emptyRoot [dummyPair 1]) + emptyDiffMap' <- DiffMap.empty emptyRoot + let nonEmptyDiffMap = uncurry DiffMap.insert (dummyPair 1) emptyDiffMap' + dMapFromList <- DiffMap.fromList emptyRoot [dummyPair 1] + assertBool "fromList on empty list should yield the empty difference map" (nonEmptyDiffMap == dMapFromList) + assertEqual "there should be one account present" 1 (DiffMap.getNumberOfAccounts nonEmptyDiffMap) tests :: Spec tests = describe "AccountMap.DifferenceMap" $ do From 418881b857974fc3f953391fd4773a67a194b94f Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Mon, 13 Nov 2023 12:23:06 +0100 Subject: [PATCH 86/92] Revert "Cache difference map size in order to avoid flattening." This reverts commit bb4a9c2cf3d05782ab67e88d1a05ef57a0c802b3. --- .../GlobalState/AccountMap/DifferenceMap.hs | 49 ++++++----------- .../GlobalState/Persistent/Accounts.hs | 14 ++--- .../GlobalStateTests/DifferenceMap.hs | 53 +++++++------------ 3 files changed, 40 insertions(+), 76 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index 453636bcdc..c7fb07e329 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -18,10 +18,7 @@ module Concordium.GlobalState.AccountMap.DifferenceMap ( -- Get a list of all @(AccountAddress, AccountIndex)@ pairs for the -- provided 'DifferenceMap' and all parent maps. flatten, - -- Get the number of accounts present in the provided - -- difference map or any of its parents. - getNumberOfAccounts, - -- Create an empty 'DifferenceMap'. + -- Create an empty 'DifferenceMap' empty, -- Set the accounts int he 'DifferenceMap'. fromList, @@ -42,11 +39,10 @@ import Control.Monad.IO.Class import qualified Data.HashMap.Strict as HM import Data.IORef import Data.Tuple (swap) -import Data.Word import Prelude hiding (lookup) import Concordium.Types -import Concordium.Types.Option (Option (..), ofOption) +import Concordium.Types.Option (Option (..)) -- | A mutable reference to a 'DiffMap.DifferenceMap'. -- This is an 'IORef' since the parent map may belong @@ -64,9 +60,7 @@ newEmptyReference = liftIO $ newIORef Absent -- a block identified by a 'BlockHash' and its associated 'BlockHeight'. -- The difference map only contains accounts that were added since the '_dmParentMapRef'. data DifferenceMap = DifferenceMap - { -- | Number of accounts in the parent map(s). - dmAccountsInParent :: !Word64, - -- | Accounts added in a block keyed by their equivalence class and + { -- | Accounts added in a block keyed by their equivalence class and -- the @AccountIndex@ and canonical account adddress as values. dmAccounts :: !(HM.HashMap AccountAddressEq (AccountIndex, AccountAddress)), -- | Parent map of non-finalized blocks. @@ -77,11 +71,6 @@ data DifferenceMap = DifferenceMap } deriving (Eq) --- | Get the number of accounts present in the provided 'DifferenceMap' --- and its parent(s). -getNumberOfAccounts :: DifferenceMap -> Word64 -getNumberOfAccounts DifferenceMap{..} = dmAccountsInParent + (fromIntegral $! HM.size dmAccounts) - -- | Gather all accounts from the provided 'DifferenceMap' and its parent maps. -- Accounts are returned in ascending order of their 'AccountAddress'. -- @@ -99,16 +88,12 @@ flatten dmap = go dmap [] -- | Create a new empty 'DifferenceMap' potentially based on the difference map of -- the parent. -empty :: (MonadIO m) => DifferenceMapReference -> m DifferenceMap -empty parentRef = do - parentDiffMap <- liftIO $ readIORef parentRef - let accsInParent = ofOption 0 getNumberOfAccounts parentDiffMap - return - DifferenceMap - { dmAccountsInParent = accsInParent, - dmAccounts = HM.empty, - dmParentMapRef = parentRef - } +empty :: DifferenceMapReference -> DifferenceMap +empty mParentDifferenceMap = + DifferenceMap + { dmAccounts = HM.empty, + dmParentMapRef = mParentDifferenceMap + } -- | Internal helper function for looking up an entry in @dmAccounts@. lookupViaEquivalenceClass' :: (MonadIO m) => AccountAddressEq -> DifferenceMap -> m (Maybe (AccountIndex, AccountAddress)) @@ -153,16 +138,12 @@ insert :: AccountAddress -> AccountIndex -> DifferenceMap -> DifferenceMap insert addr accIndex m = m{dmAccounts = HM.insert (accountAddressEmbed addr) (accIndex, addr) $ dmAccounts m} -- | Create a 'DifferenceMap' with the provided parent and list of account addresses and account indices. -fromList :: (MonadIO m) => IORef (Option DifferenceMap) -> [(AccountAddress, AccountIndex)] -> m DifferenceMap -fromList parentRef listOfAccountsAndIndices = do - parentDiffMap <- liftIO $ readIORef parentRef - let accsInParent = ofOption 0 dmAccountsInParent parentDiffMap - return - DifferenceMap - { dmAccountsInParent = accsInParent, - dmAccounts = HM.fromList $ map mkKeyVal listOfAccountsAndIndices, - dmParentMapRef = parentRef - } +fromList :: IORef (Option DifferenceMap) -> [(AccountAddress, AccountIndex)] -> DifferenceMap +fromList parentRef listOfAccountsAndIndices = + DifferenceMap + { dmAccounts = HM.fromList $ map mkKeyVal listOfAccountsAndIndices, + dmParentMapRef = parentRef + } where -- Make a key value pair to put in the @dmAccounts@. mkKeyVal (accAddr, accIdx) = (accountAddressEmbed accAddr, (accIdx, accAddr)) diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 23301b818e..750eea559f 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -166,8 +166,7 @@ writeAccountsCreated Accounts{..} = do -- has a reference to the difference map of the provided @Accounts pv@. mkNewChildDifferenceMap :: (SupportsPersistentAccount pv m) => Accounts pv -> m (Accounts pv) mkNewChildDifferenceMap accts@Accounts{..} = do - emptyDiffMap <- DiffMap.empty accountDiffMapRef - newDiffMapRef <- liftIO $ newIORef $ Present emptyDiffMap + newDiffMapRef <- liftIO $ newIORef $ Present $ DiffMap.empty accountDiffMapRef return accts{accountDiffMapRef = newDiffMapRef} -- | Create and set the 'DiffMap.DifferenceMap' for the provided @Accounts pv@. @@ -197,7 +196,7 @@ reconstructDifferenceMap parentRef listOfAccounts Accounts{..} = do -- in order to the obtain the account indices we subtract the number of accounts missing -- missing in the lmdb account map from the total number of accounts, hence obtaining the first @AccountIndex@ -- to use for adding new accounts to the lmdb backed account map. - diffMap' <- DiffMap.fromList parentRef $ zip listOfAccounts [AccountIndex (L.size accountTable - fromIntegral (length listOfAccounts)) ..] + let diffMap' = DiffMap.fromList parentRef $ zip listOfAccounts [AccountIndex (L.size accountTable - fromIntegral (length listOfAccounts)) ..] liftIO $ atomicWriteIORef accountDiffMapRef $ Present diffMap' return accountDiffMapRef @@ -268,8 +267,7 @@ putNewAccount !acct a0@Accounts{..} = do Absent -> do -- create a difference map for this block state with an @Absent@ as the parent. freshDifferenceMap <- liftIO DiffMap.newEmptyReference - emptyDiffMap <- DiffMap.empty freshDifferenceMap - return $ DiffMap.insert addr accIdx emptyDiffMap + return $ DiffMap.insert addr accIdx $ DiffMap.empty freshDifferenceMap Present accDiffMap -> do -- reuse the already existing difference map for this block state. return $ DiffMap.insert addr accIdx accDiffMap @@ -313,12 +311,14 @@ getAccountIndex addr Accounts{..} = do DiffMap.lookupViaEquivalenceClass (accountAddressEmbed addr) accDiffMap >>= \case Just accIdx -> return $ Just accIdx Nothing -> do - lookupDisk $! DiffMap.getNumberOfAccounts accDiffMap + diffMapSize <- length <$> DiffMap.flatten accDiffMap + lookupDisk $ fromIntegral diffMapSize else DiffMap.lookupExact addr accDiffMap >>= \case Just accIdx -> return $ Just accIdx Nothing -> do - lookupDisk $! DiffMap.getNumberOfAccounts accDiffMap + diffMapSize <- length <$> DiffMap.flatten accDiffMap + lookupDisk $ fromIntegral diffMapSize where -- Lookup the 'AccountIndex' in the lmdb backed account map, -- and make sure it's within the bounds of the account table. diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs index b252eec7d1..2f01fc8bb2 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs @@ -39,8 +39,7 @@ testDoLookup accAddr diffMap = do testInsertLookupAccount :: Assertion testInsertLookupAccount = do emptyParentMap <- liftIO DiffMap.newEmptyReference - emptyDiffMap <- liftIO $ DiffMap.empty emptyParentMap - let diffMap = uncurry DiffMap.insert acc emptyDiffMap + let diffMap = uncurry DiffMap.insert acc $ DiffMap.empty emptyParentMap testDoLookup (fst acc) diffMap >>= \case Nothing -> assertFailure "account should be present in diff map" Just accIdx -> assertEqual "account should be there" (snd acc) accIdx @@ -55,14 +54,11 @@ mkParentPointer diffMap = newIORef diffMap >>= return testLookups :: Assertion testLookups = do emptyParentMap <- liftIO DiffMap.newEmptyReference - emptyDiffMap <- liftIO $ DiffMap.empty emptyParentMap - let diffMap1 = uncurry DiffMap.insert (dummyPair 1) emptyDiffMap + let diffMap1 = uncurry DiffMap.insert (dummyPair 1) $ DiffMap.empty emptyParentMap diffMap1Pointer <- mkParentPointer $ Present diffMap1 - emptyDiffMap2 <- DiffMap.empty diffMap1Pointer - let diffMap2 = uncurry DiffMap.insert (dummyPair 2) emptyDiffMap2 + let diffMap2 = uncurry DiffMap.insert (dummyPair 2) (DiffMap.empty diffMap1Pointer) diffMap2Pointer <- mkParentPointer $ Present diffMap2 - emptyDiffMap3 <- DiffMap.empty diffMap2Pointer - let diffMap3 = uncurry DiffMap.insert (dummyPair 3) emptyDiffMap3 + let diffMap3 = uncurry DiffMap.insert (dummyPair 3) (DiffMap.empty diffMap2Pointer) checkExists (dummyPair 1) diffMap1 checkExists (dummyPair 1) diffMap2 checkExists (dummyPair 2) diffMap2 @@ -79,14 +75,11 @@ testLookups = do testFlatten :: Assertion testFlatten = do emptyParentMap <- liftIO DiffMap.newEmptyReference - emptyDiffMap <- DiffMap.empty emptyParentMap - let diffMap1 = uncurry DiffMap.insert (dummyPair 1) emptyDiffMap + let diffMap1 = uncurry DiffMap.insert (dummyPair 1) $ DiffMap.empty emptyParentMap diffMap1Pointer <- mkParentPointer $ Present diffMap1 - emptyDiffMap2 <- DiffMap.empty diffMap1Pointer - let diffMap2 = uncurry DiffMap.insert (dummyPair 2) emptyDiffMap2 + let diffMap2 = uncurry DiffMap.insert (dummyPair 2) (DiffMap.empty diffMap1Pointer) diffMap2Pointer <- mkParentPointer $ Present diffMap2 - emptyDiffMap3 <- DiffMap.empty diffMap2Pointer - let diffMap3 = uncurry DiffMap.insert (dummyPair 3) emptyDiffMap3 + let diffMap3 = uncurry DiffMap.insert (dummyPair 3) (DiffMap.empty diffMap2Pointer) assertEqual "accounts should be the same" (map dummyPair [1 .. 3]) =<< DiffMap.flatten diffMap3 -- | Make the reference map for comparing lookups. @@ -119,10 +112,8 @@ insertionsAndLookups = it "insertions and lookups" $ forAll genInputs $ \(inputs, noDifferenceMaps) -> do let reference = HM.fromList inputs emptyRef <- liftIO DiffMap.newEmptyReference - emptyDiffMap <- liftIO $ DiffMap.empty emptyRef - diffMap <- populateDiffMap inputs noDifferenceMaps emptyDiffMap + diffMap <- populateDiffMap inputs noDifferenceMaps $ DiffMap.empty emptyRef checkAll reference diffMap - liftIO $ assertEqual "Sizes should be the same" (HM.size reference) (fromIntegral $ DiffMap.getNumberOfAccounts diffMap) where checkAll ref diffMap = forM_ (HM.toList ref) (check diffMap) check diffMap (accAddr, accIdx) = do @@ -136,8 +127,7 @@ insertionsAndLookups = it "insertions and lookups" $ -- create a new layer and insert an account. populateDiffMap ((accAddr, accIdx) : rest) remaining !accum = do pRef <- mkParentPointer (Present accum) - e <- liftIO $ DiffMap.empty pRef - let accumDiffMap'' = DiffMap.insert accAddr accIdx e + let accumDiffMap'' = DiffMap.insert accAddr accIdx $ DiffMap.empty pRef populateDiffMap rest (remaining - 1) accumDiffMap'' -- | A test that makes sure if multiple difference maps are @@ -146,16 +136,13 @@ insertionsAndLookups = it "insertions and lookups" $ testMultipleChildrenDifferenceMaps :: Assertion testMultipleChildrenDifferenceMaps = do emptyRoot <- liftIO DiffMap.newEmptyReference - e <- liftIO $ DiffMap.empty emptyRoot -- The common parent - let parent = uncurry DiffMap.insert (dummyPair 1) e + let parent = uncurry DiffMap.insert (dummyPair 1) $ DiffMap.empty emptyRoot parentReference <- mkParentPointer $ Present parent -- First branch - e' <- liftIO $ DiffMap.empty parentReference - let branch0 = uncurry DiffMap.insert (dummyPair 2) e' + let branch0 = uncurry DiffMap.insert (dummyPair 2) $ DiffMap.empty parentReference -- Second branch - e'' <- liftIO $ DiffMap.empty parentReference - let branch1 = uncurry DiffMap.insert (dummyPair 3) e'' + let branch1 = uncurry DiffMap.insert (dummyPair 3) $ DiffMap.empty parentReference -- Account from common parent should exist in both branches. checkExists (fst $ dummyPair 1) (snd $ dummyPair 1) branch0 @@ -175,18 +162,14 @@ testMultipleChildrenDifferenceMaps = do -- | Test the 'fromList' function. testFromList :: Assertion -testFromList = liftIO $ do - emptyRoot <- DiffMap.newEmptyReference +testFromList = do + emptyRoot <- liftIO DiffMap.newEmptyReference -- check creating from empty list - emptyDiffMap <- DiffMap.empty emptyRoot - emptyDmapFromList <- DiffMap.fromList emptyRoot [] - liftIO $ assertBool "fromList on empty list should yield the empty difference map" (emptyDiffMap == emptyDmapFromList) + let emptyDiffMap = DiffMap.empty emptyRoot + liftIO $ assertBool "fromList on empty list should yield the empty difference map" (emptyDiffMap == DiffMap.fromList emptyRoot []) -- check for a difference map with 1 element. - emptyDiffMap' <- DiffMap.empty emptyRoot - let nonEmptyDiffMap = uncurry DiffMap.insert (dummyPair 1) emptyDiffMap' - dMapFromList <- DiffMap.fromList emptyRoot [dummyPair 1] - assertBool "fromList on empty list should yield the empty difference map" (nonEmptyDiffMap == dMapFromList) - assertEqual "there should be one account present" 1 (DiffMap.getNumberOfAccounts nonEmptyDiffMap) + let nonEmptyDiffMap = uncurry DiffMap.insert (dummyPair 1) $ DiffMap.empty emptyRoot + liftIO $ assertBool "fromList on empty list should yield the empty difference map" (nonEmptyDiffMap == DiffMap.fromList emptyRoot [dummyPair 1]) tests :: Spec tests = describe "AccountMap.DifferenceMap" $ do From 07ab5cc5de5bbc45a342c7eec1c89bab98b55a67 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Mon, 13 Nov 2023 13:36:56 +0100 Subject: [PATCH 87/92] Avoid extraneous flattening when looking up accounts via the difference map. --- .../GlobalState/AccountMap/DifferenceMap.hs | 42 ++++++++++++------- .../src/Concordium/GlobalState/BlockState.hs | 6 +-- .../GlobalState/Persistent/Accounts.hs | 18 ++++---- .../GlobalStateTests/DifferenceMap.hs | 32 ++++++++------ 4 files changed, 57 insertions(+), 41 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index c7fb07e329..93457dda40 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -96,41 +96,51 @@ empty mParentDifferenceMap = } -- | Internal helper function for looking up an entry in @dmAccounts@. -lookupViaEquivalenceClass' :: (MonadIO m) => AccountAddressEq -> DifferenceMap -> m (Maybe (AccountIndex, AccountAddress)) -lookupViaEquivalenceClass' addr = check +-- Returns @Right AccountIndex AccountAddress Word64@ if the account could be looked up, +-- and otherwise @Left Word64@, where the number indicates how many accounts are present in the difference map +-- and potentially any parent difference maps. +lookupViaEquivalenceClass' :: (MonadIO m) => AccountAddressEq -> DifferenceMap -> m (Either Int (AccountIndex, AccountAddress)) +lookupViaEquivalenceClass' addr = check 0 where - check diffMap = case HM.lookup addr (dmAccounts diffMap) of + check accum diffMap = case HM.lookup addr (dmAccounts diffMap) of Nothing -> do mParentMap <- liftIO $ readIORef (dmParentMapRef diffMap) case mParentMap of - Absent -> return Nothing - Present parentMap -> check parentMap - Just accIdx -> return $ Just accIdx + Absent -> return $ Left $ accum + HM.size (dmAccounts diffMap) + Present parentMap -> check (HM.size (dmAccounts diffMap) + accum) parentMap + Just res -> return $ Right res -- | Lookup an account in the difference map or any of the parent -- difference maps using the account address equivalence class. -- Returns @Just AccountIndex@ if the account is present and --- otherwise @Nothing@. +-- otherwise @Left Word64@ indicating how many accounts there are present in the +-- difference map(s). -- Precondition: As this implementation uses the 'AccountAddressEq' equivalence -- class for looking up an 'AccountIndex', then it MUST only be used -- when account aliases are supported. -lookupViaEquivalenceClass :: (MonadIO m) => AccountAddressEq -> DifferenceMap -> m (Maybe AccountIndex) -lookupViaEquivalenceClass addr dm = - lookupViaEquivalenceClass' addr dm >>= \case - Nothing -> return Nothing - Just (accIdx, _) -> return $ Just accIdx +lookupViaEquivalenceClass :: (MonadIO m) => AccountAddressEq -> DifferenceMap -> m (Either Int AccountIndex) +lookupViaEquivalenceClass addr dm = fmap fst <$> lookupViaEquivalenceClass' addr dm -- | Lookup an account in the difference map or any of the parent -- difference maps via an exactness check. -- Returns @Just AccountIndex@ if the account is present and --- otherwise @Nothing@. +-- otherwise @Left Word64@ indicating how many accounts there are present in the +-- difference map(s). -- Note that this function also returns @Nothing@ if the provided 'AccountAddress.' -- is an alias but not the canonical address. -lookupExact :: (MonadIO m) => AccountAddress -> DifferenceMap -> m (Maybe AccountIndex) +lookupExact :: (MonadIO m) => AccountAddress -> DifferenceMap -> m (Either Int AccountIndex) lookupExact addr diffMap = lookupViaEquivalenceClass' (accountAddressEmbed addr) diffMap >>= \case - Nothing -> return Nothing - Just (accIdx, actualAddr) -> if actualAddr == addr then return $ Just accIdx else return Nothing + Left noAccounts -> return $ Left noAccounts + Right (accIdx, actualAddr) -> + if actualAddr == addr + then return $ Right accIdx + else do + -- This extra flatten is really not ideal, but it should also really never happen, + -- hence the extra flatten here justifies the simpler implementation and optimization + -- towards the normal use case. + size <- length <$> flatten diffMap + return $ Left size -- | Insert an account into the difference map. -- Note that it is up to the caller to ensure only the canonical 'AccountAddress' is inserted. diff --git a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs index 5a4f33fa76..65c9038329 100644 --- a/concordium-consensus/src/Concordium/GlobalState/BlockState.hs +++ b/concordium-consensus/src/Concordium/GlobalState/BlockState.hs @@ -1443,10 +1443,8 @@ class (BlockStateOperations m, FixedSizeSerialization (BlockStateRef m)) => Bloc -- | Populate the LMDB account map if it has not already been initialized. -- If the lmdb store has already been initialized, then this function does nothing. - -- This function must only be invoked when starting up when then account table already - -- contains accounts but these are not reflected in the lmdb backed account map. - -- - -- In particular this is the case when starting up from an existing state. + -- Otherwise this function populates the lmdb backed account map with the accounts + -- present in the account table of the block state. tryPopulateAccountMap :: BlockState m -> m () instance (Monad (t m), MonadTrans t, ModuleQuery m) => ModuleQuery (MGSTrans t m) where diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index 750eea559f..a973d23ee9 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -309,16 +309,12 @@ getAccountIndex addr Accounts{..} = do if supportsAccountAliases (protocolVersion @pv) then DiffMap.lookupViaEquivalenceClass (accountAddressEmbed addr) accDiffMap >>= \case - Just accIdx -> return $ Just accIdx - Nothing -> do - diffMapSize <- length <$> DiffMap.flatten accDiffMap - lookupDisk $ fromIntegral diffMapSize + Right accIdx -> return $ Just accIdx + Left diffMapSize -> lookupDisk $ fromIntegral diffMapSize else DiffMap.lookupExact addr accDiffMap >>= \case - Just accIdx -> return $ Just accIdx - Nothing -> do - diffMapSize <- length <$> DiffMap.flatten accDiffMap - lookupDisk $ fromIntegral diffMapSize + Right accIdx -> return $ Just accIdx + Left diffMapSize -> lookupDisk $ fromIntegral diffMapSize where -- Lookup the 'AccountIndex' in the lmdb backed account map, -- and make sure it's within the bounds of the account table. @@ -462,7 +458,11 @@ tryPopulateLMDBStore :: (SupportsPersistentAccount pv m) => Accounts pv -> m () tryPopulateLMDBStore accts = do noLMDBAccounts <- LMDBAccountMap.getNumberOfAccounts let expectedSize = L.size $ accountTable accts - when (noLMDBAccounts /= expectedSize) $ do + -- If the number of accounts in the lmdb backed account map is + -- less than the size of the account table then we rebuild it here. + -- This should really never happen as we're writing to the lmdb backed account map + -- BEFORE the block (and assoicated block state) is written to disk. + when (noLMDBAccounts < expectedSize) $ do -- The number of accounts in the lmdb backed account map does not match -- the number of accounts in the account table. -- Clear the map and reconstruct it from the accounts table. diff --git a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs index 2f01fc8bb2..a3f4c240e1 100644 --- a/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs +++ b/concordium-consensus/tests/globalstate/GlobalStateTests/DifferenceMap.hs @@ -28,7 +28,7 @@ dummyPair seed = (fst $ randomAccountAddress (mkStdGen seed), AccountIndex $ fro -- Precondition: The provided @AccountAddress@ MUST be the canonical address, -- and it should be present in the underlying store. -- The equivalence lookup always looks up by an alias. -testDoLookup :: (MonadIO m) => AccountAddress -> DiffMap.DifferenceMap -> m (Maybe AccountIndex) +testDoLookup :: (MonadIO m) => AccountAddress -> DiffMap.DifferenceMap -> m (Either Int AccountIndex) testDoLookup accAddr diffMap = do res1 <- DiffMap.lookupViaEquivalenceClass (accountAddressEmbed $ createAlias accAddr 42) diffMap res2 <- DiffMap.lookupExact accAddr diffMap @@ -41,8 +41,8 @@ testInsertLookupAccount = do emptyParentMap <- liftIO DiffMap.newEmptyReference let diffMap = uncurry DiffMap.insert acc $ DiffMap.empty emptyParentMap testDoLookup (fst acc) diffMap >>= \case - Nothing -> assertFailure "account should be present in diff map" - Just accIdx -> assertEqual "account should be there" (snd acc) accIdx + Left _ -> assertFailure "account should be present in diff map" + Right accIdx -> assertEqual "account should be there" (snd acc) accIdx where acc = dummyPair 1 @@ -68,8 +68,8 @@ testLookups = do where checkExists pair diffMap = testDoLookup (fst pair) diffMap >>= \case - Nothing -> assertFailure "account should be present" - Just accIdx -> assertEqual "wrong account index" (snd pair) accIdx + Left _ -> assertFailure "account should be present" + Right accIdx -> assertEqual "wrong account index" (snd pair) accIdx -- | Test flattening a difference map i.e. return all accounts as one flat map. testFlatten :: Assertion @@ -114,12 +114,18 @@ insertionsAndLookups = it "insertions and lookups" $ emptyRef <- liftIO DiffMap.newEmptyReference diffMap <- populateDiffMap inputs noDifferenceMaps $ DiffMap.empty emptyRef checkAll reference diffMap + let nonExistantAcc = fst (dummyPair (-1)) + testDoLookup nonExistantAcc diffMap >>= \case + Right _ -> liftIO $ assertFailure "account should not be present" + Left size -> do + expectedSize <- length <$> DiffMap.flatten diffMap + liftIO $ assertEqual "Sizes should match" expectedSize size where checkAll ref diffMap = forM_ (HM.toList ref) (check diffMap) check diffMap (accAddr, accIdx) = do testDoLookup accAddr diffMap >>= \case - Nothing -> liftIO $ assertFailure "account address should be present" - Just actualAccIdx -> liftIO $ assertEqual "account index should be equal" accIdx actualAccIdx + Left _ -> liftIO $ assertFailure "account address should be present" + Right actualAccIdx -> liftIO $ assertEqual "account index should be equal" accIdx actualAccIdx -- return the generated difference map(s) populateDiffMap [] _ !accum = return accum -- dump any remaining accounts at the top most difference map. @@ -132,7 +138,7 @@ insertionsAndLookups = it "insertions and lookups" $ -- | A test that makes sure if multiple difference maps are -- derivied via a common parent, then additions in one branch --- is not propagating to other branches. +-- are not propagating to other branches. testMultipleChildrenDifferenceMaps :: Assertion testMultipleChildrenDifferenceMaps = do emptyRoot <- liftIO DiffMap.newEmptyReference @@ -153,12 +159,14 @@ testMultipleChildrenDifferenceMaps = do where checkExists addr expectedAccIdx diffMap = testDoLookup addr diffMap >>= \case - Just accIdx -> liftIO $ assertEqual "Account index should match" expectedAccIdx accIdx - Nothing -> liftIO $ assertFailure "Expected an entry" + Right accIdx -> liftIO $ assertEqual "Account index should match" expectedAccIdx accIdx + Left _ -> liftIO $ assertFailure "Expected an entry" checkNotExists addr diffMap = testDoLookup addr diffMap >>= \case - Just _ -> liftIO $ assertFailure "Did not expect an entry" - Nothing -> return () + Right _ -> liftIO $ assertFailure "Did not expect an entry" + Left size -> do + expectedSize <- length <$> DiffMap.flatten diffMap + liftIO $ assertEqual "Size reported back should match flattened size" expectedSize size -- | Test the 'fromList' function. testFromList :: Assertion From 58280e317dd5beaff66c2ee9ca6e6269c4067002 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Mon, 13 Nov 2023 15:41:24 +0100 Subject: [PATCH 88/92] Add extra test and cleanup things mentioned in pr review. --- .../GlobalState/AccountMap/DifferenceMap.hs | 22 ++++------------ .../GlobalState/Persistent/Accounts.hs | 26 ++++++++----------- .../CredentialDeploymentTests.hs | 17 +++++++++--- 3 files changed, 29 insertions(+), 36 deletions(-) diff --git a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs index 93457dda40..bc2197448b 100644 --- a/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs +++ b/concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs @@ -12,26 +12,13 @@ module Concordium.GlobalState.AccountMap.DifferenceMap ( DifferenceMapReference, -- * Auxiliary functions - - -- Create a new empty mutable reference. newEmptyReference, - -- Get a list of all @(AccountAddress, AccountIndex)@ pairs for the - -- provided 'DifferenceMap' and all parent maps. flatten, - -- Create an empty 'DifferenceMap' empty, - -- Set the accounts int he 'DifferenceMap'. fromList, - -- Insert an account into the 'DifferenceMap'. insert, - -- Lookup in a difference map (and potential parent maps) whether - -- it yields the 'AccountIndex' for the provided 'AccountAddress' or any - -- alias of it. lookupViaEquivalenceClass, - -- Lookup in a difference map (and potential parent maps) whether - -- it yields the 'AccountIndex' for the provided 'AccountAddress'. lookupExact, - -- Clear up the references of difference map(s). clearReferences, ) where @@ -102,12 +89,13 @@ empty mParentDifferenceMap = lookupViaEquivalenceClass' :: (MonadIO m) => AccountAddressEq -> DifferenceMap -> m (Either Int (AccountIndex, AccountAddress)) lookupViaEquivalenceClass' addr = check 0 where - check accum diffMap = case HM.lookup addr (dmAccounts diffMap) of + check !accum diffMap = case HM.lookup addr (dmAccounts diffMap) of Nothing -> do mParentMap <- liftIO $ readIORef (dmParentMapRef diffMap) + let !accum' = accum + HM.size (dmAccounts diffMap) case mParentMap of - Absent -> return $ Left $ accum + HM.size (dmAccounts diffMap) - Present parentMap -> check (HM.size (dmAccounts diffMap) + accum) parentMap + Absent -> return $ Left accum' + Present parentMap -> check accum' parentMap Just res -> return $ Right res -- | Lookup an account in the difference map or any of the parent @@ -126,7 +114,7 @@ lookupViaEquivalenceClass addr dm = fmap fst <$> lookupViaEquivalenceClass' addr -- Returns @Just AccountIndex@ if the account is present and -- otherwise @Left Word64@ indicating how many accounts there are present in the -- difference map(s). --- Note that this function also returns @Nothing@ if the provided 'AccountAddress.' +-- Note that this function also returns @Nothing@ if the provided 'AccountAddress' -- is an alias but not the canonical address. lookupExact :: (MonadIO m) => AccountAddress -> DifferenceMap -> m (Either Int AccountIndex) lookupExact addr diffMap = diff --git a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs index a973d23ee9..f33c6d1540 100644 --- a/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs +++ b/concordium-consensus/src/Concordium/GlobalState/Persistent/Accounts.hs @@ -51,7 +51,7 @@ -- -- The lmdb backed account map consists of a single lmdb store indexed by AccountAddresses and values are the associated ‘AccountIndex' for each account. -- --- (The ‘DifferenceMap' consists of a @Map AccountAddressEq (AccountIndex, AccountAddress)@ which retains the accounts that have been added to the chain for the associated block. +-- (The ‘DifferenceMap' consists of a @Map AccountAddressEq (AccountIndex, AccountAddress)@ which retains the accounts that have been added to the chain for the associated block.) -- The equivalence class 'AccountAddressEq' is used for looking up accounts in the 'DifferenceMap'. The values are pairs @(AccountIndex, AccountAddress)@ where the -- 'AccountIndex' determines the location of the associated account in the account table. The second component (the 'AccountAddress) is the canonical account address of -- the account i.e. the account address that is derived from the reg id. @@ -148,7 +148,7 @@ instance (SupportsPersistentAccount pv m) => MHashableTo m H.Hash (Accounts pv) -- | Write accounts created for this block or any non-persisted parent block. -- Note that this also empties the difference map for this block. --- This function MUST be called whenver a block is finalized. +-- This function MUST be called whenever a block is finalized. writeAccountsCreated :: (SupportsPersistentAccount pv m) => Accounts pv -> m () writeAccountsCreated Accounts{..} = do mAccountsCreated <- liftIO $ readIORef accountDiffMapRef @@ -177,7 +177,7 @@ mkNewChildDifferenceMap accts@Accounts{..} = do -- below preconditions are respected. -- Precondition: -- * The function assumes that the account table already contains every account added for the block state. --- * The provided 'DiffMap.DifferenceMapReference@ MUST correspond to the parent map. +-- * The provided @DiffMap.DifferenceMapReference@ MUST correspond to the parent map. -- * The provided list of accounts MUST be in ascending order of account index, hence the list of accounts -- MUST be provided in the order of which the corresponding credential deployment transactions were executed. reconstructDifferenceMap :: @@ -214,7 +214,10 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where -- In earlier versions of the node the above mentioned account map was used, -- but this is now superseded by the 'LMDBAccountMap.MonadAccountMapStore'. -- We put this empty map here if the protocol version requires it in order to remain backwards compatible. - (emptyOldMap, _) <- storeUpdate $ OldMap.empty @pv @BufferedFix + pAccountMap <- + if storeRequiresAccountMap (protocolVersion @pv) + then fst <$> storeUpdate (OldMap.empty @pv @BufferedFix) + else return (return ()) (pTable, accountTable') <- storeUpdate accountTable (pRegIdHistory, regIdHistory') <- storeUpdate accountRegIdHistory let newAccounts = @@ -223,11 +226,7 @@ instance (SupportsPersistentAccount pv m) => BlobStorable m (Accounts pv) where accountRegIdHistory = regIdHistory', .. } - let putf = do - when (storeRequiresAccountMap (protocolVersion @pv)) emptyOldMap - pTable - pRegIdHistory - return (putf, newAccounts) + return (pAccountMap >> pTable >> pRegIdHistory, newAccounts) load = do -- If we're on protocol version 6 or older, then load the persistent account map and throw it away as -- the 'OldMap.PersistentAccountMap' is now superseded by the LMDBAccountMap.MonadAccountMapStore. @@ -425,7 +424,7 @@ allAccounts accounts = do Present accDiffMap -> do -- Get all persisted accounts from the account map up to and including the last account of the account table minus what we found the in the difference map. flattenedDiffMapAccounts <- DiffMap.flatten accDiffMap - persistedAccs <- LMDBAccountMap.getAllAccounts $ (AccountIndex . L.size) (accountTable accounts) - (1 + fromIntegral (length flattenedDiffMapAccounts)) + persistedAccs <- LMDBAccountMap.getAllAccounts . AccountIndex $ L.size (accountTable accounts) - (1 + fromIntegral (length flattenedDiffMapAccounts)) return $! persistedAccs <> flattenedDiffMapAccounts -- | Get a list of all account addresses. @@ -449,11 +448,8 @@ foldAccountsDesc :: (SupportsPersistentAccount pv m) => (a -> PersistentAccount foldAccountsDesc f a accts = L.mfoldDesc f a (accountTable accts) -- | Initialize the LMDB account map if it is not already. --- This puts in all accounts from the account table of the provided block state into the account map. --- If there already are accounts present in the account map, then we check that the size of the account map --- corresponds with number of accounts in the account table. --- If the number of accounts in the account table and account map matches, then this function does nothing. --- If they do not match, wipe the account map and recreate it from the account table. +-- If the account map has fewer accounts than the provided account table, the account map is +-- wiped and repopulated from the account table. Otherwise, the account map is unchanged. tryPopulateLMDBStore :: (SupportsPersistentAccount pv m) => Accounts pv -> m () tryPopulateLMDBStore accts = do noLMDBAccounts <- LMDBAccountMap.getNumberOfAccounts diff --git a/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs b/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs index 823e78ecf5..e4f0b3089a 100644 --- a/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs +++ b/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs @@ -280,7 +280,7 @@ testDeployCredentialBranching = runTestMonad noBaker testTime genesisData $ do getAccount (bpState bp2) (getAccAddress cred3) >>= \case Nothing -> return () - Just _ -> liftIO $ assertFailure $ "cred3 should not be present: " <> show (getAccAddress cred3) <> " " <> show (getAccAddress cred2) + Just _ -> liftIO $ assertFailure $ "cred3 should not be present: " <> show (getAccAddress cred3) -- Check that cred1 and cred3 is present in b3 (but not cred2) case sd ^. blockTable . liveMap . at' (getHash b3) of @@ -298,7 +298,7 @@ testDeployCredentialBranching = runTestMonad noBaker testTime genesisData $ do getAccount (bpState bp3) (getAccAddress cred2) >>= \case Nothing -> return () - Just _ -> liftIO $ assertFailure $ "cred2 should not be present: " <> show (getAccAddress cred3) <> " " <> show (getAccAddress cred2) + Just _ -> liftIO $ assertFailure $ "cred2 should not be present: " <> show (getAccAddress cred3) -- finalize bp3 and make sure that the state of the lfb matches b3. let b4 = signedPB testBB4 @@ -308,7 +308,7 @@ testDeployCredentialBranching = runTestMonad noBaker testTime genesisData $ do lfbState <- use (lastFinalized . to bpState) noAccountsLfb <- length <$> getAccountList lfbState - liftIO $ assertEqual "check that there is one extra account" (noGenesisAccs + 2) noAccountsLfb + liftIO $ assertEqual "check that there aer two extra accounts (cred 1 and 3)" (noGenesisAccs + 2) noAccountsLfb getAccount lfbState (getAccAddress cred1) >>= \case Nothing -> liftIO $ assertFailure "Should yield cred1" @@ -320,7 +320,16 @@ testDeployCredentialBranching = runTestMonad noBaker testTime genesisData $ do getAccount lfbState (getAccAddress cred2) >>= \case Nothing -> return () - Just _ -> liftIO $ assertFailure $ "cred2 should not be present: " <> show (getAccAddress cred3) <> " " <> show (getAccAddress cred2) + Just _ -> liftIO $ assertFailure $ "cred2 should not be present: " <> show (getAccAddress cred2) + + -- Check that querying the old bs is not affected by the updated lmdb backed account map. + noFinal <- length <$> getAccountList genesisState + liftIO $ assertEqual "There should be the same number of accounts present" noGenesisAccs noFinal + -- We thaw here so we can use @bsoGetAccountIndex@ for querying account index directly. + updatableBlockState <- thawBlockState genesisState + bsoGetAccountIndex updatableBlockState (getAccAddress cred1) >>= \case + Nothing -> return () + Just _ -> liftIO $ assertFailure "cred 1 should not be present." tests :: Word -> Spec tests _ = describe "EndToEndTests.CredentialDeployments" $ do From 6ccab7f114a11e7e7617d86987f23a1a25180599 Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Mon, 13 Nov 2023 15:58:20 +0100 Subject: [PATCH 89/92] Future maintainers notice. --- .../tests/e2e/EndToEndTests/CredentialDeploymentTests.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs b/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs index e4f0b3089a..3bd806ae16 100644 --- a/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs +++ b/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs @@ -3,6 +3,10 @@ {-# LANGUAGE TemplateHaskell #-} -- | End to end tests for credential deployments. +-- For future maintainers: Note that the blocks below have hardcoded transaction outcome and state hashes. +-- These can be obtained by running the test and observe the program output. +-- (The monad we're running the tests within has a logger) +-- It is not expected that the hardcoded hashes change unless the protocol version changes (AND the underlying hashing scheme). module EndToEndTests.CredentialDeploymentTests (tests) where import Concordium.Utils From 1131cc4fcd364e5e97d1fb0ea3602efd8ceb0d0b Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Mon, 13 Nov 2023 16:09:50 +0100 Subject: [PATCH 90/92] Move credential deployment tests to consensus test suite. --- concordium-consensus/package.yaml | 34 -- concordium-consensus/tests/consensus/Spec.hs | 2 + .../CredentialDeploymentTests.hs | 341 ------------------ .../tests/e2e/EndToEndTests/E2ETestData.hs | 215 ----------- concordium-consensus/tests/e2e/Spec.hs | 21 -- .../tests/globalstate/Spec.hs | 28 +- 6 files changed, 16 insertions(+), 625 deletions(-) delete mode 100644 concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs delete mode 100644 concordium-consensus/tests/e2e/EndToEndTests/E2ETestData.hs delete mode 100644 concordium-consensus/tests/e2e/Spec.hs diff --git a/concordium-consensus/package.yaml b/concordium-consensus/package.yaml index d82a277d41..91715ab15e 100644 --- a/concordium-consensus/package.yaml +++ b/concordium-consensus/package.yaml @@ -331,40 +331,6 @@ tests: - template-haskell - temporary >= 1.3 - e2e: - main: Spec.hs - source-dirs: tests/e2e - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - - -Wall - - -Wcompat - - -fno-ignore-asserts - - -Wno-deprecations - when: - - condition: os(windows) - then: - ghc-options: -static - else: - when: - - condition: flag(dynamic) - then: - ghc-options: -dynamic - else: - ghc-options: -static - dependencies: - - concordium-consensus - - hspec >= 2.6 - - QuickCheck >= 2.12 - - hspec-expectations >= 0.8 - - containers - - time >= 1.8 - - random >= 1.1 - - HUnit >= 1.6 - - temporary >= 1.3 - - monad-loops - benchmarks: trie: main: TrieBench.hs diff --git a/concordium-consensus/tests/consensus/Spec.hs b/concordium-consensus/tests/consensus/Spec.hs index 03297f22ae..fb31005530 100644 --- a/concordium-consensus/tests/consensus/Spec.hs +++ b/concordium-consensus/tests/consensus/Spec.hs @@ -7,6 +7,7 @@ import qualified ConcordiumTests.Afgjort.Freeze (tests) import qualified ConcordiumTests.Afgjort.Lottery (tests) import qualified ConcordiumTests.Afgjort.Types (tests) import qualified ConcordiumTests.Afgjort.WMVBA (tests) +import qualified ConcordiumTests.EndToEnd.CredentialDeploymentTests (tests) import qualified ConcordiumTests.FinalizationRecover (test) import qualified ConcordiumTests.KonsensusV1.CatchUp (tests) import qualified ConcordiumTests.KonsensusV1.Consensus (tests) @@ -63,3 +64,4 @@ main = atLevel $ \lvl -> hspec $ do ConcordiumTests.KonsensusV1.Timeout.tests ConcordiumTests.KonsensusV1.Consensus.Blocks.tests ConcordiumTests.KonsensusV1.CatchUp.tests + ConcordiumTests.EndToEnd.CredentialDeploymentTests.tests lvl diff --git a/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs b/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs deleted file mode 100644 index 3bd806ae16..0000000000 --- a/concordium-consensus/tests/e2e/EndToEndTests/CredentialDeploymentTests.hs +++ /dev/null @@ -1,341 +0,0 @@ -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - --- | End to end tests for credential deployments. --- For future maintainers: Note that the blocks below have hardcoded transaction outcome and state hashes. --- These can be obtained by running the test and observe the program output. --- (The monad we're running the tests within has a logger) --- It is not expected that the hardcoded hashes change unless the protocol version changes (AND the underlying hashing scheme). -module EndToEndTests.CredentialDeploymentTests (tests) where - -import Concordium.Utils -import Control.Monad.IO.Class -import Control.Monad.State -import qualified Data.Aeson as AE -import qualified Data.ByteString.Lazy as BSL -import Data.FileEmbed -import qualified Data.Vector as Vec -import Lens.Micro.Platform -import Test.HUnit -import Test.Hspec - -import Concordium.Common.Version -import Concordium.GlobalState.BlockState -import Concordium.ID.Types -import Concordium.KonsensusV1.TestMonad -import Concordium.KonsensusV1.TreeState.Implementation -import Concordium.KonsensusV1.TreeState.Types -import Concordium.KonsensusV1.Types -import Concordium.Types -import Concordium.Types.HashableTo -import Concordium.Types.Option -import Concordium.Types.Transactions -import EndToEndTests.E2ETestData - --- | Helper for reading an 'AccountCreation' from a 'ByteString'. -readAccountCreation :: BSL.ByteString -> AccountCreation -readAccountCreation bs = - case AE.eitherDecode bs of - Left err -> error $ "Cannot read account creation " ++ err - Right d -> if vVersion d == 0 then vValue d else error "Incorrect account creation version." - --- 3 valid credentials -{-# WARNING cred1 "Do not use in production." #-} -cred1 :: AccountCreation -cred1 = readAccountCreation . BSL.fromStrict $ $(makeRelativeToProject "testdata/initial-credential-1.json" >>= embedFile) - -{-# WARNING cred2 "Do not use in production." #-} -cred2 :: AccountCreation -cred2 = readAccountCreation . BSL.fromStrict $ $(makeRelativeToProject "testdata/initial-credential-2.json" >>= embedFile) - -{-# WARNING cred3 "Do not use in production." #-} -cred3 :: AccountCreation -cred3 = readAccountCreation . BSL.fromStrict $ $(makeRelativeToProject "testdata/credential-1.json" >>= embedFile) - --- | A credential deployment transaction yielding cred1. -credBi1 :: BlockItem -credBi1 = - credentialDeployment $ addMetadata (\x -> CredentialDeployment{biCred = x}) (tt + 1) cred1 - where - tt = utcTimeToTransactionTime testTime - --- | A credential deployment transaction yielding cred2. -credBi2 :: BlockItem -credBi2 = - credentialDeployment $ addMetadata (\x -> CredentialDeployment{biCred = x}) (tt + 1) cred2 - where - tt = utcTimeToTransactionTime testTime - --- | A credential deployment transaction yielding cred3 -credBi3 :: BlockItem -credBi3 = - credentialDeployment $ addMetadata (\x -> CredentialDeployment{biCred = x}) (tt + 1) cred3 - where - tt = utcTimeToTransactionTime testTime - --- | Valid block for round 1 with 1 credential deployment. -testBB1 :: BakedBlock -testBB1 = - BakedBlock - { bbRound = 1, - bbEpoch = 0, - bbTimestamp = 1_000, - bbBaker = bakerId, - bbQuorumCertificate = genesisQuorumCertificate genesisHash, - bbTimeoutCertificate = Absent, - bbEpochFinalizationEntry = Absent, - bbNonce = computeBlockNonce genesisLEN 1 (bakerVRFKey bakerId), - bbTransactions = Vec.fromList [credBi1], - bbTransactionOutcomesHash = read "b9444648bf759471276fdba1930af0c543847d22de89c27939791898d757516d", - bbStateHash = read "b8bc96ec5f162db36784ea96ec29e3e8ad92abff341a6847e3bf524fdada28ff" - } - where - bakerId = 2 - --- | Valid block for round 2. --- This block carries a QC for 'testBB1' thus certifying it. -testBB2 :: BakedBlock -testBB2 = - BakedBlock - { bbRound = 2, - bbEpoch = 0, - bbTimestamp = 3_000, - bbBaker = bakerId, - bbQuorumCertificate = validQCFor testBB1, - bbTimeoutCertificate = Absent, - bbEpochFinalizationEntry = Absent, - bbNonce = computeBlockNonce genesisLEN 2 (bakerVRFKey bakerId), - bbTransactions = Vec.empty, - bbTransactionOutcomesHash = read "375fef64a251f353d608171d283d00fe00aa0bd77596ba7703c810f48056ef89", - bbStateHash = read "798d5089818bcc7b8873e2585fb4fbf3d4dceffca32531259f466e7c435c8817" - } - where - bakerId = 4 - --- | Valid block for round 3, finalizes 'testBB1' as this block --- carries a QC for 'testBB2'. -testBB3 :: BakedBlock -testBB3 = - BakedBlock - { bbRound = 3, - bbEpoch = 0, - bbTimestamp = 5_000, - bbBaker = bakerId, - bbQuorumCertificate = validQCFor testBB2, - bbTimeoutCertificate = Absent, - bbEpochFinalizationEntry = Absent, - bbNonce = computeBlockNonce genesisLEN 3 (bakerVRFKey bakerId), - bbTransactions = Vec.empty, - bbTransactionOutcomesHash = read "375fef64a251f353d608171d283d00fe00aa0bd77596ba7703c810f48056ef89", - bbStateHash = read "4da0deab5b564cd77c617a2ac7dc8a6064f87e99b09e58c87b5f9e687db2197a" - } - where - bakerId = 4 - --- | A test that deploys a single credential, and it ends up in the last finalized block. -testDeployCredential :: Assertion -testDeployCredential = runTestMonad noBaker testTime genesisData $ do - lfbState0 <- use (lastFinalized . to bpState) - noAccs0 <- length <$> getAccountList lfbState0 - let b1 = signedPB testBB1 - succeedReceiveBlock b1 - let b2 = signedPB testBB2 - succeedReceiveBlock b2 - -- b3 finalizes b1 as it carries a qc for b2 (which carries a qc for b1). - let b3 = signedPB testBB3 - succeedReceiveBlock b3 - -- check that the account is now present in the last finalized block. - lfbState1 <- use (lastFinalized . to bpState) - noAccs1 <- length <$> getAccountList lfbState1 - liftIO $ assertEqual "there should be one extra account in lfb" (noAccs0 + 1) noAccs1 - --- | Valid block for round 2. --- This block has one credential deployment. --- This block carries a QC for 'testBB1' thus certifying it. -testBB2' :: BakedBlock -testBB2' = - BakedBlock - { bbRound = 2, - bbEpoch = 0, - bbTimestamp = 3_000, - bbBaker = bakerId, - bbQuorumCertificate = validQCFor testBB1, - bbTimeoutCertificate = Absent, - bbEpochFinalizationEntry = Absent, - bbNonce = computeBlockNonce genesisLEN 2 (bakerVRFKey bakerId), - bbTransactions = Vec.fromList [credBi2], - bbTransactionOutcomesHash = read "abc4628869bb526115226dd01ad54bf33f54609fa770d50a9242aaf009f42fa1", - bbStateHash = read "e3cf3b280159bc20645738fb1343486d16104989a524fb5feb59ac1b0b7af9ad" - } - where - bakerId = 4 - --- | Valid block for round 3, carries a TC for round 2. --- This block has one credential deployment. -testBB3' :: BakedBlock -testBB3' = - BakedBlock - { bbRound = 3, - bbEpoch = 0, - bbTimestamp = 5_000, - bbBaker = bakerId, - bbQuorumCertificate = validQCFor testBB1, - bbTimeoutCertificate = Present (validTimeoutFor (validQCFor testBB1) 2), - bbEpochFinalizationEntry = Absent, - bbNonce = computeBlockNonce genesisLEN 3 (bakerVRFKey bakerId), - bbTransactions = Vec.fromList [credBi3], - bbTransactionOutcomesHash = read "3af8504795a03353248be256f66366263f7484c814c5a26760210bbdfd609003", - bbStateHash = read "67eb8f778a4a43efa80c73a954110154ae417e21d43c33b857b962af36913e29" - } - where - bakerId = 4 - -testBB4 :: BakedBlock -testBB4 = - BakedBlock - { bbRound = 4, - bbEpoch = 0, - bbTimestamp = 7_000, - bbBaker = bakerId, - bbQuorumCertificate = validQCFor testBB3', - bbTimeoutCertificate = Absent, - bbEpochFinalizationEntry = Absent, - bbNonce = computeBlockNonce genesisLEN 4 (bakerVRFKey bakerId), - bbTransactions = Vec.empty, - bbTransactionOutcomesHash = read "b0972dd7af05ed6feaa40099fffa9c5c5e0ba9741938166cdb57584780688743", - bbStateHash = read "9e698b9c6425b382d8fda5584f530688c237ad013e8aaf848fea274e50244111" - } - where - bakerId = 3 - -testBB5 :: BakedBlock -testBB5 = - BakedBlock - { bbRound = 5, - bbEpoch = 0, - bbTimestamp = 9_000, - bbBaker = bakerId, - bbQuorumCertificate = validQCFor testBB4, - bbTimeoutCertificate = Absent, - bbEpochFinalizationEntry = Absent, - bbNonce = computeBlockNonce genesisLEN 5 (bakerVRFKey bakerId), - bbTransactions = Vec.empty, - bbTransactionOutcomesHash = read "b0972dd7af05ed6feaa40099fffa9c5c5e0ba9741938166cdb57584780688743", - bbStateHash = read "d9dd62c227d1cbc0d42da0d90bfc11d61533d058cc54b0745d6a597039dbe0ec" - } - where - bakerId = 3 - --- | Compute the 'AccountCreation' from the provided 'AccountCreation'. -getAccAddress :: AccountCreation -> AccountAddress -getAccAddress accCreation = case credential accCreation of - InitialACWP x -> initialCredentialAccountAddress $ icdiValues x - NormalACWP x -> credentialAccountAddress $ cdiValues x - --- | Test that two credential deployments (each on their own branch and with same block height) does not: --- * Alter the state of the parent block (a new child difference map and associated reference is created). -testDeployCredentialBranching :: Assertion -testDeployCredentialBranching = runTestMonad noBaker testTime genesisData $ do - genesisState <- use (lastFinalized . to bpState) - noGenesisAccs <- length <$> getAccountList genesisState - let b1 = signedPB testBB1 - succeedReceiveBlock b1 - -- Branch - let b2 = signedPB testBB2' - succeedReceiveBlock b2 - -- Another branch. - let b3 = signedPB testBB3' - succeedReceiveBlock b3 - - sd <- get - - -- Check that only the first credential deployed is present in block b1. - case sd ^. blockTable . liveMap . at' (getHash b1) of - Nothing -> liftIO $ assertFailure "failed getting bp1" - Just bp1 -> do - noAccountsBp1 <- length <$> getAccountList (bpState bp1) - liftIO $ assertEqual "check that there is one extra account" (noGenesisAccs + 1) noAccountsBp1 - getAccount (bpState bp1) (getAccAddress cred1) >>= \case - Nothing -> liftIO $ assertFailure "Should yield cred1" - Just (accIndex, _) -> liftIO $ assertEqual "incorrect account index" noGenesisAccs (fromIntegral accIndex) - - getAccount (bpState bp1) (getAccAddress cred2) >>= \case - Nothing -> return () - Just _ -> liftIO $ assertFailure "cred2 should not be present" - - getAccount (bpState bp1) (getAccAddress cred3) >>= \case - Nothing -> return () - Just _ -> liftIO $ assertFailure "cred3 should not be present" - - -- Check that cred1 and cred2 is present in b2 (but not cred3) - case sd ^. blockTable . liveMap . at' (getHash b2) of - Nothing -> liftIO $ assertFailure "failed getting bp1" - Just bp2 -> do - noAccountsBp2 <- length <$> getAccountList (bpState bp2) - liftIO $ assertEqual "check that there is one extra account" (noGenesisAccs + 2) noAccountsBp2 - getAccount (bpState bp2) (getAccAddress cred1) >>= \case - Nothing -> liftIO $ assertFailure "Should yield cred1" - Just (accIndex, _) -> liftIO $ assertEqual "incorrect account index" noGenesisAccs (fromIntegral accIndex) - - getAccount (bpState bp2) (getAccAddress cred2) >>= \case - Nothing -> liftIO $ assertFailure "Should yield cred2" - Just (accIndex, _) -> liftIO $ assertEqual "incorrect account index" (noGenesisAccs + 1) (fromIntegral accIndex) - - getAccount (bpState bp2) (getAccAddress cred3) >>= \case - Nothing -> return () - Just _ -> liftIO $ assertFailure $ "cred3 should not be present: " <> show (getAccAddress cred3) - - -- Check that cred1 and cred3 is present in b3 (but not cred2) - case sd ^. blockTable . liveMap . at' (getHash b3) of - Nothing -> liftIO $ assertFailure "failed getting bp1" - Just bp3 -> do - noAccountsBp3 <- length <$> getAccountList (bpState bp3) - liftIO $ assertEqual "check that there is one extra account" (noGenesisAccs + 2) noAccountsBp3 - getAccount (bpState bp3) (getAccAddress cred1) >>= \case - Nothing -> liftIO $ assertFailure "Should yield cred1" - Just (accIndex, _) -> liftIO $ assertEqual "incorrect account index" noGenesisAccs (fromIntegral accIndex) - - getAccount (bpState bp3) (getAccAddress cred3) >>= \case - Nothing -> liftIO $ assertFailure "Should yield cred3" - Just (accIndex, _) -> liftIO $ assertEqual "incorrect account index" (noGenesisAccs + 1) (fromIntegral accIndex) - - getAccount (bpState bp3) (getAccAddress cred2) >>= \case - Nothing -> return () - Just _ -> liftIO $ assertFailure $ "cred2 should not be present: " <> show (getAccAddress cred3) - - -- finalize bp3 and make sure that the state of the lfb matches b3. - let b4 = signedPB testBB4 - succeedReceiveBlock b4 - let b5 = signedPB testBB5 - succeedReceiveBlock b5 - - lfbState <- use (lastFinalized . to bpState) - noAccountsLfb <- length <$> getAccountList lfbState - liftIO $ assertEqual "check that there aer two extra accounts (cred 1 and 3)" (noGenesisAccs + 2) noAccountsLfb - - getAccount lfbState (getAccAddress cred1) >>= \case - Nothing -> liftIO $ assertFailure "Should yield cred1" - Just (accIndex, _) -> liftIO $ assertEqual "incorrect account index" noGenesisAccs (fromIntegral accIndex) - - getAccount lfbState (getAccAddress cred3) >>= \case - Nothing -> liftIO $ assertFailure "Should yield cred3" - Just (accIndex, _) -> liftIO $ assertEqual "incorrect account index" (noGenesisAccs + 1) (fromIntegral accIndex) - - getAccount lfbState (getAccAddress cred2) >>= \case - Nothing -> return () - Just _ -> liftIO $ assertFailure $ "cred2 should not be present: " <> show (getAccAddress cred2) - - -- Check that querying the old bs is not affected by the updated lmdb backed account map. - noFinal <- length <$> getAccountList genesisState - liftIO $ assertEqual "There should be the same number of accounts present" noGenesisAccs noFinal - -- We thaw here so we can use @bsoGetAccountIndex@ for querying account index directly. - updatableBlockState <- thawBlockState genesisState - bsoGetAccountIndex updatableBlockState (getAccAddress cred1) >>= \case - Nothing -> return () - Just _ -> liftIO $ assertFailure "cred 1 should not be present." - -tests :: Word -> Spec -tests _ = describe "EndToEndTests.CredentialDeployments" $ do - it "deploy and finalize one credential" testDeployCredential - it "deploy two credentials in two branches" testDeployCredentialBranching diff --git a/concordium-consensus/tests/e2e/EndToEndTests/E2ETestData.hs b/concordium-consensus/tests/e2e/EndToEndTests/E2ETestData.hs deleted file mode 100644 index 8e409a132b..0000000000 --- a/concordium-consensus/tests/e2e/EndToEndTests/E2ETestData.hs +++ /dev/null @@ -1,215 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} - --- | Helpers for end-to-end tests. -module EndToEndTests.E2ETestData where - -import Control.Monad.IO.Class -import Control.Monad.State -import Control.Monad.Writer.Class -import Data.Foldable -import qualified Data.Map.Strict as Map -import Data.Time -import Test.HUnit - -import qualified Concordium.Crypto.DummyData as Dummy -import qualified Concordium.Crypto.SHA256 as H -import Concordium.Genesis.Data -import qualified Concordium.Genesis.Data.P6 as P6 -import Concordium.GlobalState.BakerInfo -import Concordium.GlobalState.Basic.BlockState.LFMBTree (hashAsLFMBT) -import Concordium.GlobalState.BlockState (TransactionSummaryV1) -import qualified Concordium.GlobalState.DummyData as Dummy -import Concordium.KonsensusV1.Consensus -import Concordium.KonsensusV1.Consensus.Blocks -import Concordium.KonsensusV1.TestMonad -import Concordium.KonsensusV1.TreeState.Implementation -import Concordium.KonsensusV1.TreeState.Types -import Concordium.KonsensusV1.Types -import Concordium.Startup -import Concordium.Types -import Concordium.Types.BakerIdentity -import qualified Concordium.Types.DummyData as Dummy -import Concordium.Types.HashableTo -import Concordium.Types.Transactions -import qualified Concordium.Types.Transactions as Transactions - --- * Helper definitions - --- | Max bakers -noBakers :: (Integral a) => a -noBakers = 5 - --- | Genesis time -genTime :: Timestamp -genTime = 0 - --- | Epoch duration -genEpochDuration :: Duration -genEpochDuration = 3_600_000 - --- | Genesis data used for E2E credential deployments -genesisData :: GenesisData 'P6 -bakers :: [(BakerIdentity, FullBakerInfo)] -(genesisData, bakers, _) = - makeGenesisDataV1 - genTime - (noBakers + 1) - genEpochDuration - Dummy.dummyCryptographicParameters - Dummy.dummyIdentityProviders - Dummy.dummyArs - [ foundationAcct - ] - Dummy.dummyKeyCollection - Dummy.dummyChainParameters - where - foundationAcct = - Dummy.createCustomAccount - 1_000_000_000_000 - (Dummy.deterministicKP 0) - (Dummy.accountAddressFrom 0) - --- | Hash of the genesis block. -genesisHash :: BlockHash -genesisHash = genesisBlockHash genesisData - --- | Leadership election nonce at genesis -genesisLEN :: LeadershipElectionNonce -genesisLEN = genesisLeadershipElectionNonce $ P6.genesisInitialState $ unGDP6 genesisData - --- | Baker context with baker @i@. -baker :: Int -> BakerContext -baker i = BakerContext $ Just $ fst $ bakers !! i - --- | Private ED25519 key of the provided baker identifier. -bakerKey :: (Integral a) => a -> BakerSignPrivateKey -bakerKey i = bakerSignKey $ fst (bakers !! fromIntegral i) - --- | Private BLS key of the provided baker identifier. -bakerAggKey :: (Integral a) => a -> BakerAggregationPrivateKey -bakerAggKey i = bakerAggregationKey $ fst (bakers !! fromIntegral i) - --- | Private VRF key of the provided baker identifier. -bakerVRFKey :: (Integral a) => a -> BakerElectionPrivateKey -bakerVRFKey i = bakerElectionKey $ fst (bakers !! fromIntegral i) - --- | Finalizer set of all finalizers. -allFinalizers :: FinalizerSet -allFinalizers = finalizerSet $ FinalizerIndex <$> [0 .. noBakers] - --- | List of finalizers -theFinalizers :: [Int] -theFinalizers = [0 .. noBakers] - --- | Make a valid 'QuorumCertificate' for the provided block. -validQCFor :: BakedBlock -> QuorumCertificate -validQCFor bb = - QuorumCertificate - { qcSignatories = allFinalizers, - qcRound = bbRound bb, - qcEpoch = bbEpoch bb, - qcBlock = block, - qcAggregateSignature = sig - } - where - block = getHash bb - qsm = - QuorumSignatureMessage - { qsmGenesis = genesisHash, - qsmBlock = block, - qsmRound = bbRound bb, - qsmEpoch = bbEpoch bb - } - sig = fold [signQuorumSignatureMessage qsm (bakerAggKey i) | i <- theFinalizers] - -validTimeoutForFinalizers :: [Int] -> QuorumCertificate -> Round -> TimeoutCertificate -validTimeoutForFinalizers finalizers qc rnd = - TimeoutCertificate - { tcRound = rnd, - tcMinEpoch = qcEpoch qc, - tcFinalizerQCRoundsFirstEpoch = FinalizerRounds (Map.singleton (qcRound qc) finSet), - tcFinalizerQCRoundsSecondEpoch = FinalizerRounds Map.empty, - tcAggregateSignature = - fold - [signTimeoutSignatureMessage tsm (bakerAggKey i) | i <- finalizers] - } - where - finSet = finalizerSet $ FinalizerIndex . fromIntegral <$> finalizers - tsm = - TimeoutSignatureMessage - { tsmGenesis = genesisHash, - tsmRound = rnd, - tsmQCRound = qcRound qc, - tsmQCEpoch = qcEpoch qc - } - --- | Create a valid timeout message given a QC and a round. --- All finalizers sign the certificate and they all have the QC as their highest QC. -validTimeoutFor :: QuorumCertificate -> Round -> TimeoutCertificate -validTimeoutFor = validTimeoutForFinalizers theFinalizers - --- | Make a valid signed block from the provided @BakedBlock@. -validSignBlock :: BakedBlock -> SignedBlock -validSignBlock bb = signBlock (bakerKey (bbBaker bb)) genesisHash bb - --- | Make a valid signed pending block. -signedPB :: BakedBlock -> PendingBlock -signedPB bb = - PendingBlock - { pbReceiveTime = timestampToUTCTime $ bbTimestamp bb, - pbBlock = validSignBlock bb - } - --- | Helper to compute the transaction outcomes hash for a given set of transaction outcomes and --- special transaction outcomes. -transactionOutcomesHash :: - [TransactionSummaryV1] -> - [Transactions.SpecialTransactionOutcome] -> - Transactions.TransactionOutcomesHash -transactionOutcomesHash outcomes specialOutcomes = - Transactions.TransactionOutcomesHash $ - H.hashShort $ - "TransactionOutcomesHashV1" - <> H.hashToShortByteString out - <> H.hashToShortByteString special - where - lfmbHash :: (HashableTo H.Hash a) => [a] -> H.Hash - lfmbHash = hashAsLFMBT (H.hash "EmptyLFMBTree") . fmap getHash - out = lfmbHash outcomes - special = lfmbHash specialOutcomes - --- | Compute the transaction outcomes hash for a block with no transactions. -emptyBlockTOH :: BakerId -> Transactions.TransactionOutcomesHash -emptyBlockTOH bid = transactionOutcomesHash [] [BlockAccrueReward 0 0 0 0 0 0 bid] - --- | Baker context with no baker. -noBaker :: BakerContext -noBaker = BakerContext Nothing - --- | Current time used for running (some) tests. 5 seconds after genesis. -testTime :: UTCTime -testTime = timestampToUTCTime 5_000 - --- * Helper functions - --- | Receive a block - assert success. -succeedReceiveBlock :: PendingBlock -> TestMonad 'P6 () -succeedReceiveBlock pb = do - res <- uponReceivingBlock pb - case res of - BlockResultSuccess vb -> do - ((), events) <- listen $ executeBlock vb - status <- getBlockStatus (getHash pb) =<< get - case status of - BlockAlive _ -> return () - BlockFinalized _ -> return () - _ -> liftIO . assertFailure $ "Expected BlockAlive after executeBlock, but found: " ++ show status ++ "\n" ++ show pb - case events of - (OnBlock (NormalBlock b) : _) - | b == pbBlock pb -> return () - (OnFinalize _ : OnBlock (NormalBlock b) : _) - | b == pbBlock pb -> return () - _ -> liftIO . assertFailure $ "Expected OnBlock event on executeBlock, but saw: " ++ show events - _ -> liftIO . assertFailure $ "Expected BlockResultSuccess after uponReceivingBlock, but found: " ++ show res ++ "\n" ++ show pb diff --git a/concordium-consensus/tests/e2e/Spec.hs b/concordium-consensus/tests/e2e/Spec.hs deleted file mode 100644 index 015db18624..0000000000 --- a/concordium-consensus/tests/e2e/Spec.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Main where - -import Data.List (stripPrefix) -import Data.Semigroup -import qualified EndToEndTests.CredentialDeploymentTests (tests) -import System.Environment -import Test.Hspec - -atLevel :: (Word -> IO ()) -> IO () -atLevel a = do - args0 <- getArgs - let (args1, mlevel) = mconcat $ map lvlArg args0 - withArgs args1 $ a $! maybe 1 getLast mlevel - where - lvlArg s = case stripPrefix "--level=" s of - Nothing -> ([s], Nothing) - Just r -> ([], Just $! Last $! (read r :: Word)) - -main :: IO () -main = atLevel $ \lvl -> hspec $ do - EndToEndTests.CredentialDeploymentTests.tests lvl diff --git a/concordium-consensus/tests/globalstate/Spec.hs b/concordium-consensus/tests/globalstate/Spec.hs index 9b83df6211..36cc26f614 100644 --- a/concordium-consensus/tests/globalstate/Spec.hs +++ b/concordium-consensus/tests/globalstate/Spec.hs @@ -34,20 +34,20 @@ atLevel a = do main :: IO () main = atLevel $ \lvl -> hspec $ do - GlobalStateTests.BlockHash.tests - GlobalStateTests.Cache.tests - GlobalStateTests.LFMBTree.tests + -- GlobalStateTests.BlockHash.tests + -- GlobalStateTests.Cache.tests + -- GlobalStateTests.LFMBTree.tests GlobalStateTests.Accounts.tests lvl - GlobalStateTests.Trie.tests - GlobalStateTests.PersistentTreeState.tests - GlobalStateTests.FinalizationSerializationSpec.tests - GlobalStateTests.Instances.tests lvl - GlobalStateTests.AccountReleaseScheduleTest.tests - GlobalStateTests.AccountReleaseScheduleMigration.tests - GlobalStateTests.Updates.tests - GlobalStateTests.AccountMap.tests lvl - GlobalStateTests.EnduringDataFlags.tests - GlobalStateTests.BlobStore.tests - GlobalStateTests.UpdateQueues.tests + -- GlobalStateTests.Trie.tests + -- GlobalStateTests.PersistentTreeState.tests + -- GlobalStateTests.FinalizationSerializationSpec.tests + -- GlobalStateTests.Instances.tests lvl + -- GlobalStateTests.AccountReleaseScheduleTest.tests + -- GlobalStateTests.AccountReleaseScheduleMigration.tests + -- GlobalStateTests.Updates.tests + -- GlobalStateTests.AccountMap.tests lvl + -- GlobalStateTests.EnduringDataFlags.tests + -- GlobalStateTests.BlobStore.tests + -- GlobalStateTests.UpdateQueues.tests GlobalStateTests.LMDBAccountMap.tests GlobalStateTests.DifferenceMap.tests From ee8b4bc48dc104ef0a842ee03b387e8bab57d93a Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Mon, 13 Nov 2023 17:01:13 +0100 Subject: [PATCH 91/92] Add missing test file. --- .../EndToEnd/CredentialDeploymentTests.hs | 342 ++++++++++++++++++ 1 file changed, 342 insertions(+) create mode 100644 concordium-consensus/tests/consensus/ConcordiumTests/EndToEnd/CredentialDeploymentTests.hs diff --git a/concordium-consensus/tests/consensus/ConcordiumTests/EndToEnd/CredentialDeploymentTests.hs b/concordium-consensus/tests/consensus/ConcordiumTests/EndToEnd/CredentialDeploymentTests.hs new file mode 100644 index 0000000000..22acf3b5e9 --- /dev/null +++ b/concordium-consensus/tests/consensus/ConcordiumTests/EndToEnd/CredentialDeploymentTests.hs @@ -0,0 +1,342 @@ +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | End to end tests for credential deployments. +-- For future maintainers: Note that the blocks below have hardcoded transaction outcome and state hashes. +-- These can be obtained by running the test and observe the program output. +-- (The monad we're running the tests within has a logger) +-- It is not expected that the hardcoded hashes change unless the protocol version changes (AND the underlying hashing scheme). +module ConcordiumTests.EndToEnd.CredentialDeploymentTests (tests) where + +import Concordium.Utils +import Control.Monad.IO.Class +import Control.Monad.State +import qualified Data.Aeson as AE +import qualified Data.ByteString.Lazy as BSL +import Data.FileEmbed +import qualified Data.Vector as Vec +import Lens.Micro.Platform +import Test.HUnit +import Test.Hspec + +import Concordium.Common.Version +import Concordium.GlobalState.BlockState +import Concordium.ID.Types +import Concordium.KonsensusV1.TestMonad +import Concordium.KonsensusV1.TreeState.Implementation +import Concordium.KonsensusV1.TreeState.Types +import Concordium.KonsensusV1.Types +import Concordium.Types +import Concordium.Types.HashableTo +import Concordium.Types.Option +import Concordium.Types.Transactions + +import ConcordiumTests.KonsensusV1.Consensus.Blocks hiding (testBB1, testBB2, testBB2', testBB3, testBB3', tests) + +-- | Helper for reading an 'AccountCreation' from a 'ByteString'. +readAccountCreation :: BSL.ByteString -> AccountCreation +readAccountCreation bs = + case AE.eitherDecode bs of + Left err -> error $ "Cannot read account creation " ++ err + Right d -> if vVersion d == 0 then vValue d else error "Incorrect account creation version." + +-- 3 valid credentials +{-# WARNING cred1 "Do not use in production." #-} +cred1 :: AccountCreation +cred1 = readAccountCreation . BSL.fromStrict $ $(makeRelativeToProject "testdata/initial-credential-1.json" >>= embedFile) + +{-# WARNING cred2 "Do not use in production." #-} +cred2 :: AccountCreation +cred2 = readAccountCreation . BSL.fromStrict $ $(makeRelativeToProject "testdata/initial-credential-2.json" >>= embedFile) + +{-# WARNING cred3 "Do not use in production." #-} +cred3 :: AccountCreation +cred3 = readAccountCreation . BSL.fromStrict $ $(makeRelativeToProject "testdata/credential-1.json" >>= embedFile) + +-- | A credential deployment transaction yielding cred1. +credBi1 :: BlockItem +credBi1 = + credentialDeployment $ addMetadata (\x -> CredentialDeployment{biCred = x}) (tt + 1) cred1 + where + tt = utcTimeToTransactionTime testTime + +-- | A credential deployment transaction yielding cred2. +credBi2 :: BlockItem +credBi2 = + credentialDeployment $ addMetadata (\x -> CredentialDeployment{biCred = x}) (tt + 1) cred2 + where + tt = utcTimeToTransactionTime testTime + +-- | A credential deployment transaction yielding cred3 +credBi3 :: BlockItem +credBi3 = + credentialDeployment $ addMetadata (\x -> CredentialDeployment{biCred = x}) (tt + 1) cred3 + where + tt = utcTimeToTransactionTime testTime + +-- | Valid block for round 1 with 1 credential deployment. +testBB1 :: BakedBlock +testBB1 = + BakedBlock + { bbRound = 1, + bbEpoch = 0, + bbTimestamp = 1_000, + bbBaker = bakerId, + bbQuorumCertificate = genesisQuorumCertificate genesisHash, + bbTimeoutCertificate = Absent, + bbEpochFinalizationEntry = Absent, + bbNonce = computeBlockNonce genesisLEN 1 (bakerVRFKey bakerId), + bbTransactions = Vec.fromList [credBi1], + bbTransactionOutcomesHash = read "b9444648bf759471276fdba1930af0c543847d22de89c27939791898d757516d", + bbStateHash = read "b8bc96ec5f162db36784ea96ec29e3e8ad92abff341a6847e3bf524fdada28ff" + } + where + bakerId = 2 + +-- | Valid block for round 2. +-- This block carries a QC for 'testBB1' thus certifying it. +testBB2 :: BakedBlock +testBB2 = + BakedBlock + { bbRound = 2, + bbEpoch = 0, + bbTimestamp = 3_000, + bbBaker = bakerId, + bbQuorumCertificate = validQCFor testBB1, + bbTimeoutCertificate = Absent, + bbEpochFinalizationEntry = Absent, + bbNonce = computeBlockNonce genesisLEN 2 (bakerVRFKey bakerId), + bbTransactions = Vec.empty, + bbTransactionOutcomesHash = read "375fef64a251f353d608171d283d00fe00aa0bd77596ba7703c810f48056ef89", + bbStateHash = read "798d5089818bcc7b8873e2585fb4fbf3d4dceffca32531259f466e7c435c8817" + } + where + bakerId = 4 + +-- | Valid block for round 3, finalizes 'testBB1' as this block +-- carries a QC for 'testBB2'. +testBB3 :: BakedBlock +testBB3 = + BakedBlock + { bbRound = 3, + bbEpoch = 0, + bbTimestamp = 5_000, + bbBaker = bakerId, + bbQuorumCertificate = validQCFor testBB2, + bbTimeoutCertificate = Absent, + bbEpochFinalizationEntry = Absent, + bbNonce = computeBlockNonce genesisLEN 3 (bakerVRFKey bakerId), + bbTransactions = Vec.empty, + bbTransactionOutcomesHash = read "375fef64a251f353d608171d283d00fe00aa0bd77596ba7703c810f48056ef89", + bbStateHash = read "4da0deab5b564cd77c617a2ac7dc8a6064f87e99b09e58c87b5f9e687db2197a" + } + where + bakerId = 4 + +-- | A test that deploys a single credential, and it ends up in the last finalized block. +testDeployCredential :: Assertion +testDeployCredential = runTestMonad noBaker testTime genesisData $ do + lfbState0 <- use (lastFinalized . to bpState) + noAccs0 <- length <$> getAccountList lfbState0 + let b1 = signedPB testBB1 + succeedReceiveBlock b1 + let b2 = signedPB testBB2 + succeedReceiveBlock b2 + -- b3 finalizes b1 as it carries a qc for b2 (which carries a qc for b1). + let b3 = signedPB testBB3 + succeedReceiveBlock b3 + -- check that the account is now present in the last finalized block. + lfbState1 <- use (lastFinalized . to bpState) + noAccs1 <- length <$> getAccountList lfbState1 + liftIO $ assertEqual "there should be one extra account in lfb" (noAccs0 + 1) noAccs1 + +-- | Valid block for round 2. +-- This block has one credential deployment. +-- This block carries a QC for 'testBB1' thus certifying it. +testBB2' :: BakedBlock +testBB2' = + BakedBlock + { bbRound = 2, + bbEpoch = 0, + bbTimestamp = 3_000, + bbBaker = bakerId, + bbQuorumCertificate = validQCFor testBB1, + bbTimeoutCertificate = Absent, + bbEpochFinalizationEntry = Absent, + bbNonce = computeBlockNonce genesisLEN 2 (bakerVRFKey bakerId), + bbTransactions = Vec.fromList [credBi2], + bbTransactionOutcomesHash = read "abc4628869bb526115226dd01ad54bf33f54609fa770d50a9242aaf009f42fa1", + bbStateHash = read "e3cf3b280159bc20645738fb1343486d16104989a524fb5feb59ac1b0b7af9ad" + } + where + bakerId = 4 + +-- | Valid block for round 3, carries a TC for round 2. +-- This block has one credential deployment. +testBB3' :: BakedBlock +testBB3' = + BakedBlock + { bbRound = 3, + bbEpoch = 0, + bbTimestamp = 5_000, + bbBaker = bakerId, + bbQuorumCertificate = validQCFor testBB1, + bbTimeoutCertificate = Present (validTimeoutFor (validQCFor testBB1) 2), + bbEpochFinalizationEntry = Absent, + bbNonce = computeBlockNonce genesisLEN 3 (bakerVRFKey bakerId), + bbTransactions = Vec.fromList [credBi3], + bbTransactionOutcomesHash = read "3af8504795a03353248be256f66366263f7484c814c5a26760210bbdfd609003", + bbStateHash = read "67eb8f778a4a43efa80c73a954110154ae417e21d43c33b857b962af36913e29" + } + where + bakerId = 4 + +testBB4 :: BakedBlock +testBB4 = + BakedBlock + { bbRound = 4, + bbEpoch = 0, + bbTimestamp = 7_000, + bbBaker = bakerId, + bbQuorumCertificate = validQCFor testBB3', + bbTimeoutCertificate = Absent, + bbEpochFinalizationEntry = Absent, + bbNonce = computeBlockNonce genesisLEN 4 (bakerVRFKey bakerId), + bbTransactions = Vec.empty, + bbTransactionOutcomesHash = read "b0972dd7af05ed6feaa40099fffa9c5c5e0ba9741938166cdb57584780688743", + bbStateHash = read "9e698b9c6425b382d8fda5584f530688c237ad013e8aaf848fea274e50244111" + } + where + bakerId = 3 + +testBB5 :: BakedBlock +testBB5 = + BakedBlock + { bbRound = 5, + bbEpoch = 0, + bbTimestamp = 9_000, + bbBaker = bakerId, + bbQuorumCertificate = validQCFor testBB4, + bbTimeoutCertificate = Absent, + bbEpochFinalizationEntry = Absent, + bbNonce = computeBlockNonce genesisLEN 5 (bakerVRFKey bakerId), + bbTransactions = Vec.empty, + bbTransactionOutcomesHash = read "b0972dd7af05ed6feaa40099fffa9c5c5e0ba9741938166cdb57584780688743", + bbStateHash = read "d9dd62c227d1cbc0d42da0d90bfc11d61533d058cc54b0745d6a597039dbe0ec" + } + where + bakerId = 3 + +-- | Compute the 'AccountCreation' from the provided 'AccountCreation'. +getAccAddress :: AccountCreation -> AccountAddress +getAccAddress accCreation = case credential accCreation of + InitialACWP x -> initialCredentialAccountAddress $ icdiValues x + NormalACWP x -> credentialAccountAddress $ cdiValues x + +-- | Test that two credential deployments (each on their own branch and with same block height) does not: +-- * Alter the state of the parent block (a new child difference map and associated reference is created). +testDeployCredentialBranching :: Assertion +testDeployCredentialBranching = runTestMonad noBaker testTime genesisData $ do + genesisState <- use (lastFinalized . to bpState) + noGenesisAccs <- length <$> getAccountList genesisState + let b1 = signedPB testBB1 + succeedReceiveBlock b1 + -- Branch + let b2 = signedPB testBB2' + succeedReceiveBlock b2 + -- Another branch. + let b3 = signedPB testBB3' + succeedReceiveBlock b3 + + sd <- get + + -- Check that only the first credential deployed is present in block b1. + case sd ^. blockTable . liveMap . at' (getHash b1) of + Nothing -> liftIO $ assertFailure "failed getting bp1" + Just bp1 -> do + noAccountsBp1 <- length <$> getAccountList (bpState bp1) + liftIO $ assertEqual "check that there is one extra account" (noGenesisAccs + 1) noAccountsBp1 + getAccount (bpState bp1) (getAccAddress cred1) >>= \case + Nothing -> liftIO $ assertFailure "Should yield cred1" + Just (accIndex, _) -> liftIO $ assertEqual "incorrect account index" noGenesisAccs (fromIntegral accIndex) + + getAccount (bpState bp1) (getAccAddress cred2) >>= \case + Nothing -> return () + Just _ -> liftIO $ assertFailure "cred2 should not be present" + + getAccount (bpState bp1) (getAccAddress cred3) >>= \case + Nothing -> return () + Just _ -> liftIO $ assertFailure "cred3 should not be present" + + -- Check that cred1 and cred2 is present in b2 (but not cred3) + case sd ^. blockTable . liveMap . at' (getHash b2) of + Nothing -> liftIO $ assertFailure "failed getting bp1" + Just bp2 -> do + noAccountsBp2 <- length <$> getAccountList (bpState bp2) + liftIO $ assertEqual "check that there is one extra account" (noGenesisAccs + 2) noAccountsBp2 + getAccount (bpState bp2) (getAccAddress cred1) >>= \case + Nothing -> liftIO $ assertFailure "Should yield cred1" + Just (accIndex, _) -> liftIO $ assertEqual "incorrect account index" noGenesisAccs (fromIntegral accIndex) + + getAccount (bpState bp2) (getAccAddress cred2) >>= \case + Nothing -> liftIO $ assertFailure "Should yield cred2" + Just (accIndex, _) -> liftIO $ assertEqual "incorrect account index" (noGenesisAccs + 1) (fromIntegral accIndex) + + getAccount (bpState bp2) (getAccAddress cred3) >>= \case + Nothing -> return () + Just _ -> liftIO $ assertFailure $ "cred3 should not be present: " <> show (getAccAddress cred3) + + -- Check that cred1 and cred3 is present in b3 (but not cred2) + case sd ^. blockTable . liveMap . at' (getHash b3) of + Nothing -> liftIO $ assertFailure "failed getting bp1" + Just bp3 -> do + noAccountsBp3 <- length <$> getAccountList (bpState bp3) + liftIO $ assertEqual "check that there is one extra account" (noGenesisAccs + 2) noAccountsBp3 + getAccount (bpState bp3) (getAccAddress cred1) >>= \case + Nothing -> liftIO $ assertFailure "Should yield cred1" + Just (accIndex, _) -> liftIO $ assertEqual "incorrect account index" noGenesisAccs (fromIntegral accIndex) + + getAccount (bpState bp3) (getAccAddress cred3) >>= \case + Nothing -> liftIO $ assertFailure "Should yield cred3" + Just (accIndex, _) -> liftIO $ assertEqual "incorrect account index" (noGenesisAccs + 1) (fromIntegral accIndex) + + getAccount (bpState bp3) (getAccAddress cred2) >>= \case + Nothing -> return () + Just _ -> liftIO $ assertFailure $ "cred2 should not be present: " <> show (getAccAddress cred3) + + -- finalize bp3 and make sure that the state of the lfb matches b3. + let b4 = signedPB testBB4 + succeedReceiveBlock b4 + let b5 = signedPB testBB5 + succeedReceiveBlock b5 + + lfbState <- use (lastFinalized . to bpState) + noAccountsLfb <- length <$> getAccountList lfbState + liftIO $ assertEqual "check that there aer two extra accounts (cred 1 and 3)" (noGenesisAccs + 2) noAccountsLfb + + getAccount lfbState (getAccAddress cred1) >>= \case + Nothing -> liftIO $ assertFailure "Should yield cred1" + Just (accIndex, _) -> liftIO $ assertEqual "incorrect account index" noGenesisAccs (fromIntegral accIndex) + + getAccount lfbState (getAccAddress cred3) >>= \case + Nothing -> liftIO $ assertFailure "Should yield cred3" + Just (accIndex, _) -> liftIO $ assertEqual "incorrect account index" (noGenesisAccs + 1) (fromIntegral accIndex) + + getAccount lfbState (getAccAddress cred2) >>= \case + Nothing -> return () + Just _ -> liftIO $ assertFailure $ "cred2 should not be present: " <> show (getAccAddress cred2) + + -- Check that querying the old bs is not affected by the updated lmdb backed account map. + noFinal <- length <$> getAccountList genesisState + liftIO $ assertEqual "There should be the same number of accounts present" noGenesisAccs noFinal + -- We thaw here so we can use @bsoGetAccountIndex@ for querying account index directly. + updatableBlockState <- thawBlockState genesisState + bsoGetAccountIndex updatableBlockState (getAccAddress cred1) >>= \case + Nothing -> return () + Just _ -> liftIO $ assertFailure "cred 1 should not be present." + +tests :: Word -> Spec +tests _ = describe "EndToEndTests.CredentialDeployments" $ do + it "deploy and finalize one credential" testDeployCredential + it "deploy two credentials in two branches" testDeployCredentialBranching From 8e33fc8da08c1c7fb5e656ebb27f18093986ff0b Mon Sep 17 00:00:00 2001 From: Emil Lai Date: Mon, 13 Nov 2023 17:59:38 +0100 Subject: [PATCH 92/92] Re-introduce some tests. --- .../tests/globalstate/Spec.hs | 28 +++++++++---------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/concordium-consensus/tests/globalstate/Spec.hs b/concordium-consensus/tests/globalstate/Spec.hs index 36cc26f614..9b83df6211 100644 --- a/concordium-consensus/tests/globalstate/Spec.hs +++ b/concordium-consensus/tests/globalstate/Spec.hs @@ -34,20 +34,20 @@ atLevel a = do main :: IO () main = atLevel $ \lvl -> hspec $ do - -- GlobalStateTests.BlockHash.tests - -- GlobalStateTests.Cache.tests - -- GlobalStateTests.LFMBTree.tests + GlobalStateTests.BlockHash.tests + GlobalStateTests.Cache.tests + GlobalStateTests.LFMBTree.tests GlobalStateTests.Accounts.tests lvl - -- GlobalStateTests.Trie.tests - -- GlobalStateTests.PersistentTreeState.tests - -- GlobalStateTests.FinalizationSerializationSpec.tests - -- GlobalStateTests.Instances.tests lvl - -- GlobalStateTests.AccountReleaseScheduleTest.tests - -- GlobalStateTests.AccountReleaseScheduleMigration.tests - -- GlobalStateTests.Updates.tests - -- GlobalStateTests.AccountMap.tests lvl - -- GlobalStateTests.EnduringDataFlags.tests - -- GlobalStateTests.BlobStore.tests - -- GlobalStateTests.UpdateQueues.tests + GlobalStateTests.Trie.tests + GlobalStateTests.PersistentTreeState.tests + GlobalStateTests.FinalizationSerializationSpec.tests + GlobalStateTests.Instances.tests lvl + GlobalStateTests.AccountReleaseScheduleTest.tests + GlobalStateTests.AccountReleaseScheduleMigration.tests + GlobalStateTests.Updates.tests + GlobalStateTests.AccountMap.tests lvl + GlobalStateTests.EnduringDataFlags.tests + GlobalStateTests.BlobStore.tests + GlobalStateTests.UpdateQueues.tests GlobalStateTests.LMDBAccountMap.tests GlobalStateTests.DifferenceMap.tests