Merge pull request #1041 from Concordium/lmdb-accountmap

New account map

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.
 
 - Remove V1 GRPC API from the node. This removes configuration options
   `CONCORDIUM_NODE_RPC_SERVER_PORT`, `CONCORDIUM_NODE_RPC_SERVER_ADDRESS`, 

concordium-consensus/src/Concordium/External.hs

@@ -265,6 +265,7 @@ toStartResult =
                 GenesisBlockIncorrect _ -> 9
                 DatabaseInvariantViolation _ -> 10
                 IncorrectDatabaseVersion _ -> 11
+                AccountMapPermissionError -> 12
 
 -- | Catch exceptions which may occur at start up and return an appropriate exit code.
 handleStartExceptions :: LogMethod IO -> IO StartResult -> IO Int64

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)
@@ -29,9 +30,14 @@ 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,
-      dtdbBlockStateFile :: !FilePath
+      -- | Path to the block state database.
+      dtdbBlockStateFile :: !FilePath,
+      -- | Path to the account map database.
+      dtdAccountMapDirectory :: !FilePath
     }
 
 -- | Exceptions that can occur when initialising the global state.
@@ -65,21 +71,33 @@ 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
             liftIO $ 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 pbsc) logm
                         `onException` closeBlobStore pbscBlobStore
                 return (Just (pbsc, skovData))
         else return Nothing
 
+-- | Initialize a 'PersistentBlockStateContext' via the provided
+--  'GlobalStateConfig'.
+--  This function attempts to create a new blob store.
+initializePersistentBlockStateContext :: GlobalStateConfig -> IO (PersistentBlockStateContext pv)
+initializePersistentBlockStateContext GlobalStateConfig{..} = 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
@@ -109,11 +127,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
-    pbscBlobStore <- liftIO $ createBlobStore dtdbBlockStateFile
-    pbscAccountCache <- liftIO $ newAccountCache (rpAccountsCacheSize dtdbRuntimeParameters)
-    pbscModuleCache <- liftIO $ Modules.newModuleCache (rpModulesCacheSize dtdbRuntimeParameters)
-    let pbsc = 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."
@@ -132,18 +147,15 @@ migrateExistingState GlobalStateConfig{..} oldPbsc oldState migration genData =
                 (Just (_pendingTransactions oldState))
     isd <-
         runReaderT (runPersistentBlockStateMonad initGS) pbsc
-            `onException` liftIO (destroyBlobStore pbscBlobStore)
+            `onException` liftIO (destroyBlobStore (pbscBlobStore pbsc))
     return (pbsc, isd)
 
 -- | Initialise new global state with the given genesis. If the state already
 --  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)
-    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

concordium-consensus/src/Concordium/GlobalState/AccountMap/DifferenceMap.hs

@@ -0,0 +1,161 @@
+{-# LANGUAGE BangPatterns #-}
+
+-- | 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 (
+    -- * Definitions
+
+    -- The difference map definition.
+    DifferenceMap (..),
+    -- A mutable reference to a 'DifferenceMap'.
+    DifferenceMapReference,
+
+    -- * Auxiliary functions
+    newEmptyReference,
+    flatten,
+    empty,
+    fromList,
+    insert,
+    lookupViaEquivalenceClass,
+    lookupExact,
+    clearReferences,
+) where
+
+import Control.Monad.IO.Class
+import qualified Data.HashMap.Strict as HM
+import Data.IORef
+import Data.Tuple (swap)
+import Prelude hiding (lookup)
+
+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.
+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'.
+--  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
+      --  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
+      --  should be consulted instead.
+      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 = go dmap []
+  where
+    go diffMap !accum = do
+        mParentMap <- liftIO $ readIORef (dmParentMapRef diffMap)
+        case mParentMap of
+            Absent -> return collectedAccounts
+            Present parentMap -> go parentMap collectedAccounts
+      where
+        collectedAccounts = map swap (HM.elems $ dmAccounts diffMap) <> accum
+
+-- | 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
+        }
+
+-- | Internal helper function for looking up an entry in @dmAccounts@.
+--  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 !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'
+                Present parentMap -> check 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 @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 (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 @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 (Either Int AccountIndex)
+lookupExact addr diffMap =
+    lookupViaEquivalenceClass' (accountAddressEmbed addr) diffMap >>= \case
+        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.
+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
+        }
+  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 -> 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